Add feature to report row-column optimization values in Shiny

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: FielDHub
 Title: A Shiny App for Design of Experiments in Life Sciences
-Version: 1.4.0
+Version: 1.4.1
 Authors@R: 
        c(person(given = "Didier",
               family = "Murillo",

NAMESPACE

@@ -12,12 +12,14 @@ export(alpha_lattice)
 export(diagonal_arrangement)
 export(do_optim)
 export(full_factorial)
+export(improve_efficiency)
 export(incomplete_blocks)
 export(latin_square)
 export(multi_location_prep)
 export(optimized_arrangement)
 export(partially_replicated)
 export(rectangular_lattice)
+export(report_efficiency)
 export(row_column)
 export(run_app)
 export(sparse_allocation)
@@ -27,6 +29,7 @@ export(split_split_plot)
 export(square_lattice)
 export(strip_plot)
 export(swap_pairs)
+export(swap_treatments)
 import(shiny)
 importFrom(config,get)
 importFrom(dplyr,glimpse)

R/app_ui.R

@@ -17,7 +17,7 @@ app_ui <- function(request) {
   tagList(
     golem_add_external_resources(),
     fluidPage(theme = shinythemes::shinytheme("flatly"),
-              navbarPage(title = "FielDHub v1.4.0", 
+              navbarPage(title = "FielDHub v1.4.1", 
                          tabPanel(
                            " Welcome!", icon = icon("home", lib = "glyphicon"),
                             suppressWarnings(

R/fct_incomplete_blocks.R

@@ -57,8 +57,8 @@
 #' head(ibd2$fieldBook)
 #'
 #' @export
-incomplete_blocks <- function(t = NULL, k = NULL, r = NULL, l = 1, plotNumber = 101, locationNames = NULL,
-                              seed = NULL, data = NULL) {
+incomplete_blocks <- function(t = NULL, k = NULL, r = NULL, l = 1, plotNumber = 101, 
+                              locationNames = NULL, seed = NULL, data = NULL) {
 
   if (is.null(seed) || !is.numeric(seed)) seed <- runif(1, min = -50000, max = 50000)
   set.seed(seed)
@@ -137,17 +137,12 @@ incomplete_blocks <- function(t = NULL, k = NULL, r = NULL, l = 1, plotNumber =
   blocks_model <- list()
   for (i in 1:l) {
     mydes <- blocksdesign::blocks(treatments = nt, replicates = r, blocks = list(r, b), seed = NULL)
-    # print("---Blocks Model original design:---")
-    # print(mydes$Blocks_model)
     mydes <- rerandomize_ibd(ibd_design = mydes)
-    # print("---Blocks Model re-randomized design:---")
-    # print(mydes$Blocks_model_new)
     matdf <- base::data.frame(list(LOCATION = rep(locationNames[i], each = N)))
     matdf$PLOT <- as.numeric(unlist(ibd_plots[[i]]))
     matdf$BLOCK <- rep(c(1:r), each = nt)
     matdf$iBLOCK <- rep(c(1:b), each = k)
     matdf$UNIT <- rep(c(1:k), nincblock)
-    # matdf$TREATMENT <- mydes$Design[,4]
     matdf$TREATMENT <- mydes$Design_new[,4]
     colnames(matdf) <- c("LOCATION","PLOT", "REP", "IBLOCK", "UNIT", "ENTRY")
     outIBD_loc[[i]] <- matdf

R/fct_row_column.R

@@ -12,6 +12,7 @@
 #' @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 locationNames (optional) Names for each location.
+#' @param iterations Number of iterations for design optimization. By default \code{iterations = 1000}.
 #' @param data (optional) Data frame with label list of treatments
 #' 
 #' @author Didier Murillo [aut],
@@ -67,14 +68,15 @@
 #'   
 #' 
 #' @export
-row_column <- function(t = NULL, nrows = NULL, r = NULL, l = 1, plotNumber= 101, locationNames = NULL,
-                       seed = NULL, data = NULL) {
+row_column <- function(t = NULL, nrows = NULL, r = NULL, l = 1, plotNumber= 101, 
+                       locationNames = NULL, seed = NULL, iterations = 1000,
+                       data = NULL) {
 
   if (is.null(seed) || !is.numeric(seed)) seed <- runif(1, min = -50000, max = 50000)
-  set.seed(seed)
+  # set.seed(seed)
   k <- nrows
   lookup <- FALSE
-  if(is.null(data)) {
+  if (is.null(data)) {
     if (is.null(t) || is.null(k) || is.null(r) || is.null(l)) {
       shiny::validate('Some of the basic design parameters are missing (t, k, r or l).')
     }
@@ -92,18 +94,20 @@ row_column <- function(t = NULL, nrows = NULL, r = NULL, l = 1, plotNumber= 101,
         nt <- length(t)
         TRT <- t
       }
-    }else if (is.character(t) || is.factor(t)) {
+    } else if (is.character(t) || is.factor(t)) {
       if (length(t) == 1) {
         shiny::validate('incomplete_blocks() requires more than one treatment.')
       } 
       nt <- length(t)
-    }else if ((length(t) > 1)) {
+    } else if ((length(t) > 1)) {
       nt <- length(t)
     }
-    df <- data.frame(list(ENTRY = 1:nt, TREATMENT = paste0("G-", 1:nt)))
-    data_RowCol <- df
+    data_up <- data.frame(list(ENTRY = 1:nt, TREATMENT = paste0("G-", 1:nt)))
+    colnames(data_up) <- c("ENTRY", "TREATMENT")
     lookup <- TRUE
-  }else if (!is.null(data)) {
+    df <- data.frame(list(ENTRY = 1:nt, LABEL_TREATMENT = paste0("G-", 1:nt)))
+    dataLookUp <- df
+  } else if (!is.null(data)) {
     if (is.null(t) || is.null(r) || is.null(k) || is.null(l)) {
       shiny::validate('Some of the basic design parameters are missing (t, r, k or l).')
     }
@@ -116,43 +120,95 @@ row_column <- function(t = NULL, nrows = NULL, r = NULL, l = 1, plotNumber= 101,
     if (t != new_t) base::stop("Number of treatments do not match with data input.")
     TRT <- data_up$TREATMENT
     nt <- length(TRT)
-    data_RowCol <- data_up
     lookup <- TRUE
+    dataLookUp <- data.frame(list(ENTRY = 1:nt, LABEL_TREATMENT = TRT))
   }
   if (k >= nt) shiny::validate('incomplete_blocks() requires k < t.')
+  if (nt %% k != 0) {
+    shiny::validate('Number of treatments can not be fully distributed over the specified incomplete block specification.')
+  }
   if(is.null(locationNames) || length(locationNames) != l) locationNames <- 1:l
   nunits <- k
-  matdf <- incomplete_blocks(t = nt, k = nunits, r = r, l = l, plotNumber = plotNumber,
-                             seed = seed, locationNames = locationNames,
-                             data = data_RowCol)
-  matdf <- matdf$fieldBook
-  matdf <- as.data.frame(matdf)
-  colnames(matdf)[5] <- "COLUMN"
-  matdf$ROW <- matdf$UNIT
-  OutRowCol <- matdf[,-6]
-  OutRowCol$LOCATION <- factor(OutRowCol$LOCATION, levels = locationNames)
-  OutRowCol <- OutRowCol[order(OutRowCol$LOCATION, OutRowCol$REP, OutRowCol$ROW),]
-  RowCol_plots <- ibd_plot_numbers(nt = nt, plot.number = plotNumber, r = r, l = l)
-  OutRowCol$PLOT <- as.vector(unlist(RowCol_plots))
+
+
+  ## New code
+  N <- nt * r
+  out_row_col_loc <- vector(mode = "list", length = l)
+  blocks_model <- list()
+  for (i in 1:l) {
+    reps <- r
+    ncols <- nt / nunits
+    mydes <- blocksdesign::blocks(
+      treatments = nt, 
+      replicates = reps, 
+      blocks = list(reps, ncols),
+      seed = seed + i
+    )
+    mydes <- rerandomize_ibd(ibd_design = mydes)
+    # Create row and column design
+    row_col_design <- mydes$Design_new |> 
+      dplyr::mutate(Level_3 = rep(rep(paste0("B", 1:nrows), times = ncols), times = reps)) |> 
+      dplyr::mutate(Level_3 = paste(Level_1, Level_3, sep = ".")) |> 
+      dplyr::mutate(Level_3 = factor(Level_3, levels = unique(Level_3))) |> 
+      dplyr::select(Level_1, Level_2, Level_3, plots, treatments)
+
+    improved_design <- improve_efficiency(row_col_design, iterations, seed = seed + i)
+    field_book_best_design <- improved_design$best_design
+    row_column_efficiency <- report_efficiency(improved_design$best_design)
+    blocks_model[[i]] <- row_column_efficiency
+    row_col_fieldbook <- field_book_best_design |>
+      dplyr::rename(
+        REP = Level_1, 
+        COLUMN = Level_2, 
+        ROW = Level_3, 
+        PLOT = plots, 
+        ENTRY = treatments) |>
+      dplyr::mutate(
+        REP = as.numeric(factor(REP, levels = unique(REP))),
+        COLUMN = as.numeric(factor(COLUMN, levels = unique(COLUMN))),
+        ROW = as.numeric(factor(ROW, levels = unique(ROW)))
+      ) |>
+      dplyr::select(PLOT, REP, COLUMN, ROW, ENTRY)
+
+    locations_df <- data.frame(list(LOCATION = rep(locationNames[i], each = N)))
+    row_col_fieldbook <- dplyr::bind_cols(locations_df, row_col_fieldbook)
+    out_row_col_loc[[i]] <- row_col_fieldbook
+
+  }
+
+  out_row_col <- dplyr::bind_rows(out_row_col_loc)
+  out_row_col$ENTRY <- as.numeric(out_row_col$ENTRY)
+
   if(lookup) {
-    OutRowCol <- OutRowCol[,c(2,3,4,8,5,6,7)]
-  }else OutRowCol <- OutRowCol[,c(2,3,4,7,5,6)]
-  ID <- 1:nrow(OutRowCol)
-  OutRowCol <- cbind(ID, OutRowCol)
-  rownames(OutRowCol) <- 1:nrow(OutRowCol)
-  loc <- levels(OutRowCol$LOCATION)
+    out_row_col <- dplyr::inner_join(out_row_col, dataLookUp, by = "ENTRY")
+    out_row_col <- out_row_col |> 
+      dplyr::rename(TREATMENT = LABEL_TREATMENT) |> 
+      dplyr::select(-ENTRY)
+    out_row_col <- dplyr::inner_join(out_row_col, data_up, by = "TREATMENT") |> 
+      dplyr::select(LOCATION, PLOT, REP, ROW, COLUMN, ENTRY, TREATMENT)
+  }
+
+  ID <- 1:nrow(out_row_col)
+  out_row_col_id <- cbind(ID, out_row_col)
+
+  row_col_plots <- ibd_plot_numbers(nt = nt, plot.number = plotNumber, r = r, l = l)
+  out_row_col_id$PLOT <- as.vector(unlist(row_col_plots))
+
+  # return(list(fieldBook = out_row_col_id, blocks_model = blocks_model))
+
+  loc <- levels(out_row_col_id$LOCATION)
   ib <- nt/k
   Resolvable_rc_reps <- vector(mode = "list", length = r*l)
   w <- 1
   for (sites in 1:l) {
     for (j in 1:r) {
-      z <- OutRowCol
+      z <- out_row_col_id
       z <- subset(z, z$LOCATION == loc[sites] & z$REP == j)
       if (is.null(data)){
-        Resolvable_rc_reps[[w]] <- matrix(data = as.vector(z$ENTRY), nrow = nunits, 
+        Resolvable_rc_reps[[w]] <- matrix(data = as.vector(z$ENTRY), nrow = nunits,
                                           ncol = ib, byrow = TRUE)
       }else {
-        Resolvable_rc_reps[[w]] <- matrix(data = as.vector(z$TREATMENT), nrow = nunits, 
+        Resolvable_rc_reps[[w]] <- matrix(data = as.vector(z$TREATMENT), nrow = nunits,
                                           ncol = ib, byrow = TRUE)
       }
       w <- w + 1
@@ -164,31 +220,35 @@ row_column <- function(t = NULL, nrows = NULL, r = NULL, l = 1, plotNumber= 101,
   y <- seq(r, r * l, r)
   z <- 1
   for (loc in 1:l) {
-    NEW_Resolvable[[loc]] <- setNames(Resolvable_rc_reps[x[z]:y[z]], 
+    NEW_Resolvable[[loc]] <- setNames(Resolvable_rc_reps[x[z]:y[z]],
                                  paste0(rep("rep", r), 1:r))
     z <- z + 1
   }
-  
-  df <- OutRowCol
-  trt <- "ENTRY" 
+
+  df <- out_row_col_id
+  trt <- "ENTRY"
   c1 <- concurrence_matrix(df=df, trt=trt, target='REP')
   c2 <- concurrence_matrix (df=df, trt=trt, target='ROW')
   c3 <- concurrence_matrix (df=df, trt=trt, target='COLUMN')
   summ <- merge(c1, c2, by="Concurrence", all=TRUE)
   new_summ <- merge(summ, c3, by='Concurrence', all=TRUE)
   infoDesign <- list(
-    rows = nrows, 
-    columns = ib, 
-    reps = r, 
-    treatments = nt, 
-    locations = l, 
-    location_names = locationNames, 
+    rows = nrows,
+    columns = ib,
+    reps = r,
+    treatments = nt,
+    locations = l,
+    location_names = locationNames,
     seed = seed,
     id_design = 9
   )
-  output <- list(infoDesign = infoDesign, resolvableBlocks = NEW_Resolvable, 
-                 concurrence = new_summ,
-                 fieldBook = OutRowCol)
+  output <- list(
+    infoDesign = infoDesign,
+    blocksModel = blocks_model,
+    resolvableBlocks = NEW_Resolvable,
+    concurrence = new_summ,
+    fieldBook = out_row_col_id
+  )
   class(output) <- "FielDHub"
   return(invisible(output))
 }

R/mod_RowCol.R

@@ -46,7 +46,7 @@ mod_RowCol_ui <- function(id){
                      ns = ns,
                      numericInput(ns("t.rcd"), 
                                   label = "Input # of Treatments:",
-                                  value = 36,
+                                  value = 24,
                                   min = 2),
                    ),
                    fluidRow(
@@ -110,6 +110,16 @@ mod_RowCol_ui <- function(id){
         width = 8,
         fluidRow(
           tabsetPanel(
+            tabPanel(
+              "Summary Design",
+              br(),
+              shinycssloaders::withSpinner(
+                verbatimTextOutput(outputId = ns("summary_row_column"), 
+                                   placeholder = FALSE), 
+                type = 4
+              ),
+              style = "padding-right: 40px;"
+            ),
             tabPanel("Field Layout",
                      shinyjs::useShinyjs(),
                      shinyjs::hidden(downloadButton(ns("downloadCsv.rcd"), 
@@ -333,6 +343,12 @@ mod_RowCol_server <- function(id){
     }) |>
       bindEvent(input$RUN.rcd)
 
+    output$summary_row_column <- renderPrint({
+      req(RowCol_reactive())
+      cat("Randomization was successful!", "\n", "\n")
+      print(RowCol_reactive(), n = 6)
+    })
+
     upDateSites <- reactive({
       req(input$l.rcd)
       locs <- as.numeric(input$l.rcd)