Compare `bb15ee4 ... +12 ... e98962c`

  img <- tryCatch(
    {magick::image_read(filename)},
    error = function(cond) {
      inform(cond)
      abort(glue("img_read() non-specific error with magick::image_read({shQuote(filename)})"))
      msg <- c(glue("img_read() non-specific error with magick::image_read({shQuote(filename)})"),
               i = cond$message)
      abort(msg)
    }
  )

  img
}


#' Fetch a given path or URL as a 3D RGB array of values
#'
#' @param filename filename or URL

@@ -106,6 +106,7 @@

    density <- params$pattern_density
    rot <- params$pattern_rot
    shape <- params$pattern_shape
    assert_rp_shape(shape)

    n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape)))


@@ -285,3 +286,15 @@

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 @@

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 @@


# get width, height, length, and center cooordinates of the viewport in `units` units
get_vp_measurements <- function(units = "bigpts") {
    width <- as.numeric(convertWidth(unit(1, "npc"), units))
    height <- as.numeric(convertHeight(unit(1, "npc"), units))
    width <- convertWidth(unit(1, "npc"), units, valueOnly = TRUE)
    height <- convertHeight(unit(1, "npc"), units, valueOnly = TRUE)
    length <- max(width, height)
    x <- as.numeric(convertX(unit(0.5, "npc"), units))
    y <- as.numeric(convertY(unit(0.5, "npc"), units))
    x <- convertX(unit(0.5, "npc"), units, valueOnly = TRUE)
    y <- convertY(unit(0.5, "npc"), units, valueOnly = TRUE)
    list(width = width, height = height, length = length, x = x, y = y)
}

@@ -35,28 +35,16 @@

  # NB. large pixel sizes can cause errors with getting 'placeholder' images
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  res <- params$pattern_res # defaults to 72 DPI
  in_vp_width <- as.numeric(grid::convertWidth(unit(1, 'npc'), 'inches'))
  in_vp_width <- grid::convertWidth(unit(1, 'npc'), 'inches', valueOnly = TRUE)
  in_width <- npc_width * in_vp_width
  in_height <- npc_height * in_vp_width / aspect_ratio
  arr_width <- res * in_width
  arr_height <- res * in_height
  # enforce minimum height/width of 12 pixels
  if (arr_width < 12 || arr_height < 12) {
    mult <- 12 / min(in_width, in_height)
    arr_width  <- mult * arr_width
    arr_height <- mult * arr_height
  }
  arr_width  <- as.integer(arr_width)
  arr_height <- as.integer(arr_height)
  arr_width <- as.integer(res * in_width)
  arr_height <- as.integer(res * in_height)
  if (arr_width == 0L || arr_height == 0L)
      return(nullGrob(name = params$pattern))

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # If this is a legend, then draw a much smaller image.
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Override type for better looking legend when tiling
  if (legend) {
    arr_width  <- as.integer( arr_width / 12)
    arr_height <- as.integer(arr_height / 12)

    # Override type for better looking legend when tiling
    if (params$pattern_type %in% c('tile', 'none')) {
      params$pattern_type <- 'fit'
    }

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...

94.47% ø +0.22%

feat: 'clippingPathGrob()' function

trevorld

e98962c

CI Passed

Hiding 12 contexual commits

+1 Files

+81

+80

94.25% ø ø

chore: Update Travis-CI badge

trevorld

bb15ee4

CI Passed

Files		•	•	•	Coverage
R	+81	+80	ø	+1	^0.22% 94.47%
Project Totals (34 files)	1,646	1,555	0	91	94.47%

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

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

Compare `bb15ee4 ... +12 ... e98962c`

No flags found

Show failed CI and contexual commits `c`

14 Commits

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

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	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		}

Compare bb15ee4 ... +12 ... e98962c

No flags found

Show failed CI and contexual commits c 14 Commits

Compare `bb15ee4 ... +12 ... e98962c`

Show failed CI and contexual commits `c`

14 Commits