From d7509d4eff053651b1f6c618657a73e0d409e521 Mon Sep 17 00:00:00 2001
From: Julian Sagebiel <julian.sagebiel@idiv.de>
Date: Wed, 6 Mar 2024 16:42:33 +0100
Subject: [PATCH] added functionality fpr readdesign of spdesign objects.
---
DESCRIPTION | 2 +-
NAMESPACE | 1 +
R/readdesign.R | 46 +++++++++++++++---------
R/spdesign_utils.R | 30 ++++++++++++++++
inst/extdata/ValuGaps/des1.RDS | Bin 0 -> 992 bytes
inst/extdata/testfiles/nousefullist.RDS | Bin 0 -> 120 bytes
man/extract_b_values.Rd | 22 ++++++++++++
tests/testthat/test-readdesign.R | 25 +++++++++++++
vignettes/SE_Agri-vignette.Rmd | 2 +-
9 files changed, 110 insertions(+), 18 deletions(-)
create mode 100644 R/spdesign_utils.R
create mode 100644 inst/extdata/ValuGaps/des1.RDS
create mode 100644 inst/extdata/testfiles/nousefullist.RDS
create mode 100644 man/extract_b_values.Rd
diff --git a/DESCRIPTION b/DESCRIPTION
index fd09377..8c5f730 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
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"))
diff --git a/NAMESPACE b/NAMESPACE
index e08595a..3c8cce7 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -2,6 +2,7 @@
export("%>%")
export(download_and_extract_zip)
+export(extract_b_values)
export(readdesign)
export(sim_all)
export(sim_choice)
diff --git a/R/readdesign.R b/R/readdesign.R
index 781b964..d512e32 100644
--- a/R/readdesign.R
+++ b/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'.")
)
+
}
+
+
diff --git a/R/spdesign_utils.R b/R/spdesign_utils.R
new file mode 100644
index 0000000..a13fd76
--- /dev/null
+++ b/R/spdesign_utils.R
@@ -0,0 +1,30 @@
+#' 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))
+}
diff --git a/inst/extdata/ValuGaps/des1.RDS b/inst/extdata/ValuGaps/des1.RDS
new file mode 100644
index 0000000000000000000000000000000000000000..f6c78a8867d7a9e284744752684f0f9832d95ad6
GIT binary patch
literal 992
zcmV<610Vb!iwFP!000001I<=TXw*O$p6+hDtN3Vb(W;=adZ?O)O*Sh%s8c=ox>S5X
zQR=$QW;L>pHc9LApdvmFS|6w=)K{ybf*>AjK^m=C5foGusUp4(7A#oBgNNce$<Cz7
z)I~%T1Ji%L`M>}B|CycsNzHHofEW0@Uf|6~Q;@%M#e#}Tv{sCO9{`VOJ!ll7kq3NW
z7_yypkxl&SAjj7-GZ-|J%6XO%SSG|WVV0?!Udzm65Jf-~!J-I=5@Z>kctUn?C|9s(
zQ$#D6X9et%(we@yBFF{9mOE^^xiBJ#Y$eNwSs_R?c$C;AS~`o%H}O_2)2ZDQ)kU-h
zlua~QXvWt9;PW^L`Kf49)^L;uFZ!Yhop;OyWWNudmv@vYFt2CJ*e|bVZ>I&NL{y^%
z{Y$HtFRqbv3=1r%XH^|)ANC4aHBaU@1k8XuI$*f2B;|;vM^zFNuvX+$EF0xICT}v8
zK&IGQ0v@v>KkPVRJ}2RQY&+c6xP<MlEpHcIE!hftvY0B!PtMW&%^Y*VF%LQBBH3d0
zG7KW~7a!zl4fyoTnhVe{Yc8oO0oDWivzEs6dR5>TJchCX$^y#Lx?~;4lRD`<^pnf~
zr|ZAsIUd(}()$^5J~{SlTUsaJ_7Bk`d^#U+`|Ub&?1RQt;OCguA94?VbDj3vb#i!J
z#Jo2c7yjJZe#VV$ebMc=F&)pjtsPI*19IHY|IJce(o4F8UYCf(;-sk|M7m)tsz<rF
zih4cOu7|1VjU0Igj6}n;9sS8<GJRAZD<GZNd^d1*E5lH5!;l+_ZWwkzfg_#F>bgGo
z?#hz9NoCEMZ+OS;Wv$(_m04B&FE4EDoYF&8<+G(KWK~V81WIlgb3+Zo!Mr@Yc<B0$
zM>iNlAK6^A>fLy_vtz--G250I`+AQh0%tl6{b+0VqAw?5SLvO5?MHTId2a{cr}n9%
z<7-NdHYt5={;9R_`iiNoZI2b>K-pMr+{H8S#nRpf&ubd7-W<$Jz_xVv{=O5uaryZ9
z_r13#!@2i2l-`~80p9F9JmCu4f%7iGdJS3LtpWJ{W!ISc5fhDLT`h(E&4=K#gX^E1
zZaIhRJB#zSU_B4!?S+j84}X06s?TWJUGlZM?=#s4uCD>-eUA0^VBQ@#&{aJ;Ulae;
z`B2x>8&i_xVgl=<%^WUD08z*Vc7D+P%@^<A)~CN}NG^Y)t|SzFGohQGG~~N0nU2Zi
z|9wQgs-)FOQ#8?t&IM<R$(ph*g;B8_k1LWQr=-mhNmX=NRiZ?-NlG_S9mYOvtscvu
OB7Xqx5JTW$3jhF>4(;y%
literal 0
HcmV?d00001
diff --git a/inst/extdata/testfiles/nousefullist.RDS b/inst/extdata/testfiles/nousefullist.RDS
new file mode 100644
index 0000000000000000000000000000000000000000..46a6570c2ccaf58d1531baf573def5360ce0377d
GIT binary patch
literal 120
zcmb2|=3oE==I#ec2?+^l35jWG32CfGk`d0%cS>|6BxbZU%BU$kV@`5oV-aBZ94TSZ
zXyPAN*Xgv#$t$ZctxArWnOk_0Om<vSUY219vv9}+?d?WuP1dU@8|%wzDNTruoHJ|A
V{OL^M=?OpB847N?@J<6-2mnl2B$NOE
literal 0
HcmV?d00001
diff --git a/man/extract_b_values.Rd b/man/extract_b_values.Rd
new file mode 100644
index 0000000..e93fbe0
--- /dev/null
+++ b/man/extract_b_values.Rd
@@ -0,0 +1,22 @@
+% 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)
+}
+}
diff --git a/tests/testthat/test-readdesign.R b/tests/testthat/test-readdesign.R
index 849f213..caf80a3 100644
--- a/tests/testthat/test-readdesign.R
+++ b/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"))
+})
diff --git a/vignettes/SE_Agri-vignette.Rmd b/vignettes/SE_Agri-vignette.Rmd
index f69d31c..ee38858 100644
--- a/vignettes/SE_Agri-vignette.Rmd
+++ b/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"
--
GitLab