diff --git a/.Rbuildignore b/.Rbuildignore index 91114bf2f2bba5e0c5252e75018da19b869776f1..01993b8592e328f86fc7e3b9fa5d9067eb85da3f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,2 +1,5 @@ ^.*\.Rproj$ ^\.Rproj\.user$ +^.*\.Rproj$ +^\.Rproj.user$ +^LICENSE\.md$ diff --git a/DESCRIPTION b/DESCRIPTION index 12876f2cfeb9554eb7a9ea41a935747c9295dec9..af533e37296c8e791abc734778d3b3c8e9f38051 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,16 +1,31 @@ Package: choiceTools Type: Package Title: Various tools to work with choice experiment data in R -Version: 0.1.0 +Version: 0.2.0 Author: Julian Sagebiel Maintainer: Julian Sagebiel <julian.sagebiel@idiv.de> -Description: Most functions are made for use with apollo. -License: MIT +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. +License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Suggests: knitr, - rmarkdown + rmarkdown, + testthat (>= 3.0.0) VignetteBuilder: knitr Imports: - texreg + apollo, + dplyr, + janitor, + magrittr, + methods, + purrr, + readxl, + rlang, + stats, + texreg, + tidyr, + tidyselect, + zoo +RoxygenNote: 7.3.1 +Config/testthat/edition: 3 diff --git a/LICENSE b/LICENSE index 280db98a0bcfe3dc1cc96c148e5fb9c364f70e57..d01b4bff7798dfa75ffa4607dd9bec39432493cc 100644 --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,2 @@ -MIT License - -Copyright (c) 2023 Julian Sagebiel - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +YEAR: 2024 +COPYRIGHT HOLDER: Julian Sagebiel diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000000000000000000000000000000000000..ed02e060535fe88bd79cc6fd318294bd97bae482 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +# MIT License + +Copyright (c) 2024 Julian Sagebiel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/NAMESPACE b/NAMESPACE index d75f824ec6278db24891505b14ab3d915514dba7..aa991eecff2dec62c0d21d9bc95cff707eb7cc4a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1 +1,6 @@ -exportPattern("^[[:alpha:]]+") +# Generated by roxygen2: do not edit by hand + +export("%>%") +export(createSets) +export(quicktexregapollo) +importFrom(magrittr,"%>%") diff --git a/R/apollo_ztest.R b/R/apollo_ztest.R index f8b54208255540e32eb1d096ee796c5f891df73f..bbe6511ac4311a2f6f19d145c11a7e3e0d513435 100644 --- a/R/apollo_ztest.R +++ b/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) diff --git a/R/ass_labels.R b/R/ass_labels.R index c51104508e57552219bad77bb1496686680399f0..9c436657cd3f3c429e13be93fcbbe8ae1614f797 100644 --- a/R/ass_labels.R +++ b/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)) { diff --git a/R/createSets.R b/R/createSets.R index d46103c47c9fa2a48d45cf6bb966d5282f3cb8bd..9629b729812a76a796117ce5ce8fb20ac11b1b03 100644 --- a/R/createSets.R +++ b/R/createSets.R @@ -9,15 +9,14 @@ #' @param attributes A selection condition for attribute columns (tidyselect compatible). #' @param uniquerow A string specifying the unique row identifier column. #' @param prefix A string specifying the prefix for renaming (default is "a"). -#' @param delimiter A string specifying the delimiter for renaming (default is "_"). #' #' @return A list of tibbles representing the sets. #' #' @export #' -#' @examples +#' @examples \dontrun{ #' # Given a package dataset 'sample_data': -#' createSets(sample_data, choice = "choice_col", attributes = starts_with("attr"), uniquerow = "id") +#' createSets(sample_data, choice = "choice_col", attributes = starts_with("attr"), uniquerow = "id") } @@ -26,9 +25,9 @@ createSets <- function(.data, choice, attributes , uniquerow, prefix="a") { - require("dplyr") - require("tidyr") - require("purrr") + # require("dplyr") + # require("tidyr") + # require("purrr") if (!is.data.frame(.data)) { stop("The input data (.data) must be a data frame or tibble.") @@ -36,7 +35,7 @@ createSets <- function(.data, choice, attributes , uniquerow, prefix="a") { if (!all(c(choice, uniquerow) %in% names(.data))) { stop("Both choice and uniquerow columns must exist in the input data.") } - attribute_cols <- select(.data, {{ attributes }}) %>% names() + attribute_cols <- dplyr::select(.data, {{ attributes }}) %>% names() if (length(setdiff(attribute_cols, names(.data))) > 0) { stop("Some columns specified in attributes do not exist in the input data.") } @@ -46,15 +45,15 @@ createSets <- function(.data, choice, attributes , uniquerow, prefix="a") { } sets <- .data %>% - select({{ attributes }}, {{ choice }}, {{ uniquerow }} ) %>% - group_by(!!rlang::sym(uniquerow), !!rlang::sym(choice)) %>% - add_count() %>% ungroup %>% - group_by(!!rlang::sym(uniquerow)) %>% - distinct(n, .keep_all=TRUE) %>% - mutate(perc = round((n / sum(n) * 100))) %>% - arrange({{ uniquerow }}, {{ choice }}) %>% - group_split() %>% - set_names(map(., ~ unique(as.character(.x[[rlang::as_string(uniquerow)]])))) + dplyr::select({{ attributes }}, {{ choice }}, {{ uniquerow }} ) %>% + dplyr::group_by(!!rlang::sym(uniquerow), !!rlang::sym(choice)) %>% + dplyr::add_count() %>% dplyr::ungroup %>% + dplyr::group_by(!!rlang::sym(uniquerow)) %>% + dplyr::distinct(n, .keep_all=TRUE) %>% + dplyr::mutate(perc = round((n / sum(n) * 100))) %>% + dplyr::arrange({{ uniquerow }}, {{ choice }}) %>% + dplyr::group_split() %>% + purrr::set_names(purrr::map(., ~ unique(as.character(.x[[rlang::as_string(uniquerow)]])))) @@ -62,29 +61,29 @@ createSets <- function(.data, choice, attributes , uniquerow, prefix="a") { .data %>% - pivot_wider( - id_cols = c({{ uniquerow }}, everything()), + tidyr::pivot_wider( + id_cols = c({{ uniquerow }}, tidyselect::everything()), names_from = {{ choice }}, values_from = c(n, perc), names_sep = "." ) %>% - select(- {{ uniquerow }}) %>% - rename_with( + dplyr::select(- {{ uniquerow }}) %>% + dplyr::rename_with( ~ gsub(paste0("^(", prefix, "(\\d+))_(.*)$"), "\\3.\\2", .), - matches(paste0("^", prefix, "\\d+_")) + dplyr::matches(paste0("^", prefix, "\\d+_")) ) %>% - pivot_longer( - cols = everything(), + tidyr::pivot_longer( + cols = tidyselect::everything(), names_to = c("name", "suffix"), names_pattern = "(.*)\\.(.*)" ) %>% - pivot_wider( + tidyr::pivot_wider( names_from = suffix, values_from = value ) } - finalsets <- map(sets, ~makesets(.x )) + finalsets <- purrr::map(sets, ~makesets(.x )) diff --git a/R/poetest.R b/R/poetest.R index 692c4975c061ba891ef985db5c8805768c8fc5e3..49723eb51e061f07c5090f628b68e2b1c08069e2 100644 --- a/R/poetest.R +++ b/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) } diff --git a/R/quicktexregapollo.R b/R/quicktexregapollo.R index 556cd4db7024e2e640d67ee59045351afcd9239f..d885e12a7e483d616a84ff94972dbcf06c1fe951 100644 --- a/R/quicktexregapollo.R +++ b/R/quicktexregapollo.R @@ -4,18 +4,55 @@ #' Make your apollo object readable with texreg #' #' @param model the name of the apollo model object -#' @param wtpest if you want to display wtp instead of beta coefficients provide a dataframe with the wtp values and standard errors +#' @param wtpest if you want to display wtp instead of beta coefficients provide a data.frame with the wtp values and standard errors +#' @param se Which standard errors should be used. Either rob for robust, normal for normal standard error or bs for bootstrapped standard errors. #' -#' @return a list opject for texreg +#' @return a list object to be easily used in texreg. It makes it easy to create tables usind different standard errors (including robust and bootstrapped) and to display WTP instead of beta coefficients. #' @export #' -#' @examples +#' @examples \dontrun{quicktexregapollo(model1)} quicktexregapollo <- function(model = model, wtpest = NULL, se="rob") { + if (!se %in% c("rob", "normal", "bs")) { + stop("Invalid value for 'se'. Please use one of 'rob', 'normal', or 'bs'.") + } + + if (!all(c("apollo", "maxLik", "maxim") %in% class(model))) { + stop("Invalid model class. The model must be of classes 'apollo', 'maxLik', and 'maxim'.") + } + + + if (se == "bs" && !"bootse" %in% names(model)) { + 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)) { estimated <- janitor::clean_names(as.data.frame(apollo_modelOutput(model, modelOutput_settings))) - } else{ + if (is.null(wtpest)) { + + estimated <- janitor::clean_names(as.data.frame(apollo::apollo_modelOutput(model, modelOutput_settings))) + switch(se, + rob = { estimated$se <- estimated$rob_s_e + estimated$pv <- estimated$p_1_sided_2 + }, + bs = { + estimated$se <- estimated$bootstrap_s_e + estimated$pv <- estimated$p_1_sided_3 + }, + normal = { + estimated$se <- estimated$s_e + estimated$pv <- estimated$p_1_sided + + }, + { + # Default case if no match is found + stop("Invalid value for 'se'. Please use a valid value.") + } + ) + + + } else{ estimated <- wtpest colnames(estimated)<- c("estimate", "rob_s_e", "robt", "p_1_sided_2") @@ -24,9 +61,10 @@ quicktexregapollo <- function(model = model, wtpest = NULL, se="rob") { + coefnames <- gsub(pattern = "_[a-z]$", "" ,rownames(estimated)) - texout <- texreg::createTexreg(coef.names = coefnames , coef = estimated[["estimate"]] , se = estimated[["rob_s_e"]] , pvalues = estimated$p_1_sided_2, + texout <- texreg::createTexreg(coef.names = coefnames , coef = estimated[["estimate"]] , se = estimated[["se"]] , pvalues = estimated$pv, 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) diff --git a/R/remGOF.R b/R/remGOF.R index 2894cf0b9af2f83bf457d3e4158fccc1f3d17def..984d8739f897d45088ab7d106cda934bada012c4 100644 --- a/R/remGOF.R +++ b/R/remGOF.R @@ -1,9 +1,9 @@ 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) } diff --git a/R/subcoef.R b/R/subcoef.R index 0b9996aed3e806f2f9445d9474dcd6390b3a1096..f6fab12afcc4922f728513284ee528e82452d780 100644 --- a/R/subcoef.R +++ b/R/subcoef.R @@ -2,16 +2,16 @@ 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) diff --git a/R/utils-pipe.R b/R/utils-pipe.R new file mode 100644 index 0000000000000000000000000000000000000000..fd0b1d13db4ff91b7f836f72b7d5d88d958f6e1f --- /dev/null +++ b/R/utils-pipe.R @@ -0,0 +1,14 @@ +#' Pipe operator +#' +#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. +#' +#' @name %>% +#' @rdname pipe +#' @keywords internal +#' @export +#' @importFrom magrittr %>% +#' @usage lhs \%>\% rhs +#' @param lhs A value or the magrittr placeholder. +#' @param rhs A function call using the magrittr semantics. +#' @return The result of calling `rhs(lhs)`. +NULL diff --git a/R/wtp.R b/R/wtp.R index c277469ae7713fddef01dcc8627c3164c0850deb..0aaa139762b4e0ea7abf48e51b72094889c011db 100644 --- a/R/wtp.R +++ b/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) diff --git a/R/wtp_lc.R b/R/wtp_lc.R index 58b99f946a39e5e5416d28a078031979ad738508..5d1c1401573e46832f284adff8808da57d4dd99b 100644 --- a/R/wtp_lc.R +++ b/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)] diff --git a/inst/extdata/mixlogitInt_bootstrap.RDS b/inst/extdata/mixlogitInt_bootstrap.RDS new file mode 100644 index 0000000000000000000000000000000000000000..e5d987b251a000eaf8e4cab155301af9c9b122f3 Binary files /dev/null and b/inst/extdata/mixlogitInt_bootstrap.RDS differ diff --git a/man/createSets.Rd b/man/createSets.Rd new file mode 100644 index 0000000000000000000000000000000000000000..030018f148714e70cffffdb87ae974b1ae82ad40 --- /dev/null +++ b/man/createSets.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/createSets.R +\name{createSets} +\alias{createSets} +\title{Create sets from given data} +\usage{ +createSets(.data, choice, attributes, uniquerow, prefix = "a") +} +\arguments{ +\item{.data}{A data frame or tibble containing the data.} + +\item{choice}{A string specifying the choice column.} + +\item{attributes}{A selection condition for attribute columns (tidyselect compatible).} + +\item{uniquerow}{A string specifying the unique row identifier column.} + +\item{prefix}{A string specifying the prefix for renaming (default is "a").} +} +\value{ +A list of tibbles representing the sets. +} +\description{ +This function creates sets based on given attributes and choice columns. +It groups data by unique rows, calculates counts, and pivots the data for a +comprehensive overview. +} +\examples{ +\dontrun{ +# Given a package dataset 'sample_data': +createSets(sample_data, choice = "choice_col", attributes = starts_with("attr"), uniquerow = "id") } +} diff --git a/man/pipe.Rd b/man/pipe.Rd new file mode 100644 index 0000000000000000000000000000000000000000..1f8f237b4361f07366258cbe39500fed1a50687e --- /dev/null +++ b/man/pipe.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-pipe.R +\name{\%>\%} +\alias{\%>\%} +\title{Pipe operator} +\usage{ +lhs \%>\% rhs +} +\arguments{ +\item{lhs}{A value or the magrittr placeholder.} + +\item{rhs}{A function call using the magrittr semantics.} +} +\value{ +The result of calling `rhs(lhs)`. +} +\description{ +See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. +} +\keyword{internal} diff --git a/man/quicktexregapollo.Rd b/man/quicktexregapollo.Rd new file mode 100644 index 0000000000000000000000000000000000000000..777eecd8679ce1a59c5641e93bf0ae4253be36b0 --- /dev/null +++ b/man/quicktexregapollo.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/quicktexregapollo.R +\name{quicktexregapollo} +\alias{quicktexregapollo} +\title{Make your apollo object readable with texreg} +\usage{ +quicktexregapollo(model = model, wtpest = NULL, se = "rob") +} +\arguments{ +\item{model}{the name of the apollo model object} + +\item{wtpest}{if you want to display wtp instead of beta coefficients provide a data.frame with the wtp values and standard errors} + +\item{se}{Which standard errors should be used. Either rob for robust, normal for normal standard error or bs for bootstrapped standard errors.} +} +\value{ +a list object to be easily used in texreg. It makes it easy to create tables usind different standard errors (including robust and bootstrapped) and to display WTP instead of beta coefficients. +} +\description{ +Make your apollo object readable with texreg +} +\examples{ +\dontrun{quicktexregapollo(model1)} +} diff --git a/tests/manual-tests/quicktexregapollo-test.R b/tests/manual-tests/quicktexregapollo-test.R new file mode 100644 index 0000000000000000000000000000000000000000..fc635439ce575d58c11e67461e343341a095248e --- /dev/null +++ b/tests/manual-tests/quicktexregapollo-test.R @@ -0,0 +1,20 @@ + +rm(list = ls()) +devtools::load_all() + +model_path <- system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools") + +est_model <- readRDS(model_path) + + +different_se <-list() + +different_se[["normalse"]] <- quicktexregapollo(est_model, se="normal") + +different_se[["robustse"]] <- quicktexregapollo(est_model, se="rob") + +different_se[["bootstrapse"]] <- quicktexregapollo(est_model, se="bs") + +texreg::screenreg(different_se) + +janitor::clean_names(apollo::apollo_modelOutput(est_model)) diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000000000000000000000000000000000000..3983c525b76af989542231cd9081085b2700acfa --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(choiceTools) + +test_check("choiceTools") diff --git a/tests/testthat/test-quicktexregapollo.R b/tests/testthat/test-quicktexregapollo.R new file mode 100644 index 0000000000000000000000000000000000000000..b9b14c15a6fc7c9d9ad90dd02ee1f62bfc1a1258 --- /dev/null +++ b/tests/testthat/test-quicktexregapollo.R @@ -0,0 +1,35 @@ +test_that("quicktexregapollo function handles invalid model class", { + invalid_model <- list() + class(invalid_model) <- c("invalidClass") + + expect_error( + quicktexregapollo(model = invalid_model, se = "rob"), + "Invalid model class. The model must be of classes 'apollo', 'maxLik', and 'maxim'." + ) +}) + + + + +test_that("quicktexregapollo function handles invalid 'se' argument", { + model_path <- system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools") + est_model <- readRDS(model_path) + + expect_error( + quicktexregapollo(model = est_model, se = "invalid"), + "Invalid value for 'se'. Please use one of 'rob', 'normal', or 'bs'." + ) +}) + + +test_that("quicktexregapollo function checks for 'bootse' element when se is 'bs'", { + model_path <- system.file("extdata", "mixlogitInt_bootstrap.RDS", package = "choiceTools") + est_model <- readRDS(model_path) + est_model$bootse <- NULL # Remove 'bootse' element + + expect_error( + quicktexregapollo(model = est_model, se = "bs"), + "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'." + ) +}) +