From b174bb78e8330f58808ecb8aa3465a70bb82edde Mon Sep 17 00:00:00 2001
From: "Trevor L. Davis" <trevor.l.davis@gmail.com>
Date: Mon, 15 Apr 2024 22:38:27 -0700
Subject: [PATCH] feat: Allow pattern fills in geometry patterns

* The "geometry" patterns (e.g. "circle", "stripe", etc.) now allow
  the `fill` to be pattern fills (#67).

closes #67
---
 DESCRIPTION                          |  2 +-
 NEWS.md                              |  3 +++
 R/pattern-both-rose.R                | 18 +++++++++---------
 R/pattern-both-text.R                | 12 ++++++------
 R/pattern-geometry-crosshatch.R      |  4 ++--
 R/pattern-geometry-pch.R             | 16 ++++++++--------
 R/pattern-geometry-regular_polygon.R | 18 +++++++++---------
 R/pattern-geometry-tiling.R          |  2 +-
 R/pattern-geometry-wave.R            | 14 +++++++-------
 R/pattern-geometry-weave.R           |  2 +-
 R/utils-grid.R                       |  7 +++++++
 man/gridpattern-package.Rd           |  2 +-
 12 files changed, 55 insertions(+), 45 deletions(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index eed7efe..2f7b081 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -3,7 +3,7 @@ Type: Package
 Title: 'grid' Pattern Grobs
 Version: 1.2.0-1
 Authors@R: c(person("Mike", "FC", role = "aut", comment = "Code/docs adapted from ggpattern"),
-        person("Trevor L", "Davis", role=c("aut", "cre"), email="trevor.l.davis@gmail.com",
+        person("Trevor L.", "Davis", role=c("aut", "cre"), email="trevor.l.davis@gmail.com",
                comment = c(ORCID = "0000-0001-6341-4639")),
         person("ggplot2 authors", role = "ctb", comment = "some utility functions copied from ggplot2"))
 Description: Provides 'grid' grobs that fill in a user-defined area with various patterns.  Includes enhanced versions of the geometric and image-based patterns originally contained in the 'ggpattern' package as well as original 'pch', 'polygon_tiling', 'regular_polygon', 'rose', 'text', 'wave', and 'weave' patterns plus support for custom user-defined patterns.
diff --git a/NEWS.md b/NEWS.md
index 3485ee3..ebfad76 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -10,6 +10,9 @@ gridpattern v1.2.0 (development)
   + It does not depend on `{ggplot2}` or `{scales}`.
   + It does not throw an error with a length one list of a vector of multiple colours.
 
+* The "geometry" patterns (e.g. "circle", "stripe", etc.) now allow
+  the `fill` to be pattern fills (#67).
+
 gridpattern v1.1.1
 ==================
 
diff --git a/R/pattern-both-rose.R b/R/pattern-both-rose.R
index fdf3a98..dd230cb 100644
--- a/R/pattern-both-rose.R
+++ b/R/pattern-both-rose.R
@@ -70,7 +70,7 @@ create_pattern_rose <- function(params, boundary_df, aspect_ratio, legend = FALS
     grid_xy <- get_xy_grid(params, vpm)
 
     # construct grobs using subsets if certain inputs are vectorized
-    fill <- alpha(params$pattern_fill, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
     col  <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd  <- params$pattern_linewidth * .pt
     lty  <- params$pattern_linetype
@@ -81,13 +81,13 @@ create_pattern_rose <- function(params, boundary_df, aspect_ratio, legend = FALS
 
     n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, frequency)))
 
-    fill <- rep(fill, length.out = n_par)
-    col <- rep(col, length.out = n_par)
-    lwd <- rep(lwd, length.out = n_par)
-    lty <- rep(lty, length.out = n_par)
-    density <- rep(density, length.out = n_par)
-    rot <- rep(rot, length.out = n_par)
-    frequency <- rep(frequency, length.out = n_par)
+    fill <- rep_len_fill(fill, n_par)
+    col <- rep_len(col, n_par)
+    lwd <- rep_len(lwd, n_par)
+    lty <- rep_len(lty, n_par)
+    density <- rep_len(density, n_par)
+    rot <- rep_len(rot, n_par)
+    frequency <- rep_len(frequency, n_par)
 
     density_max <- max(density)
 
@@ -110,7 +110,7 @@ create_pattern_rose <- function(params, boundary_df, aspect_ratio, legend = FALS
         # rotate by 'angle'
         xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y)
 
-        gp <- gpar(fill = fill[i_par], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par])
+        gp <- gpar(fill = fill[[i_par]], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par])
 
         name <- paste0("rose.", i_par)
         grob <- points_to_rose_grob(xy_par, xy_rose, gp, default.units, name)
diff --git a/R/pattern-both-text.R b/R/pattern-both-text.R
index 3d19eb6..40f96a9 100644
--- a/R/pattern-both-text.R
+++ b/R/pattern-both-text.R
@@ -77,12 +77,12 @@ create_pattern_text <- function(params, boundary_df, aspect_ratio, legend = FALS
 
     n_par <- max(lengths(list(col, fontsize, fontfamily, fontface, rot, shape)))
 
-    col <- rep(col, length.out = n_par)
-    fontsize <- rep(fontsize, length.out = n_par)
-    fontfamily <- rep(fontfamily, length.out = n_par)
-    fontface <- rep(fontface, length.out = n_par)
-    rot <- rep(rot, length.out = n_par)
-    shape <- rep(shape, length.out = n_par)
+    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))
diff --git a/R/pattern-geometry-crosshatch.R b/R/pattern-geometry-crosshatch.R
index 54f604b..bfdede1 100644
--- a/R/pattern-geometry-crosshatch.R
+++ b/R/pattern-geometry-crosshatch.R
@@ -57,7 +57,7 @@ create_crosshatch_via_sf_helper <- function(params, boundary_df, add_top_hatch =
     # create grid of points large enough to cover viewport no matter the angle
     grid_xy <- get_xy_grid(params, vpm)
 
-    fill <- alpha(params$pattern_fill, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
     col  <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd  <- params$pattern_linewidth * .pt
     lty  <- params$pattern_linetype
@@ -71,7 +71,7 @@ create_crosshatch_via_sf_helper <- function(params, boundary_df, add_top_hatch =
                                             gp, default.units, "stripe")
 
     if (add_top_hatch) {
-        gp$fill <- alpha(params$pattern_fill2, params$pattern_alpha)
+        gp$fill <- update_alpha(params$pattern_fill2, params$pattern_alpha)
 
         stripes_sf_top <- create_v_stripes_sf(params, grid_xy, vpm)
         clipped_stripes_sf_top <- sf::st_intersection(stripes_sf_top, boundary_sf)
diff --git a/R/pattern-geometry-pch.R b/R/pattern-geometry-pch.R
index 30b7ced..accd992 100644
--- a/R/pattern-geometry-pch.R
+++ b/R/pattern-geometry-pch.R
@@ -67,7 +67,7 @@ grid.pattern_pch <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
 # each pch will be represented by two regular polygons (although one may be "null")
 create_pattern_pch <- function(params, boundary_df, aspect_ratio, legend = FALSE) {
     # vectorize fill, col, lwd, lty, density, rot, and shape
-    fill <- alpha(params$pattern_fill, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
     col  <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd  <- params$pattern_linewidth
     lty  <- params$pattern_linetype
@@ -79,13 +79,13 @@ create_pattern_pch <- function(params, boundary_df, aspect_ratio, legend = FALSE
 
     n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape)))
 
-    fill <- rep(fill, length.out = n_par)
-    col <- rep(col, length.out = n_par)
-    lwd <- rep(lwd, length.out = n_par)
-    lty <- rep(lty, length.out = n_par)
-    density <- rep(density, length.out = n_par)
-    rot <- rep(rot, length.out = n_par)
-    shape <- rep(shape, length.out = n_par)
+    fill <- rep_len_fill(fill, n_par)
+    col <- rep_len(col, n_par)
+    lwd <- rep_len(lwd, n_par)
+    lty <- rep_len(lty, n_par)
+    density <- rep_len(density, n_par)
+    rot <- rep_len(rot, n_par)
+    shape <- rep_len(shape, n_par)
 
     # setup bottom and top regular polygons
     pint <- as.integer(shape)
diff --git a/R/pattern-geometry-regular_polygon.R b/R/pattern-geometry-regular_polygon.R
index ec75815..2c0e9c7 100644
--- a/R/pattern-geometry-regular_polygon.R
+++ b/R/pattern-geometry-regular_polygon.R
@@ -105,7 +105,7 @@ create_pattern_regular_polygon_via_sf <- function(params, boundary_df, aspect_ra
     grid_xy <- get_xy_grid(params, vpm)
 
     # construct grobs using subsets if certain inputs are vectorized
-    fill <- alpha(params$pattern_fill, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
     col  <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd  <- params$pattern_linewidth * .pt
     lty  <- params$pattern_linetype
@@ -117,13 +117,13 @@ create_pattern_regular_polygon_via_sf <- function(params, boundary_df, aspect_ra
 
     n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape)))
 
-    fill <- rep(fill, length.out = n_par)
-    col <- rep(col, length.out = n_par)
-    lwd <- rep(lwd, length.out = n_par)
-    lty <- rep(lty, length.out = n_par)
-    density <- rep(density, length.out = n_par)
-    rot <- rep(rot, length.out = n_par)
-    shape <- rep(shape, length.out = n_par)
+    fill <- rep_len_fill(fill, n_par)
+    col <- rep_len(col, n_par)
+    lwd <- rep_len(lwd, n_par)
+    lty <- rep_len(lty, n_par)
+    density <- rep_len(density, n_par)
+    rot <- rep_len(rot, n_par)
+    shape <- rep_len(shape, n_par)
 
     density <- ifelse(shape %in% c("square", "tetrakis_left", "tetrakis_right"),
                       1.414 * density, density)
@@ -167,7 +167,7 @@ create_pattern_regular_polygon_via_sf <- function(params, boundary_df, aspect_ra
         interior_points_sf <- sf::st_intersection(all_points_sf, contracted_sf)
         exterior_points_sf <- sf::st_difference(all_points_sf, contracted_sf)
 
-        gp <- gpar(fill = fill[i_par], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par])
+        gp <- gpar(fill = fill[[i_par]], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par])
 
         # create grob for interior polygons
         name <- paste0("interior.", i_par)
diff --git a/R/pattern-geometry-tiling.R b/R/pattern-geometry-tiling.R
index b0c5605..6d19a38 100644
--- a/R/pattern-geometry-tiling.R
+++ b/R/pattern-geometry-tiling.R
@@ -148,7 +148,7 @@ create_pattern_polygon_tiling <- function(params, boundary_df, aspect_ratio, leg
 
     xyi <- boundary_df
 
-    fill <- alpha(params$pattern_fill, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
     col <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd <- params$pattern_linewidth
     lty <- params$pattern_linetype
diff --git a/R/pattern-geometry-wave.R b/R/pattern-geometry-wave.R
index 305299c..58eace0 100644
--- a/R/pattern-geometry-wave.R
+++ b/R/pattern-geometry-wave.R
@@ -62,7 +62,7 @@ create_pattern_wave_via_sf <- function(params, boundary_df, aspect_ratio,
     # create grid of points large enough to cover viewport no matter the angle
     grid_xy <- get_xy_grid(params, vpm)
 
-    fill <- alpha(params$pattern_fill, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
     col  <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd  <- params$pattern_linewidth * .pt
     lty  <- params$pattern_linetype
@@ -70,16 +70,16 @@ create_pattern_wave_via_sf <- function(params, boundary_df, aspect_ratio,
 
     n_par <- max(lengths(list(fill, col, lwd, lty, density)))
 
-    fill <- rep(fill, length.out = n_par)
-    col <- rep(col, length.out = n_par)
-    lwd <- rep(lwd, length.out = n_par)
-    lty <- rep(lty, length.out = n_par)
-    density <- rep(density, length.out = n_par)
+    fill <- rep_len_fill(fill, n_par)
+    col <- rep_len(col, n_par)
+    lwd <- rep_len(lwd, n_par)
+    lty <- rep_len(lty, n_par)
+    density <- rep_len(density, n_par)
 
     gl <- gList()
     for (i_par in seq_len(n_par)) {
 
-        gp <- gpar(col = col[i_par], fill = fill[i_par],
+        gp <- gpar(col = col[i_par], fill = fill[[i_par]],
                    lwd = lwd[i_par], lty = lty[i_par], lineend = 'square')
 
         boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0)
diff --git a/R/pattern-geometry-weave.R b/R/pattern-geometry-weave.R
index 31516b7..390608a 100644
--- a/R/pattern-geometry-weave.R
+++ b/R/pattern-geometry-weave.R
@@ -86,7 +86,7 @@ create_warp_via_sf <- function(params, boundary_df) {
     # create grid of points large enough to cover viewport no matter the angle
     grid_xy <- get_xy_grid(params, vpm)
 
-    fill <- alpha(params$pattern_fill2, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill2, params$pattern_alpha)
     col  <- alpha(params$pattern_colour, params$pattern_alpha)
     lwd  <- params$pattern_linewidth * .pt
     lty  <- params$pattern_linetype
diff --git a/R/utils-grid.R b/R/utils-grid.R
index 8d2e1b6..7fccbbc 100644
--- a/R/utils-grid.R
+++ b/R/utils-grid.R
@@ -4,6 +4,13 @@ append_gList <- function(gl, grob) {
     gl
 }
 
+rep_len_fill <- function(x, length.out) {
+    if (inherits(x, "GridPattern"))
+        rep_len(list(x), length.out)
+    else
+        rep_len(x, length.out)
+}
+
 # get width, height, length, and center cooordinates of the viewport in `units` units
 get_vp_measurements <- function(units = "bigpts") {
     width <- convertWidth(unit(1, "npc"), units, valueOnly = TRUE)
diff --git a/man/gridpattern-package.Rd b/man/gridpattern-package.Rd
index 0cc9e32..57e7a58 100644
--- a/man/gridpattern-package.Rd
+++ b/man/gridpattern-package.Rd
@@ -46,7 +46,7 @@ Useful links:
 
 }
 \author{
-\strong{Maintainer}: Trevor L Davis \email{trevor.l.davis@gmail.com} (\href{https://orcid.org/0000-0001-6341-4639}{ORCID})
+\strong{Maintainer}: Trevor L. Davis \email{trevor.l.davis@gmail.com} (\href{https://orcid.org/0000-0001-6341-4639}{ORCID})
 
 Authors:
 \itemize{