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

@@ -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="[email protected]",
+        person("Trevor L.", "Davis", role=c("aut", "cre"), email="[email protected]",
                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.

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
 ==================
 

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)

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))

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)

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)

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)

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

R/pattern-geometry-wave.R

@@ -62,24 +62,24 @@ 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
     density <- params$pattern_density
 
     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)

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

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)