R/Hatching.R

In esviz: Plotting Functions for Climate Science and Services

#' 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.
#'   
#' @return Invisibly returns \code{NULL}. The function is intended to be used as 
#' an overlay layer (e.g., when called within \code{VizEquiMap()}). It draws 
#' hatching or crosshatching onto an existing graphics device. 
#'   
#' @examples
#' mask_small <- array(c(TRUE, FALSE, TRUE, FALSE), dim = c(lat = 2, lon = 2))
#' lat_small <- 1:2
#' lon_small <- 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)
        }
      }
    }
  }
  invisible(NULL)
}