fix: More robust 'guess_has_R4.1_features()' within R 4.2

* If the active graphics device has also implemented the new R 4.2 `dev.capabilities()` support then
  `guess_has_R4.1_features()` can now better guess R 4.1 graphic feature support when called within R 4.2.

  + In particular `guess_has_R4.1_features()` can now better guess R 4.1 graphic feature support in the
    `{grDevices}` bitmap devices (i.e. `bmp()`, `jpeg()`, `png()`, `tiff()`)
    when called within R 4.2 on Windows.
    Previously it was not possible to easily distinguish on Windows if the device was called with
   `type = "windows"` or `type = "cairo"` and hence we had to conservatively guess no such support
    even if `type = "cairo"` had been specified (and within R 4.1 we must still conservatively do so).
  + Also if in the future any graphic devices add R 4.1 graphic feature support as well as
    R 4.2 `dev.capabilities()` support then we should now be able to correctly guess such support within R 4.2
    without needing to manually update `guess_has_R4.1_features()`.

* `guess_has_R4.1_features()` now supports an argument `features` which allows one to
  limit the guessing of R4.1 feature support to a subset of `c("clippingPaths", "gradients", "masks", "patterns")`.
  Although all known graphic devices either implements all or none of these features
  this need not hold true in the future.

progress on #50

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gridpattern
 Type: Package
 Title: 'grid' Pattern Grobs
-Version: 0.5.2-1
+Version: 0.5.2-2
 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("Thomas Lin", "Pedersen", role = "ctb", comment = "new_data_frame() copied from ggplot2"))
@@ -27,8 +27,9 @@ Suggests:
     ambient,
     knitr,
     magick,
-    ragg,
+    ragg (>= 1.2.0),
     rmarkdown,
+    svglite (>= 2.1.0),
     testthat,
     vdiffr
 VignetteBuilder: knitr, rmarkdown

NAMESPACE

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

NEWS.md

@@ -6,6 +6,23 @@ Bug Fixes and minor improvements
 
 * Fixes bug with `grid.pattern_image()` with `type = "tile"` (#47).
   Additionally `grid.pattern_image()` now supports `gravity` argument when `type = "tile"`.
+* If the active graphics device has also implemented the new R 4.2 `dev.capabilities()` support then
+  `guess_has_R4.1_features()` can now better guess R 4.1 graphic feature support when called within R 4.2.
+
+  + In particular `guess_has_R4.1_features()` can now better guess R 4.1 graphic feature support in the
+    `{grDevices}` bitmap devices (i.e. `bmp()`, `jpeg()`, `png()`, `tiff()`) 
+    when called within R 4.2 on Windows.
+    Previously it was not possible to easily distinguish on Windows if the device was called with 
+   `type = "windows"` or `type = "cairo"` and hence we had to conservatively guess no such support
+    even if `type = "cairo"` had been specified (and within R 4.1 we must still conservatively do so).
+  + Also if in the future any graphic devices add R 4.1 graphic feature support as well as 
+    R 4.2 `dev.capabilities()` support then we should now be able to correctly guess such support within R 4.2
+    without needing to manually update `guess_has_R4.1_features()`.
+
+* `guess_has_R4.1_features()` now supports an argument `features` which allows one to
+  limit the guessing of R4.1 feature support to a subset of `c("clippingPaths", "gradients", "masks", "patterns")`.
+  Although all known graphic devices either implements all or none of these features
+  this need not hold true in the future.
 
 gridpattern v0.5.1
 ==================

R/alphaMaskGrob.R

@@ -66,7 +66,7 @@ makeContent.alpha_mask <- function(x) {
 
     use_R4.1_masks <- x$use_R4.1_masks
     if (is.null(use_R4.1_masks))
-        use_R4.1_masks <- guess_has_R4.1_features()
+        use_R4.1_masks <- guess_has_R4.1_features("masks")
     else
         use_R4.1_masks <- as.logical(use_R4.1_masks)
 

R/clippingPathGrob.R

@@ -51,7 +51,7 @@ makeContent.clipping_path <- function(x) {
 
     use_R4.1_clipping <- x$use_R4.1_clipping
     if (is.null(use_R4.1_clipping))
-        use_R4.1_clipping <- guess_has_R4.1_features()
+        use_R4.1_clipping <- guess_has_R4.1_features("clippingPaths")
     else
         use_R4.1_clipping <- as.logical(use_R4.1_clipping)
 

R/utils-params.R

@@ -73,9 +73,16 @@ get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar())
 #' the grid graphics features introduced in R v4.1.  If it guesses it does
 #' it returns `TRUE` else `FALSE`.
 #'
+#' @param features Character vector of features to guess support for.
+#'                 Will return `TRUE` only if guesses support for all requested features.\describe{
+#'                 \item{"clippingPaths"}{Supports clipping path feature}
+#'                 \item{"gradients"}{Supports (both linear and radial) gradient feature}
+#'                 \item{"masks"}{Supports (alpha) mask feature}
+#'                 \item{"patterns"}{Supports (tiling) pattern feature}
+#'                 }
 #' @seealso \url{https://www.stat.auckland.ac.nz/~paul/Reports/GraphicsEngine/definitions/definitions.html} for more info about the new grid graphics
 #'         features introduced in R v4.1.
-#' @return `TRUE` or `FALSE`
+#' @return `TRUE` if we guess all `features` are supported else `FALSE`
 #' @examples
 #'   # If R version (weakly) greater than 4.1 should be TRUE
 #'   pdf(tempfile(fileext = ".pdf"))
@@ -88,17 +95,21 @@ get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar())
 #'   invisible(dev.off())
 #'
 #' @export
-guess_has_R4.1_features <- function() {
+guess_has_R4.1_features <- function(features = c("clippingPaths", "gradients", "masks", "patterns")) {
     if (getRversion() < '4.1.0')
         return (FALSE)
 
+    if (getRversion() >= '4.2.0' && guess_via_dev_capabilities(features))
+        return (TRUE)
+
     device <- names(grDevices::dev.cur())
     if (device %in% c("cairo_pdf", "cairo_ps", "pdf", "svg", "X11cairo")) {
         TRUE
     } else if (device %in% c("bmp", "jpeg", "png", "tiff")) {
-        switch(.Platform$OS.type,
-               windows = FALSE,
-               unix = isTRUE(capabilities("cairo")))
+        if (.Platform$OS.type == "windows") # could be `type = "windows"` or `type = "cairo"`
+            guess_via_dev_capabilities(features)
+        else # on unix non-"cairo" type have different device names from "cairo" type
+           TRUE
     } else if (device %in% c("agg_jpeg", "agg_ppm", "agg_png", "agg_tiff")) {
         packageVersion("ragg") >= '1.2.0'
     } else if (device == "devSVG") {
@@ -114,9 +125,31 @@ guess_has_R4.1_features <- function() {
     }
 }
 
+# Will always return FALSE if called within R 4.1
+# or if graphics device hasn't been updated to provide this information
+# even if the device had been updated to provide R 4.1 graphic feature support
+guess_via_dev_capabilities <- function(features = c("clippingPaths", "gradients", "masks", "patterns")) {
+    guess <- TRUE
+    support <- dev.capabilities()
+
+    if (("clippingPaths" %in% features) && !isTRUE(support$clippingPaths))
+        guess <- FALSE
+    if (("gradients" %in% features) && !all(c("LinearGradient", "RadialGradient") %in% support$patterns))
+        guess <- FALSE
+    if (("masks" %in% features) && !("alpha" %in% support$masks))
+        guess <- FALSE
+    if (("patterns" %in% features) && !("TilingPattern" %in% support$patterns))
+        guess <- FALSE
+
+    guess
+}
+
 # `vdiffr::write_svg()` is the function that calls the embedded {svglite}
 # but when `vdiffr::expect_doppelganger()` calls it its call is "writer"
 likely_called_by_vdiffr <- function() {
+    if (!requireNamespace("svglite", quietly = TRUE))
+        return (TRUE)
+
     n <- sys.nframe()
     while(n > 0) {
         call <- as.character(sys.call(n))
@@ -129,23 +162,22 @@ likely_called_by_vdiffr <- function() {
 
 get_R4.1_params <- function(l) {
     # R 4.1 features
-    default <- guess_has_R4.1_features()
     l$pattern_use_R4.1_clipping <- l$pattern_use_R4.1_clipping %||%
         getOption("ggpattern_use_R4.1_clipping") %||%
         getOption("ggpattern_use_R4.1_features") %||%
-        default
+        guess_has_R4.1_features("clippingPaths")
     l$pattern_use_R4.1_gradients <- l$pattern_use_R4.1_gradients %||%
         getOption("ggpattern_use_R4.1_gradients") %||%
         getOption("ggpattern_use_R4.1_features") %||%
-        default
+        guess_has_R4.1_features("gradients")
     l$pattern_use_R4.1_masks <- l$pattern_use_R4.1_masks %||%
         getOption("ggpattern_use_R4.1_masks") %||%
         getOption("ggpattern_use_R4.1_features") %||%
-        default
+        guess_has_R4.1_features("masks")
     l$pattern_use_R4.1_patterns <- l$pattern_use_R4.1_patterns %||%
         getOption("ggpattern_use_R4.1_patterns") %||%
         getOption("ggpattern_use_R4.1_features") %||%
-        default
+        guess_has_R4.1_features("patterns")
     l
 }
 

R/zzz.R

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

tests/testthat/test_array.R

@@ -9,7 +9,17 @@ test_raster <- function(ref_png, fn, update = FALSE) {
     unlink(tmpfile)
 
     diff <- magick::image_compare(image, ref, "AE")
-    expect_true(attr(diff, "distortion") < 0.01)
+    bool <- attr(diff, "distortion") < 0.01
+    if (!bool) {
+        grDevices::dev.new()
+        grid::pushViewport(grid::viewport(x = 0.25, width = 0.5))
+        grid::grid.raster(ref)
+        grid::popViewport()
+        grid::pushViewport(grid::viewport(x = 0.75, width = 0.5))
+        grid::grid.raster(image)
+        grid::popViewport()
+    }
+    expect_true(bool)
 }
 
 my_png <- function(f, fn) {
@@ -25,6 +35,7 @@ test_that("array patterns works as expected", {
     skip_on_ci()
     skip_on_cran()
     skip_if_not(capabilities("cairo"))
+    skip_if_not_installed("grid")
     skip_if_not_installed("magick")
     skip_if_not_installed("ragg")
 
@@ -127,8 +138,11 @@ test_that("array patterns works as expected", {
 
     clippee <- rectGrob(gp = gpar(fill = "blue", col = NA))
     clipper <- editGrob(clipper, gp = gpar(col = "black", lwd=20, fill = rgb(0, 0, 0, 0.5)))
+    bitmapType = getOption("bitmapType")
+    options(bitmapType = "cairo")
     masked <- alphaMaskGrob(clippee, clipper, use_R4.1_masks = FALSE, png_device = grDevices::png)
     test_raster("alphaMaskGrob_cairo.png", function() grid.draw(masked))
+    options(bitmapType = bitmapType)
 
     # ambient
     skip_if_not_installed("ambient")