diff --git a/DESCRIPTION b/DESCRIPTION index eebf96a..9bab906 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -59,7 +59,7 @@ Imports: desplot, shinyjs Encoding: UTF-8 -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Author: Didier Murillo [cre, aut], Salvador Gezan [aut], Ana Heilman [ctb], Thomas Walk [ctb], Johan Aparicio [ctb], Matthew Seefeldt [ctb], Jean-Marc Montpetit [ctb], Richard Horsley [ctb], diff --git a/R/fct_RCDB_augmented.R b/R/fct_RCDB_augmented.R index 2a9b8e4..4d92576 100644 --- a/R/fct_RCDB_augmented.R +++ b/R/fct_RCDB_augmented.R @@ -1,5 +1,25 @@ +#' @noRd +stack_reps <- function(x_list, repsStack = c("vertical", "horizontal")) { + repsStack <- match.arg(repsStack) + + # x_list is a list of data.frames (same dims) + if (length(x_list) == 1) return(x_list[[1]]) + + mats <- lapply(x_list, function(x) { + if (is.data.frame(x)) as.matrix(x) else x + }) + + out <- if (repsStack == "vertical") { + do.call(rbind, mats) + } else { + do.call(cbind, mats) + } + + as.data.frame(out, stringsAsFactors = FALSE) +} + #' Generates an Augmented Randomized Complete Block Design (ARCBD) -#' +#' #' @description It randomly generates an augmented randomized complete block design across locations (ARCBD). #' #' @param lines Treatments, number of lines for test. @@ -7,6 +27,7 @@ #' @param b Number of augmented blocks. #' @param l Number of locations. By default \code{l = 1}. #' @param plotNumber Numeric vector with the starting plot number for each location. By default \code{plotNumber = 101}. +#' @param repsStack Option for \code{horizontal} or \code{vertical} layout By default \code{repsStack = 'vertical'}. #' @param planter Option for \code{serpentine} or \code{cartesian} arrangement. By default \code{planter = 'serpentine'}. #' @param seed (optional) Real number that specifies the starting seed to obtain reproducible designs. #' @param exptName (optional) Name of experiment. @@ -16,182 +37,264 @@ #' @param data (optional) Data frame with the labels of treatments. #' @param nrows (optional) Number of rows in the field. #' @param ncols (optional) Number of columns in the field. -#' -#' -#' @author Didier Murillo [aut], -#' Salvador Gezan [aut], -#' Ana Heilman [ctb], -#' Thomas Walk [ctb], -#' Johan Aparicio [ctb], -#' Richard Horsley [ctb] -#' -#' @importFrom stats runif na.omit -#' -#' -#' @return A list with five elements. -#' \itemize{ -#' \item \code{infoDesign} is a list with information on the design parameters. -#' \item \code{layoutRandom} is the ARCBD layout randomization for the first location. -#' \item \code{plotNumber} is the plot number layout for the first location. -#' \item \code{exptNames} is the experiment names layout. -#' \item \code{data_entry} is a data frame with the data input. -#' \item \code{fieldBook} is a data frame with the ARCBD field book. -#' } -#' -#' @references -#' Federer, W. T. (1955). Experimental Design. Theory and Application. New York, USA. The -#' Macmillan Company. -#' -#' @examples -#' # Example 1: Generates an ARCBD with 6 blocks, 3 checks for each, and 50 treatments -#' # in two locations. -#' ARCBD1 <- RCBD_augmented(lines = 50, checks = 3, b = 6, l = 2, -#' planter = "cartesian", -#' plotNumber = c(1,1001), -#' seed = 23, -#' locationNames = c("FARGO", "MINOT")) -#' ARCBD1$infoDesign -#' ARCBD1$layoutRandom -#' ARCBD1$exptNames -#' ARCBD1$plotNumber -#' head(ARCBD1$fieldBook, 12) -#' -#' # Example 2: Generates an ARCBD with 17 blocks, 4 checks for each, and 350 treatments -#' # in 3 locations. -#' # In this case, we show how to use the option data. -#' checks <- 4; -#' list_checks <- paste("CH", 1:checks, sep = "") -#' treatments <- paste("G", 5:354, sep = "") -#' treatment_list <- data.frame(list(ENTRY = 1:354, NAME = c(list_checks, treatments))) -#' head(treatment_list, 12) -#' ARCBD2 <- RCBD_augmented(lines = 350, checks = 4, b = 17, l = 3, -#' planter = "serpentine", -#' plotNumber = c(101,1001,2001), -#' seed = 24, -#' locationNames = LETTERS[1:3], -#' data = treatment_list) -#' ARCBD2$infoDesign -#' ARCBD2$layoutRandom -#' ARCBD2$exptNames -#' ARCBD2$plotNumber -#' head(ARCBD2$fieldBook, 12) -#' +#' #' @export -RCBD_augmented <- function(lines = NULL, checks = NULL, b = NULL, l = 1, planter = "serpentine", - plotNumber = 101, exptName = NULL, seed = NULL, locationNames = NULL, - repsExpt = 1, random = TRUE, data = NULL, nrows = NULL, ncols = NULL) { - +RCBD_augmented <- function(lines = NULL, checks = NULL, b = NULL, l = 1, + planter = "serpentine", plotNumber = 101, + repsStack = c("vertical", "horizontal"), + exptName = NULL, seed = NULL, locationNames = NULL, + repsExpt = 1, random = TRUE, data = NULL, + nrows = NULL, ncols = NULL) { + repsStack <- match.arg(repsStack) if (all(c("serpentine", "cartesian") != planter)) { stop("Input planter choice is unknown. Please, choose one: 'serpentine' or 'cartesian'.") } - if (is.null(seed)) seed <- runif(1, min=-50000, max=50000) + if (is.null(seed)) seed <- runif(1, min = -50000, max = 50000) set.seed(seed) - if(!is.numeric(plotNumber) && !is.integer(plotNumber)) { + if (!is.numeric(plotNumber) && !is.integer(plotNumber)) { stop("plotNumber should be an integer or a numeric vector.") } if (any(plotNumber %% 1 != 0)) { stop("plotNumber should be integers.") } + if (!is.null(l)) { - if (is.null(plotNumber) || length(plotNumber) != l) { - if (l > 1){ - plotNumber <- seq(1001, 1000*(l+1), 1000) - message(cat("Warning message:", "\n", - "Since plotNumber was missing, it was set up to default value of: ", plotNumber, - "\n", "\n")) + if (is.null(plotNumber) || !(length(plotNumber) %in% c(l, repsExpt, l * repsExpt))) { + if (l > 1) { + plotNumber <- seq(1001, 1000 * (l + 1), 1000) + message(cat( + "Warning message:", "\n", + "Since plotNumber was missing, it was set up to default value of: ", plotNumber, + "\n", "\n" + )) } else { plotNumber <- 1001 - message(cat("Warning message:", "\n", - "Since plotNumber was missing, it was set up to default value of: ", plotNumber, - "\n", "\n")) - } + message(cat( + "Warning message:", "\n", + "Since plotNumber was missing, it was set up to default value of: ", plotNumber, + "\n", "\n" + )) + } } - }else stop("Number of locations/sites is missing") + } else { + stop("Number of locations/sites is missing") + } + if (is.null(lines) || is.null(checks) || is.null(b) || is.null(l)) { - stop('Some of the basic design parameters are missing (lines, checks, b, l).') + stop("Some of the basic design parameters are missing (lines, checks, b, l).") } - if(is.null(repsExpt)) repsExpt <- 1 - arg1 <- list(lines, b, l, repsExpt);arg2 <- c(lines, b, l, repsExpt) + if (is.null(repsExpt)) repsExpt <- 1 + + arg1 <- list(lines, b, l, repsExpt) + arg2 <- c(lines, b, l, repsExpt) if (base::any(lengths(arg1) != 1) || base::any(arg2 %% 1 != 0) || base::any(arg2 < 1)) { - stop('RCBD_augmented() requires input lines, b and l to be possitive integers.') + stop("RCBD_augmented() requires input lines, b and l to be possitive integers.") } if (!is.null(plotNumber) && is.numeric(plotNumber)) { - if(any(plotNumber < 1) || any(diff(plotNumber) < 0)) { + if (any(plotNumber < 1) || any(diff(plotNumber) < 0)) { stop("RCBD_augmented() requires input plotNumber to be possitive integers and sorted.") } } + if (!is.null(data)) { data <- as.data.frame(data) if (ncol(data) < 2) base::stop("Data input needs at least two columns with: ENTRY and NAME.") - data <- data[,1:2] + data <- data[, 1:2] data <- na.omit(data) colnames(data) <- c("ENTRY", "NAME") new_lines <- nrow(data) - checks if (lines != new_lines) base::stop("Number of experimental lines do not match with data input provided.") lines <- new_lines } else { - NAME <- c(paste(rep("CH", checks), 1:checks, sep = ""), - paste(rep("G", lines), (checks + 1):(lines + checks), sep = "")) - data <- data.frame(list(ENTRY = 1:(lines + checks), NAME = NAME)) + NAME <- c( + paste(rep("CH", checks), 1:checks, sep = ""), + paste(rep("G", lines), (checks + 1):(lines + checks), sep = "") + ) + data <- data.frame(list(ENTRY = 1:(lines + checks), NAME = NAME)) } + all_genotypes <- lines + checks * b - plots_per_block <- base::ceiling(all_genotypes/b) + plots_per_block <- base::ceiling(all_genotypes / b) + excedent <- plots_per_block * b + Fillers <- excedent - all_genotypes + if (!is.null(locationNames)) { if (length(locationNames) == l) { locationNames <- toupper(locationNames) } else { locationNames <- 1:l } - } else locationNames <- 1:l - lines_per_plot <- plots_per_block - checks - excedent <- plots_per_block * b - Fillers <- excedent - all_genotypes - dim_block <- plots_per_block - ############################################################################################# + } else { + locationNames <- 1:l + } + if (l < 1 || is.null(l)) base::stop("Check the input for the number of locations.") - if (length(plotNumber) != l || is.null(plotNumber)) plotNumber <- seq(1001, 1000*(l+1), 1000) + if (is.null(plotNumber) || !(length(plotNumber) %in% c(l, repsExpt, l * repsExpt))) { + plotNumber <- seq(1001, 1000 * (l + 1), 1000) + } + outputDesign_loc <- vector(mode = "list", length = l) - if (is.null(exptName) || length(exptName) != repsExpt){ - exptName <- paste(rep('Expt', repsExpt), 1:repsExpt, sep = "") - } - if (any(is.null(c(nrows, ncols)))) { + if (is.null(exptName) || length(exptName) != repsExpt) { + exptName <- paste(rep("Expt", repsExpt), 1:repsExpt, sep = "") + } + + # ----------------------------- + # NEW: infer within-block dims + block grid (vertical or side-by-side) + # ----------------------------- + if (is.null(nrows) || is.null(ncols)) { nrows_within_block <- 1 - ncols <- plots_per_block + ncols_within_block <- plots_per_block + blocks_per_col <- b + blocks_per_row <- 1 + field_rows <- nrows_within_block * blocks_per_col + field_cols <- ncols_within_block * blocks_per_row } else { - nrows_within_block <- nrows / b - ncols <- ncols + if (nrows %% 1 != 0 || ncols %% 1 != 0 || nrows < 1 || ncols < 1) { + stop("nrows and ncols must be positive integers.") + } + # We no longer require nrows %% b == 0 because blocks can be side-by-side. + # We infer a grid (blocks_per_col x blocks_per_row) where blocks_per_col * blocks_per_row = b. + + inferred <- infer_arcbd_grid_dims( + nrows = nrows, + ncols = ncols, + b = b, + plots_per_block = plots_per_block + ) + + if (is.null(inferred)) { + # Feedback (now includes side-by-side options) + set_blocks <- set_augmented_blocks(lines = lines, checks = checks) + blocks_dims <- set_blocks$blocks_dims + colnames(blocks_dims) <- c("BLOCKS", "DIMENSIONS") + feedback <- as.data.frame(blocks_dims) + + message(cat( + "\n", "Error in RCBD_augmented(): ", "\n", "\n", + "Field dimensions do not fit with the data entered!", "\n", + "Try one of the following options: ", "\n" + )) + return(print(feedback)) + } + + nrows_within_block <- inferred$rows_within_block + ncols_within_block <- inferred$cols_within_block + blocks_per_col <- inferred$blocks_per_col + blocks_per_row <- inferred$blocks_per_row + field_rows <- nrows + field_cols <- ncols } - ## Start feedback code - field_rows <- nrows_within_block * b - field_cols <- ncols - lines_arcbd <- lines - checks_arcbd <- checks - set_blocks <- set_augmented_blocks( - lines = lines_arcbd, - checks = checks_arcbd - ) + + # Use within-block columns downstream where the algorithm expects "ncols" + ncols <- ncols_within_block + nrows_within_block <- nrows_within_block + + # ----------------------------- + # Feedback check (updated to match inferred full field dims) + # ----------------------------- + # set_blocks <- set_augmented_blocks(lines = lines, checks = checks) + # blocks_arcbd <- set_blocks$b + # if (length(blocks_arcbd) == 0) { + # stop("No options available for that amount of treatments!", call. = FALSE) + # } + # blocks_dims <- set_blocks$blocks_dims + # colnames(blocks_dims) <- c("BLOCKS", "DIMENSIONS") + # feedback <- as.data.frame(blocks_dims) + # set_dims <- paste(field_rows, field_cols, sep = " x ") + # inputs_subset <- subset(feedback, feedback[, 1] == b & feedback[, 2] == set_dims) + # # if (nrow(inputs_subset) == 0) { + # # message(cat( + # # "\n", "Error in RCBD_augmented(): ", "\n", "\n", + # # "Field dimensions do not fit with the data entered!", "\n", + # # "Try one of the following options: ", "\n" + # # )) + # # return(print(feedback)) + # # } + # + # if (nrow(inputs_subset) == 0) { + # width <- 55 + # border <- paste(rep("=", width), collapse = "") + # thin <- paste(rep("-", width), collapse = "") + # + # cat("\n") + # cat(border, "\n") + # cat(" ERROR: RCBD_augmented()\n") + # cat(thin, "\n") + # cat(" Field dimensions do not match the data entered.\n") + # cat(" Total plots in data:", lines + checks * b, "\n") + # cat(" Field size provided:", field_rows, "x", field_cols, "=", field_rows * field_cols, "plots\n") + # cat(thin, "\n") + # cat(" Valid dimension options:\n\n") + # for (i in seq_len(nrow(feedback))) { + # cat(sprintf(" [%2d ] %s blocks x %s\n", i, feedback[i, 1], feedback[i, 2])) + # } + # cat(border, "\n\n") + # return(invisible(NULL)) + # } + + + + set_blocks <- set_augmented_blocks(lines = lines, checks = checks, start = 3) blocks_arcbd <- set_blocks$b + if (length(blocks_arcbd) == 0) { stop("No options available for that amount of treatments!", call. = FALSE) } + blocks_dims <- set_blocks$blocks_dims colnames(blocks_dims) <- c("BLOCKS", "DIMENSIONS") feedback <- as.data.frame(blocks_dims) + + width <- 55 + border <- paste(rep("=", width), collapse = "") + thin <- paste(rep("-", width), collapse = "") + + # Check if b is less than the minimum valid number of blocks + if (b < min(blocks_arcbd)) { + cat("\n") + cat(border, "\n") + cat(" ERROR: RCBD_augmented()\n") + cat(thin, "\n") + cat(" The number of blocks requested is too small.\n") + cat(" Blocks requested:", b, "\n") + cat(" Minimum blocks allowed:", min(blocks_arcbd), "\n") + cat(" Maximum blocks allowed:", max(blocks_arcbd), "\n") + cat(thin, "\n") + cat(" Valid dimension options:\n\n") + for (i in seq_len(nrow(feedback))) { + cat(sprintf(" [%2d ] %s blocks : %s\n", i, feedback[i, 1], feedback[i, 2])) + } + cat(border, "\n\n") + return(invisible(NULL)) + } + set_dims <- paste(field_rows, field_cols, sep = " x ") inputs_subset <- subset(feedback, feedback[, 1] == b & feedback[, 2] == set_dims) + if (nrow(inputs_subset) == 0) { - message(cat("\n", "Error in RCBD_augmented(): ", "\n", "\n", - "Field dimensions do not fit with the data entered!", "\n", - "Try one of the following options: ", "\n")) - return(print(feedback)) + cat("\n") + cat(border, "\n") + cat(" ERROR: RCBD_augmented()\n") + cat(thin, "\n") + cat(" Field dimensions do not match the data entered.\n") + cat(" Total plots in data:", lines + checks * b, "\n") + cat(" Field size provided:", field_rows, "x", field_cols, "=", field_rows * field_cols, "plots\n") + cat(thin, "\n") + cat(" Valid dimension options:\n\n") + for (i in seq_len(nrow(feedback))) { + cat(sprintf(" [%2d ] %s blocks : %s\n", i, feedback[i, 1], feedback[i, 2])) + } + cat(border, "\n\n") + return(invisible(NULL)) } - ## end feedback code + loc <- 1:l expt <- 1:repsExpt layout1_loc1 <- vector(mode = "list", length = 1) plot_loc1 <- vector(mode = "list", length = 1) layout_random_sites <- vector(mode = "list", length = l) layout_plots_sites <- vector(mode = "list", length = l) + for (locations in loc) { sky <- length(expt) layout1_expt <- vector(mode = "list", length = repsExpt) @@ -199,143 +302,195 @@ RCBD_augmented <- function(lines = NULL, checks = NULL, b = NULL, l = 1, planter my_names_expt <- vector(mode = "list", length = repsExpt) plot_number_expt <- vector(mode = "list", length = repsExpt) Col_checks_expt <- vector(mode = "list", length = repsExpt) + for (expts in expt) { if (random) { - if (Fillers >= (ncols - checks - 1)) { + # if (Fillers > (ncols - checks - 1)) { + if (Fillers > 0 && Fillers > (ncols - checks - 1)) { stop("Number of Filler overcome the amount allowed per block. Please, choose another quantity of blocks.") - } + } + + lines_per_plot <- plots_per_block - checks len_cuts <- rep(lines_per_plot, times = b - 1) len_cuts <- c(len_cuts, lines - sum(len_cuts)) - entries <- as.vector(data[(checks + 1):nrow(data),1]) + entries <- as.vector(data[(checks + 1):nrow(data), 1]) entries <- sample(entries) rand_len_cuts <- sample(len_cuts) lines_blocks <- split_vectors(x = entries, len_cuts = rand_len_cuts) - total_rows <- nrows_within_block * b - datos <- sample(c(rep(0, times = nrows_within_block * ncols - checks), - rep(1, checks))) + + total_rows <- field_rows + datos <- sample(c( + rep(0, times = nrows_within_block * ncols - checks), + rep(1, checks) + )) + randomized_blocks <- setNames(vector(mode = "list", length = b), paste0("Block", 1:b)) spots_for_checks <- setNames(vector(mode = "list", length = b), paste0("Block", 1:b)) + for (i in 1:b) { - block <- matrix(data = sample(datos), nrow = nrows_within_block, - ncol = ncols, - byrow = TRUE) + block <- matrix( + data = sample(datos), + nrow = nrows_within_block, + ncol = ncols, + byrow = TRUE + ) + if (Fillers > 0 && i == 1) { - if (total_rows %% 2 == 0) { + if (total_rows %% 2 == 0) { if (planter == "serpentine") { - block[1,1:Fillers] <- "Filler" - } else { - block[1,((ncol(block) + 1) - Fillers):ncol(block)] <- "Filler" - } - } else { - block[1,((ncol(block) + 1) - Fillers):ncol(block)] <- "Filler" + block[1, 1:Fillers] <- "Filler" + } else { + block[1, ((ncol(block) + 1) - Fillers):ncol(block)] <- "Filler" + } + } else { + block[1, ((ncol(block) + 1) - Fillers):ncol(block)] <- "Filler" } + v <- which.min(rand_len_cuts) lines_blocks <- lines_blocks[unique(c(v, 1:b))] block_fillers <- as.vector(lines_blocks[[1]]) zeros <- length(block_fillers) + block[block != "Filler"] <- sample(as.character(c(rep(0, zeros), 1:checks))) block <- as.data.frame(block) colnames(block) <- paste0("col", 1:ncols) spots_for_checks[[i]] <- block - block_with_checks <- block + + block_with_checks <- block block_with_checks[block_with_checks == 0] <- sample(as.character(lines_blocks[[i]])) - block_with_entries_checks <- block_with_checks - randomized_blocks[[i]] <- block_with_entries_checks + randomized_blocks[[i]] <- block_with_checks } else { block[block == 1] <- sample(as.character(1:checks)) block <- as.data.frame(block) colnames(block) <- paste0("col", 1:ncols) spots_for_checks[[i]] <- block + block_with_checks <- block block_with_checks[block_with_checks == 0] <- sample(as.character(lines_blocks[[i]])) - block_with_entries_checks <- block_with_checks - block_with_entries_checks <- as.data.frame(block_with_entries_checks) + block_with_entries_checks <- as.data.frame(block_with_checks) colnames(block_with_entries_checks) <- paste0("col", 1:ncols) randomized_blocks[[i]] <- block_with_entries_checks } } - layout <- dplyr::bind_rows(randomized_blocks) - layout <- as.matrix(layout) - binary_matrix <- dplyr::bind_rows(spots_for_checks) - binary_matrix <- as.matrix(binary_matrix) + + layout <- assemble_arcbd_blocks(block_list = randomized_blocks, blocks_per_col = blocks_per_col, blocks_per_row = blocks_per_row) + binary_matrix <- assemble_arcbd_blocks(block_list = spots_for_checks, blocks_per_col = blocks_per_col, blocks_per_row = blocks_per_row) col_checks <- ifelse(binary_matrix != "0" & binary_matrix != "Filler", 1, 0) - plotsPerBlock <- rep(ncol(layout) * nrows_within_block, b) - plotsPerBlock <- c(plotsPerBlock[-length(plotsPerBlock)], ncol(layout) * nrows_within_block - Fillers) + + plotsPerBlock <- rep(ncols * nrows_within_block, b) + plotsPerBlock <- c(plotsPerBlock[-length(plotsPerBlock)], ncols * nrows_within_block - Fillers) } else { + # if (Fillers > (ncols - checks - 1)) { + if (Fillers > 0 && Fillers > (ncols - checks - 1)){ + stop("Number of Filler overcome the amount allowed per block. Please, choose another quantity of blocks.") + } + fun <- function(x) { - matrix(data = sample(c(rep(0, (nrows_within_block * ncols) - checks), 1:checks)), - nrow = nrows_within_block, - byrow = TRUE) + matrix( + data = sample(c(rep(0, (nrows_within_block * ncols) - checks), 1:checks)), + nrow = nrows_within_block, + byrow = TRUE + ) } - entries <- as.vector(data[(checks + 1):nrow(data),1]) + + entries <- as.vector(data[(checks + 1):nrow(data), 1]) + blocks_with_checks <- lapply(1:b, fun) + + layout_a <- assemble_arcbd_blocks( + block_list = blocks_with_checks, + blocks_per_col = blocks_per_col, + blocks_per_row = blocks_per_row + ) + if (Fillers > 0) { - if (Fillers >= (ncols - checks - 1)) { - stop("Number of Filler overcome the amount allowed per block. Please, choose another quantity of blocks.") - } - blocks_with_checks <- lapply(1:b, fun) - layout_a <- paste_by_row(blocks_with_checks) - if ((nrows_within_block * b) %% 2 == 0) { + if (field_rows %% 2 == 0) { if (planter == "serpentine") { - layout_a[1,] <- c(rep("Filler", Fillers), - sample(c(1:checks, rep(0, ncol(layout_a) - Fillers - checks)), - size = ncol(layout_a) - Fillers, replace = FALSE)) + layout_a[1, ] <- c( + rep("Filler", Fillers), + sample(c(1:checks, rep(0, ncol(layout_a) - Fillers - checks)), + size = ncol(layout_a) - Fillers, replace = FALSE + ) + ) } else { - layout_a[1,] <- c(sample(c(1:checks, rep(0, ncol(layout_a) - Fillers - checks)), - size = ncol(layout_a) - Fillers, replace = FALSE), - rep("Filler", Fillers)) - } + layout_a[1, ] <- c( + sample(c(1:checks, rep(0, ncol(layout_a) - Fillers - checks)), + size = ncol(layout_a) - Fillers, replace = FALSE + ), + rep("Filler", Fillers) + ) + } } else { - layout_a[1,] <- c(sample(c(1:checks, rep(0, ncol(layout_a) - Fillers - checks)), - size = ncol(layout_a) - Fillers, replace = FALSE), - rep("Filler", Fillers)) + layout_a[1, ] <- c( + sample(c(1:checks, rep(0, ncol(layout_a) - Fillers - checks)), + size = ncol(layout_a) - Fillers, replace = FALSE + ), + rep("Filler", Fillers) + ) } - col_checks <- ifelse(layout_a != 0, 1,0) - no_randomData <- no_random_arcbd(checksMap = layout_a, - data_Entry = entries, - planter = planter) - layout <- no_randomData$w_map_letters - len_cuts <- no_randomData$len_cut - plotsPerBlock <- rep(ncol(layout) * nrows_within_block, b) - plotsPerBlock <- c(plotsPerBlock[-length(plotsPerBlock)], ncol(layout) * nrows_within_block - Fillers) - } else { - blocks_with_checks <- lapply(1:b, fun) - layout_a <- paste_by_row(blocks_with_checks) - col_checks <- ifelse(layout_a != 0, 1,0) - no_randomData <- no_random_arcbd(checksMap = layout_a, - data_Entry = entries, - planter = planter) - layout <- no_randomData$w_map_letters - plotsPerBlock <- rep(ncol(layout) * nrows_within_block, b) + } + + col_checks <- ifelse(layout_a != 0, 1, 0) + + no_randomData <- no_random_arcbd( + checksMap = layout_a, + data_Entry = entries, + planter = planter + ) + + layout <- no_randomData$w_map_letters + + plotsPerBlock <- rep(ncols * nrows_within_block, b) + if (Fillers > 0) { + plotsPerBlock <- c(plotsPerBlock[-length(plotsPerBlock)], ncols * nrows_within_block - Fillers) } } - Blocks_info <- matrix(data = rep(b:1, each = (ncols * nrows_within_block)), - nrow = nrows_within_block * b, - ncol = ncols, - byrow = TRUE) - new_exptName <- rev(exptName) - nameEXPT <- ARCBD_name(Fillers = Fillers, - b = nrows_within_block * b, - layout = layout, - name.expt = exptName[expts], - planter = planter) - plotEXPT <- ARCBD_plot_number(plot.number = plotNumber[locations], - planter = planter, - b = nrows_within_block * b, - name.expt = exptName[expts], - Fillers = Fillers, - nameEXPT = nameEXPT$my_names) + + # Blocks info (keep the same "rev" convention as before) + block_ids <- rev(seq_len(b)) + block_info_list <- lapply(seq_len(b), function(ii) { + matrix(block_ids[ii], nrow = nrows_within_block, ncol = ncols, byrow = TRUE) + }) + Blocks_info <- assemble_arcbd_blocks(block_list = block_info_list, blocks_per_col = blocks_per_col, blocks_per_row = blocks_per_row) + + nameEXPT <- ARCBD_name( + Fillers = Fillers, + b = field_rows, + layout = layout, + name.expt = exptName[expts], + planter = planter + ) + + plot_start <- if (length(plotNumber) == l) { + plotNumber[locations] + } else if (length(plotNumber) == repsExpt) { + plotNumber[expts] + } else { + plotNumber[(locations - 1) * repsExpt + expts] + } + + plotEXPT <- ARCBD_plot_number( + plot.number = plot_start, + planter = planter, + b = field_rows, + name.expt = exptName[expts], + Fillers = Fillers, + nameEXPT = nameEXPT$my_names + ) + my_data_VLOOKUP <- data COLNAMES_DATA <- colnames(my_data_VLOOKUP) layout1 <- layout + if (Fillers > 0) { layout1[layout1 == "Filler"] <- 0 - layout1 <- apply(layout1, 2 , as.numeric) - Entry_Fillers <- data.frame(list(0,"Filler")) + layout1 <- apply(layout1, 2, as.numeric) + Entry_Fillers <- data.frame(list(0, "Filler")) colnames(Entry_Fillers) <- COLNAMES_DATA my_data_VLOOKUP <- rbind(my_data_VLOOKUP, Entry_Fillers) } + my_names <- nameEXPT$my_names - plot_number <- apply(plotEXPT$plot_num, 2 ,as.numeric) + plot_number <- apply(plotEXPT$plot_num, 2, as.numeric) Col_checks <- col_checks rownames(layout1) <- paste("Row", nrow(layout1):1, sep = "") @@ -349,24 +504,38 @@ RCBD_augmented <- function(lines = NULL, checks = NULL, b = NULL, l = 1, planter sky <- sky - 1 } - layout1 <- dplyr::bind_rows(layout1_expt) - plot_number <- dplyr::bind_rows(plot_number_expt) - Col_checks <- dplyr::bind_rows(Col_checks_expt) - my_names <- dplyr::bind_rows(my_names_expt) - Blocks_info <- dplyr::bind_rows(Blocks_info_expt) + # ---- MINIMAL FIX: keep EXPT1|EXPT2|EXPT3|EXPT4 when stacking horizontally ---- + if (repsStack == "horizontal") { + layout1_expt <- rev(layout1_expt) + plot_number_expt <- rev(plot_number_expt) + Col_checks_expt <- rev(Col_checks_expt) + my_names_expt <- rev(my_names_expt) + Blocks_info_expt <- rev(Blocks_info_expt) + } + # ----------------------------------------------------------------------------- + + layout1 <- stack_reps(layout1_expt, repsStack = repsStack) + plot_number <- stack_reps(plot_number_expt, repsStack = repsStack) + Col_checks <- stack_reps(Col_checks_expt, repsStack = repsStack) + my_names <- stack_reps(my_names_expt, repsStack = repsStack) + Blocks_info <- stack_reps(Blocks_info_expt, repsStack = repsStack) if (locations == loc[1]) { layout1_loc1[[1]] <- layout1 plot_loc1[[1]] <- plot_number - } + } + results_to_export <- list(layout1, plot_number, Col_checks, my_names, Blocks_info) year <- format(Sys.Date(), "%Y") - outputDesign <- export_design(G = results_to_export, - movement_planter = planter, - location = locationNames[locations], - Year = year, - data_file = my_data_VLOOKUP, - reps = TRUE) + outputDesign <- export_design( + G = results_to_export, + movement_planter = planter, + location = locationNames[locations], + Year = year, + data_file = my_data_VLOOKUP, + reps = TRUE + ) + if (Fillers > 0) { outputDesign$CHECKS <- ifelse(outputDesign$NAME == "Filler", "NA", outputDesign$CHECKS) } @@ -375,90 +544,229 @@ RCBD_augmented <- function(lines = NULL, checks = NULL, b = NULL, l = 1, planter layout_random_sites[[locations]] <- layout1 layout_plots_sites[[locations]] <- plot_number } - ########################################################################################## + fieldbook <- dplyr::bind_rows(outputDesign_loc) ID <- 1:nrow(fieldbook) - fieldbook <- fieldbook[, c(6:9,4,2,3,5,10,1,11)] + fieldbook <- fieldbook[, c(6:9, 4, 2, 3, 5, 10, 1, 11)] fieldbook <- cbind(ID, fieldbook) colnames(fieldbook)[12] <- "TREATMENT" rownames(fieldbook) <- 1:nrow(fieldbook) fieldbook$EXPT <- factor(fieldbook$EXPT, levels = as.character(exptName)) fieldbook$LOCATION <- factor(fieldbook$LOCATION, levels = as.character(locationNames)) - fieldbook <- fieldbook[order(fieldbook$LOCATION, fieldbook$EXPT),] - - fieldbook <- fieldbook[,-4] - DataChecks <- data[1:checks,] + fieldbook <- fieldbook[order(fieldbook$LOCATION, fieldbook$EXPT), ] + fieldbook <- fieldbook[, -4] + DataChecks <- data[1:checks, ] layout_loc1 <- as.matrix(layout1_loc1[[1]]) Plot_loc1 <- as.matrix(plot_loc1[[1]]) checks <- as.numeric(nrow(DataChecks)) - field_dimensions <- c(rows = nrows_within_block * b, cols = ncols) - blocks_dimensions <- c(rows = nrows_within_block, cols = ncols) + + full_rows <- if (repsStack == "vertical") field_rows * repsExpt else field_rows + full_cols <- if (repsStack == "vertical") field_cols else field_cols * repsExpt + infoDesign <- list( - #field_dimensions = field_dimensions, - rows = as.numeric(field_dimensions[1]), - columns = as.numeric(field_dimensions[2]), - rows_within_blocks = as.numeric(blocks_dimensions[1]), - columns_within_blocks = as.numeric(blocks_dimensions[2]), + rows = as.numeric(full_rows), + columns = as.numeric(full_cols), + rows_within_blocks = as.numeric(nrows_within_block), + columns_within_blocks = as.numeric(ncols_within_block), treatments = lines, checks = checks, - blocks = b, - plots_per_block = plotsPerBlock, - locations = l, - fillers = Fillers, - seed = seed, + blocks = b, + plots_per_block = plotsPerBlock, + locations = l, + fillers = Fillers, + seed = seed, id_design = 14 ) - output <- list(infoDesign = infoDesign, layoutRandom = layout_loc1, - layout_random_sites = layout_random_sites, - layout_plots_sites = layout_plots_sites, - plotNumber = Plot_loc1, exptNames = my_names, - data_entry = data, fieldBook = fieldbook) + + output <- list( + infoDesign = infoDesign, + layoutRandom = layout_loc1, + layout_random_sites = layout_random_sites, + layout_plots_sites = layout_plots_sites, + plotNumber = Plot_loc1, + exptNames = my_names, + data_entry = data, + fieldBook = fieldbook + ) + class(output) <- "FielDHub" return(invisible(output)) } -#' @noRd -#' -#' +#' @noRd set_augmented_blocks <- function(lines, checks, start = 5) { if (lines > 40) div <- 3 else div <- 2 blocks <- start:ceiling(lines / div) - b <- vector(mode = "numeric") + + b_out <- vector(mode = "numeric") checked_dims <- list() blocks_dims <- matrix(ncol = 2, byrow = TRUE) n <- 1 + for (i in blocks) { all_genotypes <- lines + checks * i plots_per_block <- base::ceiling(all_genotypes / i) - lines_per_plot <- plots_per_block - checks excedent <- plots_per_block * i Fillers <- excedent - all_genotypes + + # Candidate within-block dims (r_block x c_block) with r_block * c_block = plots_per_block + # --- minimal change: include BOTH orientations (r,c) and (c,r) --- + within_dims <- list(c(1, plots_per_block)) + dims <- factor_subsets(plots_per_block, augmented = TRUE)$combos - default_dim <- c(1 * i, plots_per_block) - options_dims <- list(default_dim) if (!is.null(dims)) { - for (k in 1:length(dims)) { - options_dims[[k + 1]] <- as.vector(dims[[k]]) * c(i,1) + for (k in seq_along(dims)) { + rc <- as.vector(dims[[k]]) + within_dims[[length(within_dims) + 1]] <- rc + if (rc[1] != rc[2]) { + within_dims[[length(within_dims) + 1]] <- rev(rc) + } + } + } + + # unique within dims + within_dims <- unique(lapply(within_dims, function(x) paste(x[1], x[2], sep = "x"))) + within_dims <- lapply(within_dims, function(s) as.numeric(strsplit(s, "x", fixed = TRUE)[[1]])) + # --- end minimal change --- + + # Candidate block grid factors (blocks_per_col x blocks_per_row) with product = i + grid_pairs <- factor_pairs(i) + + # Build all field dims: (r_block*blocks_per_col) x (c_block*blocks_per_row) + options_dims <- list() + for (wd in within_dims) { + r_block <- wd[1] + c_block <- wd[2] + + # Filler feasibility must be evaluated against the within-block columns + # if (Fillers > (c_block - checks - 1)) next + if (Fillers > 0 && Fillers > (c_block - checks - 1)) next + + for (gp in grid_pairs) { + blocks_per_col <- gp[1] + blocks_per_row <- gp[2] + field_r <- r_block * blocks_per_col + field_c <- c_block * blocks_per_row + options_dims[[length(options_dims) + 1]] <- c(field_r, field_c) } } - for (m in 1:length(options_dims)) { - if (Fillers < (options_dims[[m]][2] - checks - 1)) { - dim_option <- as.vector(options_dims[[m]]) - dims_expt <- paste(dim_option[1], "x", dim_option[2], sep = " ") - checked_dims[[n]] <- dims_expt - b[n] <- i - blocks_dims <- rbind(blocks_dims, c(i, dims_expt)) - n <- n + 1 - } + + # # Unique options + # options_dims <- unique(lapply(options_dims, function(x) paste(x[1], x[2], sep = "x"))) + # options_dims <- lapply(options_dims, function(s) as.numeric(strsplit(s, "x", fixed = TRUE)[[1]])) + + options_dims <- unique(lapply(options_dims, function(x) paste(x[1], x[2], sep = "x"))) + options_dims <- lapply(options_dims, function(s) as.numeric(strsplit(s, "x", fixed = TRUE)[[1]])) + + # ---- FILTER OUT DEGENERATE FIELD DIMS: 1xN or Nx1 ---- + options_dims <- Filter(function(v) { + length(v) == 2 && all(!is.na(v)) && v[1] > 1 && v[2] > 1 + }, options_dims) + # ------------------------------------------------------ + + for (m in seq_along(options_dims)) { + dim_option <- options_dims[[m]] + dims_expt <- paste(dim_option[1], "x", dim_option[2], sep = " ") + checked_dims[[n]] <- dims_expt + b_out[n] <- i + blocks_dims <- rbind(blocks_dims, c(i, dims_expt)) + n <- n + 1 } } - blocks_and_dims <- blocks_dims[-1,] + + blocks_and_dims <- blocks_dims[-1, ] if (!is.matrix(blocks_and_dims)) { blocks_and_dims <- matrix(data = blocks_and_dims, ncol = 2, byrow = TRUE) } - return(list(b = b, - option_dims = checked_dims, - blocks_dims = blocks_and_dims)) -} \ No newline at end of file + + return(list( + b = b_out, + option_dims = checked_dims, + blocks_dims = blocks_and_dims + )) +} + +#' @noRd +factor_pairs <- function(n) { + out <- list() + k <- 1 + for (a in seq_len(n)) { + if (n %% a == 0) { + out[[k]] <- c(a, n / a) + k <- k + 1 + } + } + out +} + +#' @noRd +infer_arcbd_grid_dims <- function(nrows, ncols, b, plots_per_block) { + # --- minimal change: include BOTH orientations (r,c) and (c,r) --- + within_dims <- list(c(1, plots_per_block)) + + dims <- factor_subsets(plots_per_block, augmented = TRUE)$combos + if (!is.null(dims)) { + for (k in seq_along(dims)) { + rc <- as.vector(dims[[k]]) + within_dims[[length(within_dims) + 1]] <- rc + if (rc[1] != rc[2]) { + within_dims[[length(within_dims) + 1]] <- rev(rc) + } + } + } + + within_dims <- unique(lapply(within_dims, function(x) paste(x[1], x[2], sep = "x"))) + within_dims <- lapply(within_dims, function(s) as.numeric(strsplit(s, "x", fixed = TRUE)[[1]])) + # --- end minimal change --- + + grid_pairs <- factor_pairs(b) + + for (wd in within_dims) { + r_block <- wd[1] + c_block <- wd[2] + for (gp in grid_pairs) { + blocks_per_col <- gp[1] + blocks_per_row <- gp[2] + if (r_block * blocks_per_col == nrows && c_block * blocks_per_row == ncols) { + return(list( + rows_within_block = r_block, + cols_within_block = c_block, + blocks_per_col = blocks_per_col, + blocks_per_row = blocks_per_row + )) + } + } + } + + NULL +} + +#' @noRd +assemble_arcbd_blocks <- function(block_list, blocks_per_col, blocks_per_row) { + # block_list can be: + # - list of data.frames/matrices, or + # - list returned by setNames(list(...), paste0("Block", 1:b)) + blocks <- unname(block_list) + b <- length(blocks) + if (blocks_per_col * blocks_per_row != b) { + stop("Internal error: blocks_per_col * blocks_per_row must equal b.") + } + + # Ensure each block is a matrix + blocks <- lapply(blocks, function(x) { + if (is.data.frame(x)) return(as.matrix(x)) + as.matrix(x) + }) + + rows_out <- vector(mode = "list", length = blocks_per_col) + idx <- 1 + for (r in seq_len(blocks_per_col)) { + row_blocks <- blocks[idx:(idx + blocks_per_row - 1)] + idx <- idx + blocks_per_row + rows_out[[r]] <- do.call(cbind, row_blocks) + } + + do.call(rbind, rows_out) +} diff --git a/R/fct_diagonal_arrangement.R b/R/fct_diagonal_arrangement.R index bb5145a..e00142d 100644 --- a/R/fct_diagonal_arrangement.R +++ b/R/fct_diagonal_arrangement.R @@ -266,20 +266,43 @@ diagonal_arrangement <- function( choices_list[[i]] <- factor_subsets(n, diagonal = TRUE)$labels i <- i + 1 } + choices <- unlist(choices_list[!sapply(choices_list, is.null)]) - if (is.null(choices)) { - stop("Field dimensions do not fit with the data entered. Try another amount of treatments!", - call. = FALSE) - } - if (!is.null(choices)) { - message(cat("\n", "Error in diagonal_arrangement(): ", "\n", "\n", - "Field dimensions do not fit with the data entered!", "\n", - "Try one of the following options: ", "\n")) - return(for (i in 1:length(choices)) {print(choices[[i]])}) + + width <- 55 + border <- paste(rep("=", width), collapse = "") + thin <- paste(rep("-", width), collapse = "") + + cat("\n") + cat(border, "\n") + cat(" ERROR: diagonal_arrangement()\n") + cat(thin, "\n") + cat(" Field dimensions do not match the data entered.\n") + cat(" Total entries (lines + checks):", total_entries, "\n") + cat(" Field size provided:", nrows, "x", ncols, "=", nrows * ncols, "plots\n") + cat(" Searched plot range:", t1, "to", t2, "\n") + cat(thin, "\n") + + if (!is.null(choices) && length(choices) > 0) { + dims <- do.call(rbind, lapply(choices, function(x) { + parts <- as.integer(trimws(strsplit(x, "x")[[1]])) + data.frame(rows = parts[1], cols = parts[2]) + })) + dims <- dims[order(dims$rows), ] + dims <- unique(dims) + cat(" Valid dimension options (sorted by rows):\n\n") + for (i in seq_len(nrow(dims))) { + cat(sprintf(" [%2d ] %4d rows x %4d cols\n", i, dims$rows[i], dims$cols[i])) + } } else { - stop("Field dimensions do not fit with the data entered. Try another amount of treatments!", - call. = FALSE) + cat(" No valid rectangular dimensions exist in range", t1, "to", t2, "\n") + cat(" Reason: all values in range are prime numbers.\n") + cat(" Suggestion: adjust lines or checks so total plots\n") + cat(" has more than 2 factors.\n") } + + cat(border, "\n\n") + return(invisible(NULL)) } new_lines <- nrow(getData$data_entry[[sites]]) - checks infoP <- as.data.frame(checks_percentages$P) diff --git a/R/fct_do_optim.R b/R/fct_do_optim.R index 3e446e9..4e2415d 100644 --- a/R/fct_do_optim.R +++ b/R/fct_do_optim.R @@ -430,6 +430,8 @@ sparse_allocation <- function( #' @param nrows Numeric vector with the number of rows field at each location. #' @param ncols Numeric vector with the number of columns field at each location. #' @param seed (optional) Real number that specifies the starting seed to obtain reproducible designs. +#' @param spread_reps A logical value indicating whether to maximize the spatial +#' distance between replicated treatments in the field. Default is \code{TRUE}. #' @param optim_list (optional) A list object of class "MultiPrep"generated by \code{do_optim()} function. #' @param data (optional) Data frame with 2 columns: \code{ENTRY | NAME }. ENTRY must be numeric. #' @@ -507,6 +509,7 @@ multi_location_prep <- function( locationNames, optim_list, seed, + spread_reps = TRUE, data = NULL) { # set a random seed if it is missing if (missing(seed)) seed <- base::sample.int(10000, size = 1) @@ -588,11 +591,16 @@ multi_location_prep <- function( locationNames = locationNames, exptName = exptName, seed = seed, + spread_reps = spread_reps, multiLocationData = TRUE, dist_method = "euclidean", border_penalization = 0.5, data = preps$list_locs ) + # Add this guard immediately after: + if (is.null(design_randomization) || is.null(design_randomization$fieldBook)) { + return(invisible(NULL)) + } field_book_with_rep <- add_rep_column(df = design_randomization$fieldBook) design_randomization$infoDesign$id_design <- "MultiPrep" output <- list( diff --git a/R/fct_optimized_arrangement.R b/R/fct_optimized_arrangement.R index fe3bd11..2630c03 100644 --- a/R/fct_optimized_arrangement.R +++ b/R/fct_optimized_arrangement.R @@ -17,7 +17,8 @@ #' @param exptName (optional) Name of the experiment. #' @param locationNames (optional) Name for each location. #' @param data (optional) Data frame with 3 columns: \code{ENTRY | NAME | REPS}. -#' @param optim By default \code{optim = TRUE}. +#' @param spread_reps A logical value indicating whether to maximize the spatial +#' distance between replicated treatments in the field. Default is \code{TRUE}. #' #' @author Didier Murillo [aut], #' Salvador Gezan [aut], @@ -104,7 +105,7 @@ optimized_arrangement <- function( seed = NULL, exptName = NULL, locationNames = NULL, - optim = TRUE, + spread_reps = TRUE, data = NULL) { if (is.null(seed) || !is.numeric(seed)) seed <- runif(1, min = -50000, max = 50000) @@ -191,21 +192,46 @@ optimized_arrangement <- function( } } } else base::stop('"optimized_arrangement()" requires inputs checks and amountChecks to be possitive integers and distinct of NULL.') + t_plots <- as.numeric(sum(RepChecks) + lines) - if (numbers::isPrime(t_plots)) { - stop("No options when the total number of plots is a prime number.", call. = FALSE) - } - if (t_plots != (nrows * ncols)) { - choices <- factor_subsets(t_plots)$labels - if (!is.null(choices)) { - message(cat("\n", "Error in optimized_arrangement(): ", "\n", "\n", - "Field dimensions do not fit with the data entered!", "\n", - "Try one of the following options: ", "\n")) - return(for (i in 1:length(choices)) {print(choices[[i]])}) + width <- 55 + border <- paste(rep("=", width), collapse = "") + thin <- paste(rep("-", width), collapse = "") + + if (numbers::isPrime(t_plots) || t_plots != (nrows * ncols)) { + choices <- if (!numbers::isPrime(t_plots)) factor_subsets(t_plots)$labels else NULL + + cat("\n") + cat(border, "\n") + cat(" ERROR: optimized_arrangement()\n") + cat(thin, "\n") + cat(" Field dimensions do not match the data entered.\n") + cat(" Total plots in data:", t_plots, "\n") + cat(" Field size provided:", nrows, "x", ncols, "=", nrows * ncols, "plots\n") + cat(thin, "\n") + + if (!is.null(choices) && length(choices) > 0) { + dims <- do.call(rbind, lapply(choices, function(x) { + parts <- as.integer(trimws(strsplit(x, "x")[[1]])) + data.frame(rows = parts[1], cols = parts[2]) + })) + dims <- dims[order(dims$rows), ] + dims <- unique(dims) + cat(" Valid dimension options (sorted by rows):\n\n") + for (i in seq_len(nrow(dims))) { + cat(sprintf(" [%2d ] %4d rows x %4d cols\n", i, dims$rows[i], dims$cols[i])) + } } else { - stop("field dimensions do not fit with the data entered", call. = FALSE) + cat(" No valid rectangular dimensions exist for", t_plots, "plots.\n") + cat(" Reason: total plots is a prime number.\n") + cat(" Suggestion: adjust treatments or replication levels\n") + cat(" so that total plots has more than 2 factors.\n") } + + cat(border, "\n\n") + return(invisible(NULL)) } + NAME <- c(paste(rep("CH", checks), 1:checks, sep = ""), paste(rep("G", lines), (checksEntries[checks] + 1):(checksEntries[1] + lines + checks - 1), sep = "")) @@ -274,11 +300,11 @@ optimized_arrangement <- function( ncols = ncols, Fillers = 0, seed = NULL, - optim = TRUE, - niter = 1000, + spread_reps = spread_reps, data = gen_list ) - min_distance_sites[sites] <- prep$min_distance + # min_distance_sites[sites] <- prep$min_distance + min_distance_sites[sites] <- if (!is.null(prep$min_distance)) prep$min_distance else NA dataInput <- prep$gen.list BINAY_CHECKS <- prep$binary.field random_entries_map <- as.matrix(prep$field.map) diff --git a/R/fct_partially_replicated.R b/R/fct_partially_replicated.R index 454ed56..c62c8df 100644 --- a/R/fct_partially_replicated.R +++ b/R/fct_partially_replicated.R @@ -18,6 +18,8 @@ #' @param l Number of locations. By default \code{l = 1}. #' @param plotNumber Numeric vector with the starting plot number for each location. By default \code{plotNumber = 101}. #' @param seed (optional) Real number that specifies the starting seed to obtain reproducible designs. +#' @param spread_reps A logical value indicating whether to maximize the spatial +#' distance between replicated treatments in the field. Default is \code{TRUE}. #' @param exptName (optional) Name of the experiment. #' @param locationNames (optional) Name for each location. #' @param multiLocationData (optional) Option to pass an entry list for multiple locations. @@ -119,7 +121,8 @@ partially_replicated <- function( repUnits = NULL, planter = "serpentine", l = 1, - plotNumber = 101, + plotNumber = 101, + spread_reps = TRUE, seed = NULL, exptName = NULL, locationNames = NULL, @@ -137,22 +140,22 @@ partially_replicated <- function( } if (length(nrows) != l) { if (length(nrows) < l) { - warning("Number of nrows values not matching number of locations", call. = FALSE) + # warning("Number of nrows values not matching number of locations", call. = FALSE) # Filling missing nrows values with last provided value nrows <- c(nrows, rep(nrows[length(nrows)], l - length(nrows))) } else { - warning("Number of nrows values not matching number of locations", call. = FALSE) + # warning("Number of nrows values not matching number of locations", call. = FALSE) # Filling missing nrows values with last provided value nrows <- nrows[1:l] } } if (length(ncols) != l) { if (length(ncols) < l) { - warning("Number of ncols values not matching number of locations", call. = FALSE) + # warning("Number of ncols values not matching number of locations", call. = FALSE) # Filling missing nrows values with last provided value ncols <- c(ncols, rep(ncols[length(ncols)], l - length(ncols))) } else { - warning("Number of ncols values not matching number of locations", call. = FALSE) + # warning("Number of ncols values not matching number of locations", call. = FALSE) # Filling missing nrows values with last provided value ncols <- ncols[1:l] } @@ -298,12 +301,14 @@ partially_replicated <- function( ncols = ncols[sites], Fillers = 0, seed = seed, - optim = TRUE, - niter = 1000, + spread_reps = spread_reps, dist_method = dist_method, border_penalization = border_penalization, data = list_locs[[sites]] ) + if (is.null(prep)) { + return(invisible(NULL)) + } rows_incidence[sites] <- prep$rows_incidence[length(prep$rows_incidence)] min_distance_sites[sites] <- prep$min_distance dataInput <- prep$gen.list diff --git a/R/globals.R b/R/globals.R index 720436d..3885d38 100644 --- a/R/globals.R +++ b/R/globals.R @@ -35,4 +35,4 @@ utils::globalVariables(c("ENTRY", "plots", "arcbd_plot", "new_order_treatments", "LABEL_TREATMENT", "Level", - "Level_3", "ID", "YEAR")) + "Level_3", "ID", "YEAR", "IS_CHECK", "PLOT_TXT")) diff --git a/R/mod_Optim.R b/R/mod_Optim.R index 1366863..7798f2c 100644 --- a/R/mod_Optim.R +++ b/R/mod_Optim.R @@ -495,7 +495,7 @@ mod_Optim_server <- function(id) { plotNumber = plotNumber, l = sites, exptName = expt_name, - optim = TRUE, + spread_reps = TRUE, seed = seed.spatial, data = data.spatial ) diff --git a/R/mod_RCBD_augmented.R b/R/mod_RCBD_augmented.R index e462771..233916f 100644 --- a/R/mod_RCBD_augmented.R +++ b/R/mod_RCBD_augmented.R @@ -48,9 +48,22 @@ mod_RCBD_augmented_ui <- function(id){ ), column(6, style=list("padding-left: 5px;"), - checkboxInput(inputId = ns("random"), - label = "Randomize Entries?", - value = TRUE) + checkboxInput(inputId = ns("random"), + label = "Randomize Entries?", + value = TRUE) + ) + ), + + # after the row where you set nExpt_a_rcbd ... + + conditionalPanel( + condition = "input.nExpt_a_rcbd > 1", ns = ns, + selectInput( + inputId = ns("repsStack_a_rcbd"), + label = "Stack experiments:", + choices = c("vertical", "horizontal"), + selected = "vertical", + multiple = FALSE ) ), @@ -73,7 +86,7 @@ mod_RCBD_augmented_ui <- function(id){ column(6, style=list("padding-left: 5px;"), selectInput(inputId = ns("blocks_a_rcbd"), - label = "", choices = 5) + label = "", choices = 5) ) ), fluidRow( @@ -150,40 +163,40 @@ mod_RCBD_augmented_ui <- function(id){ mainPanel( width = 8, shinyjs::useShinyjs(), - tabsetPanel(id = ns("tabset_arcbd"), - tabPanel("Get Random", value = "tabPanel_augmented", - br(), - shinyjs::hidden( - selectInput(inputId = ns("field_dims"), - label = "Select dimensions of field:", - choices = "") + tabsetPanel(id = ns("tabset_arcbd"), + tabPanel("Get Random", value = "tabPanel_augmented", + br(), + shinyjs::hidden( + selectInput(inputId = ns("field_dims"), + label = "Select dimensions of field:", + choices = "") + ), + shinyjs::hidden( + actionButton(ns("get_random_augmented"), + label = "Randomize!") + ), + br(), + br(), + div( + shinycssloaders::withSpinner( + verbatimTextOutput(outputId = ns("summary_augmented"), + placeholder = FALSE), + type = 4 + ), + style = "padding-right: 40px;" + ) ), - shinyjs::hidden( - actionButton(ns("get_random_augmented"), - label = "Randomize!") + tabPanel("Input Data", + fluidRow( + column(6,DT::DTOutput(ns("data_input"))), + column(6,DT::DTOutput(ns("checks_table"))) + ) ), - br(), - br(), - div( - shinycssloaders::withSpinner( - verbatimTextOutput(outputId = ns("summary_augmented"), - placeholder = FALSE), - type = 4 - ), - style = "padding-right: 40px;" - ) - ), - tabPanel("Input Data", - fluidRow( - column(6,DT::DTOutput(ns("data_input"))), - column(6,DT::DTOutput(ns("checks_table"))) - ) - ), - tabPanel("Field Layout", br(), plotOutput(ns("field_layout"), width = "97%")), - tabPanel("Plot Number Field", br(), plotOutput(ns("plot_number_layout2"), width = "97%")), - tabPanel("Field Book", DT::DTOutput(ns("fieldBook_ARCBD"))), - tabPanel("Heatmap", plotly::plotlyOutput(ns("heatmap"), width = "97%")) - ) + tabPanel("Field Layout", br(), plotOutput(ns("field_layout"), width = "97%")), + tabPanel("Plot Number Field", br(), plotOutput(ns("plot_number_layout"), width = "97%")), + tabPanel("Field Book", DT::DTOutput(ns("fieldBook_ARCBD"))), + tabPanel("Heatmap", plotly::plotlyOutput(ns("heatmap"), width = "97%")) + ) ) ) ) @@ -241,8 +254,8 @@ mod_RCBD_augmented_server <- function(id) { lines <- nrow(data_up) - checks if (lines < 8) { shinyalert::shinyalert( - "Error!!", - "At least ten treatments are required!!", + "Error!!", + "At least ten treatments are required!!", type = "error") return(NULL) } @@ -275,8 +288,8 @@ mod_RCBD_augmented_server <- function(id) { req(input$lines_a_rcbd) if (input$lines_a_rcbd < 8) { shinyalert::shinyalert( - "Error!!", - "At least ten treatments are required!!", + "Error!!", + "At least ten treatments are required!!", type = "error") return(NULL) } @@ -291,7 +304,9 @@ mod_RCBD_augmented_server <- function(id) { entries = lines)) } }) - + # |> + # bindEvent(input$RUN.arcbd) + list_to_observe <- reactive({ req(init_data()) @@ -308,8 +323,10 @@ mod_RCBD_augmented_server <- function(id) { checks_arcbd <- as.numeric(list_to_observe()$checks) set_blocks <- set_augmented_blocks( lines = lines_arcbd, - checks = checks_arcbd + checks = checks_arcbd, + start = 3 ) + # print(set_blocks) blocks_arcbd <- set_blocks$b if (length(blocks_arcbd) == 0) { shinyalert::shinyalert( @@ -333,7 +350,7 @@ mod_RCBD_augmented_server <- function(id) { checks <- as.numeric(input$checks_a_rcbd) lines <- as.numeric(input$lines_a_rcbd) b <- as.numeric(input$blocks_a_rcbd) - set_dims <- set_augmented_blocks(lines = lines, checks = checks) + set_dims <- set_augmented_blocks(lines = lines, checks = checks, start = 3) dim_options <- set_dims$blocks_dims blocks_dims <- as.data.frame(dim_options) set_choices_dims <- as.vector(subset(blocks_dims, blocks_dims[,1] == b)[,2]) @@ -342,7 +359,7 @@ mod_RCBD_augmented_server <- function(id) { checks <- as.numeric(input$checks_a_rcbd) lines <- as.numeric(init_data()$entries) b <- as.numeric(input$blocks_a_rcbd) - set_dims <- set_augmented_blocks(lines = lines, checks = checks) + set_dims <- set_augmented_blocks(lines = lines, checks = checks, start = 3) blocks_dims <- as.data.frame(set_dims$blocks_dims) set_choices_dims <- as.vector(subset(blocks_dims, blocks_dims[,1] == b)[,2]) choices <- set_choices_dims @@ -357,6 +374,7 @@ mod_RCBD_augmented_server <- function(id) { getDataup_a_rcbd <- eventReactive(input$RUN.arcbd, { + req(init_data()) if (is.null(init_data())) { shinyalert::shinyalert( "Error!!", @@ -375,7 +393,7 @@ mod_RCBD_augmented_server <- function(id) { expts_a_rcbd = input$nExpt_a_rcbd) ) }) - + list_inputs <- eventReactive(input$RUN.arcbd, { if (input$owndata_a_rcbd != 'Yes') { @@ -393,7 +411,7 @@ mod_RCBD_augmented_server <- function(id) { } }) - + field_dims_augmented <- eventReactive(input$get_random_augmented, { dims <- unlist(strsplit(input$field_dims, " x ")) @@ -491,13 +509,13 @@ mod_RCBD_augmented_server <- function(id) { output$checks_table <- DT::renderDT({ req(getDataup_a_rcbd()$dataUp_a_rcbd) - data_entry <- getDataup_a_rcbd()$dataUp_a_rcbd - df <- data_entry[1:(as.numeric(input$checks_a_rcbd)),] - options(DT.options = list(pageLength = nrow(df), autoWidth = FALSE, - scrollX = TRUE, scrollY = "350px")) - a <- ncol(df) - 1 - DT::datatable(df, rownames = FALSE, caption = 'Table of checks.', options = list( - columnDefs = list(list(className = 'dt-left', targets = 0:a)))) + data_entry <- getDataup_a_rcbd()$dataUp_a_rcbd + df <- data_entry[1:(as.numeric(input$checks_a_rcbd)),] + options(DT.options = list(pageLength = nrow(df), autoWidth = FALSE, + scrollX = TRUE, scrollY = "350px")) + a <- ncol(df) - 1 + DT::datatable(df, rownames = FALSE, caption = 'Table of checks.', options = list( + columnDefs = list(list(className = 'dt-left', targets = 0:a)))) }) rcbd_augmented_reactive <- reactive({ @@ -525,7 +543,12 @@ mod_RCBD_augmented_server <- function(id) { if (length(loc) > l.arcbd) { validate("Length of vector with name of locations is greater than the number of locations.") } + repsExpt <- some_inputs()$expts_a_rcbd + repsStack <- NULL + if (repsExpt > 1) { + repsStack <- input$repsStack_a_rcbd + } nameexpt <- as.vector(unlist(strsplit(input$expt_name_a_rcbd, ","))) if (length(nameexpt) != 0) { Name_expt <- nameexpt @@ -547,6 +570,7 @@ mod_RCBD_augmented_server <- function(id) { locationNames = site_names, repsExpt = repsExpt, random = random, + repsStack = repsStack, data = gen.list, nrows = nrows, ncols = ncols @@ -564,83 +588,19 @@ mod_RCBD_augmented_server <- function(id) { silent = TRUE ) }) - + output$field_layout <- renderPlot({ req(reactive_layoutARCBD()) req(rcbd_augmented_reactive()) reactive_layoutARCBD()$out_layout - }, height = 620) + }, height = 620, res = 100) - output$plot_number_layout2 <- renderPlot({ + output$plot_number_layout <- renderPlot({ req(reactive_layoutARCBD()) req(rcbd_augmented_reactive()) print(reactive_layoutARCBD()$out_layoutPlots) reactive_layoutARCBD()$out_layoutPlots - }, height = 620) - - # arcbd_plot <- reactive({ - # req(rcbd_augmented_reactive()) - # loc_to_view <- as.numeric(input$locView.arcbd) - # arcbd_design <- rcbd_augmented_reactive() - # loc_field_book <- arcbd_design$fieldBook - # - # loc_field_book <- loc_field_book |> - # dplyr::mutate(LOC = factor(LOCATION, levels = unique(LOCATION))) |> - # dplyr::mutate(LOC = as.numeric(LOC)) - # - # temp_field_book <- loc_field_book |> dplyr::filter(LOC == loc_to_view) - # - # rows <- length(unique(temp_field_book$ROW)) - # cols <- length(unique(temp_field_book$COLUMN)) - # temp_field_book$BLOCK <- as.factor(temp_field_book$BLOCK) - # main <- paste0("Augmented RCBD Layout ", rows, " x ", cols) - # p1 <- desplot::ggdesplot( - # BLOCK ~ COLUMN + ROW, - # text = ENTRY, - # col = CHECKS, - # cex = 1.2, - # out1 = EXPT, - # out2 = BLOCK, - # data = temp_field_book, - # xlab = "COLUMNS", - # ylab = "ROWS", - # main = main, - # show.key = FALSE, - # gg = TRUE, - # out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) - # # Explicitly remove all legends - # p1 <- p1 + ggplot2::guides( - # fill = "none", # Remove legend for fill - # color = "none", # Remove legend for color (if used) - # text = "none" # Remove legend for text labels - # ) - # - # # Precompute the breaks based on the data - # x_breaks <- seq(floor(min(temp_field_book$COLUMN)), ceiling(max(temp_field_book$COLUMN)), by = 1) - # y_breaks <- seq(floor(min(temp_field_book$ROW)), ceiling(max(temp_field_book$ROW)), by = 1) - # - # # Apply breaks to the plot - # p1 <- p1 + - # ggplot2::scale_x_continuous(breaks = x_breaks) + - # ggplot2::scale_y_continuous(breaks = y_breaks) - # - # # Apply a minimal theme for better aesthetics - # p1 <- p1 + ggplot2::theme_minimal() + - # ggplot2::theme( - # plot.title = ggplot2::element_text(face = "bold", size = 15), - # axis.title = ggplot2::element_text(size = 12), - # axis.text = ggplot2::element_text(size = 11) - # ) - # return(p1) - # }) - # - # output$field_layout <- renderPlot({ - # arcbd_plot() - # }, height = 650) - - output$randomized_layout2 <- plotly::renderPlotly({ - arcbd_plot() - }) + }, height = 620, res = 100) output$summary_augmented <- renderPrint({ if (test_arcbd()) { @@ -665,38 +625,38 @@ mod_RCBD_augmented_server <- function(id) { output$randomized_layout <- DT::renderDT({ if(!test_arcbd()) return(NULL) - r_map <- rcbd_augmented_reactive()$layout_random_sites[[locNum()]] - checks <- 1:(as.numeric(some_inputs()$checks)) - b <- as.numeric(some_inputs()$blocks) - len_checks <- length(checks) - df <- as.data.frame(r_map) - rownames(df) <- paste0("Row", nrow(df):1) - repsExpt <- some_inputs()$expts_a_rcbd - colores <- c('royalblue','salmon', 'green', 'orange','orchid', 'slategrey', - 'greenyellow', 'blueviolet','deepskyblue','gold','blue', 'red') - colnames(df) <- paste("V", 1:ncol(df), sep = "") - options(DT.options = list(pageLength = nrow(df), - autoWidth = FALSE, - scrollY = "700px")) - DT::datatable(df, - extensions = 'Buttons', - options = list(dom = 'Blfrtip', - autoWidth = FALSE, - scrollX = TRUE, - fixedColumns = TRUE, - pageLength = nrow(df), - scrollY = "700px", - class = 'compact cell-border stripe', rownames = FALSE, - server = FALSE, - filter = list( position = 'top', clear = FALSE, plain =TRUE ), - buttons = c('copy', 'excel'), - lengthMenu = list(c(10,25,50,-1), - c(10,25,50,"All"))) - ) |> - DT::formatStyle(paste0(rep('V', ncol(df)), 1:ncol(df)), - backgroundColor = DT::styleEqual(c(checks), - colores[1:len_checks])) - }) + r_map <- rcbd_augmented_reactive()$layout_random_sites[[locNum()]] + checks <- 1:(as.numeric(some_inputs()$checks)) + b <- as.numeric(some_inputs()$blocks) + len_checks <- length(checks) + df <- as.data.frame(r_map) + rownames(df) <- paste0("Row", nrow(df):1) + repsExpt <- some_inputs()$expts_a_rcbd + colores <- c('royalblue','salmon', 'green', 'orange','orchid', 'slategrey', + 'greenyellow', 'blueviolet','deepskyblue','gold','blue', 'red') + colnames(df) <- paste("V", 1:ncol(df), sep = "") + options(DT.options = list(pageLength = nrow(df), + autoWidth = FALSE, + scrollY = "700px")) + DT::datatable(df, + extensions = 'Buttons', + options = list(dom = 'Blfrtip', + autoWidth = FALSE, + scrollX = TRUE, + fixedColumns = TRUE, + pageLength = nrow(df), + scrollY = "700px", + class = 'compact cell-border stripe', rownames = FALSE, + server = FALSE, + filter = list( position = 'top', clear = FALSE, plain =TRUE ), + buttons = c('copy', 'excel'), + lengthMenu = list(c(10,25,50,-1), + c(10,25,50,"All"))) + ) |> + DT::formatStyle(paste0(rep('V', ncol(df)), 1:ncol(df)), + backgroundColor = DT::styleEqual(c(checks), + colores[1:len_checks])) + }) output$expt_name_layout <- DT::renderDT({ if(!test_arcbd()) return(NULL) @@ -722,268 +682,209 @@ mod_RCBD_augmented_server <- function(id) { DT::formatStyle(paste0(rep('V', ncol(df)), 1:ncol(df)), backgroundColor = DT::styleEqual(Name_expt, colores_back[1:repsExpt])) }) - - # output$plot_number_layout <- DT::renderDT({ - # if(!test_arcbd()) return(NULL) - # req(rcbd_augmented_reactive()) - # plot_num1 <- rcbd_augmented_reactive()$layout_plots_sites[[locNum()]] - # b <- as.numeric(some_inputs()$blocks) - # infoDesign <- rcbd_augmented_reactive()$infoDesign - # Fillers <- as.numeric(infoDesign$fillers) - # repsExpt <- some_inputs()$expts_a_rcbd - # rownames(plot_num1) <- paste0("Row",nrow(plot_num1):1) - # if (Fillers == 0) { - # a <- as.vector(as.matrix(plot_num1)) - # len_a <- length(a) - # df <- as.data.frame(plot_num1) - # colnames(df) <- paste("V", 1:ncol(df), sep = "") - # DT::datatable(df, - # extensions = c('Buttons'), - # options = list(dom = 'Blfrtip', - # autoWidth = FALSE, - # scrollX = TRUE, - # fixedColumns = TRUE, - # pageLength = nrow(df), - # scrollY = "700px", - # class = 'compact cell-border stripe', - # rownames = FALSE, - # server = FALSE, - # filter = list( position = 'top', - # clear = FALSE, - # plain =TRUE ), - # buttons = c('copy', 'excel'), - # lengthMenu = list(c(10,25,50,-1), - # c(10,25,50,"All"))) - # ) - # }else { - # a <- as.vector(as.matrix(plot_num1)) - # a <- a[-which(a == 0)] - # len_a <- length(a) - # df <- as.data.frame(plot_num1) - # rownames(df) <- paste0("Row",nrow(df):1) - # colnames(df) <- paste("V", 1:ncol(df), sep = "") - # DT::datatable(df, - # extensions = c('Buttons'), - # options = list(dom = 'Blfrtip', - # autoWidth = FALSE, - # scrollX = TRUE, - # fixedColumns = TRUE, - # pageLength = nrow(df), - # scrollY = "700px", - # class = 'compact cell-border stripe', rownames = FALSE, - # server = FALSE, - # filter = list( position = 'top', clear = FALSE, plain =TRUE ), - # buttons = c('copy', 'excel'), - # lengthMenu = list(c(10,25,50,-1), - # c(10,25,50,"All"))) - # ) - # } - # }) - - valsARCBD <- reactiveValues(ROX = NULL, ROY = NULL, trail.arcbd = NULL, minValue = NULL, - maxValue = NULL) - - simuModal.ARCBD <- function(failed = FALSE) { - modalDialog( - fluidRow( - column(6, - selectInput(inputId = ns("trailsARCBD"), label = "Select One:", - choices = c("YIELD", "MOISTURE", "HEIGHT", "Other")), - ), - column(6, - checkboxInput(inputId = ns("heatmap_s"), label = "Include a Heatmap", value = TRUE), - ) - ), - conditionalPanel("input.trailsARCBD == 'Other'", ns = ns, - textInput(inputId = ns("OtherARCBD"), label = "Input Trial Name:", value = NULL) - ), - fluidRow( - column(6, - selectInput(inputId = ns("ROX.O"), "Select the Correlation in Rows:", - choices = seq(0.1, 0.9, 0.1), selected = 0.5) - ), - column(6, - selectInput(inputId = ns("ROY.O"), "Select the Correlation in Cols:", - choices = seq(0.1, 0.9, 0.1), selected = 0.5) - ) - ), - fluidRow( - column(6, - numericInput(inputId = ns("min.arcbd"), "Input the min value:", value = NULL) - ), - column(6, - numericInput(inputId = ns("max.arcbd"), "Input the max value:", value = NULL) - - ) - ), - if (failed) - div(tags$b("Invalid input of data max and min", style = "color: red;")), - - footer = tagList( - modalButton("Cancel"), - actionButton(inputId = ns("ok.arcbd"), "GO") - ) - ) - } - - observeEvent(input$Simulate.arcbd, { - req(rcbd_augmented_reactive()$fieldBook) - if(test_arcbd()) {showModal( - simuModal.ARCBD() - )} - }) - - observeEvent(input$ok.arcbd, { - req(input$min.arcbd, input$max.arcbd) - if (input$max.arcbd > input$min.arcbd && input$min.arcbd != input$max.arcbd) { - valsARCBD$maxValue <- input$max.arcbd - valsARCBD$minValue <- input$min.arcbd - valsARCBD$ROX <- as.numeric(input$ROX.O) - valsARCBD$ROY <- as.numeric(input$ROY.O) - if(input$trailsARCBD == "Other") { - req(input$OtherARCBD) - if(!is.null(input$OtherARCBD)) { - valsARCBD$trail.arcbd <- as.character(input$OtherARCBD) - }else showModal(simuModal.ARCBD(failed = TRUE)) - }else { - valsARCBD$trail.arcbd <- as.character(input$trailsARCBD) - } - removeModal() - }else { - showModal( - simuModal.ARCBD(failed = TRUE) - ) - } - }) - - simuDataARCBD <- reactive({ - req(rcbd_augmented_reactive()$fieldBook) - if(!is.null(valsARCBD$maxValue) && !is.null(valsARCBD$minValue) && !is.null(valsARCBD$trail.arcbd)) { - maxVal <- as.numeric(valsARCBD$maxValue) - minVal <- as.numeric(valsARCBD$minValue) - ROX_O <- as.numeric(valsARCBD$ROX) - ROY_O <- as.numeric(valsARCBD$ROY) - df_arcbd <- rcbd_augmented_reactive()$fieldBook - nrows.s <- length(levels(as.factor(df_arcbd$ROW))) - ncols.s <- length(levels(as.factor(df_arcbd$COLUMN))) - loc_levels_factors <- levels(factor(df_arcbd$LOCATION, unique(df_arcbd$LOCATION))) - seed.s <- as.numeric(input$myseed_a_rcbd) - locs <- length(loc_levels_factors) - df_arcbd_list <- vector(mode = "list", length = locs) - dfSimulationList <- vector(mode = "list", length = locs) - do_sites <- 1:(length(loc_levels_factors)) - z <- 1 - set.seed(seed.s) - for (sites in do_sites) { - df_loc <- subset(df_arcbd, LOCATION == loc_levels_factors[z]) - fieldBook <- df_loc[, c(1,6,7,10)] - dfSimulation <- AR1xAR1_simulation(nrows = nrows.s, ncols = ncols.s, - ROX = ROX_O, ROY = ROY_O, minValue = minVal, - maxValue = maxVal, fieldbook = fieldBook, - trail = valsARCBD$trail.arcbd, - seed = NULL) - dfSimulation <- dfSimulation$outOrder - dfSimulationList[[sites]] <- dfSimulation - dataArcbd_loc <- df_loc - df_arcbd_simu <- cbind(dataArcbd_loc, round(dfSimulation[,7],2)) - colnames(df_arcbd_simu)[12] <- as.character(valsARCBD$trail.arcbd) - df_arcbd_list[[sites]] <- df_arcbd_simu - z <- z + 1 - } - df_arcbd_locs <- dplyr::bind_rows(df_arcbd_list) - v <- 1 - }else { - dataArcbd <- rcbd_augmented_reactive()$fieldBook - v <- 2 - } - if (v == 1) { - return(list(df = df_arcbd_locs, dfSimulation = dfSimulationList)) - }else if (v == 2) { - return(list(df = dataArcbd)) - } - - }) - - heat_map_arcbd <- reactiveValues(heat_map_option = FALSE) - - observeEvent(input$ok.arcbd, { - req(input$min.arcbd, input$max.arcbd) - if (input$max.arcbd > input$min.arcbd && input$min.arcbd != input$max.arcbd) { - heat_map_arcbd$heat_map_option <- TRUE - } - }) - - observeEvent(heat_map_arcbd$heat_map_option, { - if (heat_map_arcbd$heat_map_option == FALSE) { - hideTab(inputId = "tabset_arcbd", target = "Heatmap") - } else { - showTab(inputId = "tabset_arcbd", target = "Heatmap") - } - }) - - - output$fieldBook_ARCBD <- DT::renderDT({ - if(!test_arcbd()) return(NULL) - df <- simuDataARCBD()$df - df$EXPT <- as.factor(df$EXPT) - df$LOCATION <- as.factor(df$LOCATION) - df$PLOT <- as.factor(df$PLOT) - df$ROW <- as.factor(df$ROW) - df$COLUMN <- as.factor(df$COLUMN) - df$CHECKS <- as.factor(df$CHECKS) - df$BLOCK <- as.factor(df$BLOCK) - df$ENTRY <- as.factor(df$ENTRY) - df$TREATMENT <- as.factor(df$TREATMENT) + + valsARCBD <- reactiveValues(ROX = NULL, ROY = NULL, trail.arcbd = NULL, minValue = NULL, + maxValue = NULL) + + simuModal.ARCBD <- function(failed = FALSE) { + modalDialog( + fluidRow( + column(6, + selectInput(inputId = ns("trailsARCBD"), label = "Select One:", + choices = c("YIELD", "MOISTURE", "HEIGHT", "Other")), + ), + column(6, + checkboxInput(inputId = ns("heatmap_s"), label = "Include a Heatmap", value = TRUE), + ) + ), + conditionalPanel("input.trailsARCBD == 'Other'", ns = ns, + textInput(inputId = ns("OtherARCBD"), label = "Input Trial Name:", value = NULL) + ), + fluidRow( + column(6, + selectInput(inputId = ns("ROX.O"), "Select the Correlation in Rows:", + choices = seq(0.1, 0.9, 0.1), selected = 0.5) + ), + column(6, + selectInput(inputId = ns("ROY.O"), "Select the Correlation in Cols:", + choices = seq(0.1, 0.9, 0.1), selected = 0.5) + ) + ), + fluidRow( + column(6, + numericInput(inputId = ns("min.arcbd"), "Input the min value:", value = NULL) + ), + column(6, + numericInput(inputId = ns("max.arcbd"), "Input the max value:", value = NULL) + + ) + ), + if (failed) + div(tags$b("Invalid input of data max and min", style = "color: red;")), - options(DT.options = list(pageLength = nrow(df), autoWidth = FALSE, - scrollX = TRUE, scrollCollapse=TRUE, scrollY = "600px")) - DT::datatable(df, - filter = "top", - rownames = FALSE, - options = list( - columnDefs = list(list(className = 'dt-center', targets = "_all"))) - ) - }) - - - - heatmap_obj <- reactive({ - req(simuDataARCBD()$dfSimulation) - if(input$heatmap_s) { - w <- as.character(valsARCBD$trail.arcbd) - df <- simuDataARCBD()$dfSimulation[[locNum()]] - df <- as.data.frame(df) - p1 <- ggplot2::ggplot(df, ggplot2::aes(x = df[,4], y = df[,3], fill = df[,7], text = df[,8])) + - ggplot2::geom_tile() + - ggplot2::xlab("COLUMN") + - ggplot2::ylab("ROW") + - ggplot2::labs(fill = w) + - viridis::scale_fill_viridis(discrete = FALSE) - - p2 <- plotly::ggplotly(p1, tooltip="text", height = 740) - - return(p2) - } - }) - - output$heatmap <- plotly::renderPlotly({ - req(heatmap_obj()) - if(!test_arcbd()) return(NULL) - heatmap_obj() - }) - - output$downloadData_a_rcbd <- downloadHandler( - filename = function() { - req(input$Location_a_rcbd) - loc <- input$Location_a_rcbd - loc <- paste(loc, "_", "ARCBD_", sep = "") - paste(loc, Sys.Date(), ".csv", sep = "") - }, - content = function(file) { - df <- as.data.frame(simuDataARCBD()$df) - write.csv(df, file, row.names = FALSE) - } - ) - + footer = tagList( + modalButton("Cancel"), + actionButton(inputId = ns("ok.arcbd"), "GO") + ) + ) + } + + observeEvent(input$Simulate.arcbd, { + req(rcbd_augmented_reactive()$fieldBook) + if(test_arcbd()) {showModal( + simuModal.ARCBD() + )} + }) + + observeEvent(input$ok.arcbd, { + req(input$min.arcbd, input$max.arcbd) + if (input$max.arcbd > input$min.arcbd && input$min.arcbd != input$max.arcbd) { + valsARCBD$maxValue <- input$max.arcbd + valsARCBD$minValue <- input$min.arcbd + valsARCBD$ROX <- as.numeric(input$ROX.O) + valsARCBD$ROY <- as.numeric(input$ROY.O) + if(input$trailsARCBD == "Other") { + req(input$OtherARCBD) + if(!is.null(input$OtherARCBD)) { + valsARCBD$trail.arcbd <- as.character(input$OtherARCBD) + }else showModal(simuModal.ARCBD(failed = TRUE)) + }else { + valsARCBD$trail.arcbd <- as.character(input$trailsARCBD) + } + removeModal() + }else { + showModal( + simuModal.ARCBD(failed = TRUE) + ) + } + }) + + simuDataARCBD <- reactive({ + req(rcbd_augmented_reactive()$fieldBook) + if(!is.null(valsARCBD$maxValue) && !is.null(valsARCBD$minValue) && !is.null(valsARCBD$trail.arcbd)) { + maxVal <- as.numeric(valsARCBD$maxValue) + minVal <- as.numeric(valsARCBD$minValue) + ROX_O <- as.numeric(valsARCBD$ROX) + ROY_O <- as.numeric(valsARCBD$ROY) + df_arcbd <- rcbd_augmented_reactive()$fieldBook + nrows.s <- length(levels(as.factor(df_arcbd$ROW))) + ncols.s <- length(levels(as.factor(df_arcbd$COLUMN))) + loc_levels_factors <- levels(factor(df_arcbd$LOCATION, unique(df_arcbd$LOCATION))) + seed.s <- as.numeric(input$myseed_a_rcbd) + locs <- length(loc_levels_factors) + df_arcbd_list <- vector(mode = "list", length = locs) + dfSimulationList <- vector(mode = "list", length = locs) + do_sites <- 1:(length(loc_levels_factors)) + z <- 1 + set.seed(seed.s) + for (sites in do_sites) { + df_loc <- subset(df_arcbd, LOCATION == loc_levels_factors[z]) + fieldBook <- df_loc[, c(1,6,7,10)] + dfSimulation <- AR1xAR1_simulation(nrows = nrows.s, ncols = ncols.s, + ROX = ROX_O, ROY = ROY_O, minValue = minVal, + maxValue = maxVal, fieldbook = fieldBook, + trail = valsARCBD$trail.arcbd, + seed = NULL) + dfSimulation <- dfSimulation$outOrder + dfSimulationList[[sites]] <- dfSimulation + dataArcbd_loc <- df_loc + df_arcbd_simu <- cbind(dataArcbd_loc, round(dfSimulation[,7],2)) + colnames(df_arcbd_simu)[12] <- as.character(valsARCBD$trail.arcbd) + df_arcbd_list[[sites]] <- df_arcbd_simu + z <- z + 1 + } + df_arcbd_locs <- dplyr::bind_rows(df_arcbd_list) + v <- 1 + }else { + dataArcbd <- rcbd_augmented_reactive()$fieldBook + v <- 2 + } + if (v == 1) { + return(list(df = df_arcbd_locs, dfSimulation = dfSimulationList)) + }else if (v == 2) { + return(list(df = dataArcbd)) + } + + }) + + heat_map_arcbd <- reactiveValues(heat_map_option = FALSE) + + observeEvent(input$ok.arcbd, { + req(input$min.arcbd, input$max.arcbd) + if (input$max.arcbd > input$min.arcbd && input$min.arcbd != input$max.arcbd) { + heat_map_arcbd$heat_map_option <- TRUE + } + }) + + observeEvent(heat_map_arcbd$heat_map_option, { + if (heat_map_arcbd$heat_map_option == FALSE) { + hideTab(inputId = "tabset_arcbd", target = "Heatmap") + } else { + showTab(inputId = "tabset_arcbd", target = "Heatmap") + } + }) + + + output$fieldBook_ARCBD <- DT::renderDT({ + if(!test_arcbd()) return(NULL) + df <- simuDataARCBD()$df + df$EXPT <- as.factor(df$EXPT) + df$LOCATION <- as.factor(df$LOCATION) + df$PLOT <- as.factor(df$PLOT) + df$ROW <- as.factor(df$ROW) + df$COLUMN <- as.factor(df$COLUMN) + df$CHECKS <- as.factor(df$CHECKS) + df$BLOCK <- as.factor(df$BLOCK) + df$ENTRY <- as.factor(df$ENTRY) + df$TREATMENT <- as.factor(df$TREATMENT) + + options(DT.options = list(pageLength = nrow(df), autoWidth = FALSE, + scrollX = TRUE, scrollCollapse=TRUE, scrollY = "600px")) + DT::datatable(df, + filter = "top", + rownames = FALSE, + options = list( + columnDefs = list(list(className = 'dt-center', targets = "_all"))) + ) + }) + + heatmap_obj <- reactive({ + req(simuDataARCBD()$dfSimulation) + if(input$heatmap_s) { + w <- as.character(valsARCBD$trail.arcbd) + df <- simuDataARCBD()$dfSimulation[[locNum()]] + df <- as.data.frame(df) + p1 <- ggplot2::ggplot(df, ggplot2::aes(x = df[,4], y = df[,3], fill = df[,7], text = df[,8])) + + ggplot2::geom_tile() + + ggplot2::xlab("COLUMN") + + ggplot2::ylab("ROW") + + ggplot2::labs(fill = w) + + viridis::scale_fill_viridis(discrete = FALSE) + + p2 <- plotly::ggplotly(p1, tooltip="text", height = 740) + + return(p2) + } + }) + + output$heatmap <- plotly::renderPlotly({ + req(heatmap_obj()) + if(!test_arcbd()) return(NULL) + heatmap_obj() + }) + + output$downloadData_a_rcbd <- downloadHandler( + filename = function() { + req(input$Location_a_rcbd) + loc <- input$Location_a_rcbd + loc <- paste(loc, "_", "ARCBD_", sep = "") + paste(loc, Sys.Date(), ".csv", sep = "") + }, + content = function(file) { + df <- as.data.frame(simuDataARCBD()$df) + write.csv(df, file, row.names = FALSE) + } + ) + }) -} +} \ No newline at end of file diff --git a/R/run_app.R b/R/run_app.R index 0b87c71..c6bb034 100644 --- a/R/run_app.R +++ b/R/run_app.R @@ -2,6 +2,7 @@ #' #' @return A shiny app object #' @param ... Unused, for extensibility +#' @param launch.browser Logical. If `TRUE`, the application is launched in the system's default web browser. #' #' @export #' @importFrom shiny shinyApp diff --git a/R/utils_pREP.R b/R/utils_pREP.R index 3b2af99..1a638f7 100644 --- a/R/utils_pREP.R +++ b/R/utils_pREP.R @@ -11,9 +11,8 @@ #' @param ncols Number of columns field. #' @param Fillers An integer #' @param seed An optional seed value to set the random number generator. -#' @param optim A logical value indicating whether or not to optimize the design. Default is TRUE. -#' @param niter The number of iterations to use in the first step optimization algorithm. -#' Default is 1000. +#' @param spread_reps A logical value indicating whether to maximize the spatial +#' distance between replicated treatments in the field. Default is \code{TRUE}. #' @param data Data frame with 3 columns: \code{ENTRY | NAME | REPS}. #' #' @importFrom stats dist @@ -40,14 +39,12 @@ pREP <- function( ncols = NULL, Fillers = NULL, seed = NULL, - optim = TRUE, - niter = 10000, - border_penalization = 0.1, + spread_reps = TRUE, + border_penalization = 0.5, dist_method = "euclidean", data = NULL ) { - niter <- 1000 prep <- TRUE if (!is.null(data)) { gen_list <- data @@ -89,15 +86,45 @@ pREP <- function( total_checks <- sum(freq_reps * nREPS) total_plots <- sum(gen_list$REPS) if (sum(total_plots) != (nrows * ncols)) { - choices <- factor_subsets(n = total_plots)$labels - if (!is.null(choices)) { - message(cat("\n", "Error in partially_replicated(): ", "\n", "\n", - "Field dimensions do not fit with the data entered!", "\n", - "Try one of the following options: ", "\n")) - return(for (i in 1:length(choices)) {print(choices[[i]])}) - } else { - stop("Field dimensions do not fit with the data entered. Try another amount of treatments!", call. = FALSE) + choices <- factor_subsets(n = total_plots)$labels + width <- 55 + border <- paste(rep("=", width), collapse = "") + thin <- paste(rep("-", width), collapse = "") + + cat("\n") + cat(border, "\n") + cat(" ERROR: partially_replicated()\n") + cat(thin, "\n") + cat(" Field dimensions do not match the data entered.\n") + cat(" Total plots in data:", total_plots, "\n") + cat(" Field size provided:", nrows, "x", ncols, "=", nrows * ncols, "plots\n") + cat(thin, "\n") + + if (!is.null(choices)) { + # Parse choices into a data frame + dims <- do.call(rbind, lapply(choices, function(x) { + parts <- as.integer(trimws(strsplit(x, "x")[[1]])) + data.frame(rows = parts[1], cols = parts[2]) + })) + + # Sort by number of rows ascending + dims <- dims[order(dims$rows), ] + # Remove duplicates (e.g. 7x72 and 72x7 kept as separate entries) + dims <- unique(dims) + + cat(" Valid dimension options (sorted by rows):\n\n") + for (i in seq_len(nrow(dims))) { + cat(sprintf(" [%2d ] %4d rows x %4d cols\n", i, dims$rows[i], dims$cols[i])) } + } else { + cat(" No valid rectangular dimensions exist for", total_plots, "plots.\n") + cat(" Reason: total plots is a prime number.\n") + cat(" Suggestion: adjust lines, checks, or replication levels\n") + cat(" so that total plots has more than 2 factors.\n") + } + + cat(border, "\n\n") + return(invisible(NULL)) } } ########## Init the p-rep data ############################################## @@ -110,34 +137,8 @@ pREP <- function( ncol = ncols, byrow = FALSE ) - ################## Get optimized the design using a metric distance ########## - if (optim) { - m1 <- as.vector(field0) - dist_field0 <- sum(dist(field0)) - designs <- vector(mode = "list", length = niter) - dists <- vector(mode = "numeric", length = niter) - designs[[1]] <- field0 - dists[1] <- dist_field0 - for(i in 2:niter) { - m <- as.vector(designs[[i-1]]) - k1 <- which(m == 1);k2 <- which(m == 0) - D <- vector(length = 2) - D[1] <- sample(k1, 1, replace = FALSE) - D[2] <- sample(k2, 1, replace = FALSE) - m1 <- replace(m, D, m[rev(D)]) - iter_designs <- matrix(m1, nrow = nrows, ncol = ncols, byrow = FALSE) - iter_dist <- sum(dist(iter_designs)) - if (iter_dist > dists[i - 1]) { - designs[[i]] <- iter_designs - dists[i] <- iter_dist - } else { - designs[[i]] <- designs[[i - 1]] - dists[i] <- dists[i-1] - } - } - # Selecting the 'best' design - field <- designs[[niter]] - } else field <- field0 + + field <- field0 if (prep == TRUE) { entry_gens <- as.vector(data_unrep_treatments[,1]) @@ -176,31 +177,57 @@ pREP <- function( } # Make numeric each element in the matrix layout1 field_layout <- apply(layout1, c(1,2), as.numeric) - - ################### Optimization ########################################## - # Perform an optimization by using the function swap_pairs() - if (max(table(field_layout)) == 2) { - swap <- swap_pairs(X = field_layout, starting_dist = 3, stop_iter = 5, - dist_method = dist_method, lambda = border_penalization) + + ################### Spread Reps Optimization ############################### + if (spread_reps) { + # Perform an optimization by using the function swap_pairs() + if (max(table(field_layout)) == 2) { + swap <- swap_pairs( + X = field_layout, + starting_dist = 3, + stop_iter = 10, + dist_method = dist_method, + lambda = border_penalization + ) + } else { + swap <- swap_pairs( + X = field_layout, + starting_dist = 2, + stop_iter = 10, + dist_method = dist_method, + lambda = border_penalization + ) + } + optim_layout <- swap$optim_design + min_distance <- swap$min_distance + pairwise_distance <- swap$pairwise_distance + rows_incidence <- swap$rows_incidence } else { - swap <- swap_pairs(X = field_layout, starting_dist = 2, stop_iter = 5, - dist_method = dist_method, lambda = border_penalization) + init_pd <- pairs_distance(field_layout) + rows_incidence <- numeric() + genos <- unique(init_pd$geno) + optim_layout <- field_layout + pairwise_distance <- pairs_distance(optim_layout) + min_distance <- min(pairwise_distance$DIST) + rows_incidence[1L] <- sum(apply(optim_layout, 1L, function(row) { + any(tabulate(match(row, genos)) >= 2L) + })) } - optim_layout <- swap$optim_design + dups <- table(as.vector(optim_layout)) replicated_treatments <- as.numeric(rownames(dups)[dups > 1]) treatments <- as.vector(optim_layout) rep_trts <- treatments[which(treatments %in% replicated_treatments)] + # Check if the frequency of rep treatments is the same as the input data if (total_plot_reps != length(rep_trts)) { - stop("In the final design, rep treatments does not match with imput data") + stop("In the final design, rep treatments does not match with input data") } + unreplicated_treatments <- as.numeric(rownames(dups)[dups == 1]) - min_distance <- swap$min_distance - pairwise_distance <- swap$pairwise_distance - rows_incidence <- swap$rows_incidence binary_field <- optim_layout binary_field[!binary_field %in% replicated_treatments] <- 0 + return( list( field.map = optim_layout, diff --git a/R/utils_plot_diagonal_arrangement.R b/R/utils_plot_diagonal_arrangement.R index 7e83212..5560e08 100644 --- a/R/utils_plot_diagonal_arrangement.R +++ b/R/utils_plot_diagonal_arrangement.R @@ -107,59 +107,129 @@ plot_optim <- function(x, l) { return(list(p1 = p1, allSitesFieldbook = fieldbook)) } + #' @noRd plot_augmented_RCBD <- function(x, l) { - fieldbook <- x$fieldBook - - sites <- factor(fieldbook$LOCATION, levels = unique(fieldbook$LOCATION)) - - site_levels <- levels(sites) - - loc_field_book <- fieldbook |> - dplyr::filter(LOCATION == site_levels[l]) |> - as.data.frame() - - cols <- max(as.numeric(loc_field_book$COLUMN)) - rows <- max(as.numeric(loc_field_book$ROW)) - - loc_field_book$ENTRY <- as.character(loc_field_book$ENTRY) - loc_field_book$CHECKS <- as.character(loc_field_book$CHECKS) - loc_field_book$BLOCK <- as.character(loc_field_book$BLOCK) - main <- paste0("Augmented RCBD Layout ", rows, " x ", cols) - p1 <- desplot::ggdesplot( - BLOCK ~ COLUMN + ROW, - text = ENTRY, - col = CHECKS, - cex = 1, - out1 = EXPT, - out2 = BLOCK, - data = loc_field_book, - xlab = "COLUMNS", - ylab = "ROWS", - main = main, - show.key = FALSE, - gg = TRUE, - out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) - - p1 <- add_gg_features(p1) - - main_plot <- paste0("Augmented RCBD Plot Number Layout ", rows, " x ", cols) - p2 <- desplot::ggdesplot( - BLOCK ~ COLUMN + ROW, - text = PLOT, - cex = 1.1, - out1 = EXPT, - out2 = BLOCK, - data = loc_field_book, - xlab = "COLUMNS", - ylab = "ROWS", - main = main_plot, - show.key = FALSE, - gg = TRUE, - out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) - - p2 <- add_gg_features(p2) - - return(list(p1 = p1, p2 = p2, allSitesFieldbook = fieldbook)) + fieldbook <- x$fieldBook + + sites <- factor(fieldbook$LOCATION, levels = unique(fieldbook$LOCATION)) + site_levels <- levels(sites) + + loc_field_book <- fieldbook |> + dplyr::filter(LOCATION == site_levels[l]) |> + as.data.frame() + + cols <- max(as.numeric(loc_field_book$COLUMN)) + rows <- max(as.numeric(loc_field_book$ROW)) + + loc_field_book$ENTRY <- as.character(loc_field_book$ENTRY) + loc_field_book$CHECKS <- as.character(loc_field_book$CHECKS) + loc_field_book$BLOCK <- as.character(loc_field_book$BLOCK) + + # labels that must NEVER be reformatted by desplot + loc_field_book$PLOT_TXT <- sprintf("%d", as.integer(loc_field_book$PLOT)) + + # flag checks (used only for p1 text color) + loc_field_book$IS_CHECK <- loc_field_book$CHECKS == "1" + + # ----------------------------- + # Muted palette for BLOCK bg + # ----------------------------- + block_levels <- sort(unique(loc_field_book$BLOCK)) + muted6 <- c("#F2F2F2", "#E6EEF5", "#E9F2EC", "#F3EEE6", "#EDE7F2", "#F1E9E9") + if (length(block_levels) > length(muted6)) { + muted6 <- grDevices::colorRampPalette(muted6)(length(block_levels)) + } else { + muted6 <- muted6[seq_along(block_levels)] + } + fill_vals <- stats::setNames(muted6, block_levels) + + # ----------------------------- + # p1: layout (ENTRY labels) + # ----------------------------- + main <- paste0("Augmented RCBD Layout ", rows, " x ", cols) + + p1_bg <- desplot::ggdesplot( + BLOCK ~ COLUMN + ROW, + text = "", + cex = 0, + col = BLOCK, # bg by block (muted palette) + out1 = EXPT, + out2 = BLOCK, + data = loc_field_book, + xlab = "COLUMNS", + ylab = "ROWS", + main = main, + show.key = FALSE, + gg = TRUE, + out2.gpar = list(col = "gray50", lwd = 1, lty = 1) + ) + + p1 <- p1_bg + + ggplot2::scale_fill_manual(values = fill_vals, guide = "none") + + ggplot2::geom_text( + data = dplyr::filter(loc_field_book, !IS_CHECK), + ggplot2::aes( + x = as.numeric(COLUMN), + y = as.numeric(ROW), + label = ENTRY + ), + inherit.aes = FALSE, + color = "gray10", + size = 3.2 + ) + + ggplot2::geom_text( + data = dplyr::filter(loc_field_book, IS_CHECK), + ggplot2::aes( + x = as.numeric(COLUMN), + y = as.numeric(ROW), + label = ENTRY + ), + inherit.aes = FALSE, + color = "red3", + fontface = "bold", + size = 3.2 + ) + + p1 <- add_gg_features(p1) + + # ----------------------------- + # p2: plot numbers (NO check highlighting) + # ----------------------------- + main_plot <- paste0("Augmented RCBD Plot Number Layout ", rows, " x ", cols) + + p2_bg <- desplot::ggdesplot( + BLOCK ~ COLUMN + ROW, + text = "", + cex = 0, + col = BLOCK, # keep same muted bg by block + out1 = EXPT, + out2 = BLOCK, + data = loc_field_book, + xlab = "COLUMNS", + ylab = "ROWS", + main = main_plot, + show.key = FALSE, + gg = TRUE, + out2.gpar = list(col = "gray50", lwd = 1, lty = 1) + ) + + p2 <- p2_bg + + ggplot2::scale_fill_manual(values = fill_vals, guide = "none") + + ggplot2::geom_text( + data = loc_field_book, + ggplot2::aes( + x = as.numeric(COLUMN), + y = as.numeric(ROW), + label = PLOT_TXT + ), + inherit.aes = FALSE, + color = "gray10", + size = 3.2 + ) + + p2 <- add_gg_features(p2) + + return(list(p1 = p1, p2 = p2, allSitesFieldbook = fieldbook)) } diff --git a/R/utils_swap_functions.R b/R/utils_swap_functions.R index caf9fe1..ef4cd8f 100644 --- a/R/utils_swap_functions.R +++ b/R/utils_swap_functions.R @@ -1,12 +1,12 @@ #' @title Calculate pairwise distances between all elements in a matrix that appears twice or more. #' -#' @description Given a matrix of integers, this function calculates the pairwise Euclidean -#' distance between all possible pairs of elements in the matrix that appear two or more times. +#' @description Given a matrix of integers, this function calculates the pairwise Euclidean +#' distance between all possible pairs of elements in the matrix that appear two or more times. #' If no element appears two or more times, the function will return an error message. #' -#' +#' #' @param X a matrix of integers -#' +#' #' @return A data frame with the following columns: #' \itemize{ #' \item \code{geno}: the integer value for which the pairwise distances are calculated @@ -18,97 +18,141 @@ #' \item \code{rB}: the row index of the second element in the pair #' \item \code{cB}: the column index of the second element in the pair #' } -#' +#' #' @author Jean-Marc Montpetit [aut] -#' -#' @noRd +#' +#' @noRd pairs_distance <- function(X) { - # check if the input X is a matrix - if (!is.matrix(X)) { - stop("Input must be a matrix") - } - # check if the input matrix X is numeric - if (!is.numeric(X)) { - stop("Matrix elements must be numeric") - } - possPairs <- function(Z) { - PAIRS <- base::expand.grid(Z, Z, KEEP.OUT.ATTRS = FALSE) - colnames(PAIRS) <- c("P1","P2") - # removing self PAIRS - PAIRS <- PAIRS[!(PAIRS$P1==PAIRS$P2),] - # removing reciprocals - # Relying on rownames to remove dups - rownames(PAIRS) <- 1:nrow(PAIRS) - c_id <- as.integer(rownames(unique(t(apply(PAIRS[, 1:2], MARGIN = 1, FUN = sort))))) - PAIRS <- PAIRS[c_id,] - # row name reset - rownames(PAIRS) <- 1:nrow(PAIRS) - # row-wise sort - PAIRS <- as.data.frame(t(apply(X=PAIRS,MARGIN=1,FUN=sort))) - - return(PAIRS) - } - dups <- base::table(as.vector(X)) - if (sum(dups > 1) == 0) { - stop("All elements in X appear only once") - } - dupsI <- as.numeric(rownames(dups)[dups > 1]) - pair_points <- matrix(data = NA, nrow = 0, ncol = 2) - int_reps <- numeric() - colnames(pair_points) <- c("P2", "P1") - for (i in seq_along(dupsI)) { - id <- which(X == dupsI[i]) - id <- which(X==dupsI[i]) - loopPairs <- possPairs(id) - int_reps[i] <- nrow(loopPairs) - pair_points <- rbind(pair_points, loopPairs) - } - #preloop DF creation - plotDist <- data.frame(geno = rep(dupsI, times = int_reps), - Pos1=as.integer(NA), - Pos2=as.integer(NA), - DIST=as.numeric(NA), - rA=as.integer(NA), - cA=as.integer(NA), - rB=as.integer(NA), - cB=as.integer(NA)) - loopPairs <- pair_points - for (z in 1:nrow(loopPairs)) { - coord.a <- which( - matrix((1:length(X)) == loopPairs[z, 1, drop = TRUE], dim(X), byrow = FALSE), - arr.ind = TRUE - ) - coord.b <- which( - matrix((1:length(X)) == loopPairs[z, 2, drop = TRUE], dim(X), byrow = FALSE), - arr.ind = TRUE - ) - loopDist <- sqrt(sum(abs(coord.a-coord.b)^2)) - plotDist[z, 4] <- loopDist - plotDist[z, 2:3] <- loopPairs[z,] - plotDist[z, 5:6] <- coord.a - plotDist[z, 7:8] <- coord.b - } - plotDist <- plotDist[order(plotDist$DIST), ] - return(plotDist) + if (!is.matrix(X)) stop("Input must be a matrix") + if (!is.numeric(X)) stop("Matrix elements must be numeric") + + nr <- nrow(X) + tab <- table(as.vector(X)) + dupsI <- as.integer(names(tab)[tab > 1L]) + if (length(dupsI) == 0L) stop("All elements in X appear only once") + + out_list <- vector("list", length(dupsI)) + for (i in seq_along(dupsI)) { + g <- dupsI[i] + id <- which(X == g) + pairs <- utils::combn(id, 2) + p1 <- pairs[1L, ] + p2 <- pairs[2L, ] + rA <- ((p1 - 1L) %% nr) + 1L + cA <- ((p1 - 1L) %/% nr) + 1L + rB <- ((p2 - 1L) %% nr) + 1L + cB <- ((p2 - 1L) %/% nr) + 1L + dr <- rA - rB + dc <- cA - cB + out_list[[i]] <- data.frame( + geno = rep.int(g, length(dr)), + Pos1 = p1, Pos2 = p2, DIST = sqrt(dr * dr + dc * dc), + rA = rA, cA = cA, rB = rB, cB = cB + ) + } + plotDist <- do.call(rbind, out_list) + plotDist <- plotDist[order(plotDist$DIST), ] + rownames(plotDist) <- NULL + plotDist +} + +# ============================================================ +# Internal helpers +# ============================================================ +#' @noRd +.vec_dist_euclidean <- function(r0, c0, rmat, cmat) { + sqrt((rmat - r0)^2 + (cmat - c0)^2) +} + +#' @noRd +.vec_dist_manhattan <- function(r0, c0, rmat, cmat) { + abs(rmat - r0) + abs(cmat - c0) +} + +#' @noRd +# All pairwise distances for ONE genotype in matrix mat +.pair_dists_for_geno <- function(mat, g) { + pos <- which(mat == g, arr.ind = TRUE) + if (nrow(pos) < 2L) { + return(numeric(0)) + } + pairs <- utils::combn(seq_len(nrow(pos)), 2L) + dr <- pos[pairs[1L, ], 1L] - pos[pairs[2L, ], 1L] + dc <- pos[pairs[1L, ], 2L] - pos[pairs[2L, ], 2L] + sqrt(dr * dr + dc * dc) +} + +# ---- Score a candidate swap ---------------------------------------------------- +# +# Returns a list(score, delta): +# +# score : adjusted_global_mean - lambda * candidate_center_dist (maximise) +# delta : new_contrib - old_contrib +# +# The DELTA is the key optimisation here. After the best swap is applied the +# caller updates base_sum as: +# +# base_sum <- base_sum + delta +# +# This is pure arithmetic — no pairs_distance() call, no allocations. +# n_pairs never changes (swapping cells doesn't add/remove pairs). +# +# Border penalisation is identical to the previous version: +# large candidate_center_dist => candidate near border => lower score +# +#' @noRd +.score_swap <- function(X, ri, ci, rj, cj, + lambda, center, + base_sum, n_pairs) { + g_i <- X[ri, ci] + g_j <- X[rj, cj] + + # old pairwise-distance sums for the two affected genotypes + old_i <- .pair_dists_for_geno(X, g_i) + old_j <- if (g_j != g_i) .pair_dists_for_geno(X, g_j) else numeric(0) + old_contrib <- sum(old_i) + sum(old_j) + + # apply swap on a temp copy + X_tmp <- X + X_tmp[ri, ci] <- g_j + X_tmp[rj, cj] <- g_i + + # new pairwise-distance sums for the same genotypes + new_i <- .pair_dists_for_geno(X_tmp, g_i) + new_j <- if (g_j != g_i) .pair_dists_for_geno(X_tmp, g_j) else numeric(0) + new_contrib <- sum(new_i) + sum(new_j) + + delta <- new_contrib - old_contrib + + # incrementally updated global mean + adjusted_mean <- (base_sum + delta) / max(n_pairs, 1L) + + # border penalty: penalise far-from-center (= near-border) placement + candidate_center_dist <- sqrt((rj - center[1L])^2 + (cj - center[2L])^2) + + list( + score = adjusted_mean - lambda * candidate_center_dist, + delta = delta + ) } #' @title Swap pairs in a matrix of integers -#' +#' #' @description Modifies the input matrix \code{X} to ensure that the distance between any two occurrences #' of the same integer is at least a distance \code{d}, by swapping one of the occurrences with a #' candidate cell of a different integer. The function starts with \code{starting_dist = 3} and increases it #' by \code{1} until the algorithm no longer converges or \code{stop_iter} iterations have been performed. #' This version evaluates candidate swaps using both the mean pairwise distance and a centrality penalty, #' and it uses candidate sampling to reduce computation. -#' +#' #' @param X A matrix of integers. #' @param starting_dist The minimum starting distance to enforce between pairs of occurrences of the same integer. Default is 3. #' @param stop_iter The maximum number of iterations to perform. Default is 50. #' @param lambda A tuning parameter for the centrality penalty. Default is 0.1. #' @param dist_method The method used for distance calculation. Options are "euclidean" (default) and "manhattan". #' @param candidate_sample_size Maximum number of candidate cells to evaluate per swap. Default is 5. -#' +#' #' @return A list containing: #' \item{optim_design}{The modified matrix.} #' \item{designs}{A list of all intermediate designs, starting from the input matrix.} @@ -116,190 +160,214 @@ pairs_distance <- function(X) { #' \item{min_distance}{The minimum distance between pairs of occurrences of the same integer in the final design.} #' \item{pairwise_distance}{A data frame with the pairwise distances for the final design.} #' \item{rows_incidence}{A vector recording the number of rows with repeated integers for each iteration.} -#' +#' #' @examples #' set.seed(123) #' X <- matrix(sample(c(rep(1:10, 2), 11:50), replace = FALSE), ncol = 10) #' B <- swap_pairs( -#' X, -#' starting_dist = 3, -#' stop_iter = 50, -#' lambda = 0.5, -#' dist_method = "euclidean", -#' candidate_sample_size = 3 +#' X, +#' starting_dist = 3, +#' stop_iter = 50, +#' lambda = 0.5, +#' dist_method = "euclidean", +#' candidate_sample_size = 3 #' ) #' B$optim_design -#' +#' #' @export -swap_pairs <- function(X, starting_dist = 3, stop_iter = 10, lambda = 0.5, - dist_method = "euclidean", candidate_sample_size = 4) { - # Check if the input X is a matrix and numeric. - if (!is.matrix(X)) { - stop("Input must be a matrix") - } - if (!is.numeric(X)) { - stop("Matrix elements must be numeric") - } +swap_pairs <- function(X, + starting_dist = 3, + stop_iter = 10, + lambda = 0.5, + dist_method = "euclidean", + candidate_sample_size = 4) { + if (!is.matrix(X)) stop("Input must be a matrix") + if (!is.numeric(X)) stop("Matrix elements must be numeric") - # lambda <- calculate_lambda(X, lambda_base = lambda) - - swap_succeed <- FALSE - input_X <- X - input_freq <- table(input_X) - minDist <- sqrt(sum(dim(X)^2)) - designs <- list() - designs[[1]] <- X - distances <- list() - rows_incidence <- numeric() - - init_dist <- pairs_distance(X = X) - genos <- unique(init_dist$geno) - distances[[1]] <- init_dist - w <- 2 - - # Main loop: Increase the minimum distance from starting_dist to maximum possible. - for (min_dist in seq(starting_dist, minDist, 1)) { - n_iter <- 1 - while (n_iter <= stop_iter) { - plotDist <- pairs_distance(X) - rownames(plotDist) <- NULL # Reset rownames. - LowID <- which(plotDist$DIST < min_dist) - low_dist_gens <- unique(plotDist$geno[LowID]) - LS <- length(LowID) - if (LS == 0) { - n_iter <- stop_iter + 1 - break - } - - # Compute the center of the matrix for the centrality penalty. - center <- c(nrow(X) / 2, ncol(X) / 2) - - for (genotype in low_dist_gens) { - indices <- which(X == genotype, arr.ind = TRUE) - other_indices <- which(X != genotype, arr.ind = TRUE) - - for (i in seq_len(nrow(indices))) { - # Calculate distances from the current occurrence to all other indices. - if (dist_method == "euclidean") { - d <- sqrt(apply(other_indices, 1, function(x) sum((x - indices[i, ])^2))) - } else if (dist_method == "manhattan") { - d <- apply(other_indices, 1, function(x) sum(abs(x - indices[i, ]))) - } else { - stop("Invalid distance method specified. Use 'euclidean' or 'manhattan'.") - } - - other_indices_df <- as.data.frame(other_indices) - valid_indices <- other_indices_df[d >= min_dist, ] - if (nrow(valid_indices) == 0) break - - if (nrow(valid_indices) > candidate_sample_size) { - sample_idx <- sample(seq_len(nrow(valid_indices)), candidate_sample_size) - candidate_set <- valid_indices[sample_idx, , drop = FALSE] - } else { - candidate_set <- valid_indices - } - - candidate_scores <- numeric(nrow(candidate_set)) - for (j in seq_len(nrow(candidate_set))) { - X_temp <- X - X_temp[indices[i, 1], indices[i, 2]] <- X_temp[candidate_set[j, 1], candidate_set[j, 2]] - X_temp[candidate_set[j, 1], candidate_set[j, 2]] <- genotype - - candidate_mean <- mean(pairs_distance(X_temp)$DIST) - - candidate_center_dist <- sqrt(sum((c(candidate_set[j, 1], candidate_set[j, 2]) - center)^2)) - - candidate_scores[j] <- candidate_mean - lambda * candidate_center_dist - } - - best_candidate_index <- which.max(candidate_scores) - best_candidate <- as.numeric(unlist(candidate_set[best_candidate_index, , drop = TRUE])) - - X[indices[i, 1], indices[i, 2]] <- X[best_candidate[1], best_candidate[2]] - X[best_candidate[1], best_candidate[2]] <- genotype - } - } - n_iter <- n_iter + 1 - } + input_X <- X + input_freq <- table(input_X) + nr <- nrow(X) + nc <- ncol(X) + minDist <- sqrt(nr^2 + nc^2) + center <- c(nr / 2, nc / 2) + + dist_fn <- if (dist_method == "euclidean") { + .vec_dist_euclidean + } else if (dist_method == "manhattan") { + .vec_dist_manhattan + } else { + stop("Invalid dist_method. Use 'euclidean' or 'manhattan'.") + } + + swap_succeed <- FALSE + designs <- list(X) + init_pd <- pairs_distance(X) + distances <- list(init_pd) + rows_incidence <- numeric() + genos <- unique(init_pd$geno) + w <- 2L + + # ------------------------------------------------------------------ # + # Main loop over increasing minimum-distance thresholds # + # ------------------------------------------------------------------ # + for (min_dist in seq(starting_dist, minDist, 1)) { + n_iter <- 1L + + while (n_iter <= stop_iter) { + # ---- (A) pairs_distance() called ONCE per while-iteration --------- + plotDist <- pairs_distance(X) + LowID <- which(plotDist$DIST < min_dist) + if (length(LowID) == 0L) { + n_iter <- stop_iter + 1L + break + } + + low_dist_gens <- unique(plotDist$geno[LowID]) + + # Global sum and pair-count for incremental scoring. + # n_pairs stays constant throughout — swapping never adds/removes pairs. + base_sum <- sum(plotDist$DIST) + n_pairs <- nrow(plotDist) + + # ---- (B) Resolve each violating genotype -------------------------- + for (genotype in low_dist_gens) { + geno_rc <- which(X == genotype, arr.ind = TRUE) + + other_mask <- X != genotype + other_r <- row(X)[other_mask] + other_c <- col(X)[other_mask] + + for (i in seq_len(nrow(geno_rc))) { + r0 <- geno_rc[i, 1L] + c0 <- geno_rc[i, 2L] + + # ---- (C) Vectorised distance to every other cell -------------- + d <- dist_fn(r0, c0, other_r, other_c) + valid <- d >= min_dist + if (!any(valid)) next - if (min(pairs_distance(X)$DIST) < min_dist) { - break - } else { - swap_succeed <- TRUE - output_freq <- table(X) - if (!all(input_freq == output_freq)) { - stop("The swap function changed the frequency of some integers.") - } - frequency_rows <- as.data.frame(search_matrix_values(X = X, values_search = genos)) - df <- frequency_rows |> dplyr::filter(Times >= 2) - rows_incidence[w - 1] <- nrow(df) - designs[[w]] <- X - distances[[w]] <- pairs_distance(X) - w <- w + 1 + v_r <- other_r[valid] + v_c <- other_c[valid] + nv <- length(v_r) + + # ---- (D) Sample candidates ------------------------------------ + if (nv > candidate_sample_size) { + idx <- sample.int(nv, candidate_sample_size) + v_r <- v_r[idx] + v_c <- v_c[idx] + nv <- candidate_sample_size + } + + # ---- (E) Score candidates — no pairs_distance() call ---------- + scores <- numeric(nv) + deltas <- numeric(nv) + for (j in seq_len(nv)) { + res <- .score_swap( + X, r0, c0, v_r[j], v_c[j], + lambda, center, base_sum, n_pairs + ) + scores[j] <- res$score + deltas[j] <- res$delta + } + + # ---- (F) Apply best swap -------------------------------------- + best <- which.max(scores) + rb <- v_r[best] + cb <- v_c[best] + tmp <- X[rb, cb] + X[rb, cb] <- X[r0, c0] + X[r0, c0] <- tmp + + # ---- (G) Update base_sum — pure arithmetic, zero allocations -- + base_sum <- base_sum + deltas[best] + # n_pairs is unchanged; no call needed } + } + + n_iter <- n_iter + 1L } - optim_design <- designs[[length(designs)]] - pairwise_distance <- pairs_distance(optim_design) - min_distance <- min(pairwise_distance$DIST) + # ---- Did we satisfy the current min_dist threshold? ----------------- + current_min <- min(pairs_distance(X)$DIST) + if (current_min < min_dist) { + break + } else { + swap_succeed <- TRUE + + output_freq <- table(X) + if (!all(input_freq == output_freq)) { + stop("swap_pairs_fast changed the frequency of some integers.") + } + + rows_incidence[w - 1L] <- sum(apply(X, 1L, function(row) { + any(tabulate(match(row, genos)) >= 2L) + })) - if (!swap_succeed) { - optim_design <- designs[[1]] - distances[[1]] <- pairs_distance(optim_design) - pairwise_distance <- pairs_distance(optim_design) - min_distance <- min(pairwise_distance$DIST) - frequency_rows <- as.data.frame(search_matrix_values(X = optim_design, values_search = genos)) - df <- frequency_rows |> dplyr::filter(Times >= 2) - rows_incidence[1] <- nrow(df) + designs[[w]] <- X + distances[[w]] <- pairs_distance(X) + w <- w + 1L } + } - return( - list( - rows_incidence = rows_incidence, - optim_design = optim_design, - designs = designs, - distances = distances, - min_distance = min_distance, - pairwise_distance = pairwise_distance - ) - ) + # ---- Assemble output (identical structure to original swap_pairs) ---- + optim_design <- designs[[length(designs)]] + pairwise_distance <- pairs_distance(optim_design) + min_distance <- min(pairwise_distance$DIST) + + if (!swap_succeed) { + optim_design <- designs[[1L]] + pairwise_distance <- pairs_distance(optim_design) + min_distance <- min(pairwise_distance$DIST) + rows_incidence[1L] <- sum(apply(optim_design, 1L, function(row) { + any(tabulate(match(row, genos)) >= 2L) + })) + distances[[1L]] <- pairwise_distance + } + + list( + rows_incidence = rows_incidence, + optim_design = optim_design, + designs = designs, + distances = distances, + min_distance = min_distance, + pairwise_distance = pairwise_distance + ) } #' @title Search Matrix Values #' #' @description Search for values in a matrix and return the row number, value, and frequency. -#' +#' #' @author Jean-Marc Montpetit [aut], Didier Murillo [aut] #' #' @param X A matrix. #' @param values_search A vector of values to search for in the matrix. -#' @return A data frame with three columns: Row (the row number where the value is found), +#' @return A data frame with three columns: Row (the row number where the value is found), #' Value (the searched value), and Times (the frequency of the searched value in the row). #' @examples #' A <- matrix(c(1, 2, 3, 2, 3, 4, 3, 4, 5), nrow = 3, byrow = TRUE) -#' search_matrix_values( X = A, values_search = c(2, 3, 5)) +#' search_matrix_values(X = A, values_search = c(2, 3, 5)) #' @noRd search_matrix_values <- function(X, values_search) { - # Initialize an empty list to store the results - result <- list() - # Loop through each row of X - for (i in 1:nrow(X)) { - # Get the unique values and their frequency in the current row - row_vals <- unique(X[i,]) - row_counts <- tabulate(match(X[i,], row_vals)) - # Find the values that are in the search list - search_vals <- row_vals[row_vals %in% values_search] - # XAd the row number, search values, and their frequency to the result list - for (val in search_vals) { - freq <- sum(X[i,] == val) - result[[length(result)+1]] <- c(i, val, freq) - } + # Initialize an empty list to store the results + result <- list() + # Loop through each row of X + for (i in 1:nrow(X)) { + # Get the unique values and their frequency in the current row + row_vals <- unique(X[i, ]) + row_counts <- tabulate(match(X[i, ], row_vals)) + # Find the values that are in the search list + search_vals <- row_vals[row_vals %in% values_search] + # XAd the row number, search values, and their frequency to the result list + for (val in search_vals) { + freq <- sum(X[i, ] == val) + result[[length(result) + 1]] <- c(i, val, freq) } - # Convert the result list to a data frame - result_df <- do.call(rbind, result) - colnames(result_df) <- c("Row", "Value", "Times") - # Return the final data frame - return(result_df) + } + # Convert the result list to a data frame + result_df <- do.call(rbind, result) + colnames(result_df) <- c("Row", "Value", "Times") + # Return the final data frame + return(result_df) } - diff --git a/man/RCBD_augmented.Rd b/man/RCBD_augmented.Rd index 4c4ef4d..b637969 100644 --- a/man/RCBD_augmented.Rd +++ b/man/RCBD_augmented.Rd @@ -11,6 +11,7 @@ RCBD_augmented( l = 1, planter = "serpentine", plotNumber = 101, + repsStack = c("vertical", "horizontal"), exptName = NULL, seed = NULL, locationNames = NULL, @@ -34,6 +35,8 @@ RCBD_augmented( \item{plotNumber}{Numeric vector with the starting plot number for each location. By default \code{plotNumber = 101}.} +\item{repsStack}{Option for \code{horizontal} or \code{vertical} layout By default \code{repsStack = 'vertical'}.} + \item{exptName}{(optional) Name of experiment.} \item{seed}{(optional) Real number that specifies the starting seed to obtain reproducible designs.} @@ -50,64 +53,6 @@ RCBD_augmented( \item{ncols}{(optional) Number of columns in the field.} } -\value{ -A list with five elements. -\itemize{ - \item \code{infoDesign} is a list with information on the design parameters. - \item \code{layoutRandom} is the ARCBD layout randomization for the first location. - \item \code{plotNumber} is the plot number layout for the first location. - \item \code{exptNames} is the experiment names layout. - \item \code{data_entry} is a data frame with the data input. - \item \code{fieldBook} is a data frame with the ARCBD field book. -} -} \description{ It randomly generates an augmented randomized complete block design across locations (ARCBD). } -\examples{ -# Example 1: Generates an ARCBD with 6 blocks, 3 checks for each, and 50 treatments -# in two locations. -ARCBD1 <- RCBD_augmented(lines = 50, checks = 3, b = 6, l = 2, - planter = "cartesian", - plotNumber = c(1,1001), - seed = 23, - locationNames = c("FARGO", "MINOT")) -ARCBD1$infoDesign -ARCBD1$layoutRandom -ARCBD1$exptNames -ARCBD1$plotNumber -head(ARCBD1$fieldBook, 12) - -# Example 2: Generates an ARCBD with 17 blocks, 4 checks for each, and 350 treatments -# in 3 locations. -# In this case, we show how to use the option data. -checks <- 4; -list_checks <- paste("CH", 1:checks, sep = "") -treatments <- paste("G", 5:354, sep = "") -treatment_list <- data.frame(list(ENTRY = 1:354, NAME = c(list_checks, treatments))) -head(treatment_list, 12) -ARCBD2 <- RCBD_augmented(lines = 350, checks = 4, b = 17, l = 3, - planter = "serpentine", - plotNumber = c(101,1001,2001), - seed = 24, - locationNames = LETTERS[1:3], - data = treatment_list) -ARCBD2$infoDesign -ARCBD2$layoutRandom -ARCBD2$exptNames -ARCBD2$plotNumber -head(ARCBD2$fieldBook, 12) - -} -\references{ -Federer, W. T. (1955). Experimental Design. Theory and Application. New York, USA. The -Macmillan Company. -} -\author{ -Didier Murillo [aut], - Salvador Gezan [aut], - Ana Heilman [ctb], - Thomas Walk [ctb], - Johan Aparicio [ctb], - Richard Horsley [ctb] -} diff --git a/man/multi_location_prep.Rd b/man/multi_location_prep.Rd index c145e67..f08952e 100644 --- a/man/multi_location_prep.Rd +++ b/man/multi_location_prep.Rd @@ -19,6 +19,7 @@ multi_location_prep( locationNames, optim_list, seed, + spread_reps = TRUE, data = NULL ) } @@ -51,6 +52,9 @@ multi_location_prep( \item{seed}{(optional) Real number that specifies the starting seed to obtain reproducible designs.} +\item{spread_reps}{A logical value indicating whether to maximize the spatial +distance between replicated treatments in the field. Default is \code{TRUE}.} + \item{data}{(optional) Data frame with 2 columns: \code{ENTRY | NAME }. ENTRY must be numeric.} } \value{ diff --git a/man/optimized_arrangement.Rd b/man/optimized_arrangement.Rd index 9de768e..ee912c5 100644 --- a/man/optimized_arrangement.Rd +++ b/man/optimized_arrangement.Rd @@ -16,7 +16,7 @@ optimized_arrangement( seed = NULL, exptName = NULL, locationNames = NULL, - optim = TRUE, + spread_reps = TRUE, data = NULL ) } @@ -43,7 +43,8 @@ optimized_arrangement( \item{locationNames}{(optional) Name for each location.} -\item{optim}{By default \code{optim = TRUE}.} +\item{spread_reps}{A logical value indicating whether to maximize the spatial +distance between replicated treatments in the field. Default is \code{TRUE}.} \item{data}{(optional) Data frame with 3 columns: \code{ENTRY | NAME | REPS}.} } diff --git a/man/partially_replicated.Rd b/man/partially_replicated.Rd index 20a3fdd..921a91b 100644 --- a/man/partially_replicated.Rd +++ b/man/partially_replicated.Rd @@ -12,6 +12,7 @@ partially_replicated( planter = "serpentine", l = 1, plotNumber = 101, + spread_reps = TRUE, seed = NULL, exptName = NULL, locationNames = NULL, @@ -36,6 +37,9 @@ partially_replicated( \item{plotNumber}{Numeric vector with the starting plot number for each location. By default \code{plotNumber = 101}.} +\item{spread_reps}{A logical value indicating whether to maximize the spatial +distance between replicated treatments in the field. Default is \code{TRUE}.} + \item{seed}{(optional) Real number that specifies the starting seed to obtain reproducible designs.} \item{exptName}{(optional) Name of the experiment.} diff --git a/man/run_app.Rd b/man/run_app.Rd index 88dbbc3..0068d73 100644 --- a/man/run_app.Rd +++ b/man/run_app.Rd @@ -4,10 +4,12 @@ \alias{run_app} \title{Run the Shiny Application} \usage{ -run_app(...) +run_app(..., launch.browser = TRUE) } \arguments{ \item{...}{Unused, for extensibility} + +\item{launch.browser}{Logical. If `TRUE`, the application is launched in the system's default web browser.} } \value{ A shiny app object diff --git a/man/swap_pairs.Rd b/man/swap_pairs.Rd index 882e262..5f2d6e7 100644 --- a/man/swap_pairs.Rd +++ b/man/swap_pairs.Rd @@ -47,12 +47,12 @@ and it uses candidate sampling to reduce computation. set.seed(123) X <- matrix(sample(c(rep(1:10, 2), 11:50), replace = FALSE), ncol = 10) B <- swap_pairs( - X, - starting_dist = 3, - stop_iter = 50, - lambda = 0.5, - dist_method = "euclidean", - candidate_sample_size = 3 + X, + starting_dist = 3, + stop_iter = 50, + lambda = 0.5, + dist_method = "euclidean", + candidate_sample_size = 3 ) B$optim_design