New "aRtsy" pattern (#89)

* feat: 'grid.pattern_aRtsy()'

* New pattern "aRtsy" with corresponding `grid.pattern_aRtsy()` with
  patterns powered by the `{aRtsy}` package (#87).

closes #87

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gridpattern
 Type: Package
 Title: 'grid' Pattern Grobs
-Version: 1.2.2
+Version: 1.3.0-1
 Authors@R: c(
         person("Trevor L.", "Davis", role=c("aut", "cre"), email="[email protected]",
                comment = c(ORCID = "0000-0001-6341-4639")),
@@ -27,7 +27,9 @@ Imports:
     utils
 Suggests:
     ambient,
+    aRtsy,
     ggplot2 (>= 3.5.0),
+    gtable,
     knitr,
     magick (>= 2.7.4),
     ragg (>= 1.2.0),

NAMESPACE

@@ -13,6 +13,7 @@ S3method(update_pattern_alpha,list)
 export(alphaMaskGrob)
 export(clippingPathGrob)
 export(grid.pattern)
+export(grid.pattern_aRtsy)
 export(grid.pattern_ambient)
 export(grid.pattern_circle)
 export(grid.pattern_crosshatch)
@@ -33,6 +34,7 @@ export(grid.pattern_wave)
 export(grid.pattern_weave)
 export(guess_has_R4.1_features)
 export(mean_col)
+export(names_aRtsy)
 export(names_hex)
 export(names_magick)
 export(names_magick_intensity)

NEWS.md

@@ -1,3 +1,9 @@
+gridpattern v1.3.0 (development)
+================================
+
+* New pattern "aRtsy" with corresponding `grid.pattern_aRtsy()` with
+  patterns powered by the `{aRtsy}` package (#87).
+
 gridpattern v1.2.2
 ==================
 
@@ -25,7 +31,7 @@ Bug fixes and minor improvements
     - "placeimg" and "placeimgbw" ([support officially ended July 2023](https://www.gomasuga.com/placeimg?souce=placeimg))
 
   + The "dummybw" name now provides a pure black-and-white image (i.e. no grey).
-  + Fixes a regression for the "placeholderbw" name where it redirected to the "segal" name instead of "placeholder".
+  + Fixes a regression for the "placeholderbw" name where it redirected to the "seagal" name instead of "placeholder".
 
 gridpattern v1.2.1
 ==================

R/alphaMaskGrob.R

@@ -18,7 +18,7 @@
 #' @return A `grid` grob
 #' @inheritParams grid::polygonGrob
 #' @examples
-#'   \donttest{ # Once took more >10s on a CRAN autocheck
+#'   \donttest{# May take more than 5 seconds on CRAN servers
 #'   if (capabilities("png") && require("grid")) {
 #'     maskee <- patternGrob("circle", gp = gpar(col = "black", fill = "yellow"),
 #'                            spacing = 0.1, density = 0.5)

R/grid-pattern.R

@@ -9,6 +9,8 @@
 #' \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.
@@ -61,7 +63,7 @@
 #'         If `draw` is `TRUE` then `grid.pattern()` also draws to the graphic device as a side effect.
 #' @examples
 #'  print(names_pattern)
-#'  \donttest{ # Once took more >10s on a CRAN autocheck
+#'  \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))
 #'
@@ -125,7 +127,7 @@ grid.pattern <- function(pattern = "stripe",
 
 #' @rdname grid.pattern
 #' @export
-names_pattern <- c("ambient", "circle", "crosshatch", "fill", "gradient", "image",
+names_pattern <- c("ambient", "aRtsy", "circle", "crosshatch", "fill", "gradient", "image",
                    "magick", "none", "pch", "placeholder", "plasma", "polygon_tiling",
                    "regular_polygon", "rose", "stripe", "text", "wave", "weave")
 
@@ -175,7 +177,8 @@ 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(circle = create_pattern_circle_via_sf,
+    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,

R/pattern-pattern-aRtsy.R

@@ -0,0 +1,77 @@
+#' Create grob objects for the pattern elements within a boundary
+#'
+#' @param params params/coords for a single element. named list or single row data.frame
+#' @param boundary_df mask for the pattern rendering
+#' @param aspect_ratio a aspect ratio of the plotting area.
+#' @param legend is the pattern being created in the legend? default FALSE.
+#'  Use this flag if you want different pattern drawing behviour for the legend.
+#'
+#' @return grid grob objects.
+#' @noRd
+create_pattern_aRtsy <- function(params, boundary_df, aspect_ratio,
+                                 legend = FALSE) {
+    assert_suggested("aRtsy", "aRtsy")
+    requireNamespace("aRtsy", quietly = TRUE)
+    stopifnot(guess_has_R4.1_features("patterns"))
+    alpha <- ifelse(is.na(params$pattern_alpha), 1, params$pattern_alpha)
+    colors <- update_alpha(params$pattern_fill, alpha)
+    fn_name <- paste0("canvas_", params$pattern_type)
+    fn <- utils::getFromNamespace(fn_name, "aRtsy")
+    args <- list()
+    nformals <- names(formals(fn))
+    if ("color" %in% nformals) { # e.g. `canvas_maze()`
+        args$color <- colors
+    }
+    if ("colors" %in% nformals) { # e.g. most canvas functions
+        args$colors <- colors
+    }
+    pat <- ggplot2pat(do.call(fn, args))
+    gp <- grid::gpar(col = NA_character_, fill = pat)
+    convert_polygon_df_to_polygon_grob(boundary_df, gp = gp)
+}
+
+#' Grobs with patterns powered by the aRtsy package
+#'
+#' `grid.pattern_aRtsy()` draws patterns powered by the `aRtsy` package.
+#' `names_aRtsy()` returns character vector of supported types.
+#'
+#' @param type Name of pattern.
+#' @inheritParams grid.pattern_circle
+#' @param fill Passed to the underlying `aRtsy` function's `color` / `colors` argument.
+#' @param ... Currently ignored
+#' @return A grid grob object invisibly.  If `draw` is `TRUE` then also draws to the graphic device as a side effect.
+#' @examples
+#' if (requireNamespace("aRtsy", quietly = TRUE)) {
+#'   print(names_aRtsy())
+#' }
+#'
+#' \donttest{# Make 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))
+#' if (requireNamespace("aRtsy", quietly = TRUE) &&
+#'     guess_has_R4.1_features("patterns")) {
+#'   grid::grid.newpage()
+#'   grid.pattern_aRtsy(x_hex, y_hex, type = "forest",
+#'                      fill = c("black", "white", "grey"))
+#' }
+#' }
+#' @seealso <https://koenderks.github.io/aRtsy/> for more information about the `aRtsy` package.
+#' @export
+grid.pattern_aRtsy <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
+                               type = "strokes",
+                               fill = gp$fill %||% "grey80",
+                               alpha = gp$alpha %||% NA_real_,
+                               default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
+    grid.pattern("aRtsy", x, y, id,
+                 type = type, fill = fill, alpha = alpha,
+                 default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
+}
+
+#' @rdname grid.pattern_aRtsy
+#' @export
+names_aRtsy <- function() {
+    assert_suggested("aRtsy", "aRtsy")
+    requireNamespace("aRtsy", quietly = TRUE)
+    fns <- grep("^canvas", getNamespaceExports("aRtsy"), value = TRUE)
+    gsub("^canvas_", "", fns)
+}

R/utils-ggplot2.R

@@ -26,3 +26,15 @@ data_frame <- function(...) {
   new_data_frame(list(...))
 }
 .pt <- 2.845276 # ggplot2 constant
+
+ggplot2pat <- function(gg) {
+    stopifnot(getRversion() >= "4.1.0",
+              requireNamespace("ggplot2", quietly = TRUE),
+              requireNamespace("gtable", quietly = TRUE))
+    gg <- suppressMessages(gg +
+                           ggplot2::scale_x_continuous(expand=c(0, 0)) +
+                           ggplot2::scale_y_continuous(expand=c(0, 0)))
+    grob <- gtable::gtable_filter(ggplot2::ggplotGrob(gg), "panel")
+    pat <- grid::pattern(grob)
+    pat
+}

R/utils-params.R

@@ -103,6 +103,7 @@ convert_params_units <- function(params, units = "bigpts") {
 default_pattern_type <- function(pattern) {
     switch(pattern,
            ambient = "simplex",
+           aRtsy = "strokes",
            image = "fit",
            placeholder = "bear",
            polygon_tiling = "square",

README.Rmd

@@ -26,27 +26,29 @@ as well as original "pch", "polygon_tiling", "regular_polygon", "rose", "text",
 
 `{gridpattern}` currently provides `{grid}` grob support for the following patterns:
 
-1.  [ambient](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_ambient.html):
+1. [ambient](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_ambient.html):
     noise array patterns powered by the [ambient](https://cran.r-project.org/package=ambient) package
-2.  [circle](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_circle.html): circle geometry patterns
-3.  [crosshatch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_crosshatch.html): crosshatch geometry patterns
-4.  [fill](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_fill.html): simple fill patterns
-5.  [gradient](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_gradient.html): gradient array/geometry patterns
-6.  [image](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_image.html): image array patterns
-7.  [magick](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_magick.html): imagemagick array patterns
-8.  [none](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_none.html): draws nothing
-9.  [placeholder](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_placeholder.html): placeholder image array patterns
-10.  [plasma](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_plasma.html): plasma array patterns
-11. [pch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_pch.html): plotting character geometry patterns
-12. [polygon_tiling](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_polygon_tiling.html): polygon tiling patterns
-13. [regular_polygon](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_regular_polygon.html): regular polygon geometry patterns
-14. [rose](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_rose.html): rose curve array/geometry patterns
-15. [stripe](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_stripe.html): stripe geometry patterns
-16. [text](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_text.html): text array/geometry patterns
-17. [wave](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_wave.html): wave geometry patterns
-18. [weave](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_weave.html): weave geometry patterns
-19. [custom geometry-based patterns](https://trevorldavis.com/R/gridpattern/dev/articles/developing-patterns.html)
-20. [custom array-based patterns](https://trevorldavis.com/R/gridpattern/dev/articles/developing-patterns.html)
+1. [aRtsy](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_aRtsy.html):
+    patterns powered by the [aRtsy](https://cran.r-project.org/package=aRtsy) package
+1. [circle](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_circle.html): circle geometry patterns
+1. [crosshatch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_crosshatch.html): crosshatch geometry patterns
+1. [fill](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_fill.html): simple fill patterns
+1. [gradient](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_gradient.html): gradient array/geometry patterns
+1. [image](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_image.html): image array patterns
+1. [magick](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_magick.html): imagemagick array patterns
+1. [none](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_none.html): draws nothing
+1. [placeholder](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_placeholder.html): placeholder image array patterns
+1. [plasma](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_plasma.html): plasma array patterns
+1. [pch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_pch.html): plotting character geometry patterns
+1. [polygon_tiling](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_polygon_tiling.html): polygon tiling patterns
+1. [regular_polygon](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_regular_polygon.html): regular polygon geometry patterns
+1. [rose](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_rose.html): rose curve array/geometry patterns
+1. [stripe](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_stripe.html): stripe geometry patterns
+1. [text](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_text.html): text array/geometry patterns
+1. [wave](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_wave.html): wave geometry patterns
+1. [weave](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_weave.html): weave geometry patterns
+1. [custom geometry-based patterns](https://trevorldavis.com/R/gridpattern/dev/articles/developing-patterns.html)
+1. [custom array-based patterns](https://trevorldavis.com/R/gridpattern/dev/articles/developing-patterns.html)
 
 ## <a name="installation">Installation</a>