trevorld / gridpattern

Compare bb15ee4 ... +12 ... e98962c

Showing 9 of 65 files from the diff.
Newly tracked file
R/clipGrob.R created.
Other files ignored by Codecov
.appveyor.yml was deleted.
.Rbuildignore has changed.
NAMESPACE has changed.
README.Rmd has changed.
.travis.yml was deleted.
README.md has changed.
DESCRIPTION has changed.
NEWS.md has changed.

@@ -18,15 +18,14 @@
Loading
18 18
  img <- tryCatch(
19 19
    {magick::image_read(filename)},
20 20
    error = function(cond) {
21 -
      inform(cond)
22 -
      abort(glue("img_read() non-specific error with magick::image_read({shQuote(filename)})"))
21 +
      msg <- c(glue("img_read() non-specific error with magick::image_read({shQuote(filename)})"),
22 +
               i = cond$message)
23 +
      abort(msg)
23 24
    }
24 25
  )
25 -
26 26
  img
27 27
}
28 28
29 -
30 29
#' Fetch a given path or URL as a 3D RGB array of values
31 30
#'
32 31
#' @param filename filename or URL

@@ -106,6 +106,7 @@
Loading
106 106
    density <- params$pattern_density
107 107
    rot <- params$pattern_rot
108 108
    shape <- params$pattern_shape
109 +
    assert_rp_shape(shape)
109 110
110 111
    n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape)))
111 112
@@ -285,3 +286,15 @@
Loading
285 286
        concave_xy(n_vertices, polygon_angle, radius_outer, radius_inner)
286 287
    }
287 288
}
289 +
290 +
assert_rp_shape <- function(shape) {
291 +
    tf <- grepl("^convex[[:digit:]]+$|^star[[:digit:]]+$|^square$|^circle$|^null$", shape)
292 +
    if (all(tf)) {
293 +
        invisible(NULL)
294 +
    } else {
295 +
        shape <- shape[which(!tf)[1]]
296 +
        msg <- c(paste("Unknown shape", shape),
297 +
                 i = 'See `help("grid.pattern_regular_polygon")` for supported shapes')
298 +
        abort(msg)
299 +
    }
300 +
}

@@ -0,0 +1,89 @@
Loading
1 +
#' Clip grob using another grob to specify the clipping path
2 +
#'
3 +
#' `clippingPathGrob()` clips a grob using another grob to specify the clipping path
4 +
#'
5 +
#' @param clippee Grob to be clipped
6 +
#' @param clipper Grob that defines clipping region
7 +
#' @param use_R4.1_clipping If `TRUE` use the grid clipping path feature introduced in R v4.1.0
8 +
#'                          else do a `rasterGrob` approximation.
9 +
#'                          Note not all graphic devices support the grid clipping path feature.
10 +
#' @param png_device \dQuote{png} graphics device to use if `use_R4.1_clipping` is `FALSE`.
11 +
#'                   If `NULL` (default) will use `ragg::agg_png()` if the
12 +
#'                   suggested package `ragg` is available else `grDevices::png()`.
13 +
#' @param res Resolution of desired `rasterGrob` in pixels per inch if `use_R4.1_clipping` is `FALSE`.
14 +
#' @return A `grid` grob
15 +
#' @inheritParams grid::polygonGrob
16 +
#' @examples
17 +
#'   if (capabilities("png") && require("grid")) {
18 +
#'     clippee <- patternGrob("circle", gp = gpar(col = "black", fill = "yellow"),
19 +
#'                            spacing = 0.1, density = 0.5)
20 +
#'     angle <- seq(2 * pi / 4, by = 2 * pi / 6, length.out = 7)
21 +
#'     x_hex_outer <- 0.5 + 0.5 * cos(angle)
22 +
#'     y_hex_outer <- 0.5 + 0.5 * sin(angle)
23 +
#'     x_hex_inner <- 0.5 + 0.25 * cos(rev(angle))
24 +
#'     y_hex_inner <- 0.5 + 0.25 * sin(rev(angle))
25 +
#'     clipper <- grid::pathGrob(x = c(x_hex_outer, x_hex_inner),
26 +
#'                               y = c(y_hex_outer, y_hex_inner),
27 +
#'                               rule = "evenodd")
28 +
#'     clipped <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = FALSE)
29 +
#'     grid.newpage()
30 +
#'     grid.draw(clipped)
31 +
#'   }
32 +
#' @export
33 +
clippingPathGrob <- function(clippee, clipper,
34 +
         use_R4.1_clipping = getOption("ggpattern_use_R4.1_clipping", FALSE),
35 +
         png_device = NULL, res = 72,
36 +
         name = NULL, gp = gpar(), vp = NULL) {
37 +
    if (use_R4.1_clipping) {
38 +
        grob_clip <- grobTree(clippee, vp = viewport(clip = clipper), name = "clip")
39 +
        grobTree(grob_clip, name = name, gp = gp, vp = vp)
40 +
    } else {
41 +
        gTree(clippee = clippee, clipper = clipper,
42 +
              res = res, png_device = png_device,
43 +
              name=name, gp=gp, vp=vp, cl="gridpattern_clip")
44 +
    }
45 +
}
46 +
47 +
#' @export
48 +
makeContent.gridpattern_clip <- function(x) {
49 +
    current_dev <- grDevices::dev.cur()
50 +
    on.exit(grDevices::dev.set(current_dev))
51 +
52 +
    height <- x$res * convertHeight(unit(1, "npc"), "in",  valueOnly = TRUE)
53 +
    width <- x$res * convertWidth(unit(1, "npc"),  "in", valueOnly = TRUE)
54 +
    png_clippee <- tempfile(fileext = ".png")
55 +
    on.exit(unlink(png_clippee))
56 +
    if (is.null(x$png_device)) {
57 +
        if (requireNamespace("ragg", quietly = TRUE))
58 +
            png_device <- ragg::agg_png
59 +
        else
60 +
            png_device <- grDevices::png
61 +
    }
62 +
63 +
    png_device(png_clippee, height = height, width = width, bg = "transparent")
64 +
65 +
    grid.draw(x$clippee)
66 +
    dev.off()
67 +
68 +
    png_clipper <- tempfile(fileext = ".png")
69 +
    on.exit(unlink(png_clipper))
70 +
    png_device(png_clipper, height = height, width = width, bg = "transparent")
71 +
    pushViewport(viewport(gp = gpar(lwd = 0, col = NA, fill = "black")))
72 +
    grid.draw(x$clipper)
73 +
    popViewport()
74 +
    dev.off()
75 +
76 +
    raster_clippee <- png::readPNG(png_clippee, native = FALSE)
77 +
    raster_clipper <- png::readPNG(png_clipper, native = FALSE)
78 +
    clip_region <- apply(raster_clipper, c(1,2), function(x) any(x > 0))
79 +
    if (length(dim(raster_clippee) == 2)) {
80 +
        raster_clippee[!clip_region] <- 0
81 +
    } else {
82 +
        for (j in seq_len(dim(raster_clippee)[3])) {
83 +
            raster_clippee[!clip_region, j] <- 0
84 +
        }
85 +
    }
86 +
    grob <- rasterGrob(raster_clippee, name = "clip")
87 +
    gl <- gList(grob)
88 +
    setChildren(x, gl)
89 +
}

@@ -6,10 +6,10 @@
Loading
6 6
7 7
# get width, height, length, and center cooordinates of the viewport in `units` units
8 8
get_vp_measurements <- function(units = "bigpts") {
9 -
    width <- as.numeric(convertWidth(unit(1, "npc"), units))
10 -
    height <- as.numeric(convertHeight(unit(1, "npc"), units))
9 +
    width <- convertWidth(unit(1, "npc"), units, valueOnly = TRUE)
10 +
    height <- convertHeight(unit(1, "npc"), units, valueOnly = TRUE)
11 11
    length <- max(width, height)
12 -
    x <- as.numeric(convertX(unit(0.5, "npc"), units))
13 -
    y <- as.numeric(convertY(unit(0.5, "npc"), units))
12 +
    x <- convertX(unit(0.5, "npc"), units, valueOnly = TRUE)
13 +
    y <- convertY(unit(0.5, "npc"), units, valueOnly = TRUE)
14 14
    list(width = width, height = height, length = length, x = x, y = y)
15 15
}

@@ -35,28 +35,16 @@
Loading
35 35
  # NB. large pixel sizes can cause errors with getting 'placeholder' images
36 36
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
37 37
  res <- params$pattern_res # defaults to 72 DPI
38 -
  in_vp_width <- as.numeric(grid::convertWidth(unit(1, 'npc'), 'inches'))
38 +
  in_vp_width <- grid::convertWidth(unit(1, 'npc'), 'inches', valueOnly = TRUE)
39 39
  in_width <- npc_width * in_vp_width
40 40
  in_height <- npc_height * in_vp_width / aspect_ratio
41 -
  arr_width <- res * in_width
42 -
  arr_height <- res * in_height
43 -
  # enforce minimum height/width of 12 pixels
44 -
  if (arr_width < 12 || arr_height < 12) {
45 -
    mult <- 12 / min(in_width, in_height)
46 -
    arr_width  <- mult * arr_width
47 -
    arr_height <- mult * arr_height
48 -
  }
49 -
  arr_width  <- as.integer(arr_width)
50 -
  arr_height <- as.integer(arr_height)
41 +
  arr_width <- as.integer(res * in_width)
42 +
  arr_height <- as.integer(res * in_height)
43 +
  if (arr_width == 0L || arr_height == 0L)
44 +
      return(nullGrob(name = params$pattern))
51 45
52 -
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
53 -
  # If this is a legend, then draw a much smaller image.
54 -
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
46 +
  # Override type for better looking legend when tiling
55 47
  if (legend) {
56 -
    arr_width  <- as.integer( arr_width / 12)
57 -
    arr_height <- as.integer(arr_height / 12)
58 -
59 -
    # Override type for better looking legend when tiling
60 48
    if (params$pattern_type %in% c('tile', 'none')) {
61 49
      params$pattern_type <- 'fit'
62 50
    }

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Learn more Showing 1 files with coverage changes found.

New file R/clipGrob.R
New
Loading file...
Files Coverage
R 0.22% 94.47%
Project Totals (34 files) 94.47%
Loading