R/create_png.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Creates a PNG file graphic of a scorecard data frame.
#' @param df scorecard data frame, as from \code{scorecard_produce}
#' @param scorecard_dir directory destination for file write
#' @param name file name body; the
#' function will paste together the \code{file_date},
#' an underscore, and the \code{name} with the \code{.png}
#' extension to create the complete file name.
#' The \code{file_date} is used to facilitate directory sorting.
#' @param title a title appearing above the table, default empty
#' @param file_date a date stamp for the destination file
#' @param highlight_rank whether to highlight rank 1 fields
#' @param fill_activated fill color for activated model cell
#' @param fg_activated foreground color for activated model cell
#' @param fill_candidate fill color for candidate model cell
#' @param fg_candidate foreground color for candidate model cell
#' @param fill_deactivated fill color for deactivated model cell
#' @param fg_deactivated foreground color for deactivated model cell
#' @param fill_retired fill color for retired model cell
#' @param fg_retired foreground color for retired model cell
#' @param fill_rank fill color for rank one outcome cells
#' @param fg_rank foreground color for rank out outcome cells
create_png <- function(df,
                       scorecard_dir = stop("Pass scorecard directory"),
                       name = "",
                       title = "",
                       file_date = lubridate::today(),
                       highlight_rank = TRUE,
                       fill_activated = "#1ec322",
                       fg_activated = "black",
                       fill_candidate = "#fedd32",
                       fg_candidate = "black",
                       fill_deactivated = "#fd696a",
                       fg_deactivated = "black",
                       fill_retired = "#6496fc",
                       fg_retired = "white",
                       fill_rank = "#1ec322",
                       fg_rank = "black"
                       ) {
  # dodges command check complaints
  Status <- NULL
  file_name <- file.path(scorecard_dir,
                        paste0(file_date, "_", name, ".png"))
  grDevices::png(file_name,
                 width = 650,
                height = 25 * nrow(df) + 30,
                units = "px")
  tg <- grid::textGrob(title, gp = grid::gpar(fontsize = 24))
  pg <- gridExtra::tableGrob(df, rows = NULL)
  padding <- grid::unit(5, "mm")

  # table body, title, border
  table <-
    gtable::gtable_add_rows(pg,
                            heights = grid::grobHeight(tg) + padding,
                            pos = 0)
  table <-
    gtable::gtable_add_grob(table,
                            tg,
                            1,
                            1,
                            1,
                            ncol(table))
  table <-
    gtable::gtable_add_grob(table,
                            grobs = grid::rectGrob(gp = grid::gpar(fill = NA,
                                                                   lwd = 2)),
                            t = 2,
                            b = nrow(table),
                            l = 1,
                            r = ncol(table))

  # dividers for status
  xdf <- df[, 1:2]
  adf <- xdf %>% filter(Status == "activated")
  cdf <- xdf %>% filter(Status == "candidate")
  ddf <- xdf %>% filter(Status == "deactivated")
  rdf <- xdf %>% filter(Status == "retired")

  # cell fills and section borders
  table <- recolor_status(table,
                          adf,
                          fill_activated,
                          cell_fg = fg_activated,
                          cell_alpha = 1.0)
  table <- recolor_status(table,
                          cdf,
                          fill_candidate,
                          cell_fg = fg_candidate,
                          cell_alpha = 1.0)
  table <- recolor_status(table,
                          ddf,
                          fill_deactivated,
                          cell_fg = fg_deactivated,
                          cell_alpha = 1.0)
  table <- recolor_status(table,
                          rdf,
                          fill_retired,
                          cell_fg = fg_retired,
                          cell_alpha = 1.0)

  # rank one fills
  if ( highlight_rank )
    table <- recolor_rank(table,
                          df,
                          cell_fill = fill_rank,
                          cell_fg = fg_rank,
                          cell_alpha = 0.8)

  # write it
  grid::grid.newpage()
  grid::grid.draw(table)
  dev.off()
}