Upload New File

R_Functions/helpfunctions.R

+#function to clean the output folders from old files generated automatically with apollo
+
+moveold <- function(){
+  oldfiles <- list.files(pattern = "OLD[1-9]", recursive = TRUE)
+  
+  
+  for(file in oldfiles) {
+    
+    file.rename(from = file, to = paste0("OLD/",gsub("^.*/", "",file)))
+    
+  }
+  
+} 
+
+###z-standardization function###
+z_st <- function(var) {
+  
+  database$mean.var<-mean(var)
+  m<- mean(var)
+  s<- sd(var)
+  var.z<-(var-m)/s
+  return( var.z)
+}
+
+
+
+## This function is used to create WTP values using the delta method.
+
+
+wtp <- function(cost, attr, modelname) {
+  
+  wtp_values =data.frame(wtp =numeric(), robse=numeric() , robt= numeric() ) 
+  attr <- attr[-which(attr==cost)]
+  
+  for (a in attr) {
+    
+    
+    deltaMethod_settings=list(operation="ratio", parName1=a, parName2=cost)
+    wtp_values[which(attr==a),]<- apollo_deltaMethod(modelname, deltaMethod_settings)
+    
+  }
+  wtp_values$wtp <- wtp_values$wtp*-1
+  wtp_values$robse <- wtp_values$robse*1
+  wtp_values$robt <- wtp_values$robt*-1
+  wtp_values$pVal <- (1-pnorm((abs(wtp_values$robt))))*2
+  
+  rownames(wtp_values) <- attr
+  return(wtp_values) 
+  
+}
+
+
+#this function uses the wtp function and wraps it for all Classes in a LC model.
+
+wtp_lc <-function(modelname) {
+  
+  
+  wtpvalues=list()
+  
+  for (class in 1:(length(modelname$LL0)-1)) {
+   
+    
+    clet <- intToUtf8(96+class) 
+    coefs<- data.frame(apollo_modelOutput(modelname, modelOutput_settings = list(printPVal=T)))
+    coefs<- coefs[grep(paste0("delta_.*", clet,"$"),x = rownames(coefs), value=TRUE, perl = TRUE), c(1,5:7)]
+    
+    
+    
+    
+    print(clet)
+    
+    wtpvalues[[paste0("Class ",class)]] <- 
+      wtp(paste0("cost_",clet), 
+          grep(paste0("^(?=.*_",clet,")(?!.*delta)"), names(modelname$estimate) , value=T, perl = TRUE),modelname = modelname) 
+    
+colnames(coefs)<- colnames(wtpvalues[[paste0("Class ",class)]])
+    
+wtpvalues[[paste0("Class ",class)]] <- rbind(wtpvalues[[paste0("Class ",class)]],coefs)
+   
+   #  print("this is other")
+   #  print(other)
+   #  if(class(other) =="numeric") other<-as.data.frame(as.list(other))
+   # colnames(other) <- names(wtpvalues[[paste0("Class ",class)]])
+   # print("this is other after rename")
+   # print(other)
+   #  wtpvalues[[paste0("Class ",class)]] <-rbind(wtpvalues[[paste0("Class ",class)]],other)
+    }
+  
+  return(wtpvalues)
+  
+}
+
+# This function lets us create output tables with texreg with objects from Apollo
+
+
+quicktexregapollo <- function(model =model, wtpest=NULL) {
+  
+  modelOutput_settings = list(printPVal=T) 
+  
+  if (is.null(wtpest)) {  estimated <- janitor::clean_names(as.data.frame(apollo_modelOutput(model, modelOutput_settings)))
+  } else{
+    estimated <- wtpest
+    colnames(estimated)<- c("estimate", "rob_s_e", "robt", "p_1_sided_2")
+    
+  }
+  
+  
+  coefnames <- gsub(pattern = "_[a-z]$", "" ,rownames(estimated))
+  
+  texout <- createTexreg(coef.names = coefnames , coef = estimated[["estimate"]] , se = estimated[["rob_s_e"]] , pvalues = estimated$p_1_sided_2,
+                         gof.names = c("No Observations" , "No Respondents" , "Log Likelihood (Null)" , "Log Likelihood (Converged)") ,
+                         gof = c(model[["nObsTot"]] , model[["nIndivs"]], model[["LL0"]][[1]] , model[["LLout"]][[1]] ) ,
+                         gof.decimal = c(FALSE,FALSE,TRUE,TRUE)
+  )
+  
+  
+  return(texout)
+  
+}
+
+
+
+
+
+quicktexregapollo_old <- function(model =model) {
+  
+  modelOutput_settings = list(printPVal=T) 
+  
+  estimated <- janitor::clean_names(as.data.frame(apollo_modelOutput(model, modelOutput_settings)))
+  
+  
+  texout <- createTexreg(coef.names = names(model[["estimate"]]) , coef = model[["estimate"]] , se = model[["robse"]] , pvalues = estimated$p_1_sided_2,
+                         gof.names = c("No Observations" , "No Respondents" , "Log Likelihood (Null)" , "Log Likelihood (Converged)") ,
+                         gof = c(model[["nObsTot"]] , model[["nIndivs"]], model[["LL0"]][[1]] , model[["LLout"]][[1]] ) ,
+                         gof.decimal = c(FALSE,FALSE,TRUE,TRUE)
+  )
+  
+  
+  return(texout)
+  
+}
+
+
+
+
+#function to assign labels for data generated by SurveyEngine.
+
+ass_labels <- function(path, seelab=TRUE, lower=FALSE) {
+  
+  labels <- read_excel(path = path, sheet = "dictionary", col_names = TRUE)[-2:-1,2:4]  %>% rename( "Variable"=1 ,   "Labels"=2   ,   "valuelabels"=3)
+  
+  
+  if (lower==TRUE) labels$Variable <- tolower(labels$Variable)
+  
+  
+  covdata <- read_excel(path = path)
+  
+  
+  ## check if variables are all present
+  #test 1
+  
+  cat("Number of variables in dataset: ",length(names(covdata)) ,
+      "\n Number of variables in label set:", length(labels$Variable[!is.na(labels$Variable)]), "\n")
+  
+  if (length(names(covdata)) != length(labels$Variable[!is.na(labels$Variable)]) ){ 
+    cat("\n labels do not match, will be ignored, but make sure this is ok. 
+           \n Below are the variables that are problematic. \n \n These variables exist in the dataset but not in the label set:", 
+        setdiff(names(covdata) , labels$Variable[!is.na(labels$Variable)]) ,
+        "\n and these exist in the labels and not in the dataset:" ,
+        setdiff(labels$Variable[!is.na(labels$Variable)], names(covdata)))
+  }
+  
+  for (vn in names(covdata)) {
+    attr(covdata[[vn]], "label") <- toString(labels[which(labels$Variable==vn),"Labels"])
+  }
+  
+  
+  labels$Variable <- na.locf(labels$Variable)
+  labels <- labels[!is.na(labels$Labels),]
+  
+  X <- base::split(labels, labels$Variable)
+  
+  Y=lapply(X, row_to_names , row_number = 1)
+  
+  
+  for (vn in names(covdata)) {
+    
+    if (is.null(attr(covdata[[vn]], "class")) == TRUE) {
+      attr(covdata[[vn]], "class") <- "haven_labelled"
+    }
+    
+    
+    if (exists(vn,Y)==TRUE && nrow(Y[[vn]])>1 ) {
+      
+      if(seelab==TRUE) cat("\n the variable", vn , " will be labelled \n" )
+      
+      t <- as.numeric(unlist(Y[[vn]][2]))
+      names(t) <- unlist(Y[[vn]][3])
+      attr(covdata[[vn]] , "labels") <- t
+    }
+    else{ if(seelab==TRUE) cat("\n Attention: the values of the variable", vn , " will NOT be labelled \n" )}
+    
+  }
+  
+  return(covdata)
+  
+}  
+
+
+
+# function to split model into different columns for texreg
+
+subcoef <- function(condition, mname){
+  
+  sub <- grep(condition,slot(mname,"coef.names"))
+  
+  for (ele in c("coef.names","coef","se","pvalues"))  {
+    elements<- slot(mname,ele)[sub]
+    slot(mname,ele) <- elements
+  }
+  
+  slot(mname,"coef.names")<-gsub(pattern = condition,replacement = "",x =slot(mname,"coef.names") )  
+  
+  slot(mname,"model.name")<-gsub("_","",condition)  
+  
+  
+  return(mname)
+  
+}
+
+#ff<- subcoef(mname=rpl,condition = "mean_")
+
+
+
+remGOF<- function(models){
+
+ gof<- function(m){  
+slot(m,"gof.names")<- character(0)
+slot(m,"gof")<- numeric(0)
+slot(m,"gof.decimal")<- logical(0)
+
+return(m)
+}
+  
+return(purrr::map(models,gof)) 
+  
+}
+
+#tes <- remGOF(rpl_cols[2:5])
+
+
+
+uf <- function(var, int=NULL, pre){ 
+  
+  
+  par <- paste0("b_",var)
+  var<-paste0(pre,var)
+  int2<-NULL
+  
+  main <- paste(paste(par,var,sep = "*"),collapse = "+")
+  form <-main
+  parnames<-par
+  
+  
+  if (!is.null(int)) {
+    int2 <- paste(paste(paste(par, int,sep = "X"),var,int,sep = "*"),collapse = "+")
+    
+    form <- paste(main,int2,sep = "+")
+    
+    
+    parnames<-c(par,paste(par, int,sep = "X"))
+  }
+  
+  
+  par2<-rep(0,length(parnames))
+  names(par2)<-parnames
+  
+  
+  alls <- list(form,par2)
+  
+  return(alls)
+  
+} 
+