NAMESPACE

@@ -29,6 +29,7 @@ import(rnaturalearth)
 import(sf)
 import(stats)
 import(utils)
+importFrom(CSTools,MergeDims)
 importFrom(CSTools,SplitDim)
 importFrom(ClimProjDiags,Subset)
 importFrom(RColorBrewer,brewer.pal)

R/VizScorecard.R

@@ -10,6 +10,9 @@
 #'@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 
@@ -44,8 +47,8 @@
 #'  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 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. 
@@ -56,28 +59,33 @@
 #'  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 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. 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 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.
 #' 
@@ -96,41 +104,58 @@
 #'             fileout = 'test.png')
 #'
 #'@import kableExtra
+#'@importFrom RColorBrewer brewer.pal
 #'@importFrom s2dv Reorder
 #'@importFrom ClimProjDiags Subset
+#'@importFrom CSTools MergeDims
 #'@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,
+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, 
+                         legend_white_space = 6, columns_width = 1.2, 
                          col1_width = NULL, col2_width = NULL,
                          fileout = './scorecard.png') {
 
   # Input parameter checks
-  ## Check data
+  # 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
+  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
+  # Check row_names
   if (is.null(row_names)) {
     row_names <- as.character(1:dim(data)[row_dim])
   }
@@ -138,14 +163,14 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
     stop("Parameter 'row_names' must have the same length of dimension ",
          "'row_dim'.")
   }
-  ## Check subrow_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
+  # Check subrow_names
   if (is.null(subrow_names)) {
     subrow_names <- as.character(1:dim(data)[subrow_dim])
   }
@@ -153,14 +178,14 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
     stop("Parameter 'subrow_names' must have the same length of dimension ",
          "'subrow_dim'.")
   }
-  ## Check col_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
+  # Check col_names
   if (is.null(col_names)) {
     col_names <- as.character(1:dim(data)[col_dim])
   }
@@ -168,14 +193,14 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
     stop("Parameter 'col_names' must have the same length of dimension ",
          "'col_dim'.")
   }
-  ## Check subcol_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
+  # Check subcol_names
   if (is.null(subcol_names)) {
     subcol_names <- as.character(1:dim(data)[subcol_dim])
   }
@@ -183,14 +208,14 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
     stop("Parameter 'subcol_names' must have the same length of dimension ",
           "'subcol_dim'.")
   }
-  ## Check legend_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
+  # Check row_title
   if (is.null(row_title)) {
     row_title <- ""
   } else {
@@ -198,7 +223,7 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
       stop("Parameter 'row_title' must be a character string.")
     }
   }
-  ## Check subrow_title
+  # Check subrow_title
   if (is.null(subrow_title)) {
     subrow_title <- ""
   } else {
@@ -206,7 +231,7 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
       stop("Parameter 'subrow_title' must be a character string.")
     }
   }
-  ## Check col_title
+  # Check col_title
   if (is.null(col_title)) {
     col_title <- ""
   } else {
@@ -214,7 +239,7 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
       stop("Parameter 'col_title' must be a character string.")
     }
   }
-  ## Check table_title
+  # Check table_title
   if (is.null(table_title)) {
     table_title <- ""
   } else {
@@ -222,7 +247,7 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
       stop("Parameter 'table_title' must be a character string.")
     }
   }
-  ## Check table_subtitle
+  # Check table_subtitle
   if (is.null(table_subtitle)) {
     table_subtitle <- ""
   } else {
@@ -243,25 +268,25 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
   } else {
     stop("Parameter 'legend_breaks' must be a numeric vector, a list or NULL.")
   }
-  ## Check plot_legend
+  # Check plot_legend
   if (!inherits(plot_legend, 'logical')) {
     stop("Parameter 'plot_legend' must be a logical value.")
   }
-  ## Check label_scale
+  # 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
+  # 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
+  # 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
+  # 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 ",
@@ -283,55 +308,65 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
     } else if (n == 11) {
       colors <- c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', 
                   '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08')
-    } else {
+    } 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
+  # 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.")
+    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.")
   }
-  ## Check colorsup
+  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 (!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.")
+    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.")
   }
-  ## Check round_decimal
+  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
+  # Check font_size
   if (!is.numeric(font_size)) {
     stop("Parameter 'font_size' must be a numeric value of length 1.")
   }
-  ## Check legend white space
+  # 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
+  # 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))
@@ -341,7 +376,7 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
   } else if (!is.numeric(col1_width)) {
     stop("Parameter 'col1_width' must be a numeric value of length 1.")
   }  
-  ## Check col2_width
+  # Check col2_width
   if (is.null(col2_width)) {
     if (max(nchar(subrow_names)) == 1 ) {
       col2_width <- max(nchar(subrow_names))
@@ -353,31 +388,31 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
   }
   
   # 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)
+  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)
+  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]
+  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))
+  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) {
+  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) {
+    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'), 
@@ -391,80 +426,94 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
   }
   
   # 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))
+  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,
+  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
-  
+  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'))
+
   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)
+  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) %>%
+  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_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]
+
+  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], 
-                    bold = T) ## strsplit(toString(bold), ', ')[[1]]
+      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)
+  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
+  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')) %>%
+  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(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), 
+                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)
+    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
+    legend_white_space <- 37.8 * legend_white_space # converting pixels to cm
     
     # Create and save color bar legend
     .ScorecardLegend(legend_breaks = legend_breaks,
@@ -484,17 +533,79 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
     unlink(paste0(fileout, '_tmpScorecard*.png'))
   }
   if (plot_legend == FALSE) {
-    save_kable(table.html, file = fileout)
+    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
+
+  # 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) 
@@ -503,7 +614,7 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
                        col_sup = colorsup[[i]]) 
     dev.off()
     if (i == 1) {
-      ## Add white space to the left of the first color bar legend
+      # 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 {
@@ -514,65 +625,3 @@ VizScorecard <- function(data, row_dim = 'region', subrow_dim = 'time',
   }
   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))
-}
\ No newline at end of file

man/VizScorecard.Rd

@@ -6,6 +6,7 @@
 \usage{
 VizScorecard(
   data,
+  sign = NULL,
   row_dim = "region",
   subrow_dim = "time",
   col_dim = "metric",
@@ -31,6 +32,7 @@ VizScorecard(
   round_decimal = 2,
   font_size = 1.1,
   legend_white_space = 6,
+  columns_width = 1.2,
   col1_width = NULL,
   col2_width = NULL,
   fileout = "./scorecard.png"
@@ -41,6 +43,10 @@ VizScorecard(
 at least four dimensions. Each dimension will have assigned a structure 
 element: row, subrow, column and subcolumn.}
 
+\item{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.}
+
 \item{row_dim}{A character string indicating the dimension name to show in the 
 rows of the plot. It is set as 'region' by default.}
 
@@ -90,8 +96,8 @@ colors in the scorecard table. It is set as NULL by default.}
 \item{plot_legend}{A logical value to determine if the legend is plotted. It 
 is set as TRUE by default.}
 
-\item{label_scale}{A numeric value indicating the label scale of the legend 
-values. It is set as 1.4 by default.}
+\item{label_scale}{A numeric value to define the size of the legend labels. 
+It is set as 1.4 by default.}
 
 \item{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.}
@@ -106,34 +112,40 @@ 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.}
 
-\item{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.}
-
-\item{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.}
+\item{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.}
+
+\item{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.}
 
 \item{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.}
 
-\item{font_size}{A numeric indicating the font size on the scorecard table. It 
-is set as 1.1 by default.}
+\item{font_size}{A numeric indicating the font size on the scorecard table. 
+Default is 2.}
 
-\item{legend_white_space}{A numeric value indicating the white space width at 
-the left side of the legend. The default value is 6.}
+\item{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.}
 
-\item{col1_width}{A numeric value indicating the width of the column header. 
-It is set as NULL by default.}
+\item{columns_width}{A numeric value defining the width all columns within the 
+table in cm (excluding the first and second columns containing the titles).}
+
+\item{col1_width}{A numeric value defining the width of the first table column
+in cm. It is set as NULL by default.}
 
-\item{col2_width}{A numeric value indicating the width of the subcolumn 
-header. It is set as NULL by default.}
+\item{col2_width}{A numeric value defining the width of the second table 
+column in cm. It is set as NULL by default.}
 
 \item{fileout}{A path of the location to save the scorecard plots. By default 
 the plots will be saved to the working directory.}

tests/testthat/test-VizScorecard.R

@@ -9,6 +9,10 @@ data <- array(rnorm(1000), dim = c('sdate' = 12, 'metric' = 4, 'region' = 3,
 row_names <- c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH')
 col_names <- c('Mean bias (K)', 'Correlation', 'RPSS','CRPSS')
 
+vals <- c(rep(T, 200), rep(F, 300), T, F, rep(T, 200), rep(F, 162))
+sign <- array(vals, dim = c('sdate' = 12, 'metric' = 4, 'region' = 3, 
+                            'time' = 6)) 
+
 #--------------------------------------------------------------------
 test_that("1. Test input", {
   # Check data
@@ -16,6 +20,19 @@ test_that("1. Test input", {
     VizScorecard('a'),
     "Parameter 'data' must be a numeric array."
   )
+  # check sign
+  expect_error(
+    VizScorecard(data = data, sign = 1, plot_legend = TRUE),
+    "Parameter 'sign' must be a boolean array or NULL."
+  )
+  expect_error(
+    VizScorecard(data, sign = array(c(T, T, F), dim = c(a = 10, b = 2))),
+    "Parameter 'sign' must have same dimensions as 'data'."
+  )
+  expect_error(
+    VizScorecard(data, sign = array(c(T, 1, F), dim = dim(data))),
+    "Parameter 'sign' must be an array with logical values."
+  )
   # Check row_dim
   expect_error(
     VizScorecard(data, row_dim = 1),
@@ -176,24 +193,50 @@ test_that("1. Test input", {
     "Parameter 'palette' must be a character vector, a list or NULL."
   )
   # Check colorunder
+  expect_error(
+    VizScorecard(data, colorunder = c(1:3)),
+    paste0("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.")
+  )
+  expect_error(
+    VizScorecard(data, colorunder = list('a', NULL, 'c')),
+    paste0("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.")
+  )
   expect_error(
     VizScorecard(data, colorunder = 1),
-    "Parameter 'colorunder' must be a character string vector."
+    paste0("Parameter 'colorunder' must be a character string vector or a ",
+           "list of character string elements.")
   )
   expect_error(
-    VizScorecard(data, colorunder = rep('a', 5)),
-    paste0("Parameter 'colorunder' must be a list with the same number of ",
-           "elements as the length of the 'legend_dim' dimension in data.")
+    VizScorecard(data, colorunder = list(1)),
+    paste0("Parameter 'colorunder' must be a character string vector or a ",
+           "list of character string elements.")
   )
   # Check colorsup
+  expect_error(
+    VizScorecard(data, colorsup = c(1:3)),
+    paste0("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.")
+  )
+  expect_error(
+    VizScorecard(data, colorsup = list('a', NULL, 'c')),
+    paste0("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.")
+  )
   expect_error(
     VizScorecard(data, colorsup = 1),
-    "Parameter 'colorsup' must be a character string vector."
+    paste0("Parameter 'colorsup' must be a character string vector or a ",
+           "list of character string elements.")
   )
   expect_error(
-    VizScorecard(data, colorsup = rep('a', 5)),
-    paste0("Parameter 'colorsup' must be a list with the same number of ",
-           "elements as the length of the 'legend_dim' dimension in data.")
+    VizScorecard(data, colorsup = list(1)),
+    paste0("Parameter 'colorsup' must be a character string vector or a ",
+           "list of character string elements.")
   )
   # Check round_decimal
   expect_error(
@@ -210,6 +253,10 @@ test_that("1. Test input", {
     VizScorecard(data, legend_white_space = 'a'),
     "Parameter 'legend_white_space' must be a numeric value of length 1."
   )
+  expect_error(
+    VizScorecard(data, columns_width = 'a'),
+    "Parameter 'columns_width' must be a numeric value."
+  )
   # Check col1_width
   expect_error(
     VizScorecard(data, col1_width = 'a'),
@@ -226,7 +273,7 @@ test_that("1. Test input", {
 
 
 #-------------------------------------------------------------------
-# NOTE: A change is detected by expect_snapshot_file but I haven't found the difference
+# NOTE: A change is detected by expect_snapshot_file but there is no difference
 
 # # Simple example
 # # Example with random data