R/pattern-both-text.R

In gridpattern: 'grid' Pattern Grobs

#' Text character patterned grobs
#'
#' `grid.pattern_text()` draws a text character pattern onto the graphic device.
#'
#' @inheritParams grid.pattern_regular_polygon
#' @inheritParams alphaMaskGrob
#' @param shape A character or expression vector.
#'              See `label` argument of [grid::textGrob()] for more details.
#' @param size Fontsize
#' @param fontfamily The font family.  See [grid::gpar()] for more details.
#' @param fontface The font face.  See [grid::gpar()] for more details.
#' @return A grid grob object invisibly.  If `draw` is `TRUE` then also draws to the graphic device as a side effect.
#' @examples
#' if (capabilities("png") &&
#'     gridpattern:::device_supports_unicode()) {
#'   x_hex <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6))
#'   y_hex <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6))
#'
#'   playing_card_symbols <- c("\u2660", "\u2665", "\u2666", "\u2663")
#'   grid.pattern_text(x_hex, y_hex,
#'                    shape = playing_card_symbols,
#'                    colour = c("black", "red", "red", "black"),
#'                    size = 18, spacing = 0.1, angle = 0)
#' }
#' @export
grid.pattern_text <- function(
	x = c(0, 0, 1, 1),
	y = c(1, 0, 0, 1),
	id = 1L,
	...,
	colour = gp$col %||% "grey20",
	angle = 30,
	spacing = 0.05,
	xoffset = 0,
	yoffset = 0,
	units = "snpc",
	scale = 0.5,
	shape = "X",
	grid = "square",
	type = NULL,
	subtype = NULL,
	rot = 0,
	alpha = gp$alpha %||% NA_real_,
	size = gp$fontsize %||% 12,
	fontfamily = gp$fontfamily %||% "sans",
	fontface = gp$fontface %||% "plain",
	use_R4.1_masks = getOption(
		"ggpattern_use_R4.1_masks",
		getOption("ggpattern_use_R4.1_features")
	),
	png_device = NULL,
	res = getOption("ggpattern_res", 72),
	default.units = "npc",
	name = NULL,
	gp = gpar(),
	draw = TRUE,
	vp = NULL
) {
	if (missing(colour) && hasName(l <- list(...), "color")) {
		colour <- l$color
	}
	grid.pattern(
		"text",
		x,
		y,
		id,
		colour = colour,
		angle = angle,
		spacing = spacing,
		xoffset = xoffset,
		yoffset = yoffset,
		units = units,
		scale = scale,
		shape = shape,
		grid = grid,
		type = type,
		subtype = subtype,
		rot = rot,
		alpha = alpha,
		size = size,
		fontfamily = fontfamily,
		fontface = fontface,
		use_R4.1_masks = use_R4.1_masks,
		png_device = png_device,
		res = res,
		default.units = default.units,
		name = name,
		gp = gp,
		draw = draw,
		vp = vp
	)
}

create_pattern_text <- function(params, boundary_df, aspect_ratio, legend = FALSE) {
	# work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio
	default.units <- "bigpts"
	boundary_df <- convert_polygon_df_units(boundary_df, default.units)
	params <- convert_params_units(params, default.units)
	vpm <- get_vp_measurements(default.units)

	spacing <- params$pattern_spacing
	grid <- params$pattern_grid

	# create grid of points large enough to cover viewport no matter the angle
	grid_xy <- get_xy_grid(params, vpm)

	# vectorize fill, col, lwd, lty, density, rot, and shape
	col <- update_alpha_col(params$pattern_colour, params$pattern_alpha)
	fontsize <- params$pattern_size
	fontfamily <- params$pattern_fontfamily
	fontface <- params$pattern_fontface

	rot <- params$pattern_rot + params$pattern_angle
	shape <- params$pattern_shape

	n_par <- max(lengths(list(col, fontsize, fontfamily, fontface, rot, shape)))

	col <- rep_len(col, n_par)
	fontsize <- rep_len(fontsize, n_par)
	fontfamily <- rep_len(fontfamily, n_par)
	fontface <- rep_len(fontface, n_par)
	rot <- rep_len(rot, n_par)
	shape <- rep_len(shape, n_par)

	# compute pattern matrix of graphical elements (e.g. fill colors)
	if (is.null(params$pattern_type) || is.na(params$pattern_type)) {
		params$pattern_type <- switch(grid, square = "square", "hex")
	}
	m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par)

	gl <- gList()
	for (i_par in seq(n_par)) {
		if (shape[i_par] == "null") {
			next
		}
		xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing)
		if (length(xy_par$x) == 0) {
			next
		}

		# rotate by 'angle'
		xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y)

		gp <- gpar(
			col = col[i_par],
			fontsize = fontsize[i_par],
			fontfamily = fontfamily[i_par],
			fontface = fontface[i_par]
		)

		# create grob for interior polygons
		name <- paste0("text.", i_par)

		grob <- textGrob(
			label = shape[i_par],
			x = xy_par$x,
			y = xy_par$y,
			rot = rot[i_par],
			just = "center",
			default.units = "bigpts",
			name = name,
			gp = gp
		)

		gl <- append_gList(gl, grob)
	}
	maskee <- gTree(children = gl)
	masker <- convert_polygon_df_to_polygon_grob(
		boundary_df,
		default.units = "bigpts",
		gp = gpar(fill = "white", col = NA, lwd = 0)
	)
	png_device <- params$pattern_png_device
	alphaMaskGrob(
		maskee,
		masker,
		use_R4.1_masks = params$pattern_use_R4.1_masks,
		png_device = png_device,
		res = params$pattern_res,
		name = "text"
	)
}