R/recolor_status.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Recolors a scorecard table grid by setting the
#' model activation status cells to the given colors.
#' This is useful for highlighting the \code{status} column.
#' Pass a subset of the scorecard data frame to apply
#' recoloring for a particular status type; uses the data frame
#' index column to work out row offsets in the table grid.
#' @param table the table grid to modify
#' @param sdf scorecard data frame, subset for recoloring
#' @param cell_fill the cell fill color to apply to matches
#' @param cell_fg the cell foreground color, default black
#' @param cell_border the cell border color, default dark gray
#' @param cell_alpha the cell alpha color adjustment, default 1
#' @return the modified table grid
#' @seealso grid::gpar, tableGrid, gtable
recolor_status <- function(table,
                           sdf,
                           cell_fill,
                           cell_fg = "black",
                           cell_border = "darkgray",
                           cell_alpha = 1) {
  if (nrow(sdf) > 0) {
    min_sdf <- min(sdf$Index, na.rm = TRUE) + 2
    max_sdf <- max(sdf$Index, na.rm = TRUE) + 2
    table <-
      gtable::gtable_add_grob(table,
                              grobs = grid::rectGrob(gp =
                                                       grid::gpar(fill = NA,
                                                                  lwd = 2)),
                              t = min_sdf,
                              b = max_sdf,
                              l = 1,
                              r = ncol(table))
    for (i in min_sdf:max_sdf) {
      fc <- find_cell(table, i, 2, "core-bg")
      if ( ! is.null(fc)) {
        table$grobs[fc][[1]][["gp"]] <- grid::gpar(fill = cell_fill,
                                                   col = cell_border,
                                                   alpha = cell_alpha,
                                                   lwd = 1)
      }
      fc <- find_cell(table, i, 2, "core-fg")
      if ( ! is.null(fc)) {
        table$grobs[fc][[1]]$gp$col <- cell_fg
      }
    }
  }
  return(table)
}