Skip to content
GitLab
Commits (6)
Hide whitespace changes
Inline Side-by-side
NAMESPACE
View file @ 89aef5bd
......@@ -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
View file @ 89aef5bd
......@@ -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
View file @ 89aef5bd
......@@ -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
View file @ 89aef5bd
......@@ -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
......