R/plot_augmented_design.R

In inti: Tools and Statistical Procedures in Plant Science

#' Plot augmented fieldbook design
#'
#' Plot fieldbook sketches for augmented experimental designs generated by
#' `design_augmented()`.
#'
#' The function always uses the physical `rows` and `cols` coordinates stored in
#' the fieldbook. Therefore, custom dimensions and zigzag layouts are preserved.
#' The `block` column never replaces `rows` as a plotting coordinate. When each
#' row represents exactly one block, only the visible y-axis title changes from
#' `"Rows"` to `"Blocks"`. The statistical block remains available as a color
#' factor and, when a block occupies a complete rectangular region, its external
#' border is highlighted.
#'
#' @param data Fieldbook data frame from an augmented design.
#' @param factor Character scalar. Column used to color experimental units.
#'   If missing, `"type"` is used.
#' @param fill Character vector. Column or columns used as labels inside each
#'   experimental unit. Default is `"plots"`. When `ntreat` is selected, it is
#'   displayed as `T1`, `T2`, etc.
#' @param xlab Character scalar. Optional x axis title. If `NULL`, `"Columns"`
#'   is used.
#' @param ylab Character scalar. Optional y axis title. If `NULL`, the title is
#'   `"Blocks"` when every physical row corresponds to exactly one statistical
#'   block; otherwise `"Rows"` is used.
#' @param glab Character scalar. Optional legend title. If `NULL`, the selected
#'   color 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 displayed as spaces only in the
#'   sketch; the original 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 and
#'   legends. Defaults to `"plain"`.
#'
#' @details
#' Empty experimental units are represented by the level `"empty"`. When
#' `factor = "type"`, checks, test entries and empty plots receive stable
#' colors. Other factor columns use the regular TARPUY color palette.
#'
#' Automatic wrapping and formatting affect only the displayed text. They do
#' not modify `entry`, `plots`, `ntreat`, QR codes or any other fieldbook value.
#'
#' @return A `ggplot` object.
#'
#' @import dplyr
#' @import ggplot2
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' plot_augmented_design(
#'   data = fieldbook,
#'   factor = "type",
#'   fill = c("plots", "entry"),
#'   text_size = 9,
#'   font_family = "Open Sans",
#'   font_face = "plain"
#' )
#'
#' }

plot_augmented_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]]
    
    # Split identifiers that do not contain a natural wrapping point.
    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 optional empty 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 fields need 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))
  }
  
  build_rectangular_block_boxes <- function(data) {
    
    boxes <- data %>%
      dplyr::group_by(.data$block) %>%
      dplyr::summarise(
        xmin = min(.data$cols) - 0.5,
        xmax = max(.data$cols) + 0.5,
        ymin = min(.data$rows) - 0.5,
        ymax = max(.data$rows) + 0.5,
        .n_units = dplyr::n(),
        .n_expected =
          (max(.data$cols) - min(.data$cols) + 1L) *
          (max(.data$rows) - min(.data$rows) + 1L),
        .groups = "drop"
      ) %>%
      dplyr::filter(.data$.n_units == .data$.n_expected) %>%
      dplyr::select(-dplyr::all_of(c(".n_units", ".n_expected")))
    
    boxes
  }
  
  # -------------------------------------------------------------------------
  # 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",
    "entry",
    "type",
    "block",
    "rows",
    "cols"
  )
  
  missing_cols <- setdiff(required_cols, names(data))
  
  if(length(missing_cols) > 0L) {
    stop(
      "Missing required columns for an augmented sketch: ",
      paste(missing_cols, collapse = ", "),
      ".",
      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
      )
    }
  }
  
  if(anyNA(data$block)) {
    stop(
      "Column 'block' must not contain 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
    )
  }
  
  if(is_missing_scalar(factor)) {
    factor <- "type"
  }
  
  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 ---------------------------------------
  # -------------------------------------------------------------------------
  
  # Preserve the approximate visual defaults used by the previous plotter,
  # while exposing the public value consistently in typographic points.
  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 UI 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 ---------------------------------------------------------
  # -------------------------------------------------------------------------
  
  factor_values <- as.character(data[[factor]])
  factor_values[is.na(factor_values)] <- ""
  factor_values <- trimws(factor_values)
  factor_values[!nzchar(factor_values)] <- "empty"
  
  if(identical(factor, "type")) {
    factor_values <- tolower(factor_values)
  }
  
  if(identical(factor, "type")) {
    observed_levels <- unique(factor_values)
    preferred_levels <- c("check", "test")
    extra_levels <- setdiff(observed_levels, c(preferred_levels, "empty"))
    factor_levels <- c(
      intersect(preferred_levels, observed_levels),
      extra_levels,
      intersect("empty", observed_levels)
    )
  } else {
    factor_levels <- unique(factor_values)
  }
  
  data_plot <- data %>%
    dplyr::mutate(
      .plot_factor = base::factor(
        factor_values,
        levels = factor_levels
      ),
      .plot_label = make_label(
        data = .,
        fill = fill,
        width = wrap_width
      )
    )
  
  # -------------------------------------------------------------------------
  # Colors ------------------------------------------------------------------
  # -------------------------------------------------------------------------
  
  if(identical(factor, "type")) {
    
    stable_colors <- c(
      check = "#4E79A7",
      test = "#59A14F",
      empty = "#D9D9D9"
    )
    
    known_levels <- intersect(factor_levels, names(stable_colors))
    color_values <- stable_colors[known_levels]
    extra_levels <- setdiff(factor_levels, names(stable_colors))
    
    if(length(extra_levels) > 0L) {
      extra_colors <- grDevices::colorRampPalette(
        c(
          "#86CD80",
          "#F4CB8C",
          "#F3BB00",
          "#0198CD",
          "#FE6673"
        )
      )(length(extra_levels))
      
      names(extra_colors) <- extra_levels
      color_values <- c(color_values, extra_colors)
    }
    
    # Restore the same order used by the factor levels.
    color_values <- color_values[factor_levels]
    
  } else {
    
    n_factor_levels <- max(length(factor_levels), 1L)
    
    color_values <- grDevices::colorRampPalette(
      c(
        "#86CD80",
        "#F4CB8C",
        "#F3BB00",
        "#0198CD",
        "#FE6673"
      )
    )(n_factor_levels)
    
    names(color_values) <- factor_levels
  }
  
  # -------------------------------------------------------------------------
  # Labels, theme and block boundaries --------------------------------------
  # -------------------------------------------------------------------------
  
  # The geometry always uses cols on x and rows on y. Only the visible axis
  # title changes when rows and blocks have a strict one-to-one relationship.
  row_block_map <- unique(
    data.frame(
      rows = data_plot$rows,
      block = as.character(data_plot$block),
      stringsAsFactors = FALSE
    )
  )
  
  one_row_per_block <-
    nrow(row_block_map) == length(unique(data_plot$rows)) &&
    nrow(row_block_map) == length(unique(as.character(data_plot$block))) &&
    !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
  }
  
  block_boxes <- build_rectangular_block_boxes(data_plot)
  
  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 ----------------------------------------------------
  # -------------------------------------------------------------------------
  
  plot <- 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
    )
  
  if(nrow(block_boxes) > 0L) {
    plot <- plot +
      ggplot2::geom_rect(
        data = block_boxes,
        ggplot2::aes(
          xmin = .data$xmin,
          xmax = .data$xmax,
          ymin = .data$ymin,
          ymax = .data$ymax
        ),
        inherit.aes = FALSE,
        fill = NA,
        color = "black",
        linewidth = 0.55
      )
  }
  
  plot +
    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_values,
      drop = FALSE,
      na.value = "#D9D9D9"
    ) +
    ggplot2::labs(
      x = xlab,
      y = ylab,
      fill = glab
    ) +
    common_theme
}