feat: 'clippingPathGrob()' and 'alphaMaskGrob()' improvements

* `clippingPathGrob()` can now more efficiently compute a `rasterGrob()` approximation
  via `ragg::agg_capture()` and for `png_device` functions that support
  the clipping path feature such as`png(type = "cairo")`(#74).
* `alphaMaskGrob()` can now more efficiently compute a `rasterGrob()` approximation
  for `png_device` functions that support
  the alpha mask feature such as`png(type = "cairo")`(#75).
* `alphaMaskGrob()` and `clippingPathGrob()` now
  switch back to the previously open graphics device if
  they open and close any new graphics devices.

closes #74, closes #75

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gridpattern
 Type: Package
 Title: 'grid' Pattern Grobs
-Version: 1.2.0-4
+Version: 1.2.0-5
 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]",
                comment = c(ORCID = "0000-0001-6341-4639")),

NAMESPACE

@@ -55,6 +55,7 @@ import(grid)
 importFrom(glue,glue)
 importFrom(grDevices,col2rgb)
 importFrom(grDevices,dev.capabilities)
+importFrom(grDevices,dev.capture)
 importFrom(grDevices,dev.off)
 importFrom(grDevices,png)
 importFrom(grDevices,rgb)

NEWS.md

@@ -34,6 +34,19 @@ New Features
 * For completeness there is now a `grid.pattern_none()` corresponding to the previously
   supported "none" pattern which draws nothing.
 
+Bug fixes and minor improvements
+--------------------------------
+
+* `clippingPathGrob()` can now more efficiently compute a `rasterGrob()` approximation
+  via `ragg::agg_capture()` and for `png_device` functions that support
+  the clipping path feature such as`png(type = "cairo")`(#74).
+* `alphaMaskGrob()` can now more efficiently compute a `rasterGrob()` approximation
+  for `png_device` functions that support
+  the alpha mask feature such as`png(type = "cairo")`(#75).
+* `alphaMaskGrob()` and `clippingPathGrob()` now 
+  switch back to the previously open graphics device if 
+  they open and close any new graphics devices.
+
 gridpattern v1.1.1
 ==================
 

R/alphaMaskGrob.R

@@ -48,14 +48,14 @@
 #'   }
 #' @export
 alphaMaskGrob <- function(maskee, masker,
-         use_R4.1_masks = getOption("ggpattern_use_R4.1_masks",
-                                    getOption("ggpattern_use_R4.1_features")),
-         png_device = NULL, res = getOption("ggpattern_res", 72),
-         name = NULL, gp = gpar(), vp = NULL) {
+                          use_R4.1_masks = getOption("ggpattern_use_R4.1_masks",
+                                                     getOption("ggpattern_use_R4.1_features")),
+                          png_device = NULL, res = getOption("ggpattern_res", 72),
+                          name = NULL, gp = gpar(), vp = NULL) {
     gTree(maskee = maskee, masker = masker,
           use_R4.1_masks = use_R4.1_masks,
           res = res, png_device = png_device,
-          name=name, gp=gp, vp=vp, cl="alpha_mask")
+          name = name, gp = gp, vp = vp, cl = "alpha_mask")
 }
 
 # Avoid R CMD check WARNING on R 4.0 which lacks `mask` argument
@@ -82,52 +82,90 @@ makeContent.alpha_mask <- function(x) {
                getRversion() >= '4.1.0' &&
                requireNamespace("ragg", quietly = TRUE) &&
                packageVersion("ragg") >= '1.2.0') {
-        grob <- gridpattern_mask_agg_capture(x)
+        grob <- gridpattern_mask_agg_capture(x$maskee, x$masker, x$res)
     } else {
-        grob <- gridpattern_mask_raster(x)
+        png_device <- x$png_device %||% default_png_device()
+        if (device_supports_masks(png_device)) {
+            grob <- gridpattern_mask_raster_straight(x$maskee, x$masker, x$res, png_device)
+        } else {
+            grob <- gridpattern_mask_raster_manual(x$maskee, x$masker, x$res, png_device)
+        }
     }
 
     gl <- gList(grob)
     setChildren(x, gl)
 }
 
-gridpattern_mask_agg_capture <- function(x) {
-    height <- x$res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
-    width <- x$res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
+device_supports_masks <- function(png_device) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    png_file <- tempfile(fileext = ".png")
+    on.exit(unlink(png_file), add = TRUE)
+    png_device(png_file)
+    value <- guess_has_R4.1_features("masks")
+    dev.off()
+    value
+}
+
+gridpattern_mask_agg_capture <- function(maskee, masker, res) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    height <- res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
+    width <- res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
 
-    f_masked <- ragg::agg_capture(height = height, width = width, res = x$res, bg = "transparent")
-    grob <- alphaMaskGrob(x$maskee, x$masker, use_R4.1_masks = TRUE)
+    ragg::agg_capture(height = height, width = width, res = res, bg = "transparent")
+    grob <- alphaMaskGrob(maskee, masker, use_R4.1_masks = TRUE)
     grid.draw(grob)
-    raster_masked <- f_masked(native = FALSE)
+    raster_masked <- dev.capture(native = FALSE)
     dev.off()
     grid::rasterGrob(raster_masked)
 }
 
-gridpattern_mask_raster <- function(x) {
-    height <- x$res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
-    width <- x$res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
-    png_device <- x$png_device
-    if (is.null(png_device)) {
-        if (requireNamespace("ragg", quietly = TRUE)) {
-            png_device <- ragg::agg_png
-        } else {
-            stopifnot(capabilities("png"))
-            png_device <- grDevices::png
-        }
+default_png_device <- function() {
+    if (requireNamespace("ragg", quietly = TRUE)) {
+        ragg::agg_png
+    } else {
+        stopifnot(capabilities("png"))
+        grDevices::png
     }
+}
+
+gridpattern_mask_raster_straight <- function(maskee, masker, res, png_device) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    height <- res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
+    width <- res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
+
+    png_masked <- tempfile(fileext = ".png")
+    on.exit(unlink(png_masked), add = TRUE)
+    png_device(png_masked, height = height, width = width,
+               res = res, bg = "transparent")
+    grob <- alphaMaskGrob(maskee, masker, use_R4.1_masks = TRUE)
+    grid.draw(grob)
+    dev.off()
+
+    raster_masked <- png::readPNG(png_masked, native = FALSE)
+    grid::rasterGrob(raster_masked)
+}
+
+gridpattern_mask_raster_manual <- function(maskee, masker, res, png_device) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    height <- res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
+    width <- res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
 
     png_maskee <- tempfile(fileext = ".png")
-    on.exit(unlink(png_maskee))
+    on.exit(unlink(png_maskee), add = TRUE)
     png_device(png_maskee, height = height, width = width,
-               res = x$res, bg = "transparent")
-    grid.draw(x$maskee)
+               res = res, bg = "transparent")
+    grid.draw(maskee)
     dev.off()
 
     png_masker <- tempfile(fileext = ".png")
-    on.exit(unlink(png_masker))
+    on.exit(unlink(png_masker), add = TRUE)
     png_device(png_masker, height = height, width = width,
-               res = x$res, bg = "transparent")
-    grid.draw(x$masker)
+               res = res, bg = "transparent")
+    grid.draw(masker)
     dev.off()
 
     raster_maskee <- png::readPNG(png_maskee, native = FALSE)

R/clippingPathGrob.R

@@ -9,9 +9,12 @@
 #'                          If `NULL` try to guess an appropriate choice.
 #'                          Note not all graphic devices support the grid clipping path feature
 #'                          and the grid clipping path feature does not nest.
-#' @param png_device \dQuote{png} graphics device to use if `use_R4.1_clipping` is `FALSE`.
-#'                   If `NULL` (default) will use `ragg::agg_png()` if the
-#'                   suggested package `ragg` is available else `grDevices::png()`.
+#' @param png_device \dQuote{png} graphics device to save intermediate raster data with if `use_R4.1_clipping` is `FALSE`.
+#'                   If `NULL` and suggested package `ragg` is available
+#'                   and versions are high enough we directly capture clipped raster via [ragg::agg_capture()].
+#'                   Otherwise we will use `png_device`
+#'                   (default [ragg::agg_png()] if available else [grDevices::png()]) and [png::readPNG()]
+#'                   to manually compute a clipped raster.
 #' @param res Resolution of desired `rasterGrob` in pixels per inch if `use_R4.1_clipping` is `FALSE`.
 #' @return A `grid` grob
 #' @inheritParams grid::polygonGrob
@@ -41,7 +44,7 @@ clippingPathGrob <- function(clippee, clipper,
     gTree(clippee = clippee, clipper = clipper,
           use_R4.1_clipping = use_R4.1_clipping,
           res = res, png_device = png_device,
-          name=name, gp=gp, vp=vp, cl="clipping_path")
+          name = name, gp = gp, vp = vp, cl = "clipping_path")
 }
 
 #' @export
@@ -61,40 +64,86 @@ makeContent.clipping_path <- function(x) {
         grob <- grobTree(x$clippee,
                          vp = viewport(clip = x$clipper),
                          name = "clip")
+    } else if (is.null(x$png_device) &&
+               getRversion() >= '4.1.0' &&
+               requireNamespace("ragg", quietly = TRUE) &&
+               packageVersion("ragg") >= '1.2.0') {
+        grob <- gridpattern_clip_agg_capture(x$clippee, x$clipper, x$res)
     } else {
-        grob <- gridpattern_clip_raster(x)
+        png_device <- x$png_device %||% default_png_device()
+        if (device_supports_clipping(png_device)) {
+            grob <- gridpattern_clip_raster_straight(x$clippee, x$clipper, x$res, png_device)
+        } else {
+            grob <- gridpattern_clip_raster_manual(x$clippee, x$clipper, x$res, png_device)
+        }
     }
 
     gl <- gList(grob)
     setChildren(x, gl)
 }
 
-gridpattern_clip_raster <- function(x) {
-    height <- x$res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
-    width <- x$res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
-    png_device <- x$png_device
-    if (is.null(png_device)) {
-        if (requireNamespace("ragg", quietly = TRUE)) {
-            png_device <- ragg::agg_png
-        } else {
-            stopifnot(capabilities("png"))
-            png_device <- grDevices::png
-        }
-    }
+device_supports_clipping <- function(png_device) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    png_file <- tempfile(fileext = ".png")
+    on.exit(unlink(png_file), add = TRUE)
+    png_device(png_file)
+    value <- guess_has_R4.1_features("clippingPaths")
+    dev.off()
+    value
+}
+
+gridpattern_clip_agg_capture <- function(clippee, clipper, res) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    height <- res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
+    width <- res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
+
+    ragg::agg_capture(height = height, width = width, res = res, bg = "transparent")
+    grob <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = TRUE)
+    grid.draw(grob)
+    raster_clipped <- dev.capture(native = FALSE)
+    dev.off()
+    grid::rasterGrob(raster_clipped)
+}
+
+gridpattern_clip_raster_straight <- function(clippee, clipper, res, png_device) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    height <- res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
+    width <- res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
+
+    png_clipped <- tempfile(fileext = ".png")
+    on.exit(unlink(png_clipped), add = TRUE)
+    png_device(png_clipped, height = height, width = width,
+               res = res, bg = "transparent")
+    grob <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = TRUE)
+    grid.draw(grob)
+    dev.off()
+
+    raster_clipped <- png::readPNG(png_clipped, native = FALSE)
+    grid::rasterGrob(raster_clipped)
+}
+
+gridpattern_clip_raster_manual <- function(clippee, clipper, res, png_device) {
+    current_dev <- grDevices::dev.cur()
+    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
+    height <- res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
+    width <- res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
 
     png_clippee <- tempfile(fileext = ".png")
-    on.exit(unlink(png_clippee))
+    on.exit(unlink(png_clippee), add = TRUE)
     png_device(png_clippee, height = height, width = width,
-               res = x$res, bg = "transparent")
-    grid.draw(x$clippee)
+               res = res, bg = "transparent")
+    grid.draw(clippee)
     dev.off()
 
     png_clipper <- tempfile(fileext = ".png")
-    on.exit(unlink(png_clipper))
+    on.exit(unlink(png_clipper), add = TRUE)
     png_device(png_clipper, height = height, width = width,
-               res = x$res, bg = "transparent")
+               res = res, bg = "transparent")
     pushViewport(viewport(gp = gpar(lwd = 0, col = NA, fill = "black")))
-    grid.draw(x$clipper)
+    grid.draw(clipper)
     popViewport()
     dev.off()
 

R/gridpattern-package.R

@@ -17,7 +17,7 @@
 #'                          If `FALSE` do a `rasterGrob` approximation of the masked pattern.
 #'                          If `NULL` try to guess an appropriate choice.}
 #'    \item{ggpattern_use_R4.1_patterns}{If `TRUE` use the grid pattern feature introduced in R v4.1.0.
-#'                          Currently unused by this package.}
+#'                          Currently only used by a couple of examples.}
 #'  }
 #'  Note to use the R v4.1.0 features one needs R be (at least) version 4.1 and not all graphic devices
 #'  support any/all these features.  See \url{https://www.stat.auckland.ac.nz/~paul/Reports/GraphicsEngine/definitions/definitions.html} for more information on these features.

R/utils-polygon_df.R

@@ -148,13 +148,17 @@ get_poly_lengths <- function(sf_object) {
 #'
 #' @noRd
 convert_polygon_df_to_alpha_channel <- function(polygon_df, width, height) {
+  current_dev <- grDevices::dev.cur()
+  if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Convert the polygon to an actual grob, coloured 'black'
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   gp <- gpar(fill = 'black')
   boundary_grob <- convert_polygon_df_to_polygon_grob(polygon_df, gp=gp)
 
+  # Note `ragg::agg_capture()`'s non-"native" format is a matrix of color strings
+  # while `png::readPNG()`'s non-"native" format is an array of numeric values
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Save the grob as an image of the given size
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -167,7 +171,7 @@ convert_polygon_df_to_alpha_channel <- function(polygon_df, width, height) {
   # Load the file and convert o a numeric matrix with values 0/1 depending
   # on whether the pixel is white or black.
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  alpha_channel <- png::readPNG(png_file)
+  alpha_channel <- png::readPNG(png_file, native = FALSE)
   alpha_channel <- alpha_channel[,,1] < 0.5
   storage.mode(alpha_channel) <- 'numeric'
 

R/zzz.R

@@ -14,7 +14,7 @@ img_read_memoised <- img_read
 
 #' @import grid
 #' @importFrom glue glue
-#' @importFrom grDevices col2rgb dev.capabilities dev.off png rgb
+#' @importFrom grDevices col2rgb dev.capture dev.capabilities dev.off png rgb
 #' @importFrom rlang %||% abort inform warn
 #' @importFrom utils hasName head packageVersion tail
 NULL