From 9b8ced1cb9e59c9e62d64f4ea10b0927030608fd Mon Sep 17 00:00:00 2001 From: ARIADNA BATALLA FERRES Date: Tue, 22 Apr 2025 16:50:20 +0200 Subject: [PATCH] Update VizEquiMap.R and Hatching.R to esviz versions --- modules/Visualization/R/tmp/Hatching.R | 172 ++++++++++ modules/Visualization/R/tmp/VizEquiMap.R | 379 +++++++++++++---------- 2 files changed, 389 insertions(+), 162 deletions(-) create mode 100644 modules/Visualization/R/tmp/Hatching.R diff --git a/modules/Visualization/R/tmp/Hatching.R b/modules/Visualization/R/tmp/Hatching.R new file mode 100644 index 00000000..0a0b82e1 --- /dev/null +++ b/modules/Visualization/R/tmp/Hatching.R @@ -0,0 +1,172 @@ +#' Draws hatching or crosshatching over a mask on a map +#' +#' Adds hatching or crosshatching lines over grid cells of a map based on a +#' logical mask. The hatching is applied only to grid cells where the mask is +#' TRUE (or 1). A number of graphical options are available to customize the +#' appearance of the hatching, such as line density, angle, line width, and +#' color. Optionally, crosshatching can be drawn using a second set of lines in +#' the opposite direction. +#' The function assumes that the input mask is a 2D array with dimensions +#' corresponding to latitude (rows) and longitude (columns), and it is designed +#' to be used as a layer over existing map plots (e.g., within a call to +#' \code{VizEquiMap}) and does not initiate a plot by itself. +#' +#'@param hatching_mask Logical or binary (0/1) array with two named dimensions: +#' c(latitude, longitude).Hatching is applied to grid cells where +#' 'hatching_mask' is TRUE (or 1). Arrays with dimensions c(longitude, latitude) +#' are also accepted, but the resulting hatching may appear transposed. To +#' ensure correct alignment with the map, provide 'data'. The function will +#' compare the dimension order of 'hatching_mask' and 'data', and automatically +#' transpose 'hatching_mask' if the latitude and longitude dimensions appear to +#' be reversed. +#'@param lat Numeric vector of latitude locations of the cell centers of the +#' grid. +#'@param lon Numeric vector of longitude locations of the cell centers of the +#' grid. +#'@param data Array of the data that the hatching will be drawn over. The array +#' should have named latidude and longitude dimensions. If the dimension order +#' is reversed relative to 'hatching_mask', the mask is automatically +#' transposed. Default is NULL. +#'@param hatching_density The density of shading lines, in lines per inch. A +#' zero value of density means no shading nor filling, whereas negative values +#' and NA suppress shading (and so allow color filling). NULL means that no +#' shading lines are drawn. Default is 10. +#'@param hatching_angle The slope of shading lines, given as an angle in degrees +#' (counter-clockwise). Default is 45. +#'@param hatching_color Color of the hatching lines. Default is +#' \code{"#252525"}. +#'@param hatching_lwd The line width, a positive number. The interpretation is +#' device-specific, and some devices do not implement line widths less than +#' one. Default is 0.5. +#'@param hatching_cross A logical value indicating crosshatching. If TRUE, adds +#' a second set of lines in the opposite angle. Default is FALSE. +#'@examples +#' \dontrun{ +#'hatching_mask <- array(c(TRUE, FALSE, TRUE, FALSE), dim = c(lat = 2, lon = 2)) +#'lats <- 1:2 +#'lons <- 1:2 +#'image(lon_small, lat_small, matrix(1:4, nrow = 2)) +#'Hatching(hatching_mask = mask_small, lat = lat_small, lon = lon_small, +#' hatching_lwd = 2) +#' } +#'@export + +Hatching <- function(hatching_mask, lat, lon, data = NULL, + hatching_density = 10, hatching_angle = 45, + hatching_color = '#252525', hatching_lwd = 0.5, + hatching_cross = FALSE) { + + if (length(dim(hatching_mask)) != 2 || is.null(names(dim(hatching_mask)))) { + stop("The 'hatching_mask' array should have two named latitude and longitude dimensions") + } + if (!(any(names(dim(hatching_mask)) %in% .KnownLonNames()) && + any(names(dim(hatching_mask)) %in% .KnownLatNames()))) { + stop("Dimension names of 'hatching_mask' don't correspond to any + coordinates names supported by the esviz package.") + } + lon_dim <- names(dim(hatching_mask))[names(dim(hatching_mask)) %in% .KnownLonNames()] + lat_dim <- names(dim(hatching_mask))[names(dim(hatching_mask)) %in% .KnownLatNames()] + if (dim(hatching_mask)[[lat_dim]] != length(lat) | dim(hatching_mask)[[lon_dim]] != length(lon)) { + stop("The dimensions of the hatching 'hatching_mask' do not match the lengths of 'lat' and 'lon'.") + } + + # If 'hatching_mask' dimensions are reversed respect 'data', reorder them + if (!is.null(data)) { + if (!is.null(names(dim(data)))) { + if (!identical(names(dim(hatching_mask)), names(dim(data)))) { + hatching_mask <- aperm(hatching_mask, match(names(dim(data)), names(dim(hatching_mask)))) + } + } + } + + # Convert numeric values to logical values in hatching_mask + if (is.numeric(hatching_mask)) { + if (all(hatching_mask %in% c(0, 1))) { + hatching_mask <- hatching_mask == 1 + } else { + stop("The 'hatching_mask' array must have only TRUE/FALSE or 0/1.") + } + } else if (!is.logical(hatching_mask)) { + stop("The 'hatching_mask' array must have only TRUE/FALSE or 0/1.") + } + + # Check lon, lat + if (!is.numeric(lon) || !is.numeric(lat)) { + stop("Parameters 'lon' and 'lat' must be numeric vectors.") + } + + # Check data + if (!is.null(data)) { + if (!is.array(data)) { + stop("Parameter 'data' must be a numeric array.") + } + } + + # Check hatching_density + if (!is.null(hatching_density)) { + if (!is.numeric(hatching_density) || length(hatching_density) != 1) { + stop("Parameter 'hatching_density' must be a single numeric value.") + } + } + + # Check hatching_angle + if (!is.null(hatching_angle)) { + if (!is.numeric(hatching_angle) || length(hatching_angle) != 1) { + stop("Parameter 'hatching_angle' must be a single numeric value.") + } + } + + # Check hatching_color + if (!is.null(hatching_color)) { + if (!.IsColor(hatching_color)) { + stop("Parameter 'hatching_color' must be a valid colour identifier.") + } + } + + # Check hatching_lwd + if (!is.null(hatching_lwd)) { + if (!is.numeric(hatching_lwd) || length(hatching_lwd) != 1 || hatching_lwd <= 0) { + stop("Parameter 'hatching_lwd' must be a single positive numeric value.") + } + } + + # Check hatching_cross + if (!is.null(hatching_cross)) { + if (!is.logical(hatching_cross) || length(hatching_cross) != 1) { + stop("Parameter 'hatching_cross' must be a single logical value (TRUE or FALSE).") + } + } + + # Helper function to calculate cell edges (breaks between lat/lon points) + get_edges <- function(vec) { + mid <- diff(vec) / 2 + edges <- c(vec[1] - mid[1], vec[-length(vec)] + mid, vec[length(vec)] + mid[length(mid)]) + return(edges) + } + # Find lon and lat edges + x_edges <- get_edges(lon) + y_edges <- get_edges(lat) + # Loop through hatching_mask + for (i in seq_len(nrow(hatching_mask))) { + for (j in seq_len(ncol(hatching_mask))) { + if (hatching_mask[i, j]) { + # Calculate cell coordinates + x_min <- x_edges[i] + x_max <- x_edges[i + 1] + y_min <- y_edges[j] + y_max <- y_edges[j + 1] + # Draw grid cell + xs <- c(x_min, x_min, x_max, x_max) + ys <- c(y_min, y_max, y_max, y_min) + # Fill with diagonal lines + polygon(xs, ys, density = hatching_density, angle = hatching_angle, + border = NA, lwd = hatching_lwd, col = hatching_color) + if (hatching_cross) { + polygon(xs, ys, density = hatching_density, angle = -hatching_angle, + border = NA, lwd = hatching_lwd, col = hatching_color) + } + } + } + } +} + diff --git a/modules/Visualization/R/tmp/VizEquiMap.R b/modules/Visualization/R/tmp/VizEquiMap.R index 7751203e..6fef1036 100644 --- a/modules/Visualization/R/tmp/VizEquiMap.R +++ b/modules/Visualization/R/tmp/VizEquiMap.R @@ -216,6 +216,27 @@ #' the minimum value of the field. Takes TRUE by default. #'@param include_upper_boundary Logical value indicating whether to include #' the maximum value of the field. Takes TRUE by default. +#'@param hatching_mask Logical or binary (0/1) array with two named dimensions: +#' c(latitude, longitude). Hatching is applied to grid cells where +#' 'hatching_mask' is TRUE (or 1). Arrays with dimensions c(longitude, latitude) +#' are also accepted, but the resulting hatching may appear transposed. To +#' ensure correct alignment with the map, provide 'data'. The function will +#' compare the dimension order of 'hatching_mask' and 'data', and automatically +#' transpose 'hatching_mask' if the latitude and longitude dimensions appear to +#' be reversed. +#'@param hatching_density The density of shading lines, in lines per inch. A +#' zero value of density means no shading nor filling, whereas negative values +#' and NA suppress shading (and so allow color filling). NULL means that no +#' shading lines are drawn. Default is 10. +#'@param hatching_angle The slope of shading lines, given as an angle in degrees +#' (counter-clockwise). Default is 45. +#'@param hatching_color Color of the hatching lines. Default is +#' \code{"#252525"}. +#'@param hatching_lwd The line width, a positive number. The interpretation is +#' device-specific, and some devices do not implement line widths less than +#' one. Default is 0.5. +#'@param hatching_cross A logical value indicating crosshatching. If TRUE, adds +#' a second set of lines in the opposite angle. Default is FALSE. #'@param \dots Arguments to be passed to the method. Only accepts the following #' graphical parameters:\cr #' adj ann ask bg bty cex.sub cin col.axis col.lab col.main col.sub cra crt @@ -261,44 +282,47 @@ #' @importFrom s2dv InsertDim #'@export VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, - toptitle = NULL, sizetit = NULL, caption = NULL, - units = NULL, brks = NULL, cols = NULL, bar_limits = NULL, - triangle_ends = NULL, col_inf = NULL, col_sup = NULL, - colNA = NULL, color_fun = ClimPalette(), - square = TRUE, filled.continents = FALSE, - filled.oceans = FALSE, country.borders = FALSE, - coast_color = NULL, coast_width = 1, lake_color = NULL, - shapefile = NULL, shapefile_color = NULL, shapefile_lwd = 1, - contours = NULL, brks2 = NULL, contour_lwd = 0.5, - contour_color = 'black', contour_lty = 1, - contour_draw_label = TRUE, contour_label_scale = 1, - dots = NULL, dot_symbol = 4, dot_size = 1, - mask = NULL, mask_color = 'white', - arr_subsamp = floor(length(lon) / 30), arr_scale = 1, - arr_ref_len = 15, arr_units = "m/s", - arr_scale_shaft = 1, arr_scale_shaft_angle = 1, - axelab = TRUE, labW = FALSE, - lab_dist_x = NULL, lab_dist_y = NULL, degree_sym = FALSE, - intylat = 20, intxlon = 20, - xlonshft = 0, ylatshft = 0, xlabels = NULL, ylabels = NULL, - axes_tick_scale = 1, axes_label_scale = 1, - drawleg = TRUE, vertical = FALSE, subsampleg = NULL, - bar_extra_labels = NULL, draw_bar_ticks = TRUE, - draw_separators = FALSE, triangle_ends_scale = 1, - bar_label_digits = 4, bar_label_scale = 1, - units_scale = 1, bar_tick_scale = 1, - bar_extra_margin = rep(0, 4), - boxlim = NULL, boxcol = 'purple2', boxlwd = 5, - margin_scale = rep(1, 4), title_scale = 1, - caption_size = 0.8, numbfig = NULL, fileout = NULL, - width = 8, height = 5, size_units = 'in', - res = 100, include_lower_boundary = TRUE, - include_upper_boundary = TRUE, ...) { + toptitle = NULL, sizetit = NULL, caption = NULL, + units = NULL, brks = NULL, cols = NULL, bar_limits = NULL, + triangle_ends = NULL, col_inf = NULL, col_sup = NULL, + colNA = NULL, color_fun = ClimPalette(), + square = TRUE, filled.continents = FALSE, + filled.oceans = FALSE, country.borders = FALSE, + coast_color = NULL, coast_width = 1, lake_color = NULL, + shapefile = NULL, shapefile_color = NULL, shapefile_lwd = 1, + contours = NULL, brks2 = NULL, contour_lwd = 0.5, + contour_color = 'black', contour_lty = 1, + contour_draw_label = TRUE, contour_label_scale = 1, + dots = NULL, dot_symbol = 4, dot_size = 1, + mask = NULL, mask_color = 'white', + arr_subsamp = floor(length(lon) / 30), arr_scale = 1, + arr_ref_len = 15, arr_units = "m/s", + arr_scale_shaft = 1, arr_scale_shaft_angle = 1, + axelab = TRUE, labW = FALSE, + lab_dist_x = NULL, lab_dist_y = NULL, degree_sym = FALSE, + intylat = 20, intxlon = 20, + xlonshft = 0, ylatshft = 0, xlabels = NULL, ylabels = NULL, + axes_tick_scale = 1, axes_label_scale = 1, + drawleg = TRUE, vertical = FALSE, subsampleg = NULL, + bar_extra_labels = NULL, draw_bar_ticks = TRUE, + draw_separators = FALSE, triangle_ends_scale = 1, + bar_label_digits = 4, bar_label_scale = 1, + units_scale = 1, bar_tick_scale = 1, + bar_extra_margin = rep(0, 4), + boxlim = NULL, boxcol = 'purple2', boxlwd = 5, + margin_scale = rep(1, 4), title_scale = 1, + caption_size = 0.8, numbfig = NULL, fileout = NULL, + width = 8, height = 5, size_units = 'in', + res = 100, include_lower_boundary = TRUE, + include_upper_boundary = TRUE, hatching_mask = NULL, + hatching_density = 10, hatching_angle = 45, + hatching_color = "#252525", hatching_lwd = 0.5, + hatching_cross = FALSE, ...) { # Process the user graphical parameters that may be passed in the call ## Graphical parameters to exclude excludedArgs <- c("cex", "cex.axis", "cex.lab", "cex.main", "col", "din", "fig", "fin", "lab", "las", "lty", "lwd", "mai", "mar", "mgp", "new", "oma", "ps", "tck") userArgs <- .FilterUserGraphicArgs(excludedArgs, ...) - + # If there is any filenames to store the graphics, process them # to select the right device if (!is.null(fileout)) { @@ -306,12 +330,12 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, saveToFile <- deviceInfo$fun fileout <- deviceInfo$files } - + # Check lon, lat if (!is.numeric(lon) || !is.numeric(lat)) { stop("Parameters 'lon' and 'lat' must be numeric vectors.") } - + # Check var if (is.null(var)) { stop("Parameter 'var' cannot be NULL.") @@ -319,7 +343,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!is.array(var)) { stop("Parameter 'var' must be a numeric array.") } - + transpose <- FALSE if (!is.null(names(dim(var)))) { if (any(names(dim(var)) %in% .KnownLonNames()) && @@ -337,7 +361,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, lat_dim <- NULL warning("Parameter 'var' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") } - + if (length(dim(var)) > 2) { if (!is.null(lon_dim) & !is.null(lat_dim)) { dimnames <- names(dim(var)) @@ -352,11 +376,11 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } } } - + if (length(dim(var)) != 2) { stop("Parameter 'var' must be a numeric array with two dimensions.") } - + if ((dim(var)[1] == length(lon) && dim(var)[2] == length(lat)) || (dim(var)[2] == length(lon) && dim(var)[1] == length(lat))) { if (dim(var)[2] == length(lon) && dim(var)[1] == length(lat)) { @@ -375,7 +399,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else { stop("Parameters 'lon' and 'lat' must have as many elements as the number of cells along longitudes and latitudes in the input array 'var'.") } - + if (!is.null(names(dim(var)))) { if (names(dim(var)[1]) == lon_dim) { if (transpose) { @@ -390,16 +414,16 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # Transpose the input matrices because the base plot functions work directly # with dimensions c(lon, lat). - + if (transpose) { var <- t(var) } - + transpose <- FALSE - + names(dim(var)) <- c(lon_dim, lat_dim) dims <- dim(var) - + # Check varu and varv if (!is.null(varu) && !is.null(varv)) { if (!is.array(varu) || !(length(dim(varu)) == 2)) { @@ -411,7 +435,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else if (!is.null(varu) || !is.null(varv)) { stop("Only one of the components 'varu' or 'varv' has been provided. Both must be provided.") } - + if (!is.null(varu) && !is.null(varv)) { if (!all(dim(varu) %in% dim(varv)) || !all(names(dim(varv)) %in% names(dim(varu)))) { stop("Parameter 'varu' and 'varv' must have equal dimensions and dimension names.") @@ -419,7 +443,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, varv <- t(varv) names(dim(varv)) <- names(dim(varu)) } - + if (is.null(lon_dim)) { names(dim(varu)) <- NULL names(dim(varv)) <- NULL @@ -435,7 +459,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } } - + if ((dim(varu)[1] == dims[1] && dim(varu)[2] == dims[2]) || (dim(varu)[2] == dims[1] && dim(varu)[1] == dims[2])) { if (dim(varu)[2] == dims[1] && dim(varu)[1] == dims[2]) { @@ -459,21 +483,21 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, varu <- t(varu) varv <- t(varv) } - + transpose <- FALSE - + } - + # Check contours if (!is.null(contours)) { if (!is.array(contours) || !(length(dim(contours)) == 2)) { stop("Parameter 'contours' must be a numerical array with two dimensions.") } } - - + + if (!is.null(contours)) { - + if (is.null(lon_dim)) { names(dim(contours)) <- NULL } else { @@ -487,8 +511,8 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, warning("Parameters 'contours' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") } } - - + + transpose <- FALSE if ((dim(contours)[1] == dims[1] && dim(contours)[2] == dims[2]) || (dim(contours)[2] == dims[1] && dim(contours)[1] == dims[2])) { @@ -508,15 +532,15 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else { stop("Parameters 'lon' and 'lat' must have as many elements as the number of cells along longitudes and latitudes in the input array 'contours'.") } - + if (transpose) { contours <- t(contours) } - + transpose <- FALSE - + } - + # Check toptitle if (is.null(toptitle) || is.na(toptitle)) { toptitle <- '' @@ -524,7 +548,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!is.character(toptitle)) { stop("Parameter 'toptitle' must be a character string.") } - + # Check sizetit if (!is.null(sizetit)) { warning("Parameter 'sizetit' is obsolete. Use 'title_scale' instead.") @@ -533,7 +557,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } title_scale <- sizetit } - + # Check caption if (!is.null(caption)) { if (!is.character(caption)) { @@ -555,30 +579,30 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!is.logical(vertical)) { stop("Parameter 'vertical' must be TRUE or FALSE.") } - + tmp <- .create_var_limits(data = var, brks = brks, bar_limits = bar_limits, drawleg = drawleg) var_limits <- tmp$var_limits drawleg <- tmp$drawleg - + # Check: brks, cols, subsampleg, bar_limits, color_fun, bar_extra_labels, draw_bar_ticks # draw_separators, triangle_ends_scale, label_scale, units, units_scale, # bar_label_digits # Build: brks, cols, bar_limits, col_inf, col_sup colorbar <- ColorBarContinuous(brks, cols, vertical = vertical, subsampleg, bar_limits, - var_limits, triangle_ends, col_inf, col_sup, color_fun, FALSE, - extra_labels = bar_extra_labels, draw_ticks = draw_bar_ticks, - draw_separators = draw_separators, - triangle_ends_scale = triangle_ends_scale, - label_scale = bar_label_scale, title = units, - title_scale = units_scale, tick_scale = bar_tick_scale, - extra_margin = bar_extra_margin, label_digits = bar_label_digits) + var_limits, triangle_ends, col_inf, col_sup, color_fun, FALSE, + extra_labels = bar_extra_labels, draw_ticks = draw_bar_ticks, + draw_separators = draw_separators, + triangle_ends_scale = triangle_ends_scale, + label_scale = bar_label_scale, title = units, + title_scale = units_scale, tick_scale = bar_tick_scale, + extra_margin = bar_extra_margin, label_digits = bar_label_digits) brks <- colorbar$brks cols <- colorbar$cols col_inf <- colorbar$col_inf col_sup <- colorbar$col_sup bar_limits <- c(head(brks, 1), tail(brks, 1)) - + # Adjust 'var' values according to 'include_lower_boundary' and 'include_upper_boundary'. # This adjustment ensures that, by default, values at the lower limit of the color bars ('brks[1]') are included. # Refer to issue #15 in the esviz GitLab for more details. @@ -588,7 +612,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!include_upper_boundary) { var[var == tail(brks, 1)] <- tail(brks, 1) + tail(diff(brks), 1)/10 } - + # Check colNA if (is.null(colNA)) { if ('na_color' %in% names(attributes(cols))) { @@ -602,12 +626,12 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else if (!.IsColor(colNA)) { stop("Parameter 'colNA' must be a valid colour identifier.") } - + # Check square if (!is.logical(square)) { stop("Parameter 'square' must be logical.") } - + # Check filled.continents if (is.null(filled.continents)) { if (!square) { @@ -624,7 +648,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else { continent_color <- gray(0.5) } - + # Check filled.oceans if (!.IsColor(filled.oceans) & !is.logical(filled.oceans)) { stop("Parameter 'filled.oceans' must be logical or a colour identifier.") @@ -634,12 +658,12 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else if (filled.oceans) { ocean_color <- "light blue" } - + # Check country.borders if (!is.logical(country.borders)) { stop("Parameter 'country.borders' must be logical.") } - + # Check coast_color if (is.null(coast_color)) { if (filled.continents) { @@ -651,19 +675,19 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!.IsColor(coast_color)) { stop("Parameter 'coast_color' must be a valid colour identifier.") } - + # Check coast_width if (!is.numeric(coast_width)) { stop("Parameter 'coast_width' must be numeric.") } - + # Check lake_color if (!is.null(lake_color)) { if (!.IsColor(lake_color)) { stop("Parameter 'lake_color' must be a valid colour identifier.") } } - + # Check shapefile if (!is.null(shapefile)) { if (is.list(shapefile)) { @@ -697,7 +721,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } } } - + # Check shapefile_col if (is.null(shapefile_color)) { if (filled.continents) { @@ -709,7 +733,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!.IsColor(shapefile_color)) { stop("Parameter 'shapefile_color' must be a valid colour identifier.") } - + # Check brks2 if (is.null(brks2)) { if (is.null(contours)) { @@ -723,32 +747,32 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, brks2 <- signif(seq(ll, ul, length.out = length(brks)), 2) } } - + # Check contour_lwd if (!is.numeric(contour_lwd)) { stop("Parameter 'contour_lwd' must be numeric.") } - + # Check contour_color if (!.IsColor(contour_color)) { stop("Parameter 'contour_color' must be a valid colour identifier.") } - + # Check contour_lty if (!is.numeric(contour_lty) && !is.character(contour_lty)) { stop("Parameter 'contour_lty' must be either a number or a character string.") } - + # Check contour_draw_label if (!is.logical(contour_draw_label)) { stop("Parameter 'contour_draw_label' must be logical.") } - + # Check contour_label_scale if (!is.numeric(contour_label_scale)) { stop("Parameter 'contour_label_scale' must be numeric.") } - + # Check dots if (!is.null(dots)) { if (!is.array(dots) || !(length(dim(dots)) %in% c(2, 3))) { @@ -757,7 +781,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (length(dim(dots)) == 2) { dim(dots) <- c(1, dim(dots)) } - + if (is.null(lon_dim)) { names(dim(dots)) <- NULL } else { @@ -771,7 +795,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, warning("Parameters 'dots' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") } } - + transpose <- FALSE if ((dim(dots)[2] == dims[1] && dim(dots)[3] == dims[2]) || (dim(dots)[3] == dims[1] && dim(dots)[2] == dims[2])) { @@ -791,15 +815,15 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } else { stop("Parameter 'dots' must have same number of longitudes and latitudes as 'var'.") } - + if (transpose) { dots <- aperm(dots, c(1, 3, 2)) } - + transpose <- FALSE - + } - + # Check dot_symbol and dot_size if (!is.null(dots)) { if (!is.numeric(dot_symbol) && !is.character(dot_symbol)) { @@ -853,7 +877,15 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, stop("Parameter 'mask_color' must be a valid colour identifier.") } } - + + # Check hatching_mask + if (!is.null(hatching_mask)) { + hatching_mask <- drop(hatching_mask) + if (!is.array(hatching_mask) || any(!names(dim(hatching_mask)) %in% c(lon_dim, lat_dim))) { + stop("Parameter 'hatching_mask' must have two dimensions named as the longitude and latitude dimensions in 'var'.") + } + } + # Check arrow parameters if (!is.numeric(arr_subsamp)) { stop("Parameter 'arr_subsamp' must be numeric.") @@ -873,7 +905,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!is.numeric(arr_scale_shaft_angle)) { stop("Parameter 'arr_scale_shaft_angle' must be numeric.") } - + # Check axis parameters if (!is.logical(axelab)) { stop("Parameter 'axelab' must be logical.") @@ -917,12 +949,12 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, stop("Parameter 'ylabels' must be a vector of character string.") } } - + # Check legend parameters if (!is.logical(drawleg)) { stop("Parameter 'drawleg' must be logical.") } - + # Check box parameters if (!is.null(boxlim)) { if (!is.list(boxlim)) { @@ -956,12 +988,12 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } } } - + # Check margin_scale if (!is.numeric(margin_scale) || length(margin_scale) != 4) { stop("Parameter 'margin_scale' must be a numeric vector of length 4.") } - + # Check title_scale if (!is.numeric(title_scale)) { stop("Parameter 'title_scale' must be numeric.") @@ -976,17 +1008,17 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, caption_size <- 1 } } - + # Check axes_tick_scale if (!is.numeric(axes_tick_scale)) { stop("Parameter 'axes_tick_scale' must be numeric.") } - + # Check axes_label_scale if (!is.numeric(axes_label_scale)) { stop("Parameter 'axes_label_scale' must be numeric.") } - + # Check numbfig if (!is.null(numbfig)) { if (!is.numeric(numbfig)) { @@ -1004,7 +1036,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, contour_lwd <- contour_lwd * scale } } - + # # Input arguments # ~~~~~~~~~~~~~~~~~ @@ -1021,19 +1053,19 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, latmax <- ceiling(max(lat) / 10) * 10 lonmin <- floor(min(lon) / 10) * 10 lonmax <- ceiling(max(lon) / 10) * 10 - + # # Plotting the map # ~~~~~~~~~~~~~~~~~~ # - + # Open connection to graphical device if (!is.null(fileout)) { saveToFile(fileout) } else if (names(dev.cur()) == 'null device') { dev.new(units = size_units, res = res, width = width, height = height) } - + # # Defining the layout # ~~~~~~~~~~~~~~~~~~~~~ @@ -1069,7 +1101,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, } ylabs <- paste(as.character(abs(ypos)), letters, sep = '') } - + # X axis label if (!is.null(xlabels)) { xpos <- seq(lonmin, lonmax, intxlon) + xlonshft @@ -1117,7 +1149,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (!is.null(varu)) { margins[1] <- margins[1] + 2.2 * units_scale } - + if (drawleg) { if (!is.null(caption)) { margins[2] <- margins[2] + num_lines*0.5 @@ -1131,9 +1163,11 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, layout(matrix(c(1, 2, 3), ncol = 1, nrow = 3), heights = c(5, 1, 0.2 + num_lines*caption_size/4)) } - } else { + } else { if (vertical) { # vertical bar, no caption - layout(matrix(1:2, ncol = 2, nrow = 1), widths = c(5, 1.3)) + layout(matrix(c(1, 2, 1, 3), ncol = 2, nrow = 2, byrow = TRUE), + widths = c(5, 1.3), + heights = c(0.1, 5)) } else { # horizontal bar, no caption layout(matrix(1:2, ncol = 1, nrow = 2), heights = c(5, 1)) } @@ -1150,7 +1184,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, par(userArgs) par(mar = margins, cex.main = cex_title, cex.axis = cex_axes_labels, mgp = c(0, spaceticklab, 0), las = 0) - + #NOTE: Here creates the window for later plot. If 'usr' for par() is not specified, # use the lat/lon as the borders. If 'usr' is specified, use the assigned values. if (is.null(userArgs$usr)) { @@ -1160,17 +1194,17 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, ylim_cal <- c(latb$x[1] - (latb$x[2] - latb$x[1]) / 2, latb$x[length(latb$x)] + (latb$x[2] - latb$x[1]) / 2) plot.window(xlim = xlim_cal, ylim = ylim_cal, xaxs = 'i', yaxs = 'i') -# Below is Old code. The border grids are only half plotted. -# plot.window(xlim = range(lonb$x, finite = TRUE), ylim = range(latb$x, finite = TRUE), -# xaxs = 'i', yaxs = 'i') + # Below is Old code. The border grids are only half plotted. + # plot.window(xlim = range(lonb$x, finite = TRUE), ylim = range(latb$x, finite = TRUE), + # xaxs = 'i', yaxs = 'i') } else { plot.window(xlim = par("usr")[1:2], ylim = par("usr")[3:4], xaxs = 'i', yaxs = 'i') } - + if (axelab) { lab_distance_y <- ifelse(is.null(lab_dist_y), spaceticklab + 0.2, lab_dist_y) lab_distance_x <- ifelse(is.null(lab_dist_x), spaceticklab + cex_axes_labels / 2 - 0.3, lab_dist_x) - + axis(2, at = ypos, labels = ylabs, cex.axis = cex_axes_labels, tcl = cex_axes_ticks, mgp = c(0, lab_distance_y, 0)) axis(1, at = xpos, labels = xlabs, cex.axis = cex_axes_labels, tcl = cex_axes_ticks, @@ -1200,19 +1234,19 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, col = c(col_inf_image, cols, col_sup_image)) } if (!is.null(contours)) { -#NOTE: 'labcex' is the absolute size of contour labels. Parameter 'contour_label_scale' -# is provided in PlotEquiMap() but it was not used. Here, 'cex_axes_labels' was used -# and it was calculated from 'axes_label_scale', the size of lat/lon axis label. -# It is changed to use contour_label_scale*par('cex'). + #NOTE: 'labcex' is the absolute size of contour labels. Parameter 'contour_label_scale' + # is provided in PlotEquiMap() but it was not used. Here, 'cex_axes_labels' was used + # and it was calculated from 'axes_label_scale', the size of lat/lon axis label. + # It is changed to use contour_label_scale*par('cex'). contour(lonb$x, latb$x, contours[lonb$ix, latb$ix], levels = brks2, method = "edge", add = TRUE, -# labcex = cex_axes_labels, + # labcex = cex_axes_labels, labcex = contour_label_scale * par("cex"), lwd = contour_lwd, lty = contour_lty, col = contour_color, drawlabels = contour_draw_label) } - - + + # # Adding black dots or symbols # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1227,7 +1261,19 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, lwd = dot_size[counter] * 3 / sqrt(sqrt(length(var)))) } } - + + # + # Adding hatching + # ~~~~~~~~~~~~~~~~~ + # + if (!is.null(hatching_mask)) { + Hatching(hatching_mask = hatching_mask, lat = lat, lon = lon, data = var, + hatching_density = hatching_density, + hatching_angle = hatching_angle, + hatching_color = hatching_color, hatching_lwd = hatching_lwd, + hatching_cross = hatching_cross) + } + # # Adding a mask # ~~~~~~~~~~~~~~~ @@ -1271,7 +1317,9 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # Plotting continents # ~~~~~~~~~~~~~~~~~~~~~ # - wrap_vec <- c(lonb$x[1], lonb$x[1] + 360) + lonb_c <- lonb + lonb_c$x[1] <- lonb_c$x[1] - abs(diff(lonb_c$x)[1]) + wrap_vec <- c(lonb_c$x[1], lonb_c$x[1] + 360) old_lwd <- par('lwd') par(lwd = coast_width) # If [0, 360], use GEOmap; if [-180, 180], use maps::map @@ -1280,7 +1328,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # GEOmap has better lakes. coast <- maps::map(interior = country.borders, wrap = wrap_vec, fill = filled.continents, add = TRUE, plot = FALSE) - + if (filled.continents) { polygon(coast, col = continent_color, border = coast_color, lwd = coast_width) } else { @@ -1290,22 +1338,22 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, maps::map('lakes', add = TRUE, wrap = wrap_vec, fill = filled.continents, col = lake_color) } par(lwd = old_lwd) - + # filled.oceans if (filled.oceans) { - old_lwd <- par('lwd') - par(lwd = coast_width) - - outline <- maps::map(wrap = wrap_vec, fill = T, plot = FALSE) # must be fill = T - xbox <- wrap_vec + c(-2, 2) - ybox <- c(-92, 92) - outline$x <- c(outline$x, NA, c(xbox, rev(xbox), xbox[1])) - outline$y <- c(outline$y, NA, rep(ybox, each = 2), ybox[1]) - polypath(outline, col = ocean_color, rule = 'evenodd', border = NA) - - par(lwd = old_lwd) - } - + old_lwd <- par('lwd') + par(lwd = coast_width) + + outline <- maps::map(wrap = wrap_vec, fill = T, plot = FALSE) # must be fill = T + xbox <- wrap_vec + c(-2, 2) + ybox <- c(-92, 92) + outline$x <- c(outline$x, NA, c(xbox, rev(xbox), xbox[1])) + outline$y <- c(outline$y, NA, rep(ybox, each = 2), ybox[1]) + polypath(outline, col = ocean_color, rule = 'evenodd', border = NA) + + par(lwd = old_lwd) + } + # Plot shapefile #NOTE: the longitude range cannot cut shapefile range, or not all the shapefile will be plotted. if (!is.null(shapefile)) { @@ -1313,7 +1361,7 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, fill = filled.continents, add = TRUE, plot = TRUE, lwd = shapefile_lwd, col = shapefile_color) } - + box() # Draw rectangle on the map if (!is.null(boxlim)) { @@ -1357,15 +1405,15 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, lattab <- InsertDim(latb$x, 1, length(lonb$x), name = 'lon') varplotu <- varu[lonb$ix, latb$ix] varplotv <- varv[lonb$ix, latb$ix] - + # Select a subsample af the points to an arrow #for each "subsample" grid point sublon <- seq(1,length(lon), arr_subsamp) sublat <- seq(1,length(lat), arr_subsamp) - + uaux <- lontab[sublon, sublat] + varplotu[sublon, sublat] * 0.5 * arr_scale vaux <- lattab[sublon, sublat] + varplotv[sublon, sublat] * 0.5 * arr_scale - + lenshaft <- 0.18 * arr_scale * arr_scale_shaft angleshaft <- 12 * arr_scale_shaft_angle # Plot Wind @@ -1377,8 +1425,8 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # Plotting an arrow at the bottom of the plot for the legend posarlon <- lonb$x[1] + (lonmax - lonmin) * 0.1 posarlat <- latmin - ((latmax - latmin) + 1) / par('pin')[2] * - (spaceticklab + 0.2 + cex_axes_labels + 0.6 * units_scale) * par('csi') - + (spaceticklab + 0.2 + cex_axes_labels + 0.6 * units_scale) * par('csi') + arrows(posarlon, posarlat, posarlon + 0.5 * arr_scale * arr_ref_len, posarlat, length = lenshaft, angle = angleshaft, @@ -1404,16 +1452,19 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, if (drawleg) { if (vertical) { par(mfg = c(2, 1)) - base_line <- 1 + at_value <- par("usr")[1] - (0.38 + (num_lines - 1) * 0.15) } else { par(mfg = c(3, 1)) - base_line <- 1 + at_value <- NA } } else { par(mfg = c(2, 1)) - base_line <- 1 + at_value <- NA } - mtext(caption, side = 1, line = base_line, adj = 0, + base_line <- 1 + mtext(caption, side = 1, line = base_line, + at = at_value, # left placement + adj = 0, cex = caption_size, col = "black") } @@ -1423,23 +1474,27 @@ VizEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # if (drawleg) { if (vertical) { - par(mfg = c(1, 2)) + if(is.null(caption)) { + par(mfg = c(2, 1)) + } else { + par(mfg = c(1, 2)) + } } else { if (!is.null(caption)) { par(mfg = c(2, 1)) } } ColorBarContinuous(brks, cols, vertical = vertical, subsampleg, bar_limits, - var_limits, triangle_ends, col_inf = col_inf, col_sup = col_sup, - extra_labels = bar_extra_labels, draw_ticks = draw_bar_ticks, - draw_separators = draw_separators, title = units, - title_scale = units_scale, triangle_ends_scale = triangle_ends_scale, - label_scale = bar_label_scale, tick_scale = bar_tick_scale, - extra_margin = bar_extra_margin, label_digits = bar_label_digits) - } - + var_limits, triangle_ends, col_inf = col_inf, col_sup = col_sup, + extra_labels = bar_extra_labels, draw_ticks = draw_bar_ticks, + draw_separators = draw_separators, title = units, + title_scale = units_scale, triangle_ends_scale = triangle_ends_scale, + label_scale = bar_label_scale, tick_scale = bar_tick_scale, + extra_margin = bar_extra_margin, label_digits = bar_label_digits) + } + # If the graphic was saved to file, close the connection with the device if (!is.null(fileout)) dev.off() - + invisible(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup)) } -- GitLab