Feature/factorial design

DESCRIPTION

@@ -35,6 +35,7 @@ Description: The Speed package optimises spatial experimental designs by rearran
 License: MIT + file LICENSE
 URL: https://biometryhub.github.io/speed/
 BugReports: https://github.com/biometryhub/speed/issues
+Depends: R (>= 4.1)
 Imports: 
     farver,
     ggplot2,

NAMESPACE

@@ -15,6 +15,7 @@ export(get_vertices)
 export(initialise_design_df)
 export(initialize_design_df)
 export(objective_function)
+export(objective_function_factorial)
 export(objective_function_piepho)
 export(objective_function_signature)
 export(optim_params)

R/metrics.R

@@ -70,6 +70,57 @@ objective_function <- function(layout_df,
   ))
 }
 
+#' Objective Function for Factorial Design Optimization
+#'
+#' @inheritParams objective_function
+#' @inheritDotParams objective_function
+#' @param factorial_separator A character used to separate treatments in the factorial design (default: "-")
+#'
+#' @examples
+#' treatment_a <- paste0("A", 1:8)
+#' treatment_b <- paste0("B", 1:3)
+#' treatments <- with(expand.grid(treatment_a, treatment_b), paste(Var1, Var2, sep = "-"))
+#' df <- initialise_design_df(treatments, 24, 3, 8, 3)
+#' objective_function_factorial(df, "treatment", c("row", "col", "block"))
+#'
+#' @export
+# fmt: skip
+objective_function_factorial <- function(layout_df,
+                                         swap,
+                                         spatial_cols,
+                                         factorial_separator = "-",
+                                         ...) {
+  if (is.null(factorial_separator) || factorial_separator == "") {
+    return(objective_function(layout_df, swap, spatial_cols, ...))
+  }
+
+  # count number of treatments
+  n_treatments <- stringi::stri_count_fixed(
+    as.character(layout_df[[swap]][1]),
+    factorial_separator
+  ) + 1
+
+  # split treatments
+  subtreatments <- stringi::stri_split_fixed(
+    as.character(layout_df[[swap]]),
+    factorial_separator,
+    n = n_treatments,
+    simplify = TRUE
+  )
+
+  # create temp columns
+  # now <- as.numeric(Sys.time())
+  treatment_n <- paste0("treatment_", 1:n_treatments)
+  layout_df[treatment_n] <- subtreatments
+
+  treatment_score <- calculate_balance_score(layout_df, swap, spatial_cols)
+  subtreatment_scores <- vapply(treatment_n, function(treatment) {
+    objective_function(layout_df, treatment, spatial_cols, ...)$score
+  }, numeric(1))
+
+  return(list(score = sum(subtreatment_scores) + treatment_score))
+}
+
 #' Calculate Balance Score for Experimental Design
 #'
 #' @description

tests/testthat/test-objective_functions.R

@@ -479,10 +479,47 @@ test_that("objective_function_piepho handles extra parameters via ...", {
                                         extra_param = "test", another_param = 123)
   })
 
-  result <- objective_function_piepho(design_df, "treatment", c("row", "col"),
-                                      pair_mapping = pair_mapping,
-                                      extra_param = "test", another_param = 123)
   expect_type(result, "list")
   expect_named(result, c("score", "ed", "bal", "adj", "nb"))
 })
 
+test_that("objective_function_factorial works", {
+  treatment_a <- paste0("A", 1:8)
+  treatment_b <- paste0("B", 1:3)
+  treatments <- with(expand.grid(treatment_a, treatment_b), paste(Var1, Var2, sep = "-"))
+  df <- initialise_design_df(treatments, 24, 3, 8, 3)
+  df <- shuffle_items(df, "treatment", "block", 112)
+
+  subtreatments <- strsplit(as.character(df$treatment), "-") |>
+    unlist() |>
+    matrix(ncol = 2, byrow = TRUE)
+  df[c("treatment_a", "treatment_b")] <- subtreatments
+
+  score_treatment <- calculate_balance_score(df, "treatment", c("row", "col"))
+  score_treatment_a <- objective_function(df, "treatment_a", c("row", "col"))$score
+  score_treatment_b <- objective_function(df, "treatment_b", c("row", "col"))$score
+  expected_score <- score_treatment + score_treatment_a + score_treatment_b
+
+  result <- objective_function_factorial(df, "treatment", c("row", "col"))
+
+  expect_type(result, "list")
+  expect_named(result, "score")
+  expect_type(result$score, "double")
+  expect_equal(result$score, expected_score)
+})
+
+test_that("objective_function_factorial falls back to objective_function with invalid separator", {
+  treatment_a <- paste0("A", 1:8)
+  treatment_b <- paste0("B", 1:3)
+  treatments <- with(expand.grid(treatment_a, treatment_b), paste(Var1, Var2, sep = "-"))
+  df <- initialise_design_df(treatments, 24, 3, 8, 3)
+  df <- shuffle_items(df, "treatment", "block", 112)
+
+  expected_score <- objective_function(df, "treatment", c("row", "col"))$score
+
+  result <- objective_function_factorial(df, "treatment", c("row", "col"), factorial_separator = "")
+  expect_equal(result$score, expected_score)
+
+  result <- objective_function_factorial(df, "treatment", c("row", "col"), factorial_separator = NULL)
+  expect_equal(result$score, expected_score)
+})

tests/testthat/test-speed.R

@@ -2078,6 +2078,83 @@ test_that("speed runs with legacy options(speed.{option})", {
   expect_true(isTRUE(all.equal(result_legacy, result)))
 })
 
+test_that("speed handles factorial designs", {
+  treatment_a <- paste0("A", 1:5)
+  treatment_b <- paste0("B", 1:3)
+  treatments <- with(expand.grid(treatment_a, treatment_b), paste(Var1, Var2, sep = "-"))
+  df <- initialise_design_df(treatments, 15, 3, 5, 3)
+
+  result <- speed(
+    data = df,
+    swap = "treatment",
+    swap_within = "block",
+    spatial_factors = ~ row + col,
+    obj_function = objective_function_factorial,
+    optimise_params = optim_params(adaptive_swaps = TRUE),
+    early_stop_iterations = 2000,
+    iterations = 100000,
+    seed = 112,
+    quiet = TRUE
+  )
+  df_result <- result$design_df
+
+  expect_equal(nrow(result$design_df), 45)
+  expect_setequal(result$treatments, df$treatment)
+  expect_lt(result$score, objective_function_factorial(df, "treatment", c("row", "col"))$score)
+})
+
+test_that("speed handles factorial designs with alternative separator", {
+  treatment_a <- paste0("A", 1:5)
+  treatment_b <- paste0("B", 1:3)
+  treatments <- with(expand.grid(treatment_a, treatment_b), paste(Var1, Var2, sep = ":"))
+  df <- initialise_design_df(treatments, 15, 3, 5, 3)
+
+  result <- speed(
+    data = df,
+    swap = "treatment",
+    swap_within = "block",
+    spatial_factors = ~ row + col,
+    obj_function = objective_function_factorial,
+    factorial_separator = ":",
+    optimise_params = optim_params(adaptive_swaps = TRUE),
+    early_stop_iterations = 2000,
+    iterations = 100000,
+    seed = 42,
+    quiet = TRUE
+  )
+  df_result <- result$design_df
+
+  expect_equal(nrow(result$design_df), 45)
+  expect_setequal(result$treatments, df$treatment)
+  expect_lt(result$score, objective_function_factorial(df, "treatment", c("row", "col"))$score)
+})
+
+test_that("speed handles 3-way factorial designs", {
+  treatment_a <- paste0("A", 1:5)
+  treatment_b <- paste0("B", 1:3)
+  treatment_c <- paste0("C", 1:3)
+  treatments <- with(expand.grid(treatment_a, treatment_b, treatment_c), paste(Var1, Var2, Var3, sep = "-"))
+  df <- initialise_design_df(treatments, 15, 9, 5, 9)
+
+  result <- speed(
+    data = df,
+    swap = "treatment",
+    swap_within = "block",
+    spatial_factors = ~ row + col,
+    obj_function = objective_function_factorial,
+    optimise_params = optim_params(adaptive_swaps = TRUE),
+    early_stop_iterations = 2000,
+    iterations = 100000,
+    seed = 112,
+    quiet = TRUE
+  )
+  df_result <- result$design_df
+
+  expect_equal(nrow(result$design_df), 135)
+  expect_setequal(result$treatments, df$treatment)
+  expect_lt(result$score, objective_function_factorial(df, "treatment", c("row", "col"))$score)
+})
+
 # TODO: Test cases to add/update
 # - Add more detailed checking of current designs
 # - NSE