R/VizScorecard.R

In esviz: Plotting Functions for Climate Science and Services

#' Function to plot Scorecard tables
#'  
#' This function renders a scorecard table from a multidimensional array 
#' in HTML style. The structure of the table is based on the assignment of each 
#' dimension of the array as a structure element: row, subrow, column or 
#' subcolumn. It is useful to present tabular results with colors in a nice way.
#'  
#' Note: Module PhantomJS is required.
#'   
#' @param data A multidimensional array containing the data to be plotted with 
#'   at least four dimensions. Each dimension will have assigned a structure 
#'   element: row, subrow, column and subcolumn.
#' @param sign A multidimensional boolean array with the same dimensions as 
#'   'data', indicting which values to be highlighted. If set to NULL no values 
#'   will be highlighted.
#' @param row_dim A character string indicating the dimension name to show in the 
#'   rows of the plot. It is set as 'region' by default.
#' @param subrow_dim A character string indicating the dimension name to show in 
#'   the sub-rows of the plot. It is set as 'time' by default.
#' @param col_dim A character string indicating the dimension name to show in the 
#'   columns of the plot. It is set as 'metric' by default.
#' @param subcol_dim A character string indicating the dimension name to show in  
#'   the sub-columns of the plot. It is set as 'sdate' by default.
#' @param legend_dim  A character string indicating the dimension name to use for 
#'   the legend. It is set as 'metric' by default.
#' @param row_names A vector of character strings with row display names. It 
#'   is set as NULL by default.
#' @param subrow_names A vector of character strings with sub-row display names. 
#'   It is set as NULL by default.
#' @param col_names A vector of character strings with column display names. It 
#'   is set as NULL by default.
#' @param subcol_names A vector of character strings with sub-column display 
#'   names. It is set as NULL by default.
#' @param row_title A character string for the title of the row names. It is set 
#'   as NULL by default.
#' @param subrow_title A character string for the title of the sub-row names. It 
#'   is set as NULL by default.
#' @param col_title A character string for the title of the column names. It is 
#'   set as NULL by default.
#' @param table_title A character string for the title of the plot. It is set as 
#'   NULL by default.
#' @param table_subtitle A character string for the sub-title of the plot. It is 
#'   set as NULL by default.
#' @param legend_breaks A vector of numerics or a list of vectors of numerics,
#'   containing the breaks for the legends. If a vector is given as input, then 
#'   these breaks will be repeated for each 'legend_dim'. A list of vectors can 
#'   be given as input if the 'legend_dims' require different breaks. This  
#'   parameter is required even if the legend is not plotted, to define the 
#'   colors in the scorecard table. It is set as NULL by default.
#' @param plot_legend A logical value to determine if the legend is plotted. It 
#'   is set as TRUE by default.
#' @param label_scale A numeric value to define the size of the legend labels. 
#'   It is set as 1.4 by default.
#' @param legend_width A numeric value to define the width of the legend bars. By 
#'   default it is set to NULL and calculated internally from the table width.
#' @param legend_height A numeric value to define the height of the legend bars. 
#'   It is set as 50 by default.
#' @param palette A vector of character strings or a list of vectors of 
#'   character strings containing the colors to use in the legends. If a vector 
#'   is given as input, then these colors will be used for each legend_dim. A 
#'   list of vectors can be given as input if different colors are desired for 
#'   the legend_dims. This parameter must be included even if the legend is 
#'   not plotted, to define the colors in the scorecard table. 
#' @param colorunder A character string, a vector of character strings or a 
#'   list with single character string elements defining the colors to use for 
#'   data values with are inferior to the lowest breaks value. This parameter 
#'   will also plot a inferior triangle in the legend bar. The parameter can be 
#'   set to NULL if there are no inferior values. If a character string is given 
#'   this color will be applied to all 'legend_dims'. It is set as NULL by 
#'   default.
#' @param colorsup A character string, a vector of character strings or a 
#'   list with single character string elements defining the colors to use for 
#'   data values with are superior to the highest breaks value. This parameter 
#'   will also plot a inferior triangle in the legend bar. The parameter can be 
#'   set to NULL if there are no superior values. If a character string is given 
#'   this color will be applied to all legend_dims. It is set as NULL by default. 
#' @param round_decimal A numeric indicating to which decimal point the data 
#'   is to be displayed in the scorecard table. It is set as 2 by default.
#' @param font_size A numeric indicating the font size on the scorecard table. 
#'   Default is 2.
#' @param legend_white_space A numeric value defining the initial starting 
#'   position of the legend bars, the white space infront of the legend is 
#'   calculated from the left most point of the table as a distance in cm. The 
#'   default value is 6.
#' @param columns_width A numeric value defining the width all columns within the 
#'   table in cm (excluding the first and second columns containing the titles).
#' @param col1_width A numeric value defining the width of the first table column
#'   in cm. It is set as NULL by default.
#' @param col2_width A numeric value defining the width of the second table 
#'   column in cm. It is set as NULL by default.
#' @param fileout A path of the location to save the scorecard plots. By default 
#'   the plots will be saved to the working directory.
#'  
#' @return An image file containing the scorecard.
#' 
#' @examples
#' data <- array(rnorm(1000), dim = c('sdate' = 12, 'metric' = 4, 'region' = 3, 
#'                                    'time' = 6)) 
#' row_names <- c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH')
#' col_names <- c('Mean bias (K)', 'Correlation', 'RPSS','CRPSS')
#' \donttest{
#' tmp <- tempfile()
#' VizScorecard(data = data, row_names = row_names, col_names = col_names, 
#'              subcol_names =  month.abb[as.numeric(1:12)],
#'              row_title = 'Region', subrow_title = 'Forecast Month', 
#'              col_title = 'Start date', 
#'              table_title = "Temperature of ECMWF System 5", 
#'              table_subtitle = "(Ref: ERA5 1994-2016)", 
#'              plot_legend = FALSE, fileout = tmp)
#' unlink(paste0(tmp, "*"))
#' }
#' 
#' @importFrom kableExtra kbl kable_paper add_header_above column_spec row_spec save_kable
#' @importFrom RColorBrewer brewer.pal
#' @importFrom s2dv Reorder
#' @importFrom ClimProjDiags Subset
#' @importFrom CSTools MergeDims
#' @importFrom webshot2 webshot
#' @export
VizScorecard <- function(data, sign = NULL, row_dim = 'region', 
                         subrow_dim = 'time', col_dim = 'metric', 
                         subcol_dim = 'sdate', legend_dim = 'metric', 
                         row_names = NULL, subrow_names = NULL, 
                         col_names = NULL, subcol_names = NULL, 
                         row_title = NULL, subrow_title = NULL, 
                         col_title = NULL, table_title = NULL, 
                         table_subtitle = NULL, legend_breaks = NULL, 
                         plot_legend = TRUE, label_scale = 1.4, 
                         legend_width = NULL, legend_height = 50, 
                         palette = NULL, colorunder = NULL, colorsup = NULL,
                         round_decimal = 2, font_size = 1.1,
                         legend_white_space = 6, columns_width = 1.2, 
                         col1_width = NULL, col2_width = NULL,
                         fileout = NULL) {

  # Input parameter checks
  # Check data
  if (!is.array(data)) {
    stop("Parameter 'data' must be a numeric array.")
  }
  if (length(dim(data)) != 4) {
    stop("Parameter 'data' must have four dimensions.")
  }
  dimnames <- names(dim(data))
  # Check sign
  if (is.null(sign)) {
    sign <- array(FALSE, dim = dim(data))
  } else {
    if (!is.array(sign)) {
      stop("Parameter 'sign' must be a boolean array or NULL.")
    }
    if (any(sort(names(dim(sign))) != sort(dimnames))) {
      stop("Parameter 'sign' must have same dimensions as 'data'.")
    }
    if (typeof(sign) != 'logical') {
      stop("Parameter 'sign' must be an array with logical values.")
    }
  }
  # Check row_dim
  if (!is.character(row_dim)) {
    stop("Parameter 'row_dim' must be a character string.")
  }
  if (!row_dim %in% names(dim(data))) {
    stop("Parameter 'row_dim' is not found in 'data' dimensions.")
  }
  # Check row_names
  if (is.null(row_names)) {
    row_names <- as.character(1:dim(data)[row_dim])
  }
  if (length(row_names) != as.numeric(dim(data)[row_dim])) {
    stop("Parameter 'row_names' must have the same length of dimension ",
         "'row_dim'.")
  }
  # Check subrow_dim
  if (!is.character(subrow_dim)) {
    stop("Parameter 'subrow_dim' must be a character string.")
  }
  if (!subrow_dim %in% names(dim(data))) {
    stop("Parameter 'subrow_dim' is not found in 'data' dimensions.")
  }
  # Check subrow_names
  if (is.null(subrow_names)) {
    subrow_names <- as.character(1:dim(data)[subrow_dim])
  }
  if (length(subrow_names) != as.numeric(dim(data)[subrow_dim])) {
    stop("Parameter 'subrow_names' must have the same length of dimension ",
         "'subrow_dim'.")
  }
  # Check col_dim
  if (!is.character(col_dim)) {
    stop("Parameter 'col_dim' must be a character string.")
  }
  if (!col_dim %in% names(dim(data))) {
    stop("Parameter 'col_dim' is not found in 'data' dimensions.")
  }
  # Check col_names
  if (is.null(col_names)) {
    col_names <- as.character(1:dim(data)[col_dim])
  }
  if (length(col_names) != as.numeric(dim(data)[col_dim])) {
    stop("Parameter 'col_names' must have the same length of dimension ",
         "'col_dim'.")
  }
  # Check subcol_dim
  if (!is.character(subcol_dim)) {
    stop("Parameter 'subcol_dim' must be a character string.")
  }
  if (!subcol_dim %in% names(dim(data))) {
    stop("Parameter 'subcol_dim' is not found in 'data' dimensions.")
  }
  # Check subcol_names
  if (is.null(subcol_names)) {
    subcol_names <- as.character(1:dim(data)[subcol_dim])
  }
  if (length(subcol_names) != as.numeric(dim(data)[subcol_dim])) {
    stop("Parameter 'subcol_names' must have the same length of dimension ",
          "'subcol_dim'.")
  }
  # Check legend_dim
  if (!is.character(legend_dim)) {
    stop("Parameter 'legend_dim' must be a character string.")
  }
  if (!legend_dim %in% names(dim(data))) {
    stop("Parameter 'legend_dim' is not found in 'data' dimensions.")
  }
  # Check row_title
  if (is.null(row_title)) {
    row_title <- ""
  } else {
    if (!is.character(row_title)) {
      stop("Parameter 'row_title' must be a character string.")
    }
  }
  # Check subrow_title
  if (is.null(subrow_title)) {
    subrow_title <- ""
  } else {
    if (!is.character(subrow_title)) {
      stop("Parameter 'subrow_title' must be a character string.")
    }
  }
  # Check col_title
  if (is.null(col_title)) {
    col_title <- ""
  } else {
    if (!is.character(col_title)) {
      stop("Parameter 'col_title' must be a character string.")
    }
  }
  # Check table_title
  if (is.null(table_title)) {
    table_title <- ""
  } else {
    if (!is.character(table_title)) {
      stop("Parameter 'table_title' must be a character string.")
    }
  }
  # Check table_subtitle
  if (is.null(table_subtitle)) {
    table_subtitle <- ""
  } else {
    if (!is.character(table_subtitle)) {
      stop("Parameter 'table_subtitle' must be a character string.")
    }
  }
  # Check legend_breaks
  if (inherits(legend_breaks, 'list')) {
    if (!(length(legend_breaks) == as.numeric(dim(data)[legend_dim]))) {
      stop("Parameter 'legend_breaks' must be a list with the same number of ",
           "elements as the length of the 'legend_dim' dimension in data.")
    }
  } else if (is.numeric(legend_breaks)) {
    legend_breaks <- rep(list(legend_breaks), as.numeric(dim(data)[legend_dim]))
  } else if (is.null(legend_breaks)) {
    legend_breaks <- rep(list(seq(-1, 1, 0.2)), as.numeric(dim(data)[legend_dim]))
  } else {
    stop("Parameter 'legend_breaks' must be a numeric vector, a list or NULL.")
  }
  # Check plot_legend
  if (!inherits(plot_legend, 'logical')) {
    stop("Parameter 'plot_legend' must be a logical value.")
  }
  # Check label_scale
  if (any(!is.numeric(label_scale), length(label_scale) != 1)) {
    stop("Parameter 'label_scale' must be a numeric value of length 1.")
  }
  # Check legend_width
  if (is.null(legend_width)) {
    legend_width <- length(subcol_names) * 46.5
  } else if (any(!is.numeric(legend_width), length(legend_width) != 1)) {
    stop("Parameter 'legend_width' must be a numeric value of length 1.")
  }
  # Check legend_height
  if (any(!is.numeric(legend_height), length(legend_height) != 1)) {
    stop("Parameter 'legend_height' must be a numeric value of length 1.")
  }
  # Check colour palette input
  if (inherits(palette, 'list')) {
    if (!(length(palette) == as.numeric(dim(data)[legend_dim]))) {
      stop("Parameter 'palette' must be a list with the same number of ",
           "elements as the length of the 'legend_dim' dimension in data.")
    }
    if (!all(sapply(palette, is.character))) {
      stop("Parameter 'palette' must be a list of character vectors.")
    }
  } else if (is.character(palette)) {
    palette <- rep(list(palette), as.numeric(dim(data)[legend_dim]))
  } else if (is.null(palette)) {
    n <- length(legend_breaks[[1]])
    if (n == 1) { 
      stop("Parameter 'legend_breaks' can't be of length 1.")
    } else if (n == 2) {
      colors <- c('#B35806')
    } else if (n == 3) { 
      colors <- c('#8073AC', '#E08214')
    } else if (n == 11) {
      colors <- c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', 
                  '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08')
    } else if (n > 11) {
      stop("Parameter 'palette' must be provided when 'legend_breaks' ",
           "exceed the length of 11.")
    } else {
      colors <- rev(brewer.pal(n-1, "PuOr"))
    }
    palette <- rep(list(colors), as.numeric(dim(data)[legend_dim]))
  } else {
    stop("Parameter 'palette' must be a character vector, a list or NULL.")
  }
  # Check colorunder
  if (is.null(colorunder)) {
    colorunder <- rep("#04040E", as.numeric(dim(data)[legend_dim]))
  }
  if (length(colorunder) == 1) {
    colorunder <- rep(colorunder, as.numeric(dim(data)[legend_dim]))
  } 
  if (length(colorunder) != as.numeric(dim(data)[legend_dim])) {
    stop("Parameter 'colorunder' must be a character string vector or a list ", 
         "with the same number of elements as the length of the 'legend_dim' ",
         "dimension in data.")
  }
  if (!is.character(unlist(colorunder))) {
    stop("Parameter 'colorunder' must be a character string vector ", 
         "or a list of character string elements.")
  }
  # Check colorsup
  if (is.null(colorsup)) {
    colorsup <- rep("#730C04", as.numeric(dim(data)[legend_dim]))
  } 
  if (length(colorsup) == 1) {
    colorsup <- rep(colorsup, as.numeric(dim(data)[legend_dim]))
  } 
  if (length(colorsup) != as.numeric(dim(data)[legend_dim])) {
    stop("Parameter 'colorsup' must be a character string vector or a list ", 
         "with the same number of elements as the length of the 'legend_dim' ",
         "dimension in data.")
  }
  if (!is.character(unlist(colorsup))) {
    stop("Parameter 'colorsup' must be a character string vector ", 
         "or a list of character string elements.")
  }
  # Check round_decimal
  if (!is.numeric(round_decimal)) {
    stop("Parameter 'round_decimal' must be a numeric value of length 1.")
  }
  # Check font_size
  if (!is.numeric(font_size)) {
    stop("Parameter 'font_size' must be a numeric value of length 1.")
  }
  # Check legend white space
  if (!is.numeric(legend_white_space)) {
    stop("Parameter 'legend_white_space' must be a numeric value of length 1.")
  }
  # columns_width
  if (!is.numeric(columns_width)) {
    stop("Parameter 'columns_width' must be a numeric value.")
  }
  # Check col1_width
  if (is.null(col1_width)) {
    if (max(nchar(row_names)) == 1) {
      col1_width <- max(nchar(row_names))
    } else {
      col1_width <- max(nchar(row_names))/4
    }
  } else if (!is.numeric(col1_width)) {
    stop("Parameter 'col1_width' must be a numeric value of length 1.")
  }  
  # Check col2_width
  if (is.null(col2_width)) {
    if (max(nchar(subrow_names)) == 1 ) {
      col2_width <- max(nchar(subrow_names))
    } else {
      col2_width <- max(nchar(subrow_names))/4
    }
  } else if (!is.numeric(col2_width)) {
    stop("Parameter 'col2_width' must be a numeric value of length 1.")
  }
  
  # Get dimensions of inputs
  n_col_names <- length(col_names) 
  n_subcol_names <- length(subcol_names)
  n_row_names <- length(row_names)
  n_subrow_names <- length(subrow_names)
  
  # Define table size
  n_rows <- n_row_names * n_subrow_names 
  n_columns <- 2 + (n_col_names * n_subcol_names)
  
  # Column names
  row_names_table <- rep("", n_rows)
  for (row in 1:n_row_names) {
    row_names_table[floor(n_subrow_names/2) + (row - 1) * n_subrow_names] <- row_names[row]
  }
  
  # Define scorecard table titles
  column_titles <- c(row_title, subrow_title, rep(c(subcol_names), n_col_names))
  
  # Round data
  data <- round(data, round_decimal)
  
  # Define data inside the scorecards table
  for (row in 1:n_row_names) {
    table_temp <- data.frame(table_column_2 = as.character(subrow_names))
    for (col in 1:n_col_names) {
      table_temp <- data.frame(table_temp, 
                               Reorder(data = Subset(x = data, along = c(col_dim, row_dim), 
                                                     indices = list(col, row), drop = 'selected'), 
                               order = c(subrow_dim, subcol_dim)))
    }
    if (row == 1) {
      table_data <- table_temp
    } else {
      table_data <- rbind(table_data, table_temp)
    }
  }
  
  # All data for plotting in table
  table <- data.frame(table_column_1 = row_names_table, table_data)
  table_temp <- array(unlist(table[3:n_columns]), dim = c(n_rows, n_columns - 2))

  # Define colors to show in table
  table_colors  <- .ScorecardColors(table = table_temp, n_col = n_col_names, 
                                    n_subcol = n_subcol_names, n_row = n_row_names,
                                    n_subrow = n_subrow_names, legend_breaks = legend_breaks,
                                    palette = palette, colorunder = colorunder,
                                    colorsup = colorsup)
  metric_color <- table_colors$metric_color
  metric_text_color <- table_colors$metric_text_color
  # metric_text_bold <- table_colors$metric_text_bold

  # Remove temporary table
  rm(table_temp)

  # Format values to underline in table
  metric_underline <- MergeDims(sign, c(subcol_dim, col_dim), 
                                rename_dim = 'col', na.rm = FALSE)
  metric_underline <- MergeDims(metric_underline, c(subrow_dim, row_dim), 
                                rename_dim = 'row', na.rm = FALSE)
  metric_underline <- Reorder(metric_underline, c('row', 'col'))
  
  old_opts <- options()
  on.exit(options(old_opts), add = TRUE)

  options(stringsAsFactors = FALSE) 
  title <- data.frame(c1 = table_title, c2 = n_columns)
  subtitle <- data.frame(c1 = table_subtitle, c2 = n_columns)
  header_names <- as.data.frame(data.frame(c1 = c("", col_names), 
                                           c2 = c(2, rep(n_subcol_names, n_col_names))))
  header_names2 <- as.data.frame(data.frame(c1 = c("", paste0(rep(col_title, n_col_names))), 
                                            c2 = c(2, rep(n_subcol_names, n_col_names))))
  title_space <- data.frame(c1 = "\n", c2 = n_columns)
  
  # Hide NA values in table
  options(knitr.kable.NA = '')
  
  # Create HTML table
  table_html_part <- list()
  table_html_part[[1]] <- kbl(table, escape = F, col.names = column_titles, align = rep("c", n_columns)) %>%
                          kable_paper("hover", full_width = FALSE, font_size = 14 * font_size) %>%
                          add_header_above(header = header_names2, font_size = 16 * font_size) %>%
                          add_header_above(header = title_space, font_size = 10 * font_size) %>%
                          add_header_above(header = header_names, font_size = 20 * font_size) %>%
                          add_header_above(header = title_space, font_size = 10 * font_size) %>%
                          add_header_above(header = subtitle, font_size = 16 * font_size, align = "left") %>% 
                          add_header_above(header = title_space, font_size = 10 * font_size) %>%
                          add_header_above(header = title, font_size = 22 * font_size, align = "left")

  for (i in 1:n_col_names) { 
    for (j in 1:n_subcol_names) { 
      my_background <- metric_color[, (i - 1) * n_subcol_names + j]
      my_text_color <- metric_text_color[, (i - 1) * n_subcol_names + j]
      my_underline <- metric_underline[, (i - 1) * n_subcol_names + j]
      # my_bold <- metric_text_bold[(i - 1) * n_subcol_names + j]
      
      table_html_part[[(i - 1) * n_subcol_names + j + 1]] <-
        column_spec(table_html_part[[(i - 1) * n_subcol_names + j]], 
                    2 + n_subcol_names * (i - 1) + j, 
                    background = my_background[1:n_rows], 
                    color = my_text_color[1:n_rows], 
                    underline = my_underline[1:n_rows],
                    bold = T) # strsplit(toString(bold), ', ')[[1]]
    }
  }

  # Define position of table borders
  column_borders <- NULL
  for (i in 1:n_col_names) {
    column_spacing <- (n_subcol_names * i) + 2
    column_borders <- c(column_borders, column_spacing)
  }
  
  n_last_list <- n_col_names * n_subcol_names + 1

  table_html <- column_spec(table_html_part[[n_last_list]], 1, bold = TRUE, 
                            width_min = paste0(col1_width, 'cm')) %>%
                column_spec(2, bold = TRUE,  width_min = paste0(col2_width, 'cm')) %>%
                column_spec(3:n_columns, width_min = paste0(columns_width, 'cm')) %>% 
                column_spec(c(1, 2, column_borders), border_right = "2px solid black") %>% 
                column_spec(1, border_left = "2px solid black") %>%
                column_spec(n_columns, border_right = "2px solid black") %>%
                row_spec(seq(from = 0, to = n_subrow_names * n_row_names, by = n_subrow_names), 
                         extra_css = "border-bottom: 2px solid black", hline_after = TRUE)
  if (plot_legend == TRUE) {
    # Save the scorecard (without legend)
    save_kable(table_html, file = paste0(fileout, '_tmpScorecard.png'), vheight = 1)
    
    # White space for legend
    legend_white_space <- 37.8 * legend_white_space # converting pixels to cm
    
    # Create and save color bar legend
    .ScorecardLegend(legend_breaks = legend_breaks,
                     palette = palette,
                     colorunder = colorunder,
                     colorsup = colorsup,
                     label_scale = label_scale,
                     legend_width = legend_width,
                     legend_height = legend_height,
                     legend_white_space = legend_white_space,
                     fileout = fileout)
    
    # Add the legends below the scorecard table 
    system(paste0('convert -append ', fileout, '_tmpScorecard.png ', fileout, 
                  '_tmpScorecardLegend.png ', fileout))
    # Remove temporary scorecard table
    unlink(paste0(fileout, '_tmpScorecard*.png'))
  }
  if (plot_legend == FALSE) {
    save_kable(table_html, file = fileout)
  } 
}

# Scorecards function to assign background color of table cells, 
# color of text in table and to bold the text.
#
# It will return a list  with 2 arrays: 
# (1) metric_color, A 2-dimensional array with character strings containing the 
# color codes for each cell background.
# (2) metric_text_color, A 2-dimensional array with character strings 
# containing the color codes for each cell text.
.ScorecardColors <- function(table, n_col, n_subcol, n_row, n_subrow, 
                             legend_breaks, palette, colorunder, colorsup) {
  # Define rows and columns
  n_rows <- n_row * n_subrow
  n_columns <- n_col * n_subcol

  # Set table background colors
  metric_color <- array(colorunder, c(n_row * n_subrow, n_columns)) 
  metric_text_color <- array("#2A2A2A", c(n_row * n_subrow , n_columns)) 
  # metric_text_bold <- array(TRUE, c(n_row * n_subrow , n_columns - 2)) # Setting all values to bold
  
  # Define cell and text colors to show in table
  for (i in 1:n_col) {
    metric_int <- legend_breaks[[i]]
    for (rr in 1:n_rows) {
      for (j in 1:n_subcol) {
        for (pp in 1:(length(metric_int) - 1)) {
          if (is.na(table[rr, ((i - 1) * n_subcol + j)])) {
            metric_color[rr, ((i - 1) * n_subcol + j)] <- "gray"
          } else {
            if (table[rr, ((i - 1) * n_subcol + j)] >= 
                metric_int[pp] && table[rr, ((i - 1) * n_subcol + j)] <= 
                metric_int[pp + 1]) {
              metric_color[rr, ((i - 1) * n_subcol + j)] <- palette[[i]][pp] # palette[pp]
            } 
            if (table[rr, ((i - 1) * n_subcol + j)] < metric_int[1]) {
              metric_color[rr, ((i - 1) * n_subcol + j)] <- colorunder[i]
            }
            if (table[rr,((i - 1) * n_subcol + j)] >= 
                metric_int[length(metric_int)]) {
              metric_color[rr, ((i - 1) * n_subcol + j)] <- colorsup[i]
            } 
          }
          # color text in white and bold if background is white or dark blue or dark red:
          if (is.na(table[rr, ((i - 1) * n_subcol + j)]) ||
              (!is.na(table[rr, ((i - 1) * n_subcol + j)]) && pp == 1 && 
                      table[rr, ((i - 1) * n_subcol + j)] < metric_int[2]) ||
              (!is.na(table[rr, ((i - 1) * n_subcol + j)]) && pp == 2 && 
                      table[rr, ((i - 1) * n_subcol + j)] < metric_int[3]) ||
              (!is.na(table[rr, ((i - 1) * n_subcol + j)]) && pp == (length(metric_int) - 1) && 
                      table[rr, ((i - 1) * n_subcol + j)] >= metric_int[length(metric_int) - 1]) ||
              (!is.na(table[rr, ((i - 1) * n_subcol + j)]) && pp == (length(metric_int) - 2) && 
                      table[rr, ((i - 1) * n_subcol + j)] >= metric_int[length(metric_int) - 2])) {
            metric_text_color[rr, ((i - 1) * n_subcol + j)] <- "white"
            # metric_text_bold[rr,((i - 1) * n_subcol + j)] <- TRUE
          }
        }
      }
    }
  }
  return(list(metric_color = metric_color, 
              metric_text_color = metric_text_color))
}

# Scorecards function to create the color bar legends for the required metrics
# and paste them below the scorecard table
.ScorecardLegend <- function(legend_breaks, palette, colorunder, colorsup,
                             label_scale, legend_width, legend_height,
                             legend_white_space, fileout) {

  # Create color bar legends for each metric
  for (i in 1:length(palette)) {
    png(filename = paste0(fileout, '_tmpLegend', i, '.png'), width = legend_width, 
        height = legend_height) 
    ColorBarContinuous(brks = legend_breaks[[i]], cols = palette[[i]], vertical = FALSE, 
                       label_scale = label_scale, col_inf = colorunder[[i]], 
                       col_sup = colorsup[[i]]) 
    dev.off()
    if (i == 1) {
      # Add white space to the left of the first color bar legend
      system(paste0('convert ', fileout, '_tmpLegend1.png -background white -splice ', 
                    legend_white_space, 'x0 ', fileout, '_tmpScorecardLegend.png'))
    } else {
      system(paste0('convert +append ', fileout, '_tmpScorecardLegend.png ',
                    fileout, '_tmpLegend', i, '.png ', fileout, 
                    '_tmpScorecardLegend.png'))
    }
  }
  unlink(c(paste0(fileout, '_tmpLegend*.png'), '_tmpScorecard.png'))
}