diff --git a/R/PlotCombinedMap.R b/R/PlotCombinedMap.R index 7d639a49016b44752231d17458efac1324e15d1d..d7d5f49e6e5de173e81573cbb8c0a4be1adef8e1 100644 --- a/R/PlotCombinedMap.R +++ b/R/PlotCombinedMap.R @@ -78,6 +78,12 @@ #' '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 return_leg A logical value indicating if the color bars information +#' should be returned by the function. If TRUE, the function doesn't plot the +#' color bars but still creates the layout with color bar areas, and the +#' arguments for GradientCatsColorBar() or ColorBar() will be returned. It is +#' convenient for users to adjust the color bars manually. The default is +#' FALSE, the color bars will be plotted directly. #'@param ... Additional parameters to be passed on to \code{PlotEquiMap}. #' #'@examples @@ -121,14 +127,15 @@ PlotCombinedMap <- function(maps, lon, lat, map_select_fun, display_range, map_dim = 'map', brks = NULL, cols = NULL, + bar_limits = NULL, triangle_ends = c(F, F), col_inf = NULL, col_sup = NULL, col_unknown_map = 'white', mask = NULL, col_mask = 'grey', dots = NULL, bar_titles = NULL, legend_scale = 1, cex_bar_titles = 1.5, - plot_margin = NULL, + plot_margin = NULL, bar_extra_margin = c(2, 0, 2, 0), fileout = NULL, width = 8, height = 5, - size_units = 'in', res = 100, drawleg = T, + size_units = 'in', res = 100, drawleg = T, return_leg = FALSE, ...) { args <- list(...) @@ -255,12 +262,16 @@ 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 <- GradientCatsColorBar(nmap = dim(maps)[map_dim], + var_limits_maps <- range(maps, na.rm = TRUE) + if (is.null(bar_limits)) bar_limits <- display_range + nmap <- dim(maps)[map_dim] + colorbar <- GradientCatsColorBar(nmap = nmap, brks = brks, cols = cols, vertical = FALSE, - subsampleg = NULL, bar_limits = display_range, var_limits = NULL, - triangle_ends = NULL, plot = FALSE, draw_separators = TRUE, + subsampleg = NULL, bar_limits = bar_limits, + var_limits = var_limits_maps, + triangle_ends = triangle_ends, col_inf = col_inf, col_sup = col_sup, plot = FALSE, draw_separators = TRUE, bar_titles = bar_titles, title_scale = cex_bar_titles, label_scale = legend_scale * 1.5, - extra_margin = c(2, 0, 2, 0)) + extra_margin = bar_extra_margin) # Check legend_scale if (!is.numeric(legend_scale)) { @@ -304,9 +315,56 @@ PlotCombinedMap <- function(maps, lon, lat, #---------------------- # Identify the most likely map #---------------------- - brks_norm <- seq(0, 1, length.out = length(colorbar$brks)) - if (is.function(map_select_fun)) { - range_width <- display_range[2] - display_range[1] + #TODO: Consider col_inf + if (!is.null(colorbar$col_inf[[1]])) { + .warning("Lower triangle is not supported now. Please contact maintainer if you have this need.") + } + if (!is.null(colorbar$col_sup[[1]])) { + + brks_norm <- vector('list', length = nmap) + range_width <- vector('list', length = nmap) + slightly_tune_val <- vector('list', length = nmap) + for (ii in 1:nmap) { + brks_norm[[ii]] <- seq(0, 1, length.out = length(colorbar$brks[[ii]]) + 1) # add one break for col_sup + slightly_tune_val[[ii]] <- brks_norm[[ii]][2] / (length(brks_norm[[ii]]) * 2) + range_width[[ii]] <- diff(range(colorbar$brks[[ii]])) + } + ml_map <- apply(maps, c(lat_dim, lon_dim), function(x) { + if (any(is.na(x))) { + res <- NA + } else { + res <- which(x == map_select_fun(x)) + if (length(res) > 0) { + res <- res_ind <- res[1] + if (map_select_fun(x) < display_range[1] || map_select_fun(x) > display_range[2]) { + res <- -0.5 + } else { + if (map_select_fun(x) > tail(colorbar$brks[[res_ind]], 1)) { # col_sup + res <- res + 1 - slightly_tune_val[[res_ind]] + } else { + res <- res + ((map_select_fun(x) - colorbar$brks[[res_ind]][1]) / + range_width[[res_ind]] * ((length(brks_norm[[res_ind]]) - 2) / (length(brks_norm[[res_ind]]) - 1))) + if (map_select_fun(x) == colorbar$brks[[res_ind]][1]) { + res <- res + slightly_tune_val[[res_ind]] + } + } + } + } else { + res <- -0.5 + } + } + res + }) + + } else { + + brks_norm <- vector('list', length = nmap) + range_width <- display_range[2] - display_range[1] #vector('list', length = nmap) + slightly_tune_val <- vector('list', length = nmap) + for (ii in 1:nmap) { + brks_norm[[ii]] <- seq(0, 1, length.out = length(colorbar$brks[[ii]])) + slightly_tune_val[[ii]] <- brks_norm[[ii]][2] / (length(brks_norm[[ii]]) * 2) + } ml_map <- apply(maps, c(lat_dim, lon_dim), function(x) { if (any(is.na(x))) { res <- NA @@ -314,13 +372,13 @@ PlotCombinedMap <- function(maps, lon, lat, res <- which(x == map_select_fun(x)) if (length(res) > 0) { res <- res[1] - if (map_select_fun(x) < display_range[1] || - map_select_fun(x) > display_range[2]) { + if (map_select_fun(x) < display_range[1] || + map_select_fun(x) > display_range[2]) { res <- -0.5 } 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] / (length(brks_norm) * 2) + res <- res + slightly_tune_val } } } else { @@ -329,18 +387,15 @@ PlotCombinedMap <- function(maps, lon, lat, } res }) - } else { - stop("Providing 'map_select_fun' as array not implemented yet.") - ml_map <- map_select_fun } - nmap <- dim(maps)[map_dim] + nlat <- length(lat) nlon <- length(lon) #---------------------- # Set latitudes from minimum to maximum #---------------------- - if (lat[1] > lat[nlat]){ + if (lat[1] > lat[nlat]) { lat <- lat[nlat:1] indices <- list(nlat:1, TRUE) ml_map <- do.call("[", c(list(x = ml_map), indices)) @@ -373,11 +428,21 @@ PlotCombinedMap <- function(maps, lon, lat, #---------------------- # Set colors and breaks and then PlotEquiMap #---------------------- - tcols <- c(col_unknown_map, colorbar$cols[[1]]) - for (k in 2:nmap) { - tcols <- append(tcols, c(col_unknown_map, colorbar$cols[[k]])) + if (!is.null(colorbar$col_sup[[1]])) { + tcols <- c(col_unknown_map, colorbar$cols[[1]], colorbar$col_sup[[1]]) + tbrks <- c(-1, brks_norm[[1]] + rep(1, each = length(brks_norm[[1]]))) + for (k in 2:nmap) { + tcols <- append(tcols, c(col_unknown_map, colorbar$cols[[k]], colorbar$col_sup[[k]])) + tbrks <- c(tbrks, brks_norm[[k]] + rep(k, each = length(brks_norm[[k]]))) + } + } else { # original code + tcols <- c(col_unknown_map, colorbar$cols[[1]]) + tbrks <- c(-1, brks_norm[[1]] + rep(1, each = length(brks_norm[[1]]))) + for (k in 2:nmap) { + tcols <- append(tcols, c(col_unknown_map, colorbar$cols[[k]])) + tbrks <- c(tbrks, brks_norm[[k]] + rep(k, each = length(brks_norm[[k]]))) + } } - 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 @@ -430,16 +495,35 @@ PlotCombinedMap <- function(maps, lon, lat, par(mar = old_mar) } - if (drawleg) { - GradientCatsColorBar(nmap = dim(maps)[map_dim], + if (drawleg & !return_leg) { + 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, + subsampleg = NULL, bar_limits = bar_limits, + var_limits = var_limits_maps, + triangle_ends = triangle_ends, col_inf = colorbar$col_inf, col_sup = colorbar$col_sup, + plot = TRUE, draw_separators = TRUE, bar_titles = bar_titles, title_scale = cex_bar_titles, label_scale = legend_scale * 1.5, - extra_margin = c(2, 0, 2, 0)) + extra_margin = bar_extra_margin) } - - # If the graphic was saved to file, close the connection with the device - if (!is.null(fileout)) dev.off() + + if (!return_leg) { + # If the graphic was saved to file, close the connection with the device + if (!is.null(fileout)) dev.off() + } + + if (return_leg) { + tmp <- list(nmap = dim(maps)[map_dim], + brks = colorbar$brks, cols = colorbar$cols, vertical = FALSE, + subsampleg = NULL, bar_limits = bar_limits, + var_limits = var_limits_maps, + triangle_ends = triangle_ends, col_inf = colorbar$col_inf, col_sup = colorbar$col_sup, + plot = TRUE, draw_separators = TRUE, + bar_titles = bar_titles, title_scale = cex_bar_titles, label_scale = legend_scale * 1.5, + extra_margin = bar_extra_margin) + .warning("The device is not off yet. Use dev.off() after plotting the color bars.") + return(tmp) + #NOTE: The device is not off! Can keep plotting the color bars. + } + } diff --git a/R/zzz.R b/R/zzz.R index b0c8b259b6434bbc11ad9c3d99a30bb22ae8b319..b181d75845acb8fa4780e58e0213449924fcffb1 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -83,26 +83,46 @@ #categories, and each category has different color set. GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, bar_limits, var_limits = NULL, - triangle_ends = NULL, plot = TRUE, + triangle_ends = NULL, col_inf = NULL, col_sup = 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.") - } + # bar_limits: a vector of 2 or a list + if (!is.list(bar_limits)) { + if (!is.numeric(bar_limits) || length(bar_limits) != 2) { + stop("Parameter 'bar_limits' must be a numeric vector of length 2 or a list containing that.") + } + # turn into list + bar_limits <- rep(list(bar_limits), nmap) + } else { + if (any(!sapply(bar_limits, is.numeric)) || any(sapply(bar_limits, length) != 2)) { + stop("Parameter 'bar_limits' must be a numeric vector of length 2 or a list containing that.") + } + if (length(bar_limits) != nmap) { + stop("Parameter 'bar_limits' must have the length of 'nmap'.") + } + } # Check brks - if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { - num_brks <- 5 - if (is.numeric(brks)) { - num_brks <- brks + if (!is.list(brks)) { + if (is.null(brks)) { + brks <- 5 + } else if (!is.numeric(brks)) { + stop("Parameter 'brks' must be a numeric vector.") + } + # Turn it into list + brks <- rep(list(brks), nmap) + } else { + if (length(brks) != nmap) { + stop("Parameter 'brks' must have the length of 'nmap'.") } - 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.") + for (i_map in 1:nmap) { + if (length(brks[[i_map]]) == 1) { + brks[[i_map]] <- seq(from = bar_limits[[i_map]][1], to = bar_limits[[i_map]][2], length.out = brks[[i_map]]) + } } + # Check cols col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), @@ -117,6 +137,44 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE chosen_sets <- array(1:length(col_sets), nmap) } cols <- col_sets[chosen_sets] + + # Set triangle_ends, col_sup, col_inf + #NOTE: The "col" input of ColorBar() later is not NULL (since we determine it here) + # so ColorBar() cannot decide these parameters for us. + #NOTE: Here, col_inf and col_sup are prior to triangle_ends, which is consistent with ColorBar(). + #TODO: Make triangle_ends a list + if (is.null(triangle_ends)) { + if (!is.null(var_limits)) { + triangle_ends <- c(FALSE, FALSE) + #TODO: bar_limits is a list + if (bar_limits[1] >= var_limits[1] | !is.null(col_inf)) { + triangle_ends[1] <- TRUE + if (is.null(col_inf)) { + col_inf <- lapply(cols, head, 1) + cols <- lapply(cols, '[', -1) + } + } + if (bar_limits[2] < var_limits[2] | !is.null(col_sup)) { + triangle_ends[2] <- TRUE + if (is.null(col_sup)) { + col_sup <- lapply(cols, tail, 1) + cols <- lapply(cols, '[', -length(cols[[1]])) + } + } + } else { + triangle_ends <- c(!is.null(col_inf), !is.null(col_sup)) + } + } else { # triangle_ends has values + if (triangle_ends[1] & is.null(col_inf)) { + col_inf <- lapply(cols, head, 1) + cols <- lapply(cols, '[', -1) + } + if (triangle_ends[2] & is.null(col_sup)) { + col_sup <- lapply(cols, tail, 1) + cols <- lapply(cols, '[', -length(cols[[1]])) + } + } + } else { if (!is.list(cols)) { stop("Parameter 'cols' must be a list of character vectors.") @@ -125,13 +183,12 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE 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'.") + stop("Parameter 'cols' must be a list of the same length as 'nmap'.") } } - for (i in 1:length(cols)) { - if (length(cols[[i]]) != (length(brks) - 1)) { - cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) + for (i_map in 1:length(cols)) { + if (length(cols[[i_map]]) != (length(brks[[i_map]]) - 1)) { + cols[[i_map]] <- grDevices::colorRampPalette(cols[[i_map]])(length(brks[[i_map]]) - 1) } } @@ -149,16 +206,16 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE 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, +#TODO: Add s2dv:: + ColorBar(brks = brks[[k]], cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, + bar_limits = bar_limits[[k]], #var_limits = var_limits, + triangle_ends = triangle_ends, col_inf = col_inf[[k]], col_sup = col_sup[[k]], 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)) + return(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup)) } } @@ -195,4 +252,4 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE } # Definition of a global variable to store the warning message used in Calibration -warning_shown <- FALSE \ No newline at end of file +warning_shown <- FALSE diff --git a/man/PlotCombinedMap.Rd b/man/PlotCombinedMap.Rd index d013f80e5aa5bf42c70bfdb8b4faa34990c24813..c734f716a08bb611540132f551da3d67e0f66162 100644 --- a/man/PlotCombinedMap.Rd +++ b/man/PlotCombinedMap.Rd @@ -13,6 +13,10 @@ PlotCombinedMap( map_dim = "map", brks = NULL, cols = NULL, + bar_limits = NULL, + triangle_ends = c(F, F), + col_inf = NULL, + col_sup = NULL, col_unknown_map = "white", mask = NULL, col_mask = "grey", @@ -21,12 +25,14 @@ PlotCombinedMap( legend_scale = 1, cex_bar_titles = 1.5, plot_margin = NULL, + bar_extra_margin = c(2, 0, 2, 0), fileout = NULL, width = 8, height = 5, size_units = "in", res = 100, drawleg = T, + return_leg = FALSE, ... ) } @@ -124,6 +130,13 @@ FALSE or:\cr 'right', 'r', 'R', 'east', 'e', 'E'\cr 'left', 'l', 'L', 'west', 'w', 'W'} +\item{return_leg}{A logical value indicating if the color bars information +should be returned by the function. If TRUE, the function doesn't plot the +color bars but still creates the layout with color bar areas, and the +arguments for GradientCatsColorBar() or ColorBar() will be returned. It is +convenient for users to adjust the color bars manually. The default is +FALSE, the color bars will be plotted directly.} + \item{...}{Additional parameters to be passed on to \code{PlotEquiMap}.} } \description{ diff --git a/vignettes/MultiModelSkill_vignette.Rmd b/vignettes/MultiModelSkill_vignette.Rmd index 5d9d123924276abd8a7df512fcdb6228345b3084..e927d4328ebf2d3668f09eac417d6d4bcc6afcdb 100644 --- a/vignettes/MultiModelSkill_vignette.Rmd +++ b/vignettes/MultiModelSkill_vignette.Rmd @@ -147,7 +147,7 @@ List of 4 $ conf.upper: num [1:4, 1, 1:35, 1:64] 0.816 0.848 0.542 0.806 0.763 ... > names(AnomDJF) [1] "data" "dims" "coords" "attrs" -> names(AnomDJF$attrs$Datasets) +> AnomDJF$attrs$Datasets [1] "glosea5" "ecmwf/system4_m1" "meteofrance/system5_m1" "erainterim" ``` @@ -163,7 +163,7 @@ PlotCombinedMap(AnomDJF$data$corr[,1,,], lon = Lon, lat = Lat, map_select_fun = c('white', 'darkblue'), c('white', 'darkred'), c('white', 'darkorange')), - bar_titles = c("MMM", names(AnomDJF$attrs$Datasets)), + bar_titles = c("MMM", AnomDJF$attrs$Datasets), width = 14, height = 8) ``` @@ -186,7 +186,6 @@ AnomDJF <- CST_MultiMetric(exp = ano_exp, obs = ano_obs, metric = 'rms', The following lines are necessary to obtain the plot which visualizes the best model given this metric for each grid point. ```r -names(dim(RMS)) <- c("maps", "lat", "lon") PlotCombinedMap(AnomDJF$data$rms[,1,,], lon = Lon, lat = Lat, map_select_fun = min, display_range = c(0, ceiling(max(abs(AnomDJF$data$rms)))), map_dim = 'nexp', legend_scale = 0.5, brks = 11, @@ -194,7 +193,7 @@ PlotCombinedMap(AnomDJF$data$rms[,1,,], lon = Lon, lat = Lat, map_select_fun = m c('darkblue', 'white'), c('darkred', 'white'), c('darkorange', 'white')), - bar_titles = c("MMM", names(AnomDJF$attrs$Datasets)), + bar_titles = c("MMM", AnomDJF$attrs$Datasets), width = 14, height = 8) ``` @@ -222,7 +221,7 @@ PlotCombinedMap(AnomDJF$data$rmsss[,1,,], lon = Lon, lat = Lat, c('white', 'darkblue'), c('white', 'darkred'), c('white', 'darkorange')), - bar_titles = c("MMM", names(AnomDJF$attrs$Datasets)), + bar_titles = c("MMM", AnomDJF$attrs$Datasets), width = 14, height = 8) ```