library(designit)
library(ggplot2)
library(dplyr)
library(tidyr)

Example 4: More than one group factor to balance and empty plate positions

In this example, we have 2 factors to distribute across one plate: Treatment and (animal) sex.

To indicate that the balancing of treatment is considered more important than the animal sex we assign a custom aggregation function giving more weight to the treatment variable. (A better aggregation mechanism has to be implemented!!!)

There can be less samples than possible positions on the plate(s). In this case, we simulate 20 animal derived samples distributed on a plate with 24 locations.

# Setting up the batch container
example4 <- BatchContainer$new(
  dimensions = c(
    plate = 1, row = 6, col = 4
  )
)


# Assign samples randomly to start from lower score (avoid Inf values even since plate 3 will miss 2 groups initially :)
example4 <- assign_in_order(example4, samples = tibble::tibble(
  Group = rep.int(c("Treatment 1", "Treatment 2"), times = c(10, 10)),
  Sex = c(rep(c("M", "F", "F", "M"), times = 4), "M", NA, NA, "F"), ID = 1:20
))

cowplot::plot_grid(
  plot_plate(example4, plate = plate, row = row, column = col, .color = Group, title = "Initial layout by Group"),
  plot_plate(example4, plate = plate, row = row, column = col, .color = Sex, title = "Initial layout by Sex"),
  ncol = 2
)



scoring_f <- c(
  Group = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Group"),
  Sex = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Sex")
)

example4$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    83.63858   239.20748
set.seed(42)
bc <- optimize_design(
  example4,
  scoring = scoring_f,
  max_iter = 750,
  n_shuffle = 1,
  acceptance_func = mk_simanneal_acceptance_func(mk_simanneal_temp_func(T0 = 10000, alpha = 1)),
  aggregate_scores_func = function(scores, ...) {
    2 * scores["Group.Plate"] + scores["Sex.Plate"]
  },
  quiet = TRUE
)
bc$trace$elapsed
#> Time difference of 3.95466 secs

bc$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    8.019656    7.608810

cowplot::plot_grid(
  plot_plate(bc, plate = plate, row = row, column = col, .color = Group, title = "Final layout by Group"),
  plot_plate(bc, plate = plate, row = row, column = col, .color = Sex, title = "Final layout by Sex"),
  ncol = 2
)

We do the same example with auto-scaling, weighted scoring and SA to have a reference!

set.seed(42)
bc <- optimize_design(
  bc,
  scoring = scoring_f,
  max_iter = 500,
  n_shuffle = 1,
  acceptance_func = mk_simanneal_acceptance_func(mk_simanneal_temp_func(T0 = 10000, alpha = 1)),
  aggregate_scores_func = function(scores, ...) {
    purrr::set_names(2 * scores["Group.Plate"] + scores["Sex.Plate"], nm = "Weighted.Score")
  },
  autoscale_scores = T,
  quiet = TRUE
)
#> ... Performing boxcox lambda estimation.
bc$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    7.467566    7.753204

cowplot::plot_grid(
  plot_plate(bc, plate = plate, row = row, column = col, .color = Group, title = "Final layout by Group"),
  plot_plate(bc, plate = plate, row = row, column = col, .color = Sex, title = "Final layout by Sex"),
  ncol = 2
)

We do the same example with auto-scaling and position-dependent scoring now, not aggregating the score vector! This is more effective even when using the default acceptance function. We are strictly prioritizing the leftmost score in addition to reflect relevance for the design.

scoring_f <- c(
  Group = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Group"),
  Sex = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Sex")
)

example4$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    83.63858   239.20748

set.seed(42)
bc <- optimize_design(
  example4,
  scoring = scoring_f,
  max_iter = 5000,
  n_shuffle = 1,
  acceptance_func = accept_leftmost_improvement,
  autoscale_scores = TRUE,
  quiet = TRUE
)
#> ... Performing boxcox lambda estimation.
bc$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    7.619846    7.473524

cowplot::plot_grid(
  plot_plate(bc, plate = plate, row = row, column = col, .color = Group, title = "Final layout by Group"),
  plot_plate(bc, plate = plate, row = row, column = col, .color = Sex, title = "Final layout by Sex"),
  ncol = 2
)

Using a tolerance value to accept slightly worse solutions in the leftmost relevant score if overcompensated by other scores:

scoring_f <- c(
  Group = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Group"),
  Sex = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Sex")
)


set.seed(42)
bc <- optimize_design(
  example4,
  scoring = scoring_f,
  max_iter = 5000,
  n_shuffle = 1,
  acceptance_func = ~ accept_leftmost_improvement(..., tolerance = 0.1),
  autoscale_scores = TRUE,
  quiet = TRUE
)
#> ... Performing boxcox lambda estimation.

bc$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    7.474561    7.412716
cowplot::plot_grid(
  plot_plate(bc, plate = plate, row = row, column = col, .color = Group, title = "Final layout by Group"),
  plot_plate(bc, plate = plate, row = row, column = col, .color = Sex, title = "Final layout by Sex"),
  ncol = 2
)

Testing an alternative left-to-right weighing of scores, based on exponential down-weighing of the respective score differences at position \(p\) with factor \(\kappa^p\), \(0 < \kappa < 1\) We choose a \(\kappa\) of 0.5, i.e. the second score’s improvement counts half of that of the first one.

scoring_f <- c(
  Group = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Group"),
  Sex = mk_plate_scoring_functions(example4, row = "row", column = "col", group = "Sex")
)

bc$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    7.474561    7.412716

set.seed(42)
bc <- optimize_design(
  example4,
  scoring = scoring_f,
  max_iter = 1000,
  n_shuffle = 1,
  acceptance_func = mk_exponentially_weighted_acceptance_func(kappa = 0.5, simulated_annealing = T),
  autoscale_scores = TRUE,
  quiet = TRUE
)
#> ... Performing boxcox lambda estimation.
bc$score(scoring_f)
#> Group.Plate   Sex.Plate 
#>    7.711676    7.499601

cowplot::plot_grid(
  plot_plate(bc, plate = plate, row = row, column = col, .color = Group, title = "Final layout by Group"),
  plot_plate(bc, plate = plate, row = row, column = col, .color = Sex, title = "Final layout by Sex"),
  ncol = 2
)