Nothing
#' Create patterned grobs by pattern name
#'
#' `grid.pattern()` draws patterned shapes onto the graphic device.
#' `patternGrob()` returns the grid grob objects.
#' `names_pattern` is a character vector of builtin patterns.
#'
#' Here is a list of the various patterns supported:
#'
#' \describe{
#' \item{ambient}{Noise array patterns onto the graphic device powered by the `ambient` package.
#' See [grid.pattern_ambient()] for more information.}
#' \item{aRtsy}{Patterns powered by the `aRtsy` package.
#' See [grid.pattern_aRtsy()] for more information.}
#' \item{circle}{Circle geometry patterns.
#' See [grid.pattern_circle()] for more information.}
#' \item{crosshatch}{Crosshatch geometry patterns.
#' See [grid.pattern_crosshatch()] for more information.}
#' \item{gradient}{Gradient array/geometry patterns.
#' See [grid.pattern_gradient()] for more information.}
#' \item{image}{Image array patterns.
#' See [grid.pattern_image()] for more information.}
#' \item{magick}{`imagemagick` array patterns.
#' See [grid.pattern_magick()] for more information.}
#' \item{none}{Does nothing.
#' See [grid::grid.null()] for more information.}
#' \item{pch}{Plotting character geometry patterns.
#' See [grid.pattern_pch()] for more information.}
#' \item{placeholder}{Placeholder image array patterns.
#' See [grid.pattern_placeholder()] for more information.}
#' \item{plasma}{Plasma array patterns.
#' See [grid.pattern_plasma()] for more information.}
#' \item{polygon_tiling}{Polygon tiling patterns.
#' See [grid.pattern_polygon_tiling()] for more information.}
#' \item{regular_polygon}{Regular polygon patterns.
#' See [grid.pattern_regular_polygon()] for more information.}
#' \item{rose}{Rose array/geometry patterns.
#' See [grid.pattern_rose()] for more information.}
#' \item{stripe}{Stripe geometry patterns.
#' See [grid.pattern_stripe()] for more information.}
#' \item{text}{Text array/geometry patterns.
#' See [grid.pattern_text()] for more information.}
#' \item{wave}{Wave geometry patterns.
#' See [grid.pattern_wave()] for more information.}
#' \item{weave}{Weave geometry patterns.
#' See [grid.pattern_weave()] for more information.}
#' \item{Custom geometry-based patterns}{See \url{https://trevorldavis.com/R/gridpattern/dev/articles/developing-patterns.html} for more information.}
#' \item{Custom array-based patterns}{See \url{https://trevorldavis.com/R/gridpattern/dev/articles/developing-patterns.html} for more information.}
#' }
#'
#' @inheritParams grid::polygonGrob
#' @param pattern Name of pattern. See Details section for a list of supported patterns.
#' @param x A numeric vector or unit object specifying x-locations of the pattern boundary.
#' @param y A numeric vector or unit object specifying y-locations of the pattern boundary.
#' @param id A numeric vector used to separate locations in x, y into multiple boundaries.
#' All locations within the same `id` belong to the same boundary.
#' @param ... Pattern parameters.
#' @param legend Whether this is intended to be drawn in a legend or not.
#' @param prefix Prefix to prepend to the name of each of the pattern parameters in `...`.
#' For compatibility with `ggpattern` most underlying functions assume parameters beginning with `pattern_`.
#' @param default.units A string indicating the default units to use if `x` or `y`
#' are only given as numeric vectors.
#' @return A grid grob object (invisibly in the case of `grid.pattern()`).
#' If `draw` is `TRUE` then `grid.pattern()` also draws to the graphic device as a side effect.
#' @examples
#' print(names_pattern)
#' \donttest{# May take more than 5 seconds on CRAN servers
#' 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))
#'
#' # geometry-based patterns
#' # 'stripe' pattern
#' grid::grid.newpage()
#' grid.pattern("stripe", x_hex, y_hex,
#' colour="black", fill=c("yellow", "blue"), density = 0.5)
#'
#' # Can alternatively use "gpar()" to specify colour and line attributes
#' grid::grid.newpage()
#' grid.pattern("stripe", x_hex, y_hex,
#' gp = grid::gpar(col="blue", fill="red", lwd=2))
#'
#' # 'weave' pattern
#' grid::grid.newpage()
#' grid.pattern("weave", x_hex, y_hex, type = "satin",
#' colour = "black", fill = "lightblue", fill2 = "yellow",
#' density = 0.3)
#'
#' # 'regular_polygon' pattern
#' grid::grid.newpage()
#' grid.pattern_regular_polygon(x_hex, y_hex, colour = "black",
#' fill = c("blue", "yellow", "red"),
#' shape = c("convex4", "star8", "circle"),
#' density = c(0.45, 0.42, 0.4),
#' spacing = 0.08, angle = 0)
#'
#' # can be used to achieve a variety of 'tiling' effects
#' grid::grid.newpage()
#' grid.pattern_regular_polygon(x_hex, y_hex, color = "transparent",
#' fill = c("white", "grey", "black"),
#' density = 1.0, spacing = 0.1,
#' shape = "convex6", grid = "hex")
#' if (suppressPackageStartupMessages(requireNamespace("magick", quietly = TRUE))) {
#' # array-based patterns
#' # 'image' pattern
#' logo_filename <- system.file("img", "Rlogo.png" , package="png")
#' grid::grid.newpage()
#' grid.pattern("image", x_hex, y_hex, filename=logo_filename, type="fit")
#' }
#' if (suppressPackageStartupMessages(requireNamespace("magick", quietly = TRUE))) {
#' # 'plasma' pattern
#' grid::grid.newpage()
#' grid.pattern("plasma", x_hex, y_hex, fill="green")
#' }
#' }
#' @seealso \url{https://coolbutuseless.github.io/package/ggpattern/index.html}
#' for more details on the `ggpattern` package.
#' @export
grid.pattern <- function(pattern = "stripe",
x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
legend = FALSE, prefix = "pattern_",
default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
grob <- patternGrob(pattern, x, y, id, ...,
legend = legend, prefix = prefix,
default.units = default.units, name = name, gp = gp, vp = vp)
if (draw) grid.draw(grob)
invisible(grob)
}
#' @rdname grid.pattern
#' @export
names_pattern <- c("ambient", "aRtsy", "circle", "crosshatch", "fill", "gradient", "image",
"magick", "none", "pch", "placeholder", "plasma", "polygon_tiling",
"regular_polygon", "rose", "stripe", "text", "wave", "weave")
#' @rdname grid.pattern
#' @export
patternGrob <- function(pattern = "stripe",
x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
legend = FALSE, prefix = "pattern_",
default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
params <- get_params(..., pattern = pattern, prefix = prefix, gp = gp)
if (!inherits(x, "unit")) x <- unit(x, default.units)
if (!inherits(y, "unit")) y <- unit(y, default.units)
gTree(pattern=pattern, x=x, y=y, id=id, params=params, legend=legend,
name=name, gp=gp, vp=vp, cl="pattern")
}
#' @export
makeContent.pattern <- function(x) {
# avoid weird errors with array patterns if there is an active device open
current_dev <- grDevices::dev.cur()
on.exit(grDevices::dev.set(current_dev))
xp <- convertX(x$x, "npc", valueOnly = TRUE)
yp <- convertY(x$y, "npc", valueOnly = TRUE)
id <- x$id
boundary_df <- create_polygon_df(xp, yp, id)
if (!is.na(x$params$pattern_aspect_ratio)) {
aspect_ratio <- x$params$pattern_aspect_ratio
} else {
width <- convertWidth(unit(1, "npc"), "in", valueOnly = TRUE)
height <- convertHeight(unit(1, "npc"), "in", valueOnly = TRUE)
aspect_ratio <- width / height
}
# needs to be called within active graphics device to guess R4.1 capabilities
params <- get_R4.1_params(x$params)
fn <- get_pattern_fn(x$pattern)
grob <- fn(params, boundary_df, aspect_ratio, x$legend)
gl <- gList(grob)
setChildren(x, gl)
}
get_pattern_fn <- function(pattern) {
user_geometry_fns <- getOption("ggpattern_geometry_funcs")
user_array_fns <- getOption("ggpattern_array_funcs")
assert_patterns_unique(user_geometry_fns, user_array_fns)
geometry_fns <- c(list(aRtsy = create_pattern_aRtsy,
circle = create_pattern_circle_via_sf,
crosshatch = create_pattern_crosshatch_via_sf,
fill = create_pattern_fill,
gradient = create_pattern_gradient,
none = create_pattern_none,
pch = create_pattern_pch,
polygon_tiling = create_pattern_polygon_tiling,
regular_polygon = create_pattern_regular_polygon_via_sf,
rose = create_pattern_rose,
stripe = create_pattern_stripes_via_sf,
text = create_pattern_text,
wave = create_pattern_wave_via_sf,
weave = create_pattern_weave_via_sf),
user_geometry_fns)
array_fns <- c(list(ambient = create_pattern_ambient,
image = img_read_as_array_wrapper,
magick = create_magick_pattern_as_array,
placeholder = fetch_placeholder_array,
plasma = create_magick_plasma_as_array),
user_array_fns)
array_fns <- lapply(array_fns, function(fn) {
function(...) create_pattern_array(..., array_fn=fn)
})
fns <- c(geometry_fns, array_fns)
fns[[pattern]] %||% abort(paste("Don't know the function for pattern", pattern))
}
assert_patterns_unique <- function(user_geometry_fns, user_array_fns) {
names_geometry <- names(user_geometry_fns)
names_array <- names(user_array_fns)
msg_geometry <- '`options("ggpattern_geometry_funcs")` sets custom "geometry" patterns'
msg_array <- '`options("ggpattern_array_funcs")` sets custom "array" patterns'
# check pattern names not duplicated within custom pattern types
duplicated_geometry <- duplicated(names_geometry)
if (any(duplicated_geometry)) {
name <- names_geometry[which(duplicated_geometry)[1]]
msg <- c(glue('There are multiple custom "geometry" patterns named "{name}"'),
i = msg_geometry)
abort(msg)
}
duplicated_array <- duplicated(names_array)
if (any(duplicated_array)) {
name <- names_array[which(duplicated_array)[1]]
msg <- c(glue('There are multiple custom "array" patterns named "{name}"'),
i = msg_array)
abort(msg)
}
# check pattern names not duplicated between custom pattern types
match_user <- match(names_geometry, names_array)
if (any(!is.na(match_user))) {
index <- which(!is.na(match_user))[1]
name <- names_geometry[index]
msg <- c(glue('There is a custom "geometry" pattern and custom "array" pattern both named "{name}"'),
i = msg_geometry,
i = msg_array)
abort(msg)
}
# check pattern names not duplicated between custom patterns and builtin patterns
match_geometry <- match(names_geometry, names_pattern)
if (any(!is.na(match_geometry))) {
index <- which(!is.na(match_geometry))[1]
name <- names_geometry[index]
msg <- c(glue('There is a custom "geometry" pattern and builtin {{gridpattern}} pattern both named "{name}"'),
i = msg_geometry)
abort(msg)
}
match_array <- match(names_array, names_pattern)
if (any(!is.na(match_array))) {
index <- which(!is.na(match_array))[1]
name <- names_array[index]
msg <- c(glue('There is a custom "array" pattern and builtin {{gridpattern}} pattern both named "{name}"'),
i = msg_array)
abort(msg)
}
invisible(NULL)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.