R/utils-array.R

In gridpattern: 'grid' Pattern Grobs

#' Generate an RGBA array and create a raster grob to fill the region
#'
#' the boundary of the shaded region will be used to generate a alpha mask
#' so that the array conforms to the shape.
#'
#' @inheritParams create_pattern_none
#' @param array_fn Array function to use
#'
#' @return rasterGrob
#'
#' @noRd
create_pattern_array <- function(
	params,
	boundary_df,
	aspect_ratio,
	legend,
	array_fn = create_magick_pattern_as_array
) {
	if (anyNA(boundary_df$x) || anyNA(boundary_df$y)) {
		return(grid::nullGrob())
	}

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# What is the size of the bounding box of the boundary for this pattern?
	# Calculate the centre (x,y) and (width,height)
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	npc_xrange <- range(boundary_df$x, na.rm = TRUE)
	npc_yrange <- range(boundary_df$y, na.rm = TRUE)
	npc_width <- abs(diff(npc_xrange))
	npc_height <- abs(diff(npc_yrange))
	npc_x <- mean(npc_xrange)
	npc_y <- mean(npc_yrange)

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# Calculate the dimensions of the bounding box and use the integer
	# values of these to define the image dimensions
	# res of 72 DPI is the imagemagick default
	# Ideally could detect resolution of graphics device and use that as default...
	# NB. large pixel sizes can cause errors with getting 'placeholder' images
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	res <- params$pattern_res # defaults to 72 DPI
	in_vp_width <- grid::convertWidth(unit(1, 'npc'), 'inches', valueOnly = TRUE)
	in_width <- npc_width * in_vp_width
	in_height <- npc_height * in_vp_width / aspect_ratio
	arr_width <- as.integer(res * in_width)
	arr_height <- as.integer(res * in_height)
	if (arr_width == 0L || arr_height == 0L) {
		return(nullGrob(name = params$pattern))
	}

	# Override type for better looking legend when tiling
	if (legend) {
		if (params$pattern_type %in% c('tile', 'none')) {
			params$pattern_type <- 'fit'
		}
	}

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# The image and the boundary_df bbox are coincident.  To mask the image,
	# scale the boundary_df to encompass the full 'npc' range from 0 to 1.
	# An alpha mask will be created to encompass the whole of the image, and
	# the resulting image will be placed at the bbox location.
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	scaled_boundary_df <- boundary_df
	scaled_boundary_df$x <- (scaled_boundary_df$x - npc_xrange[1]) / npc_width
	scaled_boundary_df$y <- (scaled_boundary_df$y - npc_yrange[1]) / npc_height

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# check for issues e.g. Zero area regions
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	if (any(is.nan(scaled_boundary_df$x)) || any(is.nan(scaled_boundary_df$y))) {
		return(grid::nullGrob())
	}

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# Fetch an image of the required dimensions.
	# Create a mask of the required dimensions from the scaled boundary_df
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	rgba_arr <- array_fn(arr_width, arr_height, params, legend)

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# Sanity check the array conforms to what we want.  This is especially
	# important as we're allowing users to generate arrays for patterns
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	if (
		!(is.array(rgba_arr) &&
			is.numeric(rgba_arr) &&
			length(dim(rgba_arr) == 3) &&
			dim(rgba_arr)[3] == 4 &&
			dim(rgba_arr)[1] == arr_height &&
			dim(rgba_arr)[2] == arr_width &&
			!anyNA(rgba_arr) &&
			min(rgba_arr) >= 0 &&
			max(rgba_arr) <= 1)
	) {
		warn(glue(
			"create_pattern_array(): Expecting a numeric RGBA array with dim = c({arr_height}, {arr_width}, 4) ",
			"but instead got a {deparse(class(rgba_arr))} ",
			"of type {typeof(rgba_arr)} with dimensions {deparse(dim(rgba_arr))}"
		))

		rgba_arr <- array(c(0, 1), dim = c(arr_height, arr_width, 4))
	}

	boundary_mask <- convert_polygon_df_to_alpha_channel(
		scaled_boundary_df,
		width = arr_width,
		height = arr_height
	)

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# Stack the current image array with an alpha channel.
	# Using a custom version of `abind::abind()` so I could avoid having it
	# as another package dependency
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	if (is.na(params$pattern_alpha)) {
		alpha <- 1
	} else {
		alpha <- params$pattern_alpha
	}
	rgba_arr[,, 4] <- rgba_arr[,, 4] * boundary_mask * alpha

	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	# Create a rasterGrob image at the location of the 'boundary_df' bounding box.
	#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	raster_grob <- rasterGrob(
		rgba_arr,
		x = npc_x,
		y = npc_y,
		width = npc_width,
		height = npc_height,
		name = params$pattern
	)
	raster_grob
}