R/plot_split_rcbd_design.R

In inti: Tools and Statistical Procedures in Plant Science

#' Plot Splitplot-RCBD fieldbook design
#'
#' Plot fieldbook sketches for Splitplot-RCBD experimental designs generated
#' by `design_split_rcbd()`.
#'
#' The function does not recalculate or rearrange the experimental design. It
#' uses the existing `rows` and `cols` coordinates from the fieldbook, so the
#' physical arrangement and zigzag order generated by Tarpuy are preserved.
#'
#' @param data Fieldbook data frame from `design_split_rcbd()`.
#' @param factor Character scalar. Column used to color experimental units.
#'   If missing, `"wp_sp"` is used when available; otherwise, `"ntreat"` is
#'   used.
#' @param fill Character vector. Column or columns used as labels inside each
#'   experimental unit. Default is `"plots"`.
#' @param xlab Character scalar. Optional x-axis title. If `NULL`,
#'   `"Whole plots"` is used.
#' @param ylab Character scalar. Optional y-axis title. If `NULL`,
#'   `"Subplots"` is used when rows can be interpreted consistently as
#'   subplot positions within blocks; otherwise, `"Rows"` is used.
#' @param glab Character scalar. Optional legend title.
#' @param text_size Optional positive numeric scalar indicating the plot-label
#'   font size in typographic points (`pt`). If `NULL` or `NA`, a suitable
#'   default is selected according to the number of label columns. The value is
#'   converted internally to the unit expected by `ggplot2::geom_text()`.
#' @param wrap_width Optional positive integer indicating the approximate
#'   maximum number of characters per line. If `NULL` or `NA`, the function
#'   calculates it automatically from the dimensions of each block, font size
#'   and number of label columns. Underscores are displayed as spaces only in
#'   the sketch; the fieldbook values are not modified.
#' @param font_family Character scalar. Font family used in the sketch.
#'   Defaults to `"Open Sans"`. If the font cannot be verified through the
#'   optional `systemfonts` package, `"sans"` is used as a fallback.
#' @param font_face Character scalar. Font face used in labels, axes, facet
#'   titles and legends. Defaults to `"plain"`.
#'
#' @details
#' Every experimental unit is positioned with `cols` on the x axis and `rows`
#' on the y axis. The `block` column is used only to identify the block panels;
#' it never replaces the physical row coordinate.
#'
#' Within each block, `cols` represents whole-plot positions. The visible
#' y-axis tick labels are derived from the rank of the actual `rows` values
#' inside each block, so the panels can display subplot positions while the
#' geometry continues to use the original fieldbook coordinates. A black
#' external border identifies each whole plot.
#'
#' Automatic wrapping affects only the displayed labels. It does not change
#' `plots`, `ntreat`, treatment factors, QR codes, rows, columns or any other
#' fieldbook value.
#'
#' @return A `ggplot` object.
#'
#' @import dplyr
#' @import ggplot2
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' plot_split_rcbd_design(
#'   data = fieldbook,
#'   factor = "wp_sp",
#'   fill = c("plots", "ntreat"),
#'   text_size = 9,
#'   font_family = "Open Sans",
#'   font_face = "plain"
#' )
#'
#' }

plot_split_rcbd_design <- function(
    data,
    factor = NA,
    fill = "plots",
    xlab = NULL,
    ylab = NULL,
    glab = NULL,
    text_size = NULL,
    wrap_width = NULL,
    font_family = "Open Sans",
    font_face = "plain"
) {
  
  # -------------------------------------------------------------------------
  # Helpers -----------------------------------------------------------------
  # -------------------------------------------------------------------------
  
  is_missing_scalar <- function(x) {
    is.null(x) ||
      length(x) == 0L ||
      (
        length(x) == 1L &&
          (
            is.na(x) ||
              (is.character(x) && !nzchar(trimws(x)))
          )
      )
  }
  
  validate_optional_positive_number <- function(x, name) {
    
    if(is_missing_scalar(x)) {
      return(NULL)
    }
    
    if(
      length(x) != 1L ||
      !is.numeric(x) ||
      !is.finite(x) ||
      x <= 0
    ) {
      stop(
        "'", name,
        "' must be a positive numeric scalar, NA, or NULL.",
        call. = FALSE
      )
    }
    
    as.numeric(x)
  }
  
  validate_optional_positive_integer <- function(x, name) {
    
    value <- validate_optional_positive_number(x, name)
    
    if(is.null(value)) {
      return(NULL)
    }
    
    if(value != floor(value)) {
      stop(
        "'", name,
        "' must be a positive integer, NA, or NULL.",
        call. = FALSE
      )
    }
    
    as.integer(value)
  }
  
  resolve_font_family <- function(value) {
    
    if(
      is.null(value) ||
      length(value) != 1L ||
      is.na(value) ||
      !nzchar(trimws(as.character(value)))
    ) {
      return("sans")
    }
    
    value <- trimws(as.character(value))
    
    if(tolower(value) == "sans") {
      return("sans")
    }
    
    if(!requireNamespace("systemfonts", quietly = TRUE)) {
      return("sans")
    }
    
    available_fonts <- tryCatch(
      systemfonts::system_fonts(),
      error = function(e) NULL
    )
    
    if(
      is.null(available_fonts) ||
      !"family" %in% names(available_fonts)
    ) {
      return("sans")
    }
    
    available <- any(
      tolower(trimws(available_fonts$family)) == tolower(value),
      na.rm = TRUE
    )
    
    if(available) value else "sans"
  }
  
  split_long_word <- function(word, width) {
    
    if(
      !nzchar(word) ||
      nchar(word, type = "width") <= width
    ) {
      return(word)
    }
    
    starts <- seq.int(
      from = 1L,
      to = nchar(word),
      by = width
    )
    
    substring(
      word,
      first = starts,
      last = pmin(starts + width - 1L, nchar(word))
    )
  }
  
  wrap_one_label <- function(value, width) {
    
    if(is.na(value) || !nzchar(value)) {
      return("")
    }
    
    # Only the displayed label is changed. Source values remain untouched.
    value <- gsub("_", " ", value, fixed = TRUE)
    value <- trimws(value)
    
    if(!nzchar(value)) {
      return("")
    }
    
    words <- strsplit(value, "[[:space:]]+")[[1L]]
    
    # Long identifiers without natural spaces are split into safe chunks.
    words <- unlist(
      lapply(words, split_long_word, width = width),
      use.names = FALSE
    )
    
    paste(
      strwrap(
        paste(words, collapse = " "),
        width = width,
        simplify = TRUE
      ),
      collapse = "\n"
    )
  }
  
  format_label_column <- function(values, column, width) {
    
    values <- as.character(values)
    values[is.na(values)] <- ""
    
    if(identical(column, "ntreat")) {
      values <- ifelse(
        nzchar(values),
        paste0("T", values),
        ""
      )
    }
    
    vapply(
      values,
      wrap_one_label,
      width = width,
      FUN.VALUE = character(1),
      USE.NAMES = FALSE
    )
  }
  
  make_label <- function(data, fill, width) {
    
    labels <- lapply(
      fill,
      function(column) {
        format_label_column(
          values = data[[column]],
          column = column,
          width = width
        )
      }
    )
    
    output <- do.call(
      paste,
      c(labels, sep = "\n")
    )
    
    output <- gsub("^\n+|\n+$", "", output)
    output <- gsub("\n{3,}", "\n\n", output)
    
    output
  }
  
  maximum_label_width <- function(data, fill) {
    
    widths <- unlist(
      lapply(
        fill,
        function(column) {
          values <- as.character(data[[column]])
          values[is.na(values)] <- ""
          
          if(identical(column, "ntreat")) {
            values <- ifelse(
              nzchar(values),
              paste0("T", values),
              ""
            )
          }
          
          values <- gsub("_", " ", values, fixed = TRUE)
          nchar(values, type = "width", allowNA = FALSE)
        }
      ),
      use.names = FALSE
    )
    
    if(length(widths) == 0L) {
      return(1L)
    }
    
    as.integer(max(c(widths, 1L), na.rm = TRUE))
  }
  
  automatic_wrap_width <- function(
    data,
    fill,
    text_size_pt,
    number_rows,
    number_cols
  ) {
    
    longest_label <- maximum_label_width(data, fill)
    grid_density <- max(number_rows, number_cols)
    
    base_width <- dplyr::case_when(
      grid_density <= 5L ~ 20,
      grid_density <= 8L ~ 16,
      grid_density <= 12L ~ 13,
      grid_density <= 18L ~ 10,
      grid_density <= 26L ~ 8,
      TRUE ~ 6
    )
    
    font_adjustment <- 9 / text_size_pt
    label_adjustment <- dplyr::case_when(
      length(fill) == 1L ~ 1,
      length(fill) == 2L ~ 0.90,
      TRUE ~ 0.80
    )
    
    calculated <- as.integer(
      round(base_width * font_adjustment * label_adjustment)
    )
    
    calculated <- max(4L, min(30L, calculated))
    max(1L, min(calculated, longest_label))
  }
  
  # -------------------------------------------------------------------------
  # Input validation ---------------------------------------------------------
  # -------------------------------------------------------------------------
  
  if(!is.data.frame(data)) {
    stop("'data' must be a data frame.", call. = FALSE)
  }
  
  if(nrow(data) == 0L) {
    stop(
      "'data' must contain at least one experimental unit.",
      call. = FALSE
    )
  }
  
  required_cols <- c(
    "plots",
    "ntreat",
    "block",
    "rows",
    "cols",
    "design"
  )
  
  missing_cols <- setdiff(required_cols, names(data))
  
  if(length(missing_cols) > 0L) {
    stop(
      "Missing required columns for Splitplot-RCBD plot: ",
      paste(missing_cols, collapse = ", "),
      ".",
      call. = FALSE
    )
  }
  
  block_values <- as.character(data$block)
  
  if(
    anyNA(block_values) ||
    any(!nzchar(trimws(block_values)))
  ) {
    stop(
      "Column 'block' must not contain missing or empty values.",
      call. = FALSE
    )
  }
  
  for(column in c("rows", "cols")) {
    
    values <- data[[column]]
    
    if(
      !is.numeric(values) ||
      anyNA(values) ||
      any(!is.finite(values)) ||
      any(values < 1) ||
      any(values != floor(values))
    ) {
      stop(
        "Column '", column,
        "' must contain positive finite integer coordinates without missing values.",
        call. = FALSE
      )
    }
  }
  
  # Coordinates may restart in another block because blocks are shown in
  # separate panels. They must, however, be unique inside each block.
  coordinates <- paste(
    block_values,
    data$rows,
    data$cols,
    sep = ":"
  )
  
  if(anyDuplicated(coordinates)) {
    stop(
      "The fieldbook contains duplicated 'rows' and 'cols' coordinates ",
      "within at least one block.",
      call. = FALSE
    )
  }
  
  design_values <- unique(
    tolower(trimws(as.character(data$design)))
  )
  
  design_values <- design_values[
    !is.na(design_values) & nzchar(design_values)
  ]
  
  accepted_designs <- c(
    "split-rcbd",
    "split_rcbd",
    "split rcbd",
    "splitplot-rcbd",
    "splitplot_rcbd",
    "splitplot rcbd",
    "split-plot-rcbd",
    "split-plot rcbd"
  )
  
  if(
    length(design_values) > 0L &&
    !all(design_values %in% accepted_designs)
  ) {
    stop(
      "The fieldbook is not identified exclusively as a Splitplot-RCBD design. ",
      "Found: ",
      paste(design_values, collapse = ", "),
      ".",
      call. = FALSE
    )
  }
  
  if(is_missing_scalar(factor)) {
    factor <- if("wp_sp" %in% names(data)) "wp_sp" else "ntreat"
  }
  
  if(length(factor) != 1L || !is.character(factor)) {
    stop(
      "'factor' must be the name of one column.",
      call. = FALSE
    )
  }
  
  factor <- trimws(factor)
  
  if(!factor %in% names(data)) {
    stop(
      "Column selected in 'factor' was not found. Available columns: ",
      paste(names(data), collapse = ", "),
      ".",
      call. = FALSE
    )
  }
  
  if(
    is.null(fill) ||
    length(fill) == 0L ||
    all(is.na(fill)) ||
    all(!nzchar(trimws(as.character(fill))))
  ) {
    fill <- "plots"
  }
  
  fill <- trimws(as.character(fill))
  fill <- fill[!is.na(fill) & nzchar(fill)]
  fill <- unique(fill)
  
  missing_fill <- setdiff(fill, names(data))
  
  if(length(missing_fill) > 0L) {
    stop(
      "Columns selected in 'fill' were not found: ",
      paste(missing_fill, collapse = ", "),
      ". Available columns: ",
      paste(names(data), collapse = ", "),
      ".",
      call. = FALSE
    )
  }
  
  text_size <- validate_optional_positive_number(
    text_size,
    "text_size"
  )
  
  wrap_width <- validate_optional_positive_integer(
    wrap_width,
    "wrap_width"
  )
  
  allowed_faces <- c(
    "plain",
    "bold",
    "italic",
    "bold.italic"
  )
  
  if(
    is.null(font_face) ||
    length(font_face) != 1L ||
    is.na(font_face) ||
    !font_face %in% allowed_faces
  ) {
    stop(
      "'font_face' must be one of: ",
      paste(allowed_faces, collapse = ", "),
      ".",
      call. = FALSE
    )
  }
  
  font_family <- resolve_font_family(font_family)
  
  # -------------------------------------------------------------------------
  # Label size and automatic wrapping ---------------------------------------
  # -------------------------------------------------------------------------
  
  if(is.null(text_size)) {
    text_size <- dplyr::case_when(
      length(fill) == 1L ~ 10,
      length(fill) == 2L ~ 8.5,
      TRUE ~ 7
    )
  }
  
  block_dimensions <- data %>%
    dplyr::group_by(.data$block) %>%
    dplyr::summarise(
      .n_rows = dplyr::n_distinct(.data$rows),
      .n_cols = dplyr::n_distinct(.data$cols),
      .groups = "drop"
    )
  
  number_rows <- max(block_dimensions$.n_rows)
  number_cols <- max(block_dimensions$.n_cols)
  
  if(is.null(wrap_width)) {
    wrap_width <- automatic_wrap_width(
      data = data,
      fill = fill,
      text_size_pt = text_size,
      number_rows = number_rows,
      number_cols = number_cols
    )
  }
  
  # geom_text() expects millimetres; users and the interface work in points.
  geom_text_size <- text_size / ggplot2::.pt
  
  line_height <- dplyr::case_when(
    length(fill) == 1L ~ 1.05,
    length(fill) == 2L ~ 1.00,
    TRUE ~ 0.95
  )
  
  # -------------------------------------------------------------------------
  # Data preparation ---------------------------------------------------------
  # -------------------------------------------------------------------------
  
  data_plot <- data %>%
    dplyr::group_by(.data$block) %>%
    dplyr::mutate(
      # This is only a display label for subplot positions. The plot geometry
      # below still uses the original 'rows' coordinate.
      .subplot_position = dplyr::dense_rank(.data$rows)
    ) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(
      .plot_factor = as.factor(.data[[factor]]),
      .plot_label = make_label(
        data = .,
        fill = fill,
        width = wrap_width
      )
    )
  
  factor_levels <- levels(data_plot$.plot_factor)
  n_factor_levels <- max(length(factor_levels), 1L)
  
  color_grps <- grDevices::colorRampPalette(
    c(
      "#86CD80",
      "#F4CB8C",
      "#F3BB00",
      "#0198CD",
      "#FE6673"
    )
  )(n_factor_levels)
  
  if(length(factor_levels) > 0L) {
    names(color_grps) <- factor_levels
  }
  
  # Build a global row-to-subplot label only when the same physical row value
  # is not assigned to different subplot positions in different blocks.
  row_subplot_map <- data_plot %>%
    dplyr::distinct(.data$rows, .data$.subplot_position)
  
  row_mapping_is_consistent <-
    !anyDuplicated(row_subplot_map$rows)
  
  if(row_mapping_is_consistent) {
    subplot_lookup <- stats::setNames(
      as.character(row_subplot_map$.subplot_position),
      as.character(row_subplot_map$rows)
    )
    
    subplot_axis_labels <- function(values) {
      labels <- unname(subplot_lookup[as.character(values)])
      labels[is.na(labels)] <- as.character(values[is.na(labels)])
      labels
    }
  } else {
    subplot_axis_labels <- function(values) as.character(values)
  }
  
  if(is.null(xlab)) {
    xlab <- "Whole plots"
  }
  
  if(is.null(ylab)) {
    ylab <- if(row_mapping_is_consistent) "Subplots" else "Rows"
  }
  
  if(is.null(glab)) {
    glab <- factor
  }
  
  # -------------------------------------------------------------------------
  # Whole-plot boxes ---------------------------------------------------------
  # -------------------------------------------------------------------------
  
  # In the fieldbook produced by design_split_rcbd(), each physical column
  # represents one whole plot within a block. Boxes use the actual row and
  # column coordinates; block is only the facet identifier.
  whole_boxes <- data_plot %>%
    dplyr::group_by(.data$block, .data$cols) %>%
    dplyr::summarise(
      xmin = min(.data$cols, na.rm = TRUE) - 0.5,
      xmax = max(.data$cols, na.rm = TRUE) + 0.5,
      ymin = min(.data$rows, na.rm = TRUE) - 0.5,
      ymax = max(.data$rows, na.rm = TRUE) + 0.5,
      .groups = "drop"
    )
  
  # -------------------------------------------------------------------------
  # Plot --------------------------------------------------------------------
  # -------------------------------------------------------------------------
  
  data_plot %>%
    dplyr::arrange(.data$block, .data$cols, .data$rows) %>%
    ggplot2::ggplot(
      ggplot2::aes(
        x = .data$cols,
        y = .data$rows,
        fill = .data$.plot_factor
      )
    ) +
    ggplot2::geom_tile(
      color = "grey35",
      linewidth = 0.25
    ) +
    ggplot2::geom_rect(
      data = whole_boxes,
      ggplot2::aes(
        xmin = .data$xmin,
        xmax = .data$xmax,
        ymin = .data$ymin,
        ymax = .data$ymax
      ),
      inherit.aes = FALSE,
      fill = NA,
      color = "black",
      linewidth = 0.65
    ) +
    ggplot2::geom_text(
      ggplot2::aes(label = .data$.plot_label),
      size = geom_text_size,
      family = font_family,
      fontface = font_face,
      lineheight = line_height,
      color = "black",
      na.rm = TRUE
    ) +
    ggplot2::facet_wrap(
      ~ block,
      nrow = 1,
      scales = "free_y",
      labeller = ggplot2::label_both
    ) +
    ggplot2::scale_y_continuous(
      expand = c(0, 0),
      trans = "reverse",
      breaks = sort(unique(data_plot$rows)),
      labels = subplot_axis_labels
    ) +
    ggplot2::scale_x_continuous(
      expand = c(0, 0),
      breaks = sort(unique(data_plot$cols))
    ) +
    ggplot2::scale_fill_manual(
      values = color_grps,
      na.value = "grey90",
      drop = FALSE
    ) +
    ggplot2::labs(
      x = xlab,
      y = ylab,
      fill = glab
    ) +
    ggplot2::theme_minimal(
      base_size = 12,
      base_family = font_family
    ) +
    ggplot2::theme(
      legend.position = "top",
      legend.title = ggplot2::element_text(
        family = font_family,
        face = font_face
      ),
      legend.text = ggplot2::element_text(
        family = font_family,
        face = font_face,
        size = 9
      ),
      panel.grid = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(
        fill = "grey90",
        color = "grey70"
      ),
      strip.text = ggplot2::element_text(
        family = font_family,
        face = font_face
      ),
      axis.title = ggplot2::element_text(
        family = font_family,
        face = font_face
      ),
      axis.text = ggplot2::element_text(
        family = font_family,
        face = font_face,
        color = "grey25"
      ),
      plot.margin = ggplot2::margin(6, 6, 6, 6)
    )
}