fix: "image" pattern bug when "type = 'tile'"

* Fixes bug with `grid.pattern_image()` with `type = "tile"` (#47).
  Additionally `grid.pattern_image()` now supports `gravity` argument when `type = "tile"`.
* We now use 'image_append()' and 'image_crop()' instead of 'convert'
  binary or 'image_blank()'.
* Transparent parts of image are now always transparent.

closes #47

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gridpattern
 Type: Package
 Title: 'grid' Pattern Grobs
-Version: 0.5.1
+Version: 0.5.2-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("Thomas Lin", "Pedersen", role = "ctb", comment = "new_data_frame() copied from ggplot2"))

NEWS.md

@@ -1,3 +1,12 @@
+gridpattern v0.5.2
+==================
+
+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"`.
+
 gridpattern v0.5.1
 ==================
 

R/pattern-array-image.R

@@ -38,7 +38,8 @@
 #' @export
 grid.pattern_image <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
                                filename = "", type = "fit", scale = 1,
-                               gravity = "center", filter = "lanczos",
+                               gravity = switch(type, tile = "southwest", "center"),
+                               filter = "lanczos",
                                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) {

R/utils-magick-fill.R

@@ -143,59 +143,27 @@ update_scale <- function(scale, img, width, height) {
 
 #' Tile image to fill the specified area
 #'
-#' Unless the width and height are carefully chosen, this operation will distort
-#' the image to force it to fit the dimensions
-#'
-#' @inheritParams fill_area_with_img
-#'
 #' @return magick image of the required dimensions
-#'
-#' @examples
-#' try({
-#'   filename <- system.file("img", "Rlogo.png", package="png")
-#'   img <- magick::image_read(filename)
-#'   fill_area_with_img_none(img, 100, 400)
-#' })
 #' @noRd
-fill_area_with_img_tile <- function(img, width, height, filter = filter, scale = 1) {
+fill_area_with_img_tile <- function(img, width, height, gravity = "SouthWest", filter = filter, scale = 1) {
 
-  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  # Scale if requested
-  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   scale <- update_scale(scale, img, width, height)
   if (scale != 1) {
     geometry <- magick::geometry_size_percent(width = scale * 100)
     img      <- magick::image_resize(img, geometry, filter = filter)
   }
 
-  img <- magick::image_flip(img)
-  # Save the source tile locally
-  tile_temp_filename <- tempfile(fileext = ".png")
-  magick::image_write(img, path = tile_temp_filename)
-  # Tile using command line 'imagemagick', seems to choke on Windows
-  img <- try(tile_image_via_convert(tile_temp_filename, width, height),
-             silent = TRUE)
-  if (inherits(img, "try-error")) {
-      # Tile using `image_blank()`, buggy on my Ubuntu system but not on Windows?
-      pseudo <- glue("tile:{tile_temp_filename}")
-      img <- magick::image_blank(width, height, pseudo_image = pseudo)
-  }
-  img <- magick::image_flip(img)
+  img_info <- magick::image_info(img)
+  n_width <- width %/% img_info$width + as.integer(width %% img_info$width > 0)
+  n_height <- height %/% img_info$height + as.integer(height %% img_info$height > 0)
+  rows <- magick::image_append(rep(img, n_width))
+  tiled <- magick::image_append(rep(rows, n_height), stack=TRUE)
 
-  img
-}
+  geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = FALSE)
 
+  cropped <- magick::image_crop(tiled, geometry = geometry, gravity = gravity)
 
-# requires `convert` command-line tool which tends to choke on Windows
-tile_image_via_convert <- function(tile_temp_filename, width, height) {
-    tmp_filename <- tempfile(fileext = ".png")
-    command <- "convert"
-    args <- c("-size", glue("{width}x{height}"),
-              glue("tile:'{tile_temp_filename}'"),
-              "-background", "none",
-              tmp_filename)
-    system2(command, args, stdout = FALSE, stderr = FALSE)
-    magick::image_read(tmp_filename)
+  cropped
 }
 
 #' Fill an area with a magick image
@@ -246,7 +214,7 @@ fill_area_with_img <- function(img, width, height, type='squish',
     expand = fill_area_with_img_expand(img, width, height, gravity = gravity, filter = filter),
     squish = fill_area_with_img_squish(img, width, height                   , filter = filter),
     none   = fill_area_with_img_none  (img, width, height, gravity = gravity, filter = filter, scale = scale),
-    tile   = fill_area_with_img_tile  (img, width, height,                    filter = filter, scale = scale),
+    tile   = fill_area_with_img_tile  (img, width, height, gravity = gravity, filter = filter, scale = scale),
     {
       warn("fill_area_with_img(): resize not understood: '", type,
            "', using 'squish'")

R/utils-params.R

@@ -25,7 +25,6 @@ get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar())
         switch(pattern, crosshatch = l$pattern_fill, "#4169E1")
     l$pattern_filter <- l$pattern_filter %||%
         switch(pattern, magick = "box", "lanczos")
-    l$pattern_gravity <- l$pattern_gravity %||% "center"
     l$pattern_grid <- l$pattern_grid %||% "square"
     l$pattern_key_scale_factor <- l$pattern_key_scale_factor %||% 1
     l$pattern_orientation <- l$pattern_orientation %||% "vertical"
@@ -41,6 +40,10 @@ get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar())
         l$pattern_type <- default_pattern_type(pattern)
     l$pattern_xoffset <- l$pattern_xoffset %||% 0
     l$pattern_yoffset <- l$pattern_yoffset %||% 0
+    l$pattern_gravity <- l$pattern_gravity %||%
+        switch(l$pattern_type, tile = "southwest", "center")
+    if (is.na(l$pattern_gravity))
+        l$pattern_gravity <- switch(l$pattern_type, tile = "southwest", "center")
 
     l$pattern_res <- l$pattern_res %||% getOption("ggpattern_res", 72) # in PPI
 
@@ -60,7 +63,6 @@ get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar())
     l$pattern_distance_ind <- l$pattern_distance_ind %||% c(1, 2)
     l$pattern_jitter <- l$pattern_jitter %||% 0.45
 
-
     l
 }