New fill pattern and other updates

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gridpattern
 Type: Package
 Title: 'grid' Pattern Grobs
-Version: 1.2.0-3
+Version: 1.2.0-4
 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

@@ -16,9 +16,11 @@ export(grid.pattern)
 export(grid.pattern_ambient)
 export(grid.pattern_circle)
 export(grid.pattern_crosshatch)
+export(grid.pattern_fill)
 export(grid.pattern_gradient)
 export(grid.pattern_image)
 export(grid.pattern_magick)
+export(grid.pattern_none)
 export(grid.pattern_pch)
 export(grid.pattern_placeholder)
 export(grid.pattern_plasma)

NEWS.md

@@ -1,6 +1,19 @@
 gridpattern v1.2.0 (development)
 ================================
 
+Breaking Changes
+----------------
+
+* The default `type` for the "placeholder" pattern
+  is now "bear" instead of "kitten".
+  Explicitly set `type = "kitten"` to continue to use
+  the "kitten" placeholder but note that although
+  the "kitten" placeholder website isn't completely down
+  it has been buggy recently (#73).
+
+New Features
+------------
+
 * `patternFill()` wraps `patternGrob()` to return a
   `grid::pattern()` fill object (#70).
 * The "geometry" patterns (e.g. "circle", "stripe", etc.) now allow
@@ -16,6 +29,11 @@ gridpattern v1.2.0 (development)
     or simply copying `standalone-update_alpha.R` into your R directory and adding
     `grDevices`, `grid`, and `rlang` to the `Imports` of your `DESCRIPTION` file.
 
+* For completeness there is now a new "fill" pattern with corresponding
+  `grid.pattern_fill()` which draws a simple fill pattern.
+* For completeness there is now a `grid.pattern_none()` corresponding to the previously
+  supported "none" pattern which draws nothing.
+
 gridpattern v1.1.1
 ==================
 

R/grid-pattern-fill.R

@@ -9,14 +9,15 @@
 #' @param just,hjust,vjust  The justification of the tile relative to its location.
 #' @param group A logical indicating whether the pattern is relative to the bounding box of the grob or whether it is relative to individual shapes within the grob.  Ignored if R is less than version 4.2.
 #' @examples
-#' if (guess_has_R4.1_features("patterns") && require("grid")) {
+#' if (guess_has_R4.1_features("patterns") &&
+#'     require("grid", quietly = TRUE)) {
 #'   grid.newpage()
 #'   stripe_fill <- patternFill("stripe", fill = c("red", "blue"))
 #'   grid.circle(gp = gpar(fill = stripe_fill))
 #' }
 #'  
 #' if (guess_has_R4.1_features("patterns") && 
-#'     require("ggplot2") && 
+#'     require("ggplot2", quietly = TRUE) &&
 #'     (getRversion() >= "4.2")) {
 #'   grid.newpage()
 #'   weave_fill <- patternFill("weave", fill = "red", fill2 = "blue", 

R/grid-pattern.R

@@ -125,7 +125,7 @@ grid.pattern <- function(pattern = "stripe",
 
 #' @rdname grid.pattern
 #' @export
-names_pattern <- c("ambient", "circle", "crosshatch", "gradient", "image",
+names_pattern <- c("ambient", "circle", "crosshatch", "fill", "gradient", "image",
                    "magick", "none", "pch", "placeholder", "plasma", "polygon_tiling",
                    "regular_polygon", "rose", "stripe", "text", "wave", "weave")
 
@@ -177,6 +177,7 @@ get_pattern_fn <- function(pattern) {
     assert_patterns_unique(user_geometry_fns, user_array_fns)
     geometry_fns <- c(list(circle = create_pattern_circle_via_sf,
                            crosshatch = create_pattern_crosshatch_via_sf,
+                           fill = create_pattern_fill,
                            gradient = create_pattern_gradient,
                            none = create_pattern_none,
                            pch = create_pattern_pch,

R/pattern-array-placeholder.R

@@ -19,7 +19,7 @@
 #' @seealso [reset_image_cache()] resets the image cache used by [grid.pattern_image()] and `grid.pattern_placeholder()`.
 #' @export
 grid.pattern_placeholder <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
-                                     type = "kitten", alpha = gp$alpha %||% NA_real_,
+                                     type = "bear", alpha = gp$alpha %||% NA_real_,
                                      aspect_ratio = 1, key_scale_factor = 1,
                                      res = getOption("ggpattern_res", 72),
                                      default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
@@ -34,11 +34,19 @@ grid.pattern_placeholder <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id =
 #' @rdname grid.pattern_placeholder
 #' @export
 names_placeholder <- c(
-  "kitten", "kittenbw", "picsum", "picsumbw", "murray", "murraybw",
-  "cage", "cagebw", "bear", "bearbw", "seagal", "seagalbw", "placeholderbw",
-  "placeholder", "dummybw", "dummy", "flickr", "flickrbw", "beard",
-  "beardbw", "lorempixel", "lorempixelbw", "placeimg", "placeimgbw",
-  'keanu', 'keanubw'
+  "bear", "bearbw",
+  "beard", "beardbw",
+  "cage", "cagebw",
+  "dummybw", "dummy",
+  "flickr", "flickrbw",
+  "keanu", "keanubw",
+  "kitten", "kittenbw",
+  "lorempixel", "lorempixelbw",
+  "murray", "murraybw",
+  "picsum", "picsumbw",
+  "placeholder", "placeholderbw",
+  "placeimg", "placeimgbw",
+  "seagal", "seagalbw"
 )
 
 #' Fetch a placeholder image of the correct dimensions
@@ -71,32 +79,32 @@ fetch_placeholder_img <- function(width = 100, height = 100, type = 'kitten') {
 
   img_url <- switch(
     type,
-    kitten         = glue("https://placekitten.com/{width}/{height}"),
-    kittenbw       = glue("https://placekitten.com/g/{width}/{height}"),
-    picsum         = glue("https://picsum.photos/{width}/{height}"),
-    picsumbw       = glue("https://picsum.photos/{width}/{height}?grayscale"),
-    murray         = glue("http://www.fillmurray.com/{width}/{height}"),
-    murraybw       = glue("http://www.fillmurray.com/g/{width}/{height}"),
-    cage           = glue("https://www.placecage.com/{width}/{height}"),
-    cagebw         = glue("https://www.placecage.com/g/{width}/{height}"),
     bear           = glue("https://placebear.com/{width}/{height}"),
     bearbw         = glue("https://placebear.com/g/{width}/{height}"),
-    seagal         = glue("https://www.stevensegallery.com/{width}/{height}"),
-    seagalbw       = glue("https://www.stevensegallery.com/g/{width}/{height}"),
-    placeholderbw  = ,
-    placeholder    = glue("https://via.placeholder.com/{width}x{height}.png"),
-    dummybw        = ,
+    beard          = glue("http://placebeard.it/{width}/{height}"),
+    beardbw        = glue("http://placebeard.it/g/{width}/{height}"),
+    cage           = glue("https://www.placecage.com/{width}/{height}"),
+    cagebw         = glue("https://www.placecage.com/g/{width}/{height}"),
     dummy          = glue("https://dummyimage.com/{width}x{height}"),
+    dummybw        = ,
     flickr         = glue("https://loremflickr.com/{width}/{height}"),
     flickrbw       = glue("https://loremflickr.com/g/{width}/{height}/all"),
-    beard          = glue("http://placebeard.it/{width}/{height}"),
-    beardbw        = glue("http://placebeard.it/g/{width}/{height}"),
+    keanu          = glue("https://placekeanu.com/{width}/{height}"),
+    keanubw        = glue("https://placekeanu.com/{width}/{height}/g"),
+    kitten         = glue("https://placekitten.com/{width}/{height}"),
+    kittenbw       = glue("https://placekitten.com/g/{width}/{height}"),
     lorempixel     = glue("http://lorempixel.com/{width}/{height}"),
     lorempixelbw   = glue("http://lorempixel.com/g/{width}/{height}"),
+    murray         = glue("http://www.fillmurray.com/{width}/{height}"),
+    murraybw       = glue("http://www.fillmurray.com/g/{width}/{height}"),
+    picsum         = glue("https://picsum.photos/{width}/{height}"),
+    picsumbw       = glue("https://picsum.photos/{width}/{height}?grayscale"),
+    placeholder    = glue("https://via.placeholder.com/{width}x{height}.png"),
+    placeholderbw  = ,
     placeimg       = glue("http://placeimg.com/{width}/{height}/any"),
     placeimgbw     = glue("http://placeimg.com/{width}/{height}/any/grayscale"),
-    keanu          = glue("https://placekeanu.com/{width}/{height}"),
-    keanubw        = glue("https://placekeanu.com/{width}/{height}/g"),
+    seagal         = glue("https://www.stevensegallery.com/{width}/{height}"),
+    seagalbw       = glue("https://www.stevensegallery.com/g/{width}/{height}"),
     {
       # warn("fetch_placeholder_image_as_array(): Unknown pattern_type (", type, ") ",
       #         "using 'kitten'")

R/pattern-both-gradient.R

@@ -3,13 +3,14 @@
 #' `grid.pattern_gradient()` draws a gradient pattern onto the graphic device.
 #'
 #' @inheritParams grid.pattern_circle
-#' @param fill2 Second colour
-#' @param orientation vertical, horizontal, or radial
-#' @param aspect_ratio Override aspect ratio
+#' @param fill Colour.
+#' @param fill2 Second colour.
+#' @param orientation vertical, horizontal, or radial.
+#' @param aspect_ratio Override aspect ratio.
 #' @param use_R4.1_gradients Whether to use the gradient feature introduced in R v4.1
 #'                           or use a `rasterGrob` approximation.
 #'                           Note not all graphic devices support the grid gradient feature.
-#' @param key_scale_factor Additional scale factor for legend
+#' @param key_scale_factor Additional scale factor for legend.
 #' @param res Assumed resolution (in pixels per graphic device inch) to use when creating array pattern.
 #' @return A grid grob object invisibly.  If `draw` is `TRUE` then also draws to the graphic device as a side effect.
 #' @examples

R/pattern-geometry-circle.R

@@ -3,18 +3,18 @@
 #' `grid.pattern_circle()` draws a circle pattern onto the graphic device.
 #'
 #' @inheritParams grid.pattern
-#' @param ... Currently ignored
-#' @param colour Stroke colour
-#' @param fill Fill colour
-#' @param angle Rotation angle in degrees
+#' @param ... Currently ignored.
+#' @param colour Stroke colour(s).
+#' @param fill Fill colour(s) or [grid::pattern()] / gradient object(s).
+#' @param angle Rotation angle in degrees.
 #' @param density Approx. fraction of area the pattern fills.
 #' @param spacing Spacing between repetitions of pattern ('snpc' units between 0 and 1).
 #' @param xoffset Shift pattern along x axis ('snpc' units between 0 and 1).
 #' @param yoffset Shift pattern along y axis ('snpc' units between 0 and 1).
 #' @param alpha Alpha (between 0 and 1) or `NA` (default, preserves colors' alpha value).
-#' @param linetype Stroke linetype
-#' @param linewidth Stroke linewidth
-#' @param size For backwards compatibility can be used to set `linewidth`
+#' @param linetype Stroke linetype.
+#' @param linewidth Stroke linewidth.
+#' @param size For backwards compatibility can be used to set `linewidth`.
 #' @param grid Adjusts placement and density of certain graphical elements.
 #'             `"square"` (default) is a square grid.
 #'             `"hex"` is a hexagonal grid suitable for hexagonal and triangular tiling.

R/pattern-geometry-fill.R

@@ -0,0 +1,46 @@
+#' 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_fill <- function(params, boundary_df, aspect_ratio,
+                                legend = FALSE) {
+    alpha <- ifelse(is.na(params$pattern_alpha), 1, params$pattern_alpha)
+    fill <- update_alpha(params$pattern_fill, alpha)
+    gp <- grid::gpar(col = NA_character_, fill = fill)
+
+    convert_polygon_df_to_polygon_grob(boundary_df, gp = gp)
+}
+
+#' Grobs with a simple fill pattern
+#'
+#' `grid.pattern_fill()` draws a simple fill pattern onto the graphics device.
+#'
+#' @inheritParams grid.pattern_circle
+#' @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
+#' 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))
+#' grid.pattern_fill(x_hex, y_hex, fill = "blue")
+#'
+#' if (guess_has_R4.1_features("patterns")) {
+#'   grid::grid.newpage()
+#'   stripe_fill <- patternFill("stripe", fill = c("red", "blue"))
+#'   grid.pattern_fill(x_hex, y_hex, fill = stripe_fill)
+#' }
+#' @seealso [grid::grid.polygon()]
+#' @export
+grid.pattern_fill <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
+                              fill = gp$fill %||% "grey80", 
+                              alpha = gp$alpha %||% NA_real_,
+                              default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
+    grid.pattern("fill", x, y, id,
+                 fill = fill, alpha = alpha,
+                 default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
+}

R/pattern-geometry-none.R

@@ -12,3 +12,22 @@ create_pattern_none <- function(params, boundary_df, aspect_ratio,
                                 legend = FALSE) {
   grid::nullGrob()
 }
+
+#' Grobs without any pattern
+#'
+#' `grid.pattern_none()` draws nothing onto the graphic device.
+#'
+#' @inheritParams grid.pattern
+#' @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
+#' 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))
+#' grid.pattern_none(x_hex, y_hex)
+#' @seealso [grid::grid.null()]
+#' @export
+grid.pattern_none <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
+                              default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
+    grid.pattern("none", x, y, id,
+                 default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
+}

R/utils-magick-read.R

@@ -8,8 +8,8 @@ img_read <- function(filename) {
   if (identical(filename, '')) {
     return(magick::image_blank(100, 100, color = 'none'))
   }
-  if (is.null(filename) || length(filename)==0 || is.na(filename) || filename == '') {
-    abort(paste0("img_read(): bad filename: ", deparse(filename)))
+  if (is.null(filename) || length(filename)== 0 || is.na(filename) || filename == '') {
+    abort(paste0("bad filename: ", deparse(filename)))
   }
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -18,7 +18,7 @@ img_read <- function(filename) {
   img <- tryCatch(
     {magick::image_read(filename)},
     error = function(cond) {
-      msg <- c(glue("img_read() non-specific error with magick::image_read({shQuote(filename)})"),
+      msg <- c(glue("couldn't read {shQuote(filename)}"),
                i = cond$message)
       abort(msg)
     }
@@ -49,7 +49,7 @@ img_read_as_array <- function(filename, width = NULL, height = NULL,
   img <- img_read_memoised(filename)
 
   if (is.null(img)) {
-    abort(glue("img_read_as_array(): couldn't read '{filename}'"))
+    abort(glue("couldn't read {shQuote(filename)}"))
   }
 
   img <- fill_area_with_img(img, width, height, type = fill_type, gravity = gravity,

R/utils-params.R

@@ -101,7 +101,7 @@ default_pattern_type <- function(pattern) {
     switch(pattern,
            ambient = "simplex",
            image = "fit",
-           placeholder = "kitten",
+           placeholder = "bear",
            polygon_tiling = "square",
            magick = "hexagons",
            wave = "triangle",