Added a function to create the blocking column. Blocking is done afte…

…r the fact and is no longer an argument for the design itself.

NAMESPACE

@@ -5,6 +5,8 @@ S3method(print,spdesign)
 S3method(summary,spdesign)
 S3method(vcov,spdesign)
 export(attribute_levels)
+export(attribute_names)
+export(block)
 export(calculate_efficiency_criteria)
 export(clean_utility)
 export(expand_attribute_levels)
@@ -21,6 +23,7 @@ export(vcov)
 import(cli)
 import(stringr)
 importFrom(stats,as.formula)
+importFrom(stats,cor)
 importFrom(stats,model.matrix)
 importFrom(stats,qnorm)
 importFrom(stats,runif)

R/block.R

@@ -0,0 +1,92 @@
+#' Block the design
+#'
+#' The function will take an object of class 'spdesign' and add a blocking
+#' column to the design matrix. The function will use random permutations of
+#' the blocking column to find the column that minimizes correlation between
+#' the blocking column and the design columns. Specifically the target for the
+#' minimization procedure is the mean squared correlation.
+#'
+#' The function uses a random permutation so every time you run the function
+#' you will get a slightly different blocking vectors. You can set a seed prior
+#' to calling the function to always return the same blocking vector.
+#'
+#' If you pass in a design that already contains a blocking column, then this
+#' blocking column will be replaced.
+#'
+#' @param x An object of class 'spdesign'
+#' @param blocks An integer giving the number of blocks. The
+#' @param target A target value for the mean squared correlation. The default
+#' value is 0.0005. Setting the target to 0 forces the function to search all
+#' `max_iter` blocking candidates
+#' @param max_iter The maximum number of candidates to consider before returning
+#' the best blocking candidate. The default value is 1000000.
+#'
+#' @return A modified 'spdesign' object where the design is replaced with the
+#' same design and a blocking column. In addition a corelation vector, number
+#' of iterations and the target value are returned.
+#'
+#' @export
+block <- function(x, blocks, target = 0.0005, max_iter = 1000000) {
+  # Check input class
+  stopifnot(class(x) == "spdesign")
+
+  # Copy 'x' to local copy of blocked_design
+  blocked_design <- x
+  design <- blocked_design[["design"]]
+
+  # Check that the number of blocks are feasible with the size of the design
+  if (blocks > nrow(design)) {
+    stop("You cannot have more blocks than rows")
+  }
+
+  if (nrow(design) %% blocks != 0)  {
+    stop("You cannot have uneven number of rows per block")
+  }
+
+  # Check if blocking column is present, and if so, drop it.
+  blocking_column <- str_detect(colnames(design), "block")
+  if (any(blocking_column)) {
+    design <- design[, which(!blocking_column)]
+  }
+
+  # Create a blocking candidate
+  block <- rep(seq_len(blocks), nrow(design) / blocks)
+
+  blocked_design[["blocks_value"]] <- 1
+  blocked_design[["design"]] <- cbind(design, block)
+  blocked_design[["blocks_correlation"]] <- cor(design, block)
+  blocked_design[["blocks_iter"]] <- 1
+
+  # Return the blocked design object when the function exits prematurely.
+  on.exit({
+    return(blocked_design)
+  }, add = TRUE)
+
+  iter <- 1
+
+  repeat {
+    # Stop if more than max_iter iterations
+    if (iter >= max_iter) break
+
+    # Calculate the correlation between the attributes and a random permutation
+    # of the blocking variable.
+    block <- sample(block)
+    correlation <- cor(design, block)
+    current <- mean(correlation ^ 2)
+
+    if (current < blocked_design[["blocks_value"]]) {
+      blocked_design[["blocks_value"]] <- current
+      blocked_design[["design"]] <- cbind(design, block)
+      blocked_design[["blocks_correlation"]] <- correlation
+      blocked_design[["blocks_iter"]] <- iter
+
+    }
+
+    # Stopping criteria
+    if (blocked_design[["blocks_value"]] <= target) break
+
+    iter <- iter + 1
+  }
+
+  return(blocked_design)
+}

R/design.R

@@ -8,9 +8,6 @@
 #' vignette for examples of how to define these correctly for different types
 #' of experimental designs.
 #' @param rows An integer giving the number of rows in the final design
-#' @param blocks An integer giving the number of blocks to block the design
-#' into. The number of blocks cannot be greater than the number of rows in the
-#' design and the number of rows per block has to be equal.
 #' @param model A character string indicating the model to optimize the design
 #' for. Currently the only model programmed is the 'mnl' model and this is also
 #' set as the default.
@@ -44,7 +41,6 @@
 #' @export
 generate_design <- function(utility,
                             rows,
-                            blocks = 1,
                             model = "mnl",
                             efficiency_criteria = c("a-error", "c-error",
                                                     "d-error", "s-error"),
@@ -95,14 +91,6 @@ generate_design <- function(utility,
 
   control <- modifyList(default_control, control)
 
-  if (blocks > rows) {
-    stop("You cannot have more blocks than rows")
-  }
-
-  if (rows %% blocks != 0)  {
-    stop("You cannot have uneven number of rows per block")
-  }
-
   if (algorithm == "rsc") {
     cli_alert_info(
       "The cycling part of the algorithm is not used. It only applies to a

R/spdesign.R

@@ -10,6 +10,6 @@
 #'
 #' @import cli
 #' @import stringr
-#' @importFrom stats runif qnorm as.formula model.matrix
+#' @importFrom stats runif qnorm as.formula model.matrix cor
 #' @importFrom utils modifyList
 NULL