Some progress on buffer plots, not finished

DESCRIPTION

@@ -70,5 +70,5 @@ Config/testthat/edition: 3
 Config/testthat/parallel: true
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.0
+RoxygenNote: 7.3.1
 VignetteBuilder: knitr

R/autoplot.R

@@ -8,6 +8,7 @@
 #' @param label_rotation Enables rotation of the treatment group labels independently of the x axis labels within the plot.
 #' @param margin Logical (default `FALSE`). A value of `FALSE` will expand the plot to the edges of the plotting area i.e. remove white space between plot and axes.
 #' @param palette A string specifying the colour scheme to use for plotting. Default is equivalent to "Spectral". Colour blind friendly palettes can also be provided via options `"colour blind"` (or `"color blind"`, both equivalent to `"viridis"`), `"magma"`, `"inferno"`, `"plasma"` or `"cividis"`. Other palettes from [scales::brewer_pal()] are also possible.
+#' @param buffer A string specifying the buffer plots to include for plotting. Default is `NULL` (no buffers plotted). Other options are "edge" (outside of trial area), "plots" (around each plot), "rows" (between rows), "columns" (between columns), "double row" (a buffer row each side of a treatment row), "double column" (a buffer row each side of a treatment column), or "blocks" (a buffer around each treatment block).
 #' @inheritParams rlang::args_dots_used
 #'
 #' @name autoplot
@@ -91,7 +92,7 @@ autoplot.mct <- function(object, size = 4, label_height = 0.1, rotation = 0, axi
 #'
 #' # Alternative colour scheme
 #' autoplot(des.out, palette = "plasma")
-autoplot.design <- function(object, rotation = 0, size = 4, margin = FALSE, palette = "default", row = NULL, col = NULL, block = NULL, ...) {
+autoplot.design <- function(object, rotation = 0, size = 4, margin = FALSE, palette = "default", buffer = NULL, row = NULL, col = NULL, block = NULL, ...) {
     stopifnot(inherits(object, "design"))
 
     if(inherits(object, "list")) {
@@ -133,6 +134,13 @@ autoplot.design <- function(object, rotation = 0, size = 4, margin = FALSE, pale
     object <- merge(object, cols)
 
     if(!any(grepl("block", tolower(names(object))))) {
+        if(!missing(buffer)) {
+            object <- create_buffers(object, type = buffer)
+            if("buffer" %in% levels(object$treatments)) {
+               colour_palette <- c(colour_palette, "white")
+            }
+        }
+
         # create the graph
         plt <- ggplot2::ggplot() +
             ggplot2::geom_tile(data = object, mapping = ggplot2::aes(x = col, y = row, fill = treatments), colour = "black") +
@@ -153,7 +161,9 @@ autoplot.design <- function(object, rotation = 0, size = 4, margin = FALSE, pale
             blkdf[i, "xmin"] <- (min(tmp$col) - 0.5)
             blkdf[i, "xmax"] <- (max(tmp$col) + 0.5)
         }
+        if(!missing(buffer)) {
 
+        }
         plt <- ggplot2::ggplot(...) +
             ggplot2::geom_tile(data = object, mapping = ggplot2::aes(x = col, y = row, fill = treatments), colour = "black", ...) +
             ggplot2::geom_text(data = object, mapping = ggplot2::aes(x = col, y = row, label = treatments), colour = object$text_col, angle = rotation, size = size, ...) +

R/create_buffers.R

@@ -0,0 +1,96 @@
+#' Title
+#'
+#' @param design The data frame of the design.
+#' @param type The type of buffer. One of edge, row, column, double row, double column, or block (coming soon).
+#'
+#' @return The original data frame, updated to include buffers
+#' @keywords internal
+create_buffers <- function(design, type) {
+    nrow <- max(design$row)
+    ncol <- max(design$col)
+
+    # Match edge, edges or e
+    if(grepl("(^edges?$|^e$)", tolower(type))) {
+        row <- c(rep(1, ncol+2), rep(nrow+2, ncol+2), rep(2:(nrow+1), 2))
+        col <- c(rep(1:(ncol+2), 2), rep(1, nrow), rep(ncol+2, nrow))
+        n_brow <- length(row)  # Number of buffer rows
+        treatments <- rep("buffer", n_brow)
+
+        design$row <- design$row+1
+        design$col <- design$col+1
+    }
+    # Match row, rows, r
+    else if(grepl("(^rows?$|^r$)", tolower(type))) {
+        row <- rep(seq(1, (2*nrow)+1, by = 2), each = ncol)
+        col <- rep(seq(1, ncol),times = nrow+1)
+        n_brow <- length(row)  # Number of buffer rows
+        treatments <- rep("buffer", n_brow)
+        design$row <- 2*design$row
+    }
+    # Match col, cols, column, columns or c
+    else if(grepl("(^col(umn)?s?$|^c$)", tolower(type))) {
+        row <- rep(seq(1, nrow), times = ncol+1)
+        col <- rep(seq(1, (2*ncol)+1, by = 2), each = nrow)
+        n_brow <- length(row)  # Number of buffer rows
+        treatments <- rep("buffer", n_brow)
+        design$col <- 2*design$col
+    }
+    # Match double row, double rows, or dr
+    else if(grepl("(^double rows?$|^dr$)", tolower(type))) {
+        row <- c(rep(seq(1, (3*nrow)-2, by = 3),
+                     each = ncol),
+                 rep(seq(3, (3*nrow), by = 3),
+                     each = ncol))
+        col <- rep(seq(1, ncol), times = 2*nrow)
+        n_brow <- length(row)  # Number of buffer rows
+        treatments <- rep("buffer", n_brow)
+        design$row <- (3*design$row)-1
+    }
+    # Match double col, double cols, double column, double columns, dc
+    else if(grepl("(^double col(umn)?s?$|^dc$)", tolower(type))) {
+        row <- rep(seq(1, nrow), times = 2*ncol)
+        col <- c(rep(seq(1, (3*ncol)-2, by = 3),
+                     each = nrow),
+                 rep(seq(3, (3*ncol), by = 3),
+                     each = nrow))
+        n_brow <- length(row)  # Number of buffer rows
+        treatments <- rep("buffer", n_brow)
+        design$col <- (3*design$col)-1
+    }
+    # Match block, blocks, or b
+    else if(grepl("(^blocks?$|^b$)", tolower(type))) {
+        stop("Block buffers are not yet supported.")
+    }
+    else {
+        stop("Invalid buffer option: ", type, call. = FALSE)
+    }
+
+    buffers <- data.frame(matrix(NA, nrow = n_brow, ncol = ncol(design)))
+    buffers <- setNames(buffers, names(design))
+    buffers$row <- row
+    buffers$col <- col
+    buffers$treatments <- factor(treatments)
+
+    design <- rbind(design, buffers)
+
+    return(design)
+}
+
+
+# # Blocks
+#
+# nrow <- max(des.out$design$row)
+# ncol <- max(des.out$design$col)
+# nblocks <- max(as.numeric(des.out$design$block))
+# autoplot(des.out)
+#
+#
+# buffers <- data.frame(row = rep(1:nrow,
+#                                 times = ncol+1),
+#                       col = rep(seq(1, (2*ncol)+1, by = 2),
+#                                 each = nrow),
+#                       plots = NA, rep = NA, treatments = factor("buffer"))
+#
+# des.out$design$col <- 2*des.out$design$col
+# des.out$design <- rbind(des.out$design, buffers)
+# autoplot(des.out)