From ef04a41552b3b4f9d33500410875b17c326ef470 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 16 Sep 2022 18:39:32 +0200 Subject: [PATCH 1/9] Development for plotting with PlotLayout. Colorbar is not common. --- R/PlotCombinedMap.R | 28 +++++++++++++++++++--------- R/PlotMostLikelyQuantileMap.R | 4 ++-- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index 8af4a14d..3be84449 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -71,6 +71,7 @@ PlotCombinedMap <- function(maps, lon, lat, dots = NULL, bar_titles = NULL, legend_scale = 1, cex_bar_titles = 1.5, + plot_margin = NULL, bar_margin = rep(0, 4), fileout = NULL, width = 8, height = 5, size_units = 'in', res = 100, ...) { @@ -360,10 +361,13 @@ PlotCombinedMap <- function(maps, lon, lat, } else if (names(dev.cur()) == 'null device') { dev.new(units = size_units, res = res, width = width, height = height) } - plot.new() + if (all(par()$mfrow == c(1, 1))) { #original, no PlotLayout + plot.new() + layout(matrix(c(rep(1, nmap),2:(nmap + 1)), 2, nmap, byrow = TRUE), heights = c(6, 1.5)) + } + par(font.main = 1) - layout(matrix(c(rep(1, nmap),2:(nmap + 1)), 2, nmap, byrow = TRUE), heights = c(6, 1.5)) - + #---------------------- # Set colors and breaks and then PlotEquiMap #---------------------- @@ -373,9 +377,14 @@ PlotCombinedMap <- function(maps, lon, lat, } tbrks <- c(-1, brks_norm + rep(1:nmap, each = length(brks))) + + if (is.null(plot_margin)) { + plot_margin <- c(5, 4, 4, 2) + 0.1 # default of par()$mar + } + PlotEquiMap(var = ml_map, lon = lon, lat = lat, brks = tbrks, cols = tcols, drawleg = FALSE, - filled.continents = FALSE, dots = dots, ...) + filled.continents = FALSE, dots = dots, mar = plot_margin, ...) #---------------------- # Add overplot on top @@ -419,13 +428,14 @@ PlotCombinedMap <- function(maps, lon, lat, old_mar[3] <- old_mar[3] - (2 * size_title + 1) par(mar = old_mar) } + + #NOTE: Should be not necessary. In ColorBar, margin is reset. + par(mar = bar_margin) for (k in 1:nmap){ ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, - draw_separators = TRUE, extra_margin = c(2, 0, 2, 0), - label_scale = legend_scale * 1.5) - if (!is.null(bar_titles)) { - mtext(bar_titles[[k]], 3, line = -3, cex = cex_bar_titles) - } + draw_separators = TRUE, extra_margin = bar_margin, + title = bar_titles[[k]], title_scale = cex_bar_titles, + label_scale = legend_scale) } # If the graphic was saved to file, close the connection with the device diff --git a/R/PlotMostLikelyQuantileMap.R b/R/PlotMostLikelyQuantileMap.R index b4e974a8..aee538ff 100644 --- a/R/PlotMostLikelyQuantileMap.R +++ b/R/PlotMostLikelyQuantileMap.R @@ -101,7 +101,7 @@ #' #'@export PlotMostLikelyQuantileMap <- function(probs, lon, lat, cat_dim = 'bin', - bar_titles = NULL, + bar_titles = NULL, plot_margin = NULL, bar_margin = rep(0, 4), col_unknown_cat = 'white', ...) { # Check probs @@ -184,6 +184,6 @@ PlotMostLikelyQuantileMap <- function(probs, lon, lat, cat_dim = 'bin', PlotCombinedMap(probs * 100, lon, lat, map_select_fun = max, display_range = c(minimum_value, 100), map_dim = cat_dim, - bar_titles = bar_titles, + bar_titles = bar_titles, plot_margin = plot_margin, bar_margin = bar_margin, col_unknown_map = col_unknown_cat, ...) } -- GitLab From 3c004cf52e9cfd0a75925466a4ae08005a848680 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 20 Sep 2022 12:03:44 +0200 Subject: [PATCH 2/9] PlotMostLikelyQuantileMap works with PlotLayout (only drawleg = 'S'); colorbar is shared. --- DESCRIPTION | 2 +- R/PlotCombinedMap.R | 124 +++++++++++++++++++++++++++---- R/PlotMostLikelyQuantileMap.R | 15 +++- man/PlotCombinedMap.Rd | 10 +++ man/PlotMostLikelyQuantileMap.Rd | 8 ++ man/s2dv_cube.Rd | 35 ++++++--- 6 files changed, 165 insertions(+), 29 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 454397ae..5b1ac599 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -86,4 +86,4 @@ VignetteBuilder: knitr License: Apache License 2.0 Encoding: UTF-8 LazyData: true -RoxygenNote: 7.0.2 +RoxygenNote: 7.2.0 diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index 3be84449..a7b5fc97 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -27,7 +27,13 @@ #'@param width File width, in the units specified in the parameter size_units (inches by default). Takes 8 by default. #'@param height File height, in the units specified in the parameter size_units (inches by default). Takes 5 by default. #'@param size_units Units of the size of the device (file or window) to plot in. Inches ('in') by default. See ?Devices and the creator function of the corresponding device. -#'@param res Resolution of the device (file or window) to plot in. See ?Devices and the creator function of the corresponding device. +#'@param res Resolution of the device (file or window) to plot in. See ?Devices and the creator function of the corresponding device. +#'@param drawleg Where to draw the common colour bar. Can take values TRUE, +#' FALSE or:\cr +#' 'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr +#' 'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr +#' 'right', 'r', 'R', 'east', 'e', 'E'\cr +#' 'left', 'l', 'L', 'west', 'w', 'W' #'@param ... Additional parameters to be passed on to \code{PlotEquiMap}. #'@seealso \code{PlotCombinedMap} and \code{PlotEquiMap} @@ -73,7 +79,7 @@ PlotCombinedMap <- function(maps, lon, lat, cex_bar_titles = 1.5, plot_margin = NULL, bar_margin = rep(0, 4), fileout = NULL, width = 8, height = 5, - size_units = 'in', res = 100, + size_units = 'in', res = 100, drawleg = T, ...) { args <- list(...) @@ -361,13 +367,14 @@ PlotCombinedMap <- function(maps, lon, lat, } else if (names(dev.cur()) == 'null device') { dev.new(units = size_units, res = res, width = width, height = height) } - if (all(par()$mfrow == c(1, 1))) { #original, no PlotLayout - plot.new() + #NOTE: I think plot.new() is not necessary in any case. +# plot.new() + par(font.main = 1) + # If colorbars need to be plotted, re-define layout. + if (drawleg) { layout(matrix(c(rep(1, nmap),2:(nmap + 1)), 2, nmap, byrow = TRUE), heights = c(6, 1.5)) } - par(font.main = 1) - #---------------------- # Set colors and breaks and then PlotEquiMap #---------------------- @@ -429,21 +436,108 @@ PlotCombinedMap <- function(maps, lon, lat, par(mar = old_mar) } - #NOTE: Should be not necessary. In ColorBar, margin is reset. - par(mar = bar_margin) - for (k in 1:nmap){ - ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, - draw_separators = TRUE, extra_margin = bar_margin, - title = bar_titles[[k]], title_scale = cex_bar_titles, - label_scale = legend_scale) + if (drawleg) { + for (k in 1:nmap) { + ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, + draw_separators = TRUE, extra_margin = c(2, 0, 2, 0), + label_scale = legend_scale * 1.5) + if (!is.null(bar_titles)) { + mtext(bar_titles[[k]], 3, line = -3, cex = cex_bar_titles) + } + #TODO: Change to below code. Plot title together. extra_margin needs to be adjusted. +# ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, +# draw_separators = TRUE, extra_margin = c(1, 0, 1, 0), +# label_scale = legend_scale * 1.5, title = bar_titles[[k]], title_scale = cex_bar_titles) + } } # If the graphic was saved to file, close the connection with the device if (!is.null(fileout)) dev.off() } -# Once PlotCombined is included in s2dverification and removed from -# CSTools, this function will be removed from CSTools too. +# Color bar for PlotMostLikelyQuantileMap +multi_ColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits = NULL, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, + draw_separators = FALSE, + bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + ...) { + + minimum_value <- ceiling(1 / nmap * 10 * 1.1) * 10 + display_range = c(minimum_value, 100) + + # Check brks + if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { + num_brks <- 5 + if (is.numeric(brks)) { + num_brks <- brks + } + brks <- seq(from = display_range[1], to = display_range[2], length.out = num_brks) + } + if (!is.numeric(brks)) { + stop("Parameter 'brks' must be a numeric vector.") + } + # Check cols + col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), + c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), + c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), + c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), + c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) + if (is.null(cols)) { + if (length(col_sets) >= nmap) { + chosen_sets <- 1:nmap + chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) + } else { + chosen_sets <- array(1:length(col_sets), nmap) + } + cols <- col_sets[chosen_sets] + } else { + if (!is.list(cols)) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (!all(sapply(cols, is.character))) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (length(cols) != dim(maps)[map_dim]) { + stop("Parameter 'cols' must be a list of the same length as the number of ", + "maps in 'maps'.") + } + } + for (i in 1:length(cols)) { + if (length(cols[[i]]) != (length(brks) - 1)) { + cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) + } + } + + # Check bar_titles + if (is.null(bar_titles)) { + if (nmap == 3) { + bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)") + } else if (nmap == 5) { + bar_titles <- c("Low (%)", "Below normal (%)", + "Normal (%)", "Above normal (%)", "High (%)") + } else { + bar_titles <- paste0("Cat. ", 1:nmap, " (%)") + } + } + + if (plot) { + for (k in 1:nmap) { + s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, + bar_limits = bar_limits, var_limits = var_limits, + triangle_ends = triangle_ends, plot = TRUE, + draw_separators = draw_separators, + title = bar_titles[[k]], title_scale = title_scale, + label_scale = label_scale, extra_margin = extra_margin) + } + } else { + #TODO: col_inf and col_sup + return(list(brks = brks, cols = cols)) + } + +} + +#TODO: use s2dv:::.SelectDevice and remove this function here? .SelectDevice <- function(fileout, width, height, units, res) { # This function is used in the plot functions to check the extension of the # files where the graphics will be stored and select the right R device to diff --git a/R/PlotMostLikelyQuantileMap.R b/R/PlotMostLikelyQuantileMap.R index aee538ff..9f9f1914 100644 --- a/R/PlotMostLikelyQuantileMap.R +++ b/R/PlotMostLikelyQuantileMap.R @@ -9,6 +9,12 @@ #'@param cat_dim the name of the dimension along which the different categories are stored in \code{probs}. This only applies if \code{probs} is provided in the form of 3-dimensional array. The default expected name is 'bin'. #'@param bar_titles vector of character strings with the names to be drawn on top of the color bar for each of the categories. As many titles as categories provided in \code{probs} must be provided. #'@param col_unknown_cat character string with a colour representation of the colour to be used to paint the cells for which no category can be clearly assigned. Takes the value 'white' by default. +#'@param drawleg Where to draw the common colour bar. Can take values TRUE, +#' FALSE or:\cr +#' 'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr +#' 'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr +#' 'right', 'r', 'R', 'east', 'e', 'E'\cr +#' 'left', 'l', 'L', 'west', 'w', 'W' #'@param ... additional parameters to be sent to \code{PlotCombinedMap} and \code{PlotEquiMap}. #'@seealso \code{PlotCombinedMap} and \code{PlotEquiMap} #' @@ -101,8 +107,8 @@ #' #'@export PlotMostLikelyQuantileMap <- function(probs, lon, lat, cat_dim = 'bin', - bar_titles = NULL, plot_margin = NULL, bar_margin = rep(0, 4), - col_unknown_cat = 'white', + bar_titles = NULL, + col_unknown_cat = 'white', drawleg = T, ...) { # Check probs error <- FALSE @@ -184,6 +190,7 @@ PlotMostLikelyQuantileMap <- function(probs, lon, lat, cat_dim = 'bin', PlotCombinedMap(probs * 100, lon, lat, map_select_fun = max, display_range = c(minimum_value, 100), map_dim = cat_dim, - bar_titles = bar_titles, plot_margin = plot_margin, bar_margin = bar_margin, - col_unknown_map = col_unknown_cat, ...) + bar_titles = bar_titles, + col_unknown_map = col_unknown_cat, + drawleg = drawleg, ...) } diff --git a/man/PlotCombinedMap.Rd b/man/PlotCombinedMap.Rd index 3d6661e1..6a222b0b 100644 --- a/man/PlotCombinedMap.Rd +++ b/man/PlotCombinedMap.Rd @@ -20,11 +20,14 @@ PlotCombinedMap( bar_titles = NULL, legend_scale = 1, cex_bar_titles = 1.5, + plot_margin = NULL, + bar_margin = rep(0, 4), fileout = NULL, width = 8, height = 5, size_units = "in", res = 100, + drawleg = T, ... ) } @@ -74,6 +77,13 @@ layers via the parameter 'dot_symbol'.} \item{res}{Resolution of the device (file or window) to plot in. See ?Devices and the creator function of the corresponding device.} +\item{drawleg}{Where to draw the common colour bar. Can take values TRUE, +FALSE or:\cr +'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr +'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr +'right', 'r', 'R', 'east', 'e', 'E'\cr +'left', 'l', 'L', 'west', 'w', 'W'} + \item{...}{Additional parameters to be passed on to \code{PlotEquiMap}.} } \description{ diff --git a/man/PlotMostLikelyQuantileMap.Rd b/man/PlotMostLikelyQuantileMap.Rd index 4c400b18..ba111d50 100644 --- a/man/PlotMostLikelyQuantileMap.Rd +++ b/man/PlotMostLikelyQuantileMap.Rd @@ -11,6 +11,7 @@ PlotMostLikelyQuantileMap( cat_dim = "bin", bar_titles = NULL, col_unknown_cat = "white", + drawleg = T, ... ) } @@ -27,6 +28,13 @@ PlotMostLikelyQuantileMap( \item{col_unknown_cat}{character string with a colour representation of the colour to be used to paint the cells for which no category can be clearly assigned. Takes the value 'white' by default.} +\item{drawleg}{Where to draw the common colour bar. Can take values TRUE, +FALSE or:\cr +'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr +'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr +'right', 'r', 'R', 'east', 'e', 'E'\cr +'left', 'l', 'L', 'west', 'w', 'W'} + \item{...}{additional parameters to be sent to \code{PlotCombinedMap} and \code{PlotEquiMap}.} } \description{ diff --git a/man/s2dv_cube.Rd b/man/s2dv_cube.Rd index 8ac06d78..2b1923c9 100644 --- a/man/s2dv_cube.Rd +++ b/man/s2dv_cube.Rd @@ -17,23 +17,40 @@ s2dv_cube( ) } \arguments{ -\item{data}{an array with any number of named dimensions, typically an object output from CST_Load, with the following dimensions: dataset, member, sdate, ftime, lat and lon.} +\item{data}{an array with any number of named dimensions, typically an object +output from CST_Load, with the following dimensions: dataset, member, sdate, +ftime, lat and lon.} -\item{lon}{an array with one dimension containing the longitudes and attributes: dim, cdo_grid_name, data_across_gw, array_across_gw, first_lon, last_lon and projection.} +\item{lon}{an array with one dimension containing the longitudes and +attributes: dim, cdo_grid_name, data_across_gw, array_across_gw, first_lon, +last_lon and projection.} -\item{lat}{an array with one dimension containing the latitudes and attributes: dim, cdo_grid_name, first_lat, last_lat and projection.} +\item{lat}{an array with one dimension containing the latitudes and +attributes: dim, cdo_grid_name, first_lat, last_lat and projection.} -\item{Variable}{a list of two elements: \code{varName} a character string indicating the abbreviation of a variable name and \code{level} a character string indicating the level (e.g., "2m"), if it is not required it could be set as NULL.} +\item{Variable}{a list of two elements: \code{varName} a character string +indicating the abbreviation of a variable name and \code{level} a character +string indicating the level (e.g., "2m"), if it is not required it could be +set as NULL.} -\item{Datasets}{a named list with the dataset model with two elements: \code{InitiatlizationDates}, containing a list of the start dates for each member named with the names of each member, and \code{Members} containing a vector with the member names (e.g., "Member_1")} +\item{Datasets}{a named list with the dataset model with two elements: +\code{InitiatlizationDates}, containing a list of the start dates for each +member named with the names of each member, and \code{Members} containing a +vector with the member names (e.g., "Member_1")} -\item{Dates}{a named list of one to two elements: The first element, \code{start}, is an array of dimensions (sdate, time) with the POSIX initial date of each forecast time of each starting date. The second element, \code{end} (optional), is an array of dimensions (sdate, time) with the POSIX final date of each forecast time of each starting date.} +\item{Dates}{a named list of one to two elements: The first element, +\code{start}, is an array of dimensions (sdate, time) with the POSIX initial +date of each forecast time of each starting date. The second element, +\code{end} (optional), is an array of dimensions (sdate, time) with the POSIX} -\item{time_dims}{a vector of strings containing the names of the temporal dimensions found in \code{data}.} +\item{time_dims}{a vector of strings containing the names of the temporal +dimensions found in \code{data}.} -\item{when}{a time stamp of the date issued by the Load() call to obtain the data.} +\item{when}{a time stamp of the date issued by the Load() call to obtain the +data.} -\item{source_files}{a vector of character strings with complete paths to all the found files involved in the Load() call.} +\item{source_files}{a vector of character strings with complete paths to all +the found files involved in the Load() call.} } \value{ The function returns an object of class 's2dv_cube'. -- GitLab From 31deb250dbbf55c30993e6898e760c1b38ea4b54 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 4 Oct 2022 12:50:20 +0200 Subject: [PATCH 3/9] Not sure what's new. Add commit for checking out --- R/PlotCombinedMap.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index a7b5fc97..b99ea512 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -369,6 +369,7 @@ PlotCombinedMap <- function(maps, lon, lat, } #NOTE: I think plot.new() is not necessary in any case. # plot.new() + #TODO: Don't hardcoded. Let users decide. par(font.main = 1) # If colorbars need to be plotted, re-define layout. if (drawleg) { -- GitLab From 7f9dc5f2660a713d41cd9d3dfe1ececa064e2c0e Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 11 Oct 2022 19:47:59 +0200 Subject: [PATCH 4/9] Use ProbsColorBar() in PlotCombinedMap() --- R/PlotCombinedMap.R | 194 ++++++++------------------------------------ 1 file changed, 32 insertions(+), 162 deletions(-) diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index b99ea512..c71d2fa1 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -86,6 +86,7 @@ PlotCombinedMap <- function(maps, lon, lat, # If there is any filenames to store the graphics, process them # to select the right device if (!is.null(fileout)) { + .SelectDevice <- utils::getFromNamespace(".SelectDevice", "s2dv") deviceInfo <- .SelectDevice(fileout = fileout, width = width, height = height, units = size_units, res = res) saveToFile <- deviceInfo$fun @@ -94,6 +95,7 @@ PlotCombinedMap <- function(maps, lon, lat, # Check probs error <- FALSE + # Change list into an array if (is.list(maps)) { if (length(maps) < 1) { stop("Parameter 'maps' must be of length >= 1 if provided as a list.") @@ -202,71 +204,13 @@ PlotCombinedMap <- function(maps, lon, lat, stop("The parameter 'map_select_fun' must be a function or a numeric array.") } - # Check display_range - if (!is.numeric(display_range) || length(display_range) != 2) { - stop("Parameter 'display_range' must be a numeric vector of length 2.") - } - - # Check brks - if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { - num_brks <- 5 - if (is.numeric(brks)) { - num_brks <- brks - } - brks <- seq(from = display_range[1], to = display_range[2], length.out = num_brks) - } - if (!is.numeric(brks)) { - stop("Parameter 'brks' must be a numeric vector.") - } - - # Check cols - col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), - c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), - c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), - c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), - c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) - if (is.null(cols)) { - if (length(col_sets) >= dim(maps)[map_dim]) { - chosen_sets <- 1:(dim(maps)[map_dim]) - chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) - } else { - chosen_sets <- array(1:length(col_sets), dim(maps)[map_dim]) - } - cols <- col_sets[chosen_sets] - } else { - if (!is.list(cols)) { - stop("Parameter 'cols' must be a list of character vectors.") - } - if (!all(sapply(cols, is.character))) { - stop("Parameter 'cols' must be a list of character vectors.") - } - if (length(cols) != dim(maps)[map_dim]) { - stop("Parameter 'cols' must be a list of the same length as the number of ", - "maps in 'maps'.") - } - } - for (i in 1:length(cols)) { - if (length(cols[[i]]) != (length(brks) - 1)) { - cols[[i]] <- colorRampPalette(cols[[i]])(length(brks) - 1) - } - } - - # Check bar_titles - if (is.null(bar_titles)) { - if (!is.null(names(cols))) { - bar_titles <- names(cols) - } else { - bar_titles <- paste0("Map ", 1:length(cols)) - } - } else { - if (!is.character(bar_titles)) { - stop("Parameter 'bar_titles' must be a character vector.") - } - if (length(bar_titles) != length(cols)) { - stop("Parameter 'bar_titles' must be of the same length as the number of ", - "maps in 'maps'.") - } - } + # Generate the desired brks and cols. Only nmap, brks, cols, and bar_titles matter here because plot = F. + colorbar <- ProbsColorBar(nmap = dim(maps)[map_dim], display_range = display_range, + brks = brks, cols = cols, vertical = FALSE, + subsampleg = NULL, bar_limits = NULL, var_limits = NULL, + triangle_ends = NULL, plot = FALSE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, + extra_margin = c(2, 0, 2, 0)) # Check legend_scale if (!is.numeric(legend_scale)) { @@ -310,7 +254,7 @@ PlotCombinedMap <- function(maps, lon, lat, #---------------------- # Identify the most likely map #---------------------- - brks_norm <- seq(0, 1, length.out = length(brks)) + brks_norm <- seq(0, 1, length.out = length(colorbar$brks)) if (is.function(map_select_fun)) { range_width <- display_range[2] - display_range[1] ml_map <- apply(maps, c(lat_dim, lon_dim), function(x) { @@ -326,7 +270,7 @@ PlotCombinedMap <- function(maps, lon, lat, } else { res <- res + (map_select_fun(x) - display_range[1]) / range_width if (map_select_fun(x) == display_range[1]) { - res <- res + brks_norm[2] / (num_brks * 2) + res <- res + brks_norm[2] / (length(brks_norm) * 2) } } } else { @@ -379,12 +323,11 @@ PlotCombinedMap <- function(maps, lon, lat, #---------------------- # Set colors and breaks and then PlotEquiMap #---------------------- - tcols <- c(col_unknown_map, cols[[1]]) + tcols <- c(col_unknown_map, colorbar$cols[[1]]) for (k in 2:nmap) { - tcols <- append(tcols, c(col_unknown_map, cols[[k]])) + tcols <- append(tcols, c(col_unknown_map, colorbar$cols[[k]])) } - - tbrks <- c(-1, brks_norm + rep(1:nmap, each = length(brks))) + tbrks <- c(-1, brks_norm + rep(1:nmap, each = length(brks_norm))) if (is.null(plot_margin)) { plot_margin <- c(5, 4, 4, 2) + 0.1 # default of par()$mar @@ -438,34 +381,30 @@ PlotCombinedMap <- function(maps, lon, lat, } if (drawleg) { - for (k in 1:nmap) { - ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, - draw_separators = TRUE, extra_margin = c(2, 0, 2, 0), - label_scale = legend_scale * 1.5) - if (!is.null(bar_titles)) { - mtext(bar_titles[[k]], 3, line = -3, cex = cex_bar_titles) - } - #TODO: Change to below code. Plot title together. extra_margin needs to be adjusted. -# ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, -# draw_separators = TRUE, extra_margin = c(1, 0, 1, 0), -# label_scale = legend_scale * 1.5, title = bar_titles[[k]], title_scale = cex_bar_titles) - } + ProbsColorBar(nmap = dim(maps)[map_dim], display_range = display_range, + brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, + subsampleg = NULL, bar_limits = NULL, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, + extra_margin = c(2, 0, 2, 0)) } # If the graphic was saved to file, close the connection with the device if (!is.null(fileout)) dev.off() } +#TODO: move to zzz.R or an independent file # Color bar for PlotMostLikelyQuantileMap -multi_ColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, - bar_limits = NULL, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, - draw_separators = FALSE, - bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), - ...) { - - minimum_value <- ceiling(1 / nmap * 10 * 1.1) * 10 - display_range = c(minimum_value, 100) +ProbsColorBar <- function(nmap, display_range, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits = NULL, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, + draw_separators = FALSE, + bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + ...) { + # display_range + if (!is.numeric(display_range) || length(display_range) != 2) { + stop("Parameter 'display_range' must be a numeric vector of length 2.") + } # Check brks if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { @@ -499,7 +438,7 @@ multi_ColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subs if (!all(sapply(cols, is.character))) { stop("Parameter 'cols' must be a list of character vectors.") } - if (length(cols) != dim(maps)[map_dim]) { + if (length(cols) != nmap) { stop("Parameter 'cols' must be a list of the same length as the number of ", "maps in 'maps'.") } @@ -538,72 +477,3 @@ multi_ColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subs } -#TODO: use s2dv:::.SelectDevice and remove this function here? -.SelectDevice <- function(fileout, width, height, units, res) { - # This function is used in the plot functions to check the extension of the - # files where the graphics will be stored and select the right R device to - # save them. - # If the vector of filenames ('fileout') has files with different - # extensions, then it will only accept the first one, changing all the rest - # of the filenames to use that extension. - - # We extract the extension of the filenames: '.png', '.pdf', ... - ext <- regmatches(fileout, regexpr("\\.[a-zA-Z0-9]*$", fileout)) - - if (length(ext) != 0) { - # If there is an extension specified, select the correct device - ## units of width and height set to accept inches - if (ext[1] == ".png") { - saveToFile <- function(fileout) { - png(filename = fileout, width = width, height = height, res = res, units = units) - } - } else if (ext[1] == ".jpeg") { - saveToFile <- function(fileout) { - jpeg(filename = fileout, width = width, height = height, res = res, units = units) - } - } else if (ext[1] %in% c(".eps", ".ps")) { - saveToFile <- function(fileout) { - postscript(file = fileout, width = width, height = height) - } - } else if (ext[1] == ".pdf") { - saveToFile <- function(fileout) { - pdf(file = fileout, width = width, height = height) - } - } else if (ext[1] == ".svg") { - saveToFile <- function(fileout) { - svg(filename = fileout, width = width, height = height) - } - } else if (ext[1] == ".bmp") { - saveToFile <- function(fileout) { - bmp(filename = fileout, width = width, height = height, res = res, units = units) - } - } else if (ext[1] == ".tiff") { - saveToFile <- function(fileout) { - tiff(filename = fileout, width = width, height = height, res = res, units = units) - } - } else { - warning("file extension not supported, it will be used '.eps' by default.") - ## In case there is only one filename - fileout[1] <- sub("\\.[a-zA-Z0-9]*$", ".eps", fileout[1]) - ext[1] <- ".eps" - saveToFile <- function(fileout) { - postscript(file = fileout, width = width, height = height) - } - } - # Change filenames when necessary - if (any(ext != ext[1])) { - warning(paste0("some extensions of the filenames provided in 'fileout' are not ", ext[1],". The extensions are being converted to ", ext[1], ".")) - fileout <- sub("\\.[a-zA-Z0-9]*$", ext[1], fileout) - } - } else { - # Default filenames when there is no specification - warning("there are no extensions specified in the filenames, default to '.eps'") - fileout <- paste0(fileout, ".eps") - saveToFile <- postscript - } - - # return the correct function with the graphical device, and the correct - # filenames - list(fun = saveToFile, files = fileout) -} - -- GitLab From 2acf8c0f2495d0084b380ecc8f7994281252aa3b Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 11 Oct 2022 20:30:48 +0200 Subject: [PATCH 5/9] donttest plotting in examples --- R/PlotCombinedMap.R | 4 ++++ R/PlotMostLikelyQuantileMap.R | 4 ++++ man/PlotCombinedMap.Rd | 4 ++++ man/PlotMostLikelyQuantileMap.Rd | 4 ++++ 4 files changed, 16 insertions(+) diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index c71d2fa1..c2f609e5 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -50,12 +50,14 @@ #'c <- 1 - (a + b) #'lons <- seq(0, 359.5, length = 20) #'lats <- seq(-89.5, 89.5, length = 10) +#'\donttest{ #'PlotCombinedMap(list(a, b, c), lons, lats, #' toptitle = 'Maximum map', #' map_select_fun = max, #' display_range = c(0, 1), #' bar_titles = paste('% of belonging to', c('a', 'b', 'c')), #' brks = 20, width = 10, height = 8) +#'} #' #'Lon <- c(0:40, 350:359) #'Lat <- 51:26 @@ -63,9 +65,11 @@ #'dim(data) <- c(map = 3, lon = 51, lat = 26) #'mask <- sample(c(0,1), replace = TRUE, size = 51 * 26) #'dim(mask) <- c(lat = 26, lon = 51) +#'\donttest{ #'PlotCombinedMap(data, lon = Lon, lat = Lat, map_select_fun = max, #' display_range = range(data), mask = mask, #' width = 12, height = 8) +#'} #' #'@export PlotCombinedMap <- function(maps, lon, lat, diff --git a/R/PlotMostLikelyQuantileMap.R b/R/PlotMostLikelyQuantileMap.R index 9f9f1914..23b2e1bb 100644 --- a/R/PlotMostLikelyQuantileMap.R +++ b/R/PlotMostLikelyQuantileMap.R @@ -29,10 +29,12 @@ #'c <- 1 - (a + b) #'lons <- seq(0, 359.5, length = 20) #'lats <- seq(-89.5, 89.5, length = 10) +#'\donttest{ #'PlotMostLikelyQuantileMap(list(a, b, c), lons, lats, #' toptitle = 'Most likely tercile map', #' bar_titles = paste('% of belonging to', c('a', 'b', 'c')), #' brks = 20, width = 10, height = 8) +#'} #' #'# More complex example #'n_lons <- 40 @@ -99,11 +101,13 @@ #'bins <- multiApply::Apply(sample_data, 'time', binning, thresholds)$output1 #' #'# 3. Plotting most likely quantile/bin +#'\donttest{ #'PlotMostLikelyQuantileMap(bins, lons, lats, #' toptitle = 'Most likely quantile map', #' bar_titles = paste('% of belonging to', letters[1:n_bins]), #' mask = 1 - (w1 + w2 / max(c(w1, w2))), #' brks = 20, width = 10, height = 8) +#'} #' #'@export PlotMostLikelyQuantileMap <- function(probs, lon, lat, cat_dim = 'bin', diff --git a/man/PlotCombinedMap.Rd b/man/PlotCombinedMap.Rd index 6a222b0b..08b08a66 100644 --- a/man/PlotCombinedMap.Rd +++ b/man/PlotCombinedMap.Rd @@ -97,12 +97,14 @@ b <- (1 - x) * 0.6 c <- 1 - (a + b) lons <- seq(0, 359.5, length = 20) lats <- seq(-89.5, 89.5, length = 10) +\donttest{ PlotCombinedMap(list(a, b, c), lons, lats, toptitle = 'Maximum map', map_select_fun = max, display_range = c(0, 1), bar_titles = paste('\% of belonging to', c('a', 'b', 'c')), brks = 20, width = 10, height = 8) +} Lon <- c(0:40, 350:359) Lat <- 51:26 @@ -110,9 +112,11 @@ data <- rnorm(51 * 26 * 3) dim(data) <- c(map = 3, lon = 51, lat = 26) mask <- sample(c(0,1), replace = TRUE, size = 51 * 26) dim(mask) <- c(lat = 26, lon = 51) +\donttest{ PlotCombinedMap(data, lon = Lon, lat = Lat, map_select_fun = max, display_range = range(data), mask = mask, width = 12, height = 8) +} } \seealso{ diff --git a/man/PlotMostLikelyQuantileMap.Rd b/man/PlotMostLikelyQuantileMap.Rd index ba111d50..9eabeb1e 100644 --- a/man/PlotMostLikelyQuantileMap.Rd +++ b/man/PlotMostLikelyQuantileMap.Rd @@ -48,10 +48,12 @@ b <- (1 - x) * 0.6 c <- 1 - (a + b) lons <- seq(0, 359.5, length = 20) lats <- seq(-89.5, 89.5, length = 10) +\donttest{ PlotMostLikelyQuantileMap(list(a, b, c), lons, lats, toptitle = 'Most likely tercile map', bar_titles = paste('\% of belonging to', c('a', 'b', 'c')), brks = 20, width = 10, height = 8) +} # More complex example n_lons <- 40 @@ -118,11 +120,13 @@ binning <- function(x, thresholds) { bins <- multiApply::Apply(sample_data, 'time', binning, thresholds)$output1 # 3. Plotting most likely quantile/bin +\donttest{ PlotMostLikelyQuantileMap(bins, lons, lats, toptitle = 'Most likely quantile map', bar_titles = paste('\% of belonging to', letters[1:n_bins]), mask = 1 - (w1 + w2 / max(c(w1, w2))), brks = 20, width = 10, height = 8) +} } \seealso{ -- GitLab From 37602071b953fcd26c221e0bdfa0b42104c62ff8 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 11 Oct 2022 21:04:53 +0200 Subject: [PATCH 6/9] Create CatColorBar (name tbd) --- R/CatColorBar.R | 85 +++++++++++++++++++++++++++++++++ R/PlotCombinedMap.R | 111 ++++++-------------------------------------- 2 files changed, 99 insertions(+), 97 deletions(-) create mode 100644 R/CatColorBar.R diff --git a/R/CatColorBar.R b/R/CatColorBar.R new file mode 100644 index 00000000..a5acc61d --- /dev/null +++ b/R/CatColorBar.R @@ -0,0 +1,85 @@ +#'Draws Color Bars for Categories +#'A wrapper of s2dv::ColorBar to generate multiple color bars for different +#'categories, and each category has different color set. +CatColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, + draw_separators = FALSE, + bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + ...) { + # bar_limits + if (!is.numeric(bar_limits) || length(bar_limits) != 2) { + stop("Parameter 'bar_limits' must be a numeric vector of length 2.") + } + + # Check brks + if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { + num_brks <- 5 + if (is.numeric(brks)) { + num_brks <- brks + } + brks <- seq(from = bar_limits[1], to = bar_limits[2], length.out = num_brks) + } + if (!is.numeric(brks)) { + stop("Parameter 'brks' must be a numeric vector.") + } + # Check cols + col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), + c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), + c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), + c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), + c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) + if (is.null(cols)) { + if (length(col_sets) >= nmap) { + chosen_sets <- 1:nmap + chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) + } else { + chosen_sets <- array(1:length(col_sets), nmap) + } + cols <- col_sets[chosen_sets] + } else { + if (!is.list(cols)) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (!all(sapply(cols, is.character))) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (length(cols) != nmap) { + stop("Parameter 'cols' must be a list of the same length as the number of ", + "maps in 'maps'.") + } + } + for (i in 1:length(cols)) { + if (length(cols[[i]]) != (length(brks) - 1)) { + cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) + } + } + + # Check bar_titles + if (is.null(bar_titles)) { + if (nmap == 3) { + bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)") + } else if (nmap == 5) { + bar_titles <- c("Low (%)", "Below normal (%)", + "Normal (%)", "Above normal (%)", "High (%)") + } else { + bar_titles <- paste0("Cat. ", 1:nmap, " (%)") + } + } + + if (plot) { + for (k in 1:nmap) { + s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, + bar_limits = bar_limits, var_limits = var_limits, + triangle_ends = triangle_ends, plot = TRUE, + draw_separators = draw_separators, + title = bar_titles[[k]], title_scale = title_scale, + label_scale = label_scale, extra_margin = extra_margin) + } + } else { + #TODO: col_inf and col_sup + return(list(brks = brks, cols = cols)) + } + +} + diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index c2f609e5..a703739a 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -208,13 +208,14 @@ PlotCombinedMap <- function(maps, lon, lat, stop("The parameter 'map_select_fun' must be a function or a numeric array.") } - # Generate the desired brks and cols. Only nmap, brks, cols, and bar_titles matter here because plot = F. - colorbar <- ProbsColorBar(nmap = dim(maps)[map_dim], display_range = display_range, - brks = brks, cols = cols, vertical = FALSE, - subsampleg = NULL, bar_limits = NULL, var_limits = NULL, - triangle_ends = NULL, plot = FALSE, draw_separators = TRUE, - bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, - extra_margin = c(2, 0, 2, 0)) + # Generate the desired brks and cols. Only nmap, brks, cols, bar_limits, and + # bar_titles matter here because plot = F. + colorbar <- CatColorBar(nmap = dim(maps)[map_dim], + brks = brks, cols = cols, vertical = FALSE, + subsampleg = NULL, bar_limits = display_range, var_limits = NULL, + triangle_ends = NULL, plot = FALSE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, + extra_margin = c(2, 0, 2, 0)) # Check legend_scale if (!is.numeric(legend_scale)) { @@ -385,99 +386,15 @@ PlotCombinedMap <- function(maps, lon, lat, } if (drawleg) { - ProbsColorBar(nmap = dim(maps)[map_dim], display_range = display_range, - brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, - subsampleg = NULL, bar_limits = NULL, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, draw_separators = TRUE, - bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, - extra_margin = c(2, 0, 2, 0)) + CatColorBar(nmap = dim(maps)[map_dim], display_range = display_range, + brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, + subsampleg = NULL, bar_limits = NULL, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, + extra_margin = c(2, 0, 2, 0)) } # If the graphic was saved to file, close the connection with the device if (!is.null(fileout)) dev.off() } -#TODO: move to zzz.R or an independent file -# Color bar for PlotMostLikelyQuantileMap -ProbsColorBar <- function(nmap, display_range, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, - bar_limits = NULL, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, - draw_separators = FALSE, - bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), - ...) { - # display_range - if (!is.numeric(display_range) || length(display_range) != 2) { - stop("Parameter 'display_range' must be a numeric vector of length 2.") - } - - # Check brks - if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { - num_brks <- 5 - if (is.numeric(brks)) { - num_brks <- brks - } - brks <- seq(from = display_range[1], to = display_range[2], length.out = num_brks) - } - if (!is.numeric(brks)) { - stop("Parameter 'brks' must be a numeric vector.") - } - # Check cols - col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), - c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), - c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), - c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), - c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) - if (is.null(cols)) { - if (length(col_sets) >= nmap) { - chosen_sets <- 1:nmap - chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) - } else { - chosen_sets <- array(1:length(col_sets), nmap) - } - cols <- col_sets[chosen_sets] - } else { - if (!is.list(cols)) { - stop("Parameter 'cols' must be a list of character vectors.") - } - if (!all(sapply(cols, is.character))) { - stop("Parameter 'cols' must be a list of character vectors.") - } - if (length(cols) != nmap) { - stop("Parameter 'cols' must be a list of the same length as the number of ", - "maps in 'maps'.") - } - } - for (i in 1:length(cols)) { - if (length(cols[[i]]) != (length(brks) - 1)) { - cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) - } - } - - # Check bar_titles - if (is.null(bar_titles)) { - if (nmap == 3) { - bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)") - } else if (nmap == 5) { - bar_titles <- c("Low (%)", "Below normal (%)", - "Normal (%)", "Above normal (%)", "High (%)") - } else { - bar_titles <- paste0("Cat. ", 1:nmap, " (%)") - } - } - - if (plot) { - for (k in 1:nmap) { - s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, - bar_limits = bar_limits, var_limits = var_limits, - triangle_ends = triangle_ends, plot = TRUE, - draw_separators = draw_separators, - title = bar_titles[[k]], title_scale = title_scale, - label_scale = label_scale, extra_margin = extra_margin) - } - } else { - #TODO: col_inf and col_sup - return(list(brks = brks, cols = cols)) - } - -} - -- GitLab From 2679c095f209798235df189b634be2c67a944cb0 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 11 Oct 2022 22:34:12 +0200 Subject: [PATCH 7/9] Fix bugs about ColorBar --- R/CatColorBar.R | 2 +- R/PlotCombinedMap.R | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/CatColorBar.R b/R/CatColorBar.R index a5acc61d..74fefae2 100644 --- a/R/CatColorBar.R +++ b/R/CatColorBar.R @@ -70,7 +70,7 @@ CatColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsamp if (plot) { for (k in 1:nmap) { s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, - bar_limits = bar_limits, var_limits = var_limits, +# bar_limits = bar_limits, var_limits = var_limits, triangle_ends = triangle_ends, plot = TRUE, draw_separators = draw_separators, title = bar_titles[[k]], title_scale = title_scale, diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index a703739a..8760f797 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -386,9 +386,9 @@ PlotCombinedMap <- function(maps, lon, lat, } if (drawleg) { - CatColorBar(nmap = dim(maps)[map_dim], display_range = display_range, + CatColorBar(nmap = dim(maps)[map_dim], brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, - subsampleg = NULL, bar_limits = NULL, var_limits = NULL, + subsampleg = NULL, bar_limits = display_range, var_limits = NULL, triangle_ends = NULL, plot = TRUE, draw_separators = TRUE, bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, extra_margin = c(2, 0, 2, 0)) -- GitLab From 795e779bb1bc31f8fe4d3ea73478a5c81470b7d9 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 13 Oct 2022 16:04:51 +0200 Subject: [PATCH 8/9] Change donttest to dontrun in plotting examples; move CatColorBar() to zzz.R --- R/CatColorBar.R | 85 ------------------------------- R/PlotCombinedMap.R | 4 +- R/PlotMostLikelyQuantileMap.R | 4 +- R/zzz.R | 86 ++++++++++++++++++++++++++++++++ man/PlotCombinedMap.Rd | 4 +- man/PlotMostLikelyQuantileMap.Rd | 4 +- 6 files changed, 94 insertions(+), 93 deletions(-) delete mode 100644 R/CatColorBar.R diff --git a/R/CatColorBar.R b/R/CatColorBar.R deleted file mode 100644 index 74fefae2..00000000 --- a/R/CatColorBar.R +++ /dev/null @@ -1,85 +0,0 @@ -#'Draws Color Bars for Categories -#'A wrapper of s2dv::ColorBar to generate multiple color bars for different -#'categories, and each category has different color set. -CatColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, - bar_limits, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, - draw_separators = FALSE, - bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), - ...) { - # bar_limits - if (!is.numeric(bar_limits) || length(bar_limits) != 2) { - stop("Parameter 'bar_limits' must be a numeric vector of length 2.") - } - - # Check brks - if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { - num_brks <- 5 - if (is.numeric(brks)) { - num_brks <- brks - } - brks <- seq(from = bar_limits[1], to = bar_limits[2], length.out = num_brks) - } - if (!is.numeric(brks)) { - stop("Parameter 'brks' must be a numeric vector.") - } - # Check cols - col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), - c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), - c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), - c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), - c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) - if (is.null(cols)) { - if (length(col_sets) >= nmap) { - chosen_sets <- 1:nmap - chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) - } else { - chosen_sets <- array(1:length(col_sets), nmap) - } - cols <- col_sets[chosen_sets] - } else { - if (!is.list(cols)) { - stop("Parameter 'cols' must be a list of character vectors.") - } - if (!all(sapply(cols, is.character))) { - stop("Parameter 'cols' must be a list of character vectors.") - } - if (length(cols) != nmap) { - stop("Parameter 'cols' must be a list of the same length as the number of ", - "maps in 'maps'.") - } - } - for (i in 1:length(cols)) { - if (length(cols[[i]]) != (length(brks) - 1)) { - cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) - } - } - - # Check bar_titles - if (is.null(bar_titles)) { - if (nmap == 3) { - bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)") - } else if (nmap == 5) { - bar_titles <- c("Low (%)", "Below normal (%)", - "Normal (%)", "Above normal (%)", "High (%)") - } else { - bar_titles <- paste0("Cat. ", 1:nmap, " (%)") - } - } - - if (plot) { - for (k in 1:nmap) { - s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, -# bar_limits = bar_limits, var_limits = var_limits, - triangle_ends = triangle_ends, plot = TRUE, - draw_separators = draw_separators, - title = bar_titles[[k]], title_scale = title_scale, - label_scale = label_scale, extra_margin = extra_margin) - } - } else { - #TODO: col_inf and col_sup - return(list(brks = brks, cols = cols)) - } - -} - diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index 8760f797..9399ba0f 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -50,7 +50,7 @@ #'c <- 1 - (a + b) #'lons <- seq(0, 359.5, length = 20) #'lats <- seq(-89.5, 89.5, length = 10) -#'\donttest{ +#'\dontrun{ #'PlotCombinedMap(list(a, b, c), lons, lats, #' toptitle = 'Maximum map', #' map_select_fun = max, @@ -65,7 +65,7 @@ #'dim(data) <- c(map = 3, lon = 51, lat = 26) #'mask <- sample(c(0,1), replace = TRUE, size = 51 * 26) #'dim(mask) <- c(lat = 26, lon = 51) -#'\donttest{ +#'\dontrun{ #'PlotCombinedMap(data, lon = Lon, lat = Lat, map_select_fun = max, #' display_range = range(data), mask = mask, #' width = 12, height = 8) diff --git a/R/PlotMostLikelyQuantileMap.R b/R/PlotMostLikelyQuantileMap.R index 23b2e1bb..31cde14f 100644 --- a/R/PlotMostLikelyQuantileMap.R +++ b/R/PlotMostLikelyQuantileMap.R @@ -29,7 +29,7 @@ #'c <- 1 - (a + b) #'lons <- seq(0, 359.5, length = 20) #'lats <- seq(-89.5, 89.5, length = 10) -#'\donttest{ +#'\dontrun{ #'PlotMostLikelyQuantileMap(list(a, b, c), lons, lats, #' toptitle = 'Most likely tercile map', #' bar_titles = paste('% of belonging to', c('a', 'b', 'c')), @@ -101,7 +101,7 @@ #'bins <- multiApply::Apply(sample_data, 'time', binning, thresholds)$output1 #' #'# 3. Plotting most likely quantile/bin -#'\donttest{ +#'\dontrun{ #'PlotMostLikelyQuantileMap(bins, lons, lats, #' toptitle = 'Most likely quantile map', #' bar_titles = paste('% of belonging to', letters[1:n_bins]), diff --git a/R/zzz.R b/R/zzz.R index c1b8664f..db5ae9fd 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -77,3 +77,89 @@ return(field) } + +#Draws Color Bars for Categories +#A wrapper of s2dv::ColorBar to generate multiple color bars for different +#categories, and each category has different color set. +CatColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, + draw_separators = FALSE, + bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + ...) { + # bar_limits + if (!is.numeric(bar_limits) || length(bar_limits) != 2) { + stop("Parameter 'bar_limits' must be a numeric vector of length 2.") + } + + # Check brks + if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { + num_brks <- 5 + if (is.numeric(brks)) { + num_brks <- brks + } + brks <- seq(from = bar_limits[1], to = bar_limits[2], length.out = num_brks) + } + if (!is.numeric(brks)) { + stop("Parameter 'brks' must be a numeric vector.") + } + # Check cols + col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), + c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), + c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), + c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), + c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) + if (is.null(cols)) { + if (length(col_sets) >= nmap) { + chosen_sets <- 1:nmap + chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) + } else { + chosen_sets <- array(1:length(col_sets), nmap) + } + cols <- col_sets[chosen_sets] + } else { + if (!is.list(cols)) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (!all(sapply(cols, is.character))) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (length(cols) != nmap) { + stop("Parameter 'cols' must be a list of the same length as the number of ", + "maps in 'maps'.") + } + } + for (i in 1:length(cols)) { + if (length(cols[[i]]) != (length(brks) - 1)) { + cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) + } + } + + # Check bar_titles + if (is.null(bar_titles)) { + if (nmap == 3) { + bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)") + } else if (nmap == 5) { + bar_titles <- c("Low (%)", "Below normal (%)", + "Normal (%)", "Above normal (%)", "High (%)") + } else { + bar_titles <- paste0("Cat. ", 1:nmap, " (%)") + } + } + + if (plot) { + for (k in 1:nmap) { + s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, +# bar_limits = bar_limits, var_limits = var_limits, + triangle_ends = triangle_ends, plot = TRUE, + draw_separators = draw_separators, + title = bar_titles[[k]], title_scale = title_scale, + label_scale = label_scale, extra_margin = extra_margin) + } + } else { + #TODO: col_inf and col_sup + return(list(brks = brks, cols = cols)) + } + +} + diff --git a/man/PlotCombinedMap.Rd b/man/PlotCombinedMap.Rd index 08b08a66..bbd2787a 100644 --- a/man/PlotCombinedMap.Rd +++ b/man/PlotCombinedMap.Rd @@ -97,7 +97,7 @@ b <- (1 - x) * 0.6 c <- 1 - (a + b) lons <- seq(0, 359.5, length = 20) lats <- seq(-89.5, 89.5, length = 10) -\donttest{ +\dontrun{ PlotCombinedMap(list(a, b, c), lons, lats, toptitle = 'Maximum map', map_select_fun = max, @@ -112,7 +112,7 @@ data <- rnorm(51 * 26 * 3) dim(data) <- c(map = 3, lon = 51, lat = 26) mask <- sample(c(0,1), replace = TRUE, size = 51 * 26) dim(mask) <- c(lat = 26, lon = 51) -\donttest{ +\dontrun{ PlotCombinedMap(data, lon = Lon, lat = Lat, map_select_fun = max, display_range = range(data), mask = mask, width = 12, height = 8) diff --git a/man/PlotMostLikelyQuantileMap.Rd b/man/PlotMostLikelyQuantileMap.Rd index 9eabeb1e..cc98f8f5 100644 --- a/man/PlotMostLikelyQuantileMap.Rd +++ b/man/PlotMostLikelyQuantileMap.Rd @@ -48,7 +48,7 @@ b <- (1 - x) * 0.6 c <- 1 - (a + b) lons <- seq(0, 359.5, length = 20) lats <- seq(-89.5, 89.5, length = 10) -\donttest{ +\dontrun{ PlotMostLikelyQuantileMap(list(a, b, c), lons, lats, toptitle = 'Most likely tercile map', bar_titles = paste('\% of belonging to', c('a', 'b', 'c')), @@ -120,7 +120,7 @@ binning <- function(x, thresholds) { bins <- multiApply::Apply(sample_data, 'time', binning, thresholds)$output1 # 3. Plotting most likely quantile/bin -\donttest{ +\dontrun{ PlotMostLikelyQuantileMap(bins, lons, lats, toptitle = 'Most likely quantile map', bar_titles = paste('\% of belonging to', letters[1:n_bins]), -- GitLab From 9c16e5a17c8da93d6cb24b8a2bfeae2ec44bfb95 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 14 Oct 2022 12:17:56 +0200 Subject: [PATCH 9/9] Change function name to GradientCatsColorBar --- R/PlotCombinedMap.R | 24 ++++++++++++------------ R/zzz.R | 12 ++++++------ 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index 9399ba0f..6379179b 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -210,12 +210,12 @@ PlotCombinedMap <- function(maps, lon, lat, # Generate the desired brks and cols. Only nmap, brks, cols, bar_limits, and # bar_titles matter here because plot = F. - colorbar <- CatColorBar(nmap = dim(maps)[map_dim], - brks = brks, cols = cols, vertical = FALSE, - subsampleg = NULL, bar_limits = display_range, var_limits = NULL, - triangle_ends = NULL, plot = FALSE, draw_separators = TRUE, - bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, - extra_margin = c(2, 0, 2, 0)) + colorbar <- GradientCatsColorBar(nmap = dim(maps)[map_dim], + brks = brks, cols = cols, vertical = FALSE, + subsampleg = NULL, bar_limits = display_range, var_limits = NULL, + triangle_ends = NULL, plot = FALSE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, + extra_margin = c(2, 0, 2, 0)) # Check legend_scale if (!is.numeric(legend_scale)) { @@ -386,12 +386,12 @@ PlotCombinedMap <- function(maps, lon, lat, } if (drawleg) { - CatColorBar(nmap = dim(maps)[map_dim], - brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, - subsampleg = NULL, bar_limits = display_range, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, draw_separators = TRUE, - bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, - extra_margin = c(2, 0, 2, 0)) + GradientCatsColorBar(nmap = dim(maps)[map_dim], + brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, + subsampleg = NULL, bar_limits = display_range, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = 1, label_scale = legend_scale * 1.5, + extra_margin = c(2, 0, 2, 0)) } # If the graphic was saved to file, close the connection with the device diff --git a/R/zzz.R b/R/zzz.R index db5ae9fd..a30e8bfb 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -81,12 +81,12 @@ #Draws Color Bars for Categories #A wrapper of s2dv::ColorBar to generate multiple color bars for different #categories, and each category has different color set. -CatColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, - bar_limits, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, - draw_separators = FALSE, - bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), - ...) { +GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, + draw_separators = FALSE, + bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + ...) { # bar_limits if (!is.numeric(bar_limits) || length(bar_limits) != 2) { stop("Parameter 'bar_limits' must be a numeric vector of length 2.") -- GitLab