added functionality fpr readdesign of spdesign objects.

DESCRIPTION

 Package: simulateDCE
 Title: Simulate data for discrete choice experiments 
-Version: 0.1.1
+Version: 0.1.2
 Authors@R: 
     person(given = "Julian", family = "Sagebiel", email = "julian.sagebiel@idiv.de", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-0253-6875"))

NAMESPACE

@@ -2,6 +2,7 @@
 
 export("%>%")
 export(download_and_extract_zip)
+export(extract_b_values)
 export(readdesign)
 export(sim_all)
 export(sim_choice)

R/readdesign.R

@@ -22,21 +22,35 @@
 
 readdesign <- function(design = designfile, designtype = destype) {
   design <- switch(designtype,
-    "ngene" = suppressWarnings(readr::read_delim(design,
-      delim = "\t",
-      escape_double = FALSE,
-      trim_ws = TRUE,
-      col_select = c(-Design, -tidyr::starts_with("...")),
-      name_repair = "universal", show_col_types = FALSE ,guess_max = Inf
-    )) %>%
-      dplyr::filter(!is.na(Choice.situation)),
-    "spdesign" = as.data.frame(readRDS(design)) %>%
-      dplyr::mutate(Choice.situation = 1:dplyr::n()) %>%
-      dplyr::rename_with(~ stringr::str_replace(., pattern = "_", "\\."), tidyr::everything()) %>%
-      dplyr::rename_with(~ dplyr::case_when(
-        . == "block" ~ "Block",
-        TRUE ~ .
-      ), tidyr::everything()),
-    stop("Invalid value for design. Please provide either 'ngene' or 'spdesign'.")
+                   "ngene" = suppressWarnings(readr::read_delim(design,
+                                                                delim = "\t",
+                                                                escape_double = FALSE,
+                                                                trim_ws = TRUE,
+                                                                col_select = c(-Design, -tidyr::starts_with("...")),
+                                                                name_repair = "universal", show_col_types = FALSE ,guess_max = Inf
+                   )) %>%
+                     dplyr::filter(!is.na(Choice.situation)),
+                   "spdesign" = {
+                         designf <- readRDS(design)
+                     if (is.list(designf) & !is.data.frame(designf)){
+                       if (!"design" %in% names(designf)) {
+                         stop("The 'design' list element is missing. Make sure to provide a proper spdesign object.")
+                       }
+                       designf<-designf[["design"]]
+                     }
+                     as.data.frame(designf) %>%
+                       dplyr::mutate(Choice.situation = 1:dplyr::n()) %>%
+                       dplyr::rename_with(~ stringr::str_replace(., pattern = "_", "\\."), tidyr::everything()) %>%
+                       dplyr::rename_with(~ dplyr::case_when(
+                         . == "block" ~ "Block",
+                         TRUE ~ .
+                       ), tidyr::everything())
+
+                   }
+                   ,
+                   stop("Invalid value for design. Please provide either 'ngene' or 'spdesign'.")
   )
+
 }
+
+

R/spdesign_utils.R

+#' Title Extracts beta values from an spdesign object
+#'
+#' @param input_list the list where the parameters are stored. Usually this is `design$utility`
+#'
+#' @return A named list with parameter values which can be used in `sim_all`
+#' @export
+#'
+#' @examples \dontrun{
+#' extract_b_values(design$utility)
+#' }
+extract_b_values <- function(input_list) {
+  extract_b_value <- function(input_string) {
+
+    matches <- gregexpr("b_\\w+\\[(-?\\d+\\.?\\d*)\\]", input_string)
+    matches <- regmatches(input_string, matches)
+    matches <- unlist(matches)
+
+
+    names <- gsub("\\[.*", "", matches)
+
+    values <- gsub(".*\\[(-?\\d+\\.?\\d*)\\]", "\\1", matches)
+
+    result <- stats::setNames(as.numeric(values), names)
+    return(result)
+  }
+
+  b_values <- unlist(lapply(input_list, extract_b_value))
+  b_values<- stats::setNames(b_values,gsub("alt\\d+\\.","",names(b_values)))
+  return(as.list(b_values))
+}

man/extract_b_values.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/spdesign_utils.R
+\name{extract_b_values}
+\alias{extract_b_values}
+\title{Title Extracts beta values from an spdesign object}
+\usage{
+extract_b_values(input_list)
+}
+\arguments{
+\item{input_list}{the list where the parameters are stored. Usually this is \code{design$utility}}
+}
+\value{
+A named list with parameter values which can be used in \code{sim_all}
+}
+\description{
+Title Extracts beta values from an spdesign object
+}
+\examples{
+\dontrun{
+extract_b_values(design$utility)
+}
+}

tests/testthat/test-readdesign.R

@@ -15,4 +15,29 @@ test_that("all is correct", {
   expect_no_error(readdesign(design = design_path, designtype = "ngene"))
 })
 
+### Tests for spdesign
 
+design_path <- system.file("extdata","CSA", "design2.RDS" ,package = "simulateDCE")
+
+test_that("all is correct", {
+  expect_no_error(readdesign(design = design_path, designtype = "spdesign"))
+})
+
+
+## trying objects that do not work
+
+design_path <- system.file("extdata","testfiles", "nousefullist.RDS" ,package = "simulateDCE")
+
+test_that("spdesign object is a list but does not contain the right element design", {
+  expect_error(readdesign(design = design_path, designtype = "spdesign"),
+               "list element is missing. Make sure to provide a ")
+})
+
+
+## test spdesign object containing original object
+
+design_path <- system.file("extdata","ValuGaps", "des1.RDS" ,package = "simulateDCE")
+
+test_that("all is correct with full spdesign objects", {
+  expect_no_error(readdesign(design = design_path, designtype = "spdesign"))
+})

vignettes/SE_Agri-vignette.Rmd

@@ -89,7 +89,7 @@ The simulation can be ran using spdesign or NGENE design files which will be con
 
 ```{r other}
 
-designpath<- system.file("extdata","se_AGRI" ,package = "simulateDCE")
+designpath<- system.file("extdata","SE_AGRI" ,package = "simulateDCE")
 ## can also be specified using relative path eg. designpath<- "Projects/CSA/Designs/"
 
 #notes <- "This design consists of different heuristics. One group did not attend the methan attribute, another group only decided based on the payment"