Merge branch 'devel' into 'main'

functions generally improved and made packagelike, quicktexregapollo added...

See merge request !1

.Rbuildignore

 ^.*\.Rproj$
 ^\.Rproj\.user$
+^.*\.Rproj$
+^\.Rproj.user$
+^LICENSE\.md$

DESCRIPTION

 Package: choiceTools
 Type: Package
 Title: Various tools to work with choice experiment data in R
-Version: 0.2.0
+Version: 0.3.0
 Author: Julian Sagebiel
 Maintainer: Julian Sagebiel <julian.sagebiel@idiv.de>
 Description: This is a random set of functions that make your life as a choice modeller easier. Some functions are made for use with apollo so that you can more easily do choice modelling in apollo. The package includes some tests like Poetest and zTest and some functions to generate publication-ready tables.

NAMESPACE

@@ -3,4 +3,6 @@
 export("%>%")
 export(createSets)
 export(quicktexregapollo)
+export(remGOF)
+export(subcoef)
 importFrom(magrittr,"%>%")

R/apollo_ztest.R

@@ -5,7 +5,7 @@ apollo_ztest <- function(model1, model2, hyp=0){
 
   comp = data.frame(m1par =model1[["estimate"]] ,m2par = model2[["estimate"]] , m1se=model1[["robse"]] , m2se=model2[["robse"]]) %>%
 
-    mutate(diffmean=m1par-m2par , error= sqrt(m1se^2+m2se^2) , z= diffmean/error , p_value=2*pnorm(-abs(z)))
+    dplyr::mutate(diffmean=m1par-m2par , error= sqrt(m1se^2+m2se^2) , z= diffmean/error , p_value=2*stats::pnorm(-abs(z)))
 
 
   print(comp)

R/ass_labels.R

@@ -2,13 +2,14 @@
 
 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)
+  labels <- readxl::read_excel(path = path, sheet = "dictionary", col_names = TRUE)[-2:-1,2:4]  %>%
+    dplyr::rename( "Variable"=1 ,   "Labels"=2   ,   "valuelabels"=3)
 
 
   if (lower==TRUE) labels$Variable <- tolower(labels$Variable)
 
 
-  covdata <- read_excel(path = path)
+  covdata <- readxl::read_excel(path = path)
 
 
   ## check if variables are all present
@@ -30,12 +31,12 @@ ass_labels <- function(path, seelab=TRUE, lower=FALSE) {
   }
 
 
-  labels$Variable <- na.locf(labels$Variable)
+  labels$Variable <- zoo::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)
+  Y=lapply(X, janitor::row_to_names , row_number = 1)
 
 
   for (vn in names(covdata)) {

R/poetest.R

@@ -3,54 +3,54 @@
 ## Extract relevant elements of models
 
 takedraws <-function(n=10000, beta,vc) {
-  
-  
+
+
   k=length(beta)
   cholesky = chol(vc)
-  
+
   draw=matrix(nrow = n, ncol=k)
-  
+
   colnames(draw) <-names(beta)
-  
+
   for (d in 1:n) {
-    draw[d,] <- beta +t(cholesky)%*%rnorm(k)
+    draw[d,] <- beta +t(cholesky)%*%stats::rnorm(k)
   }
-  
-  
-  
+
+
+
   return(draw)
 }
 
 
 getalldraws <- function(n, model1, model2, att, price) {
-  
+
   allmodels <- list(model1,model2)
-  
+
   model_draws <- list()
-  
+
   for (m in 1:2) {
- 
+
   model_draws[[m]] <-takedraws(n,allmodels[[m]][["estimate"]],allmodels[[m]][["varcov"]])
 
   model_draws[[m]] <-cbind(model_draws[[m]], wtp= model_draws[[m]][,att]/model_draws[[m]][,price])
-     } 
+     }
 
   return(model_draws)
   }
-  
+
 poetest <- function(n, model1, model2, att, price){
-  
-draws<-getalldraws(n, model1, model2, att, price)  
+
+draws<-getalldraws(n, model1, model2, att, price)
 
 wtpvec <- cbind(wtp1= draws[[1]][,"wtp"], wtp2= draws[[2]][,"wtp"])
-  
+
 
 
 # fullconv = matrix(ncol =2, nrow = 0)
 # for (i in 1:nrow(wtpvec)) {
-#   
+#
 # fullconv= rbind(fullconv , cbind(rep(wtpvec[i,1], times=nrow(wtpvec))  , wtpvec[,2] ) )
-# }  
+# }
 
 
 #fullconv = expand.grid(wtpvec[,1], wtpvec[,2])
@@ -64,6 +64,6 @@ cat( "\n The probability that WTP_1 > WTP2 is " , mean(results[,3]), "\n The pro
 
 output = list(Allcomparisions = results, p1 =mean(results[,3]) , p2 = 1 - mean(results[,3]), No_draws = n)
 
-return(output)  
+return(output)
 }
 

R/quicktexregapollo.R

@@ -26,7 +26,7 @@ quicktexregapollo <- function(model = model, wtpest = NULL, se="rob") {
     stop(" It seems you did not do bootstrapping. Thus, I cannot report bootstrapped se. The 'model' object must contain an element named 'bootse' when 'se' is 'bs'.")
   }
 
-  browser()
+
   modelOutput_settings = list(printPVal=T)
 
   if (is.null(wtpest)) {

R/remGOF.R

+#' Remove unnecessary statistics from Table for TexReg
+#'
+#' @param models the models you want to delete the GOF statistics
+#'
+#' @return a list with the same models as in models but without GOF statistics
+#' @export
+#'
+#' @examples {
+#' est_model <- readRDS(system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools"))
+#' ## make full model in one column using texreg
+#' full_model <- quicktexregapollo(est_model, se="normal")
+#' texreg::screenreg(full_model)
+#' ## split the model to different columns, e.g. for mean, sd, sample_interactions
+#' splitmodels <- purrr::map(c("mean_","sd_" , paste0("_s",c(2:6))  ) ,subcoef,full_model)
+#' texreg::screenreg(splitmodels)
+#' ## the same, but make sure gof statistics are shown only once
+#' texreg::screenreg(c(splitmodels[[1]],remGOF(splitmodels[2:7] ) ) )
+#' }
 remGOF<- function(models){
 
   gof<- function(m){
-    slot(m,"gof.names")<- character(0)
-    slot(m,"gof")<- numeric(0)
-    slot(m,"gof.decimal")<- logical(0)
+    methods::slot(m,"gof.names")<- character(0)
+    methods::slot(m,"gof")<- numeric(0)
+    methods::slot(m,"gof.decimal")<- logical(0)
 
     return(m)
   }

R/subcoef.R

-# function to split model into different columns for texreg
 
+
+#' Title function to split model into different columns for texreg
+#'
+#' @param condition The stub that is common for all parameters you want to split. For example 'mean'
+#' @param mname The name of the model you want to split
+#'
+#' @return a new texreg object with only the selected column (for example the model output with only the mean parameters)
+#' @export
+#'
+#' @examples {
+#' est_model <- readRDS(system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools"))
+#' ## make full model in one column using texreg
+#' full_model <- quicktexregapollo(est_model, se="normal")
+#' texreg::screenreg(full_model)
+#' ## split the model to different columns, e.g. for mean, sd, sample_interactions
+#' splitmodels <- purrr::map(c("mean_","sd_" , paste0("_s",c(2:6))  ) ,subcoef,full_model)
+#' texreg::screenreg(splitmodels)
+#' ## the same, but make sure gof statistics are shown only once
+#' texreg::screenreg(c(splitmodels[[1]],remGOF(splitmodels[2:7] ) ) )
+#'
+#' }
 subcoef <- function(condition, mname){
 
-  sub <- grep(condition,slot(mname,"coef.names"))
+  sub <- grep(condition,methods::slot(mname,"coef.names"))
 
   for (ele in c("coef.names","coef","se","pvalues"))  {
-    elements<- slot(mname,ele)[sub]
-    slot(mname,ele) <- elements
+    elements<- methods::slot(mname,ele)[sub]
+    methods::slot(mname,ele) <- elements
   }
 
-  slot(mname,"coef.names")<-gsub(pattern = condition,replacement = "",x =slot(mname,"coef.names") )
+  methods::slot(mname,"coef.names")<-gsub(pattern = condition,replacement = "",x =methods::slot(mname,"coef.names") )
 
-  slot(mname,"model.name")<-gsub("_","",condition)
+  methods::slot(mname,"model.name")<-gsub("_","",condition)
 
 
   return(mname)

R/wtp.R

@@ -17,14 +17,14 @@ wtp <- function(cost, attr, modelname, mediancost=FALSE) {
 
     deltaMethod_settings=list(expression=(temp=ex))
     #deltaMethod_settings=list(operation="ratio", parName1=a, parName2=cost)
-    wtp_values[which(attr==a),]<- apollo_deltaMethod(modelname, deltaMethod_settings)[,2:4]
+    wtp_values[which(attr==a),]<- apollo::apollo_deltaMethod(modelname, deltaMethod_settings)[,2:4]
   }
 
   #names(wtp_values) <- c("Expression" , "wtp" , "robse" , "robt")
   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
+  wtp_values$pVal <- (1-stats::pnorm((abs(wtp_values$robt))))*2
 
   rownames(wtp_values) <- attr
   return(wtp_values)

R/wtp_lc.R

@@ -9,7 +9,7 @@ wtp_lc <-function(modelname) {
 
 
     clet <- intToUtf8(96+class)
-    coefs<- data.frame(apollo_modelOutput(modelname, modelOutput_settings = list(printPVal=T)))
+    coefs<- data.frame(apollo::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)]
 
 

man/remGOF.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/remGOF.R
+\name{remGOF}
+\alias{remGOF}
+\title{Remove unnecessary statistics from Table for TexReg}
+\usage{
+remGOF(models)
+}
+\arguments{
+\item{models}{the models you want to delete the GOF statistics}
+}
+\value{
+a list with the same models as in models but without GOF statistics
+}
+\description{
+Remove unnecessary statistics from Table for TexReg
+}
+\examples{
+{
+est_model <- readRDS(system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools"))
+## make full model in one column using texreg
+full_model <- quicktexregapollo(est_model, se="normal")
+texreg::screenreg(full_model)
+## split the model to different columns, e.g. for mean, sd, sample_interactions
+splitmodels <- purrr::map(c("mean_","sd_" , paste0("_s",c(2:6))  ) ,subcoef,full_model)
+texreg::screenreg(splitmodels)
+## the same, but make sure gof statistics are shown only once
+texreg::screenreg(c(splitmodels[[1]],remGOF(splitmodels[2:7] ) ) )
+}
+}

man/subcoef.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/subcoef.R
+\name{subcoef}
+\alias{subcoef}
+\title{Title function to split model into different columns for texreg}
+\usage{
+subcoef(condition, mname)
+}
+\arguments{
+\item{condition}{The stub that is common for all parameters you want to split. For example 'mean'}
+
+\item{mname}{The name of the model you want to split}
+}
+\value{
+a new texreg object with only the selected column (for example the model output with only the mean parameters)
+}
+\description{
+Title function to split model into different columns for texreg
+}
+\examples{
+{
+est_model <- readRDS(system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools"))
+## make full model in one column using texreg
+full_model <- quicktexregapollo(est_model, se="normal")
+texreg::screenreg(full_model)
+## split the model to different columns, e.g. for mean, sd, sample_interactions
+splitmodels <- purrr::map(c("mean_","sd_" , paste0("_s",c(2:6))  ) ,subcoef,full_model)
+texreg::screenreg(splitmodels)
+## the same, but make sure gof statistics are shown only once
+texreg::screenreg(c(splitmodels[[1]],remGOF(splitmodels[2:7] ) ) )
+
+}
+}

tests/manual-tests/remGOF-test.R

+
+rm(list = ls())
+devtools::load_all()
+
+
+
+est_model <- readRDS(system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools"))
+
+
+
+
+
+## make full model in one column using texreg
+
+full_model <- quicktexregapollo(est_model, se="normal")
+
+texreg::screenreg(full_model)
+
+
+## split the model to different columns, e.g. for mean, sd, sample_interactions
+splitmodels <- purrr::map(c("mean_","sd_" , paste0("_s",c(2:6))  ) ,subcoef,full_model)
+
+texreg::screenreg(splitmodels)
+
+
+## the same, but make sure gof statistics are shown only once
+texreg::screenreg(c(splitmodels[[1]],remGOF(splitmodels[2:7] ) ) )
+
+
+janitor::clean_names(apollo::apollo_modelOutput(est_model))