.gitattributes

+* text=auto
+*.R text eol=lf

DESCRIPTION

 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

LICENSE

-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

LICENSE.md

+# 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.

NAMESPACE

-exportPattern("^[[:alpha:]]+")
+# Generated by roxygen2: do not edit by hand
+
+export("%>%")
+export(createSets)
+export(quicktexregapollo)
+importFrom(magrittr,"%>%")

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.")
   }
@@ -45,16 +44,18 @@ createSets <- function(.data, choice, attributes , uniquerow, prefix="a") {
     stop("The columns choice, uniquerow, and attributes should not have missing values.")
   }
 
+
+
   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 +63,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 ))
 
 
 

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)

R/utils-pipe.R

+#' 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

man/createSets.Rd

+% 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") }
+}

man/pipe.Rd

+% 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}

man/quicktexregapollo.Rd

+% 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)}
+}

tests/manual-tests/createSets-test.R

+
+rm(list = ls())
+devtools::load_all()
+
+model_path <- system.file("extdata", "csasimdata.csv", package = "choiceTools")
+
+data <- read.csv(model_path)
+
+
+sets <- createSets(data,choice = "CHOICE", uniquerow = "Choice_situation" ,attributes =c("alt1_x1" , "alt2_x1", "alt1_x2" , "alt2_x2") ,prefix = "alt" )
+
+

tests/manual-tests/quicktexregapollo-test.R

+
+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))

tests/testthat.R

+# 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")

tests/testthat/test-quicktexregapollo.R

+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'."
+  )
+})
+