#'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 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 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 indicating the label scale of the legend 
#'  values. 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 or of vector of character strings 
#'  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 or of vector of character strings 
#'  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. It 
#'  is set as 1.1 by default.
#'@param legend_white_space A numeric value indicating the white space width at 
#'  the left side of the legend. The default value is 6.
#'@param col1_width A numeric value indicating the width of the column header. 
#'  It is set as NULL by default.
#'@param col2_width A numeric value indicating the width of the subcolumn 
#'  header. 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')
#'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)", 
#'             fileout = 'test.png')
#'
#'@import kableExtra
#'@importFrom s2dv Reorder
#'@importFrom ClimProjDiags Subset
#'@export
VizScorecard <- function(data, 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, 
                         col1_width = NULL, col2_width = NULL,
                         fileout = './scorecard.png') {

  # 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.")
  }
  ## 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 {
      stop("Parameter 'palette' must be provided when 'legend_breaks' ",
           "exceed the length of 11.")
    }
    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 (!is.character(colorunder)) {
    stop("Parameter 'colorunder' must be a character string vector.")
  }
  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 list with the same number of ",
         "elements as the length of the 'legend_dim' dimension in data.")
  }
  ## Check colorsup
  if (is.null(colorsup)) {
    colorsup <- rep("#730C04", as.numeric(dim(data)[legend_dim]))
  } 
  if (!is.character(colorsup)) {
    stop("Parameter 'colorsup' must be a character string vector.")
  }
  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 list with the same number of ",
         "elements as the length of the 'legend_dim' dimension in data.")
  }
  ## 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.")
  }
  ## 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
  
  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 = T, 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.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], 
                    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 = "1.5cm") %>% 
                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 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(paste0(fileout,'_tmpLegend*.png'))
}

# 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))
}