Merge pull request #23 from edsandorf/v0.0.4-dev

V0.0.4 dev

.github/workflows/rhub.yaml

@@ -0,0 +1,95 @@
+# R-hub's generic GitHub Actions workflow file. It's canonical location is at
+# https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml
+# You can update this file to a newer version using the rhub2 package:
+#
+# rhub::rhub_setup()
+#
+# It is unlikely that you need to modify this file manually.
+
+name: R-hub
+run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}"
+
+on:
+  workflow_dispatch:
+    inputs:
+      config:
+        description: 'A comma separated list of R-hub platforms to use.'
+        type: string
+        default: 'linux,windows,macos'
+      name:
+        description: 'Run name. You can leave this empty now.'
+        type: string
+      id:
+        description: 'Unique ID. You can leave this empty now.'
+        type: string
+
+jobs:
+
+  setup:
+    runs-on: ubuntu-latest
+    outputs:
+      containers: ${{ steps.rhub-setup.outputs.containers }}
+      platforms: ${{ steps.rhub-setup.outputs.platforms }}
+
+    steps:
+    # NO NEED TO CHECKOUT HERE
+    - uses: r-hub/actions/setup@v1
+      with:
+        config: ${{ github.event.inputs.config }}
+      id: rhub-setup
+
+  linux-containers:
+    needs: setup
+    if: ${{ needs.setup.outputs.containers != '[]' }}
+    runs-on: ubuntu-latest
+    name: ${{ matrix.config.label }}
+    strategy:
+      fail-fast: false
+      matrix:
+        config: ${{ fromJson(needs.setup.outputs.containers) }}
+    container:
+      image: ${{ matrix.config.container }}
+
+    steps:
+      - uses: r-hub/actions/checkout@v1
+      - uses: r-hub/actions/platform-info@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+      - uses: r-hub/actions/setup-deps@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+      - uses: r-hub/actions/run-check@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+
+  other-platforms:
+    needs: setup
+    if: ${{ needs.setup.outputs.platforms != '[]' }}
+    runs-on: ${{ matrix.config.os }}
+    name: ${{ matrix.config.label }}
+    strategy:
+      fail-fast: false
+      matrix:
+        config: ${{ fromJson(needs.setup.outputs.platforms) }}
+
+    steps:
+      - uses: r-hub/actions/checkout@v1
+      - uses: r-hub/actions/setup-r@v1
+        with:
+          job-config: ${{ matrix.config.job-config }}
+          token: ${{ secrets.RHUB_TOKEN }}
+      - uses: r-hub/actions/platform-info@v1
+        with:
+          token: ${{ secrets.RHUB_TOKEN }}
+          job-config: ${{ matrix.config.job-config }}
+      - uses: r-hub/actions/setup-deps@v1
+        with:
+          job-config: ${{ matrix.config.job-config }}
+          token: ${{ secrets.RHUB_TOKEN }}
+      - uses: r-hub/actions/run-check@v1
+        with:
+          job-config: ${{ matrix.config.job-config }}
+          token: ${{ secrets.RHUB_TOKEN }}

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: spdesign
 Type: Package
 Title: Designing Stated Preference Experiments
-Version: 0.0.3
+Version: 0.0.4
 Authors@R: c(
   person("Erlend Dancke", "Sandorf", email = "erlend.dancke.sandorf@nmbu.no", role = c("aut", "cre")),
   person("Danny", "Campbell", email = "danny.campbell@stir.ac.uk", role = c("aut")))
@@ -24,4 +24,4 @@ Suggests:
   rmarkdown,
   testthat
 VignetteBuilder: knitr
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1

NAMESPACE

@@ -13,6 +13,7 @@ export(cor)
 export(expand_attribute_levels)
 export(full_factorial)
 export(generate_design)
+export(level_balance)
 export(make_draws)
 export(occurrences)
 export(priors)

NEWS.md

@@ -1,3 +1,8 @@
+# spdesign v0.0.4
+* Added function level_balance() that produces a list of level occurrences in the design to inspect level balance
+* Updates to documentation, examples, and syntax description
+* Minor bug fixes
+
 # spdesign v0.0.3
 * Fixed a bug related to optimizing for c-efficiency where it would sometimes fail to correctly identify the denominator. 
 * Fixed several bugs related to using a supplied candidate set with alternative specific constants and attributes. Checks have been updated. The code will now also add zero-columns for alternative specific constants and attributes in the utility functions where they are not present. This ensures that all matrices used when calculating the first- and second-order derivatives of the utility functions are square. 

R/design.R

@@ -178,7 +178,7 @@ generate_design <- function(utility,
         )
       }
 
-      candidate_levels <- apply(candidate_set, 2, function(x) unique(sort(x)))
+      candidate_levels <- apply(candidate_set, 2, function(x) unique(sort(x)), simplify = FALSE)
       utility_levels <- lapply(expand_attribute_levels(utility), as.numeric)
 
       # Subset utility levels to only correspond to the ones specified
@@ -192,10 +192,16 @@ generate_design <- function(utility,
         )
       }
 
-      # Expand candidate set to be square, i.e., fill in zero columns, for non-specified
+      # Expand candidate set to be square, i.e., fill in zero columns, for non-specified. This in case of
+      # Alternative specific attributes!
       expanded_names <- names(expand_attribute_levels(utility))
-      expr <- paste("cbind(candidate_set, ", paste(paste(expanded_names[!(expanded_names %in% utility_attributes)], 0, sep = " = "), collapse = ", "), ")")
-      candidate_set <- eval(parse(text = expr))
+
+      # Skip expansion if no alternative specific attributes are present
+      if (any(!(expanded_names %in% utility_attributes))) {
+        expr <- paste("cbind(candidate_set, ", paste(paste(expanded_names[!(expanded_names %in% utility_attributes)], 0, sep = " = "), collapse = ", "), ")")
+        candidate_set <- eval(parse(text = expr))
+      }
+
       candidate_set <- candidate_set[, expanded_names]
 
     }

R/efficiency-criteria.R

@@ -100,8 +100,8 @@ calculate_efficiency <- function(prior_values,
 #' @export
 calculate_efficiency_criteria <- function(
   design_vcov,
-  p = NULL,
-  dudx = NULL,
+  p,
+  dudx,
   return_all = FALSE,
   significance = 1.96,
   type

R/evaluate.R

@@ -23,10 +23,16 @@ evaluate_design_candidate <- function(utility,
   # Define x_j for the analytical derivatives
   x_j <- define_x_j(utility, design_candidate)
 
+  design_candidate_with_names <- x_j
+  for (i in seq_along(design_candidate_with_names)) {
+    colnames(design_candidate_with_names[[i]]) <- paste(names(design_candidate_with_names[i]), colnames(design_candidate_with_names[[i]]), sep = "_")
+  }
+
   # Update the design environment NB! Using design_candidate because we are
   # evaluating the expression in context and don't need the interaction cols
   list2env(
-    c(as.list(as.data.frame(do.call(cbind, define_base_x_j(utility, design_candidate)))),
+    # c(as.list(as.data.frame(do.call(cbind, define_base_x_j(utility, design_candidate)))),
+    c(as.list(as.data.frame(do.call(cbind, design_candidate_with_names))),
       list(x_j = x_j)),
     envir = design_env
   )

R/extract.R

@@ -1,7 +1,7 @@
 #' Extract all names
 #'
 #' Extracts all parameter and attribute names from the utility function.
-#' This is a wrapper around \code{\link{str_extract_all}} with a specified
+#' This is a wrapper around \code{\link[stringr]{str_extract_all}} with a specified
 #' boundary. The function also calls \code{\link{remove_all_brackets}} to
 #' ensure that if a word is used inside a square bracket, e.g. seq, it is not
 #' extracted.

R/level-balance.R

@@ -0,0 +1,27 @@
+#'
+#'
+#' Print level balance of your design
+#'
+#' Prints a table of level balance for your design. If the design is blocked
+#' you will get both level balance per block and overall level balance
+#'
+#' @param design An spdesign object
+#' @param block A boolean equal to TRUE if you want frequency tables per block.
+#' The default value is FALSE
+#'
+#' @export
+level_balance <- function(design, block = FALSE) {
+  x <- design[["design"]]
+
+  if (block) {
+    blocked <- split(x, x$block)
+    names(blocked) <- paste("block", unique(x$block), sep = "_")
+    # Dropping the last column because it is the blocking column by default.
+    unlist(lapply(blocked, function(y) lapply(y[, -ncol(y)], table)), recursive = FALSE)
+
+  } else {
+    lapply(x, table)
+
+  }
+
+}

R/parsing.R

@@ -398,7 +398,7 @@ lvl_occurrences <- function(utility, rows, level_balance) {
 
       names(z) <- y
       return(z)
-    }, min_lvl_occurrence(utility, rows), expand_attribute_levels(utility), level_balance)
+    }, min_lvl_occurrence(utility, rows), expand_attribute_levels(utility), level_balance, SIMPLIFY = FALSE)
   )
 }
 

README.Rmd

@@ -36,7 +36,7 @@ install.packages("spdesign")
 A development version of the package can be installed from Github. Remember to select the most recent development version (check the available branches).
 
 ```{r install_github, eval=FALSE}
-devtools::install_github("edsandorf/spdesign")
+remotes::install_github("edsandorf/spdesign", ref = "v0.0.5-dev")
 ```
 
 ## Example
@@ -73,4 +73,8 @@ summary(design)
 All software contains bugs and we would very much like to find these and root them out. If you find a bug or get an error message, please reach out so that we can try and improve the software.
 
 ## Acknowledgements
-We are grateful to Petr Mariel, Jürgen Meyerhoff and Ainhoa Vega for providing feedback and extensive testing of the package. We also thank participants in the 2022 Summer School "Valuing options of adaption to climate change using choice experiments" at the University of Cape Town for valuable feedback on a beta version of the package. The package comes with no warranty and the authors cannot be held liable for errors or mistakes resulting from use. The authors acknowledge funding from the European Union’s Horizon 2020 research and innovation program under the Marie Sklodowska-Curie grant INSPiRE (Grant agreement ID: 793163).
+We are grateful to Petr Mariel, Jürgen Meyerhoff and Ainhoa Vega for providing feedback and extensive testing of the package. We also thank participants in the 2022 Summer School "Valuing options of adaption to climate change using choice experiments" at the University of Cape Town for valuable feedback on a beta version of the package. 
+
+We would also like to acknowledge all those who have contributed with bug reports: Gabriele Iannaccone, Petr Mariel, Julian Sagebiel
+
+The package comes with no warranty and the authors cannot be held liable for errors or mistakes resulting from use. The authors acknowledge funding from the European Union’s Horizon 2020 research and innovation program under the Marie Sklodowska-Curie grant INSPiRE (Grant agreement ID: 793163).

README.md

@@ -34,7 +34,7 @@ Remember to select the most recent development version (check the
 available branches).
 
 ``` r
-devtools::install_github("edsandorf/spdesign")
+remotes::install_github("edsandorf/spdesign", ref = "v0.0.4-dev")
 ```
 
 ## Example
@@ -78,8 +78,13 @@ We are grateful to Petr Mariel, Jürgen Meyerhoff and Ainhoa Vega for
 providing feedback and extensive testing of the package. We also thank
 participants in the 2022 Summer School “Valuing options of adaption to
 climate change using choice experiments” at the University of Cape Town
-for valuable feedback on a beta version of the package. The package
-comes with no warranty and the authors cannot be held liable for errors
-or mistakes resulting from use. The authors acknowledge funding from the
-European Union’s Horizon 2020 research and innovation program under the
-Marie Sklodowska-Curie grant INSPiRE (Grant agreement ID: 793163).
+for valuable feedback on a beta version of the package.
+
+We would also like to acknowledge all those who have contributed with
+bug reports: Gabriele Iannaccone
+
+The package comes with no warranty and the authors cannot be held liable
+for errors or mistakes resulting from use. The authors acknowledge
+funding from the European Union’s Horizon 2020 research and innovation
+program under the Marie Sklodowska-Curie grant INSPiRE (Grant agreement
+ID: 793163).

cran-comments.md

@@ -1,5 +1,5 @@
 ##  Test environments
-* local MacOS Sonoma 14.12.1, R 4.3.2
+* local MacOS Sonoma 14.5, R 4.4.0
 * win-builder (devel and release)
 
 ## R CMD check results

test-function-call.R

@@ -1,4 +1,4 @@
-rows <- 20
+rows <- 10
 model <- "mnl"
 efficiency_criteria <- "d-error"
 algorithm <- "rsc"
@@ -17,3 +17,36 @@ control <- list(
 )
 return_all <- FALSE
 significance <- 1.96
+
+
+#
+# Example file for creating a simple MNL design
+#
+rm(list = ls(all = TRUE))
+# library(spdesign)
+
+# Define the list of utility functions ----
+#' Specifying a utility function with 3 attributes and a constant for the
+#' SQ alternative. The design has 20 rows.
+utility <- list(
+  alt1 = "b_x1_dummy[c(0, 0)] * x1[1:3] + b_x2_dummy[c(0, 0)] * x2[1:3] + b_x3_dummy[c(0, 0)] * x3[1:3]",
+  alt2 = "b_x1_dummy          * x1      + b_x2_dummy          * x2      + b_x3_dummy          * x3"
+)
+
+# Generate designs ----
+design <- generate_design(utility,
+                          rows = 10,
+                          model = "mnl",
+                          efficiency_criteria = "d-error",
+                          algorithm = "rsc",
+                          draws = "scrambled-sobol",
+                          control = list(
+                            max_iter = 21000,
+                            max_no_improve = 5000
+                          ))
+
+# Add a blocking variable to the design with 4 blocks.
+design <- block(design, 4)
+
+
+summary(design)