R/plot_standard_design.R

In inti: Tools and Statistical Procedures in Plant Science

#' Plot standard fieldbook experimental designs
#'
#' Plot standard fieldbook sketches for regular experimental designs generated
#' in Tarpuy, including completely randomized designs (CRD/DCA) and randomized
#' complete block designs (RCBD/DBCA).
#'
#' The function does not calculate or rearrange an experimental design. It uses
#' the existing `rows` and `cols` coordinates from the fieldbook, so the
#' physical layout and the zigzag order generated by Tarpuy are preserved.
#'
#' @param data A fieldbook data frame. It must contain at least `rows` and
#'   `cols`.
#' @param factor Character scalar. Name of the column used to color the
#'   experimental units. If missing, `"block"` is used when available;
#'   otherwise, the third column of `data` is used.
#' @param fill Character vector. Names of one or more columns used as labels
#'   inside each experimental unit. When `ntreat` is used, it is displayed as
#'   `T1`, `T2`, etc.
#' @param xlab Character scalar. Title for the x axis. If `NULL`, `"Columns"`
#'   is used.
#' @param ylab Character scalar. Title for the y axis. If `NULL`, `"Blocks"` is
#'   shown for RCBD/DBCA only when each physical row corresponds to exactly one
#'   block; otherwise `"Rows"` is used. The plotting coordinate always remains
#'   the physical `rows` column.
#' @param glab Character scalar. Legend title. If `NULL`, `factor` is used.
#' @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 field dimensions, font size and
#'   number of label columns. Underscores are shown as spaces only in the
#'   plotted label; the original fieldbook values are not modified.
#' @param font_family Character scalar. Font family used by 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 and
#'   legends. Defaults to `"plain"`.
#'
#' @details
#' All standard designs are plotted with `cols` on the x axis and `rows` on
#' the y axis. A DBCA/RCBD is therefore displayed according to its actual
#' physical coordinates rather than replacing the row coordinate with the
#' block number. When rows and blocks have a strict one-to-one relationship,
#' only the visible y-axis title changes to `"Blocks"`. The block can still be
#' selected as the color factor.
#'
#' Automatic wrapping affects only the sketch. It does not change `entry`,
#' `ntreat`, QR codes, factor levels or any other fieldbook value.
#'
#' @return A `ggplot` object.
#'
#' @import dplyr
#' @import ggplot2
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' plot_standard_design(
#'   data = fieldbook,
#'   factor = "geno",
#'   fill = c("plots", "entry"),
#'   text_size = 9,
#'   font_family = "Open Sans",
#'   font_face = "plain"
#' )
#'
#' }

plot_standard_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")
    )
    
    # Remove blank lines produced by empty optional label values.
    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 <= 6L ~ 20,
      grid_density <= 10L ~ 16,
      grid_density <= 16L ~ 13,
      grid_density <= 24L ~ 10,
      grid_density <= 36L ~ 8,
      TRUE ~ 6
    )
    
    # Larger fonts and multiple label fields require earlier line breaks.
    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_layout <- c("rows", "cols")
  missing_layout <- setdiff(required_layout, names(data))
  
  if(length(missing_layout) > 0L) {
    stop(
      "Missing required layout columns: ",
      paste(missing_layout, collapse = ", "),
      ".",
      call. = FALSE
    )
  }
  
  for(column in required_layout) {
    
    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 <- paste(data$rows, data$cols, sep = ":")
  
  if(anyDuplicated(coordinates)) {
    stop(
      "The fieldbook contains duplicated 'rows' and 'cols' coordinates.",
      call. = FALSE
    )
  }
  
  factor_missing <- is_missing_scalar(factor)
  
  if(factor_missing) {
    
    if("block" %in% names(data)) {
      factor <- "block"
    } else if(ncol(data) >= 3L) {
      factor <- names(data)[3L]
    } else {
      stop(
        "'factor' was not provided and no default color column is available.",
        call. = FALSE
      )
    }
  }
  
  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 ---------------------------------------
  # -------------------------------------------------------------------------
  
  # The previous defaults (3.5, 3.0 and 2.5 mm) correspond approximately to
  # 10, 8.5 and 7 typographic points. Keeping these visual defaults while
  # exposing the public argument in points preserves compatibility.
  if(is.null(text_size)) {
    text_size <- dplyr::case_when(
      length(fill) == 1L ~ 10,
      length(fill) == 2L ~ 8.5,
      TRUE ~ 7
    )
  }
  
  number_rows <- length(unique(data$rows))
  number_cols <- length(unique(data$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::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
  }
  
  # Geometry always uses cols on x and rows on y. For RCBD/DBCA, only the
  # visible y-axis title changes to "Blocks" when every physical row maps to
  # exactly one statistical block and every block maps to exactly one row.
  design_values <- if("design" %in% names(data_plot)) {
    values <- tolower(trimws(as.character(data_plot$design)))
    values <- values[!is.na(values) & nzchar(values)]
    unique(gsub("[[:space:]_]+", "-", values))
  } else {
    character(0)
  }
  
  is_rcbd <- length(design_values) == 1L &&
    design_values[[1L]] %in% c("rcbd", "dbca")
  
  one_row_per_block <- FALSE
  
  if(is_rcbd && "block" %in% names(data_plot)) {
    block_values <- as.character(data_plot$block)
    valid_blocks <- !is.na(block_values) & nzchar(trimws(block_values))
    
    if(all(valid_blocks)) {
      row_block_map <- unique(
        data.frame(
          rows = data_plot$rows,
          block = block_values,
          stringsAsFactors = FALSE
        )
      )
      
      one_row_per_block <-
        nrow(row_block_map) == length(unique(data_plot$rows)) &&
        nrow(row_block_map) == length(unique(block_values)) &&
        !anyDuplicated(row_block_map$rows) &&
        !anyDuplicated(row_block_map$block)
    }
  }
  
  if(is.null(xlab)) {
    xlab <- "Columns"
  }
  
  if(is.null(ylab)) {
    ylab <- if(one_row_per_block) "Blocks" else "Rows"
  }
  
  if(is.null(glab)) {
    glab <- factor
  }
  
  common_theme <- 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(),
      axis.title = ggplot2::element_text(
        family = font_family,
        face = font_face
      ),
      axis.text = ggplot2::element_text(
        family = font_family,
        face = font_face,
        color = "grey25"
      ),
      strip.text = ggplot2::element_text(
        family = font_family,
        face = font_face
      ),
      plot.margin = ggplot2::margin(6, 6, 6, 6)
    )
  
  # -------------------------------------------------------------------------
  # Physical field layout ----------------------------------------------------
  # -------------------------------------------------------------------------
  
  data_plot %>%
    dplyr::arrange(.data$rows, .data$cols) %>%
    ggplot2::ggplot(
      ggplot2::aes(
        x = .data$cols,
        y = .data$rows,
        fill = .data$.plot_factor
      )
    ) +
    ggplot2::geom_tile(
      color = "grey25",
      linewidth = 0.35
    ) +
    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::scale_y_continuous(
      expand = c(0, 0),
      trans = "reverse",
      breaks = sort(unique(data_plot$rows))
    ) +
    ggplot2::scale_x_continuous(
      expand = c(0, 0),
      breaks = sort(unique(data_plot$cols))
    ) +
    ggplot2::scale_fill_manual(
      values = color_grps,
      na.value = "grey90"
    ) +
    ggplot2::labs(
      x = xlab,
      y = ylab,
      fill = glab
    ) +
    common_theme
}