Compare `bb15ee4 ... +21 ... c1c39ff`

  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

@@ -0,0 +1,149 @@

1	+	#' Rose curve patterned grobs
2	+	#'
3	+	#' `grid.pattern_rose()` draws a rose curve pattern onto the graphic device.
4	+	#'
5	+	#' @inheritParams grid.pattern_circle
6	+	#' @inheritParams clippingPathGrob
7	+	#' @param rot Angle to rotate rose (degrees, counter-clockwise).
8	+	#' @param frequency The \dQuote{angular frequency} parameter of the rose pattern.
9	+	#' @return A grid grob object invisibly. If `draw` is `TRUE` then also draws to the graphic device as a side effect.
10	+	#' @seealso See \url{https://en.wikipedia.org/wiki/Rose_(mathematics)} for more information.
11	+	#' @examples
12	+	#' if (require("grid")) {
13	+	#' x_hex <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6))
14	+	#' y_hex <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6))
15	+	#'
16	+	#' gp <- gpar(fill = c("blue", "red", "yellow", "green"), col = "black")
17	+	#' grid.newpage()
18	+	#' grid.pattern_rose(x_hex, y_hex,
19	+	#' spacing = 0.15, density = 0.5, angle = 0,
20	+	#' frequency = 1:4, gp = gp)
21	+	#' grid.newpage()
22	+	#' grid.pattern_rose(x_hex, y_hex,
23	+	#' spacing = 0.15, density = 0.5, angle = 0,
24	+	#' frequency = 1/1:4, gp = gp)
25	+	#' }
26	+	#' @export
27	+	grid.pattern_rose <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
28	+	colour = gp$col %\|\|% "grey20",
29	+	fill = gp$fill %\|\|% "grey80",
30	+	angle = 30, density = 0.2,
31	+	spacing = 0.05, xoffset = 0, yoffset = 0,
32	+	frequency = 0.1,
33	+	grid = "square", type = NULL, subtype = NULL,
34	+	rot = 0,
35	+	alpha = gp$alpha %\|\|% NA_real_, linetype = gp$lty %\|\|% 1,
36	+	size = gp$lwd %\|\|% 1,
37	+	use_R4.1_clipping = getOption("ggpattern_use_R4.1_clipping",
38	+	getOption("ggpattern_use_R4.1_features")),
39	+	png_device = NULL, res = 72,
40	+	default.units = "npc", name = NULL,
41	+	gp = gpar(), draw = TRUE, vp = NULL) {
42	+	if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color
43	+	grid.pattern("rose", x, y, id,
44	+	colour = colour, fill = fill, angle = angle,
45	+	density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset,
46	+	scale = scale, frequency = frequency,
47	+	grid = grid, type = type, subtype = subtype, rot = rot,
48	+	use_R4.1_clipping = use_R4.1_clipping, png_device = png_device, res = res,
49	+	alpha = alpha, linetype = linetype, size = size,
50	+	default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
51	+	}
52	+
53	+	create_pattern_rose <- function(params, boundary_df, aspect_ratio, legend = FALSE) {
54	+	# work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio
55	+	default.units <- "bigpts"
56	+	boundary_df <- convert_polygon_df_units(boundary_df, default.units)
57	+	params <- convert_params_units(params, default.units)
58	+	vpm <- get_vp_measurements(default.units)
59	+
60	+	spacing <- params$pattern_spacing
61	+	grid <- params$pattern_grid
62	+
63	+	# create grid of points large enough to cover viewport no matter the angle
64	+	grid_xy <- get_xy_grid(params, vpm)
65	+
66	+	# construct grobs using subsets if certain inputs are vectorized
67	+	fill <- alpha(params$pattern_fill, params$pattern_alpha)
68	+	col <- alpha(params$pattern_colour, params$pattern_alpha)
69	+	lwd <- params$pattern_size * .pt
70	+	lty <- params$pattern_linetype
71	+
72	+	density <- params$pattern_density
73	+	rot <- params$pattern_rot
74	+	frequency <- params$pattern_frequency
75	+
76	+	n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, frequency)))
77	+
78	+	fill <- rep(fill, length.out = n_par)
79	+	col <- rep(col, length.out = n_par)
80	+	lwd <- rep(lwd, length.out = n_par)
81	+	lty <- rep(lty, length.out = n_par)
82	+	density <- rep(density, length.out = n_par)
83	+	rot <- rep(rot, length.out = n_par)
84	+	frequency <- rep(frequency, length.out = n_par)
85	+
86	+	density_max <- max(density)
87	+
88	+	# compute regular polygon relative coordinates which we will center on points
89	+	radius_mult <- switch(grid, hex = 0.578, 0.5)
90	+	radius_max <- radius_mult * spacing * density_max
91	+
92	+	# compute pattern matrix of graphical elements (e.g. fill colors)
93	+	if (is.null(params$pattern_type) \|\| is.na(params$pattern_type))
94	+	params$pattern_type <- switch(grid, square = "square", "hex")
95	+	m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par)
96	+
97	+	gl <- gList()
98	+	for (i_par in seq(n_par)) {
99	+	radius_outer <- radius_mult * spacing * density[i_par]
100	+	xy_rose <- get_xy_rose(frequency[i_par], params, radius_outer, rot[i_par])
101	+	xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing)
102	+	if (length(xy_par$x) == 0) next
103	+
104	+	# rotate by 'angle'
105	+	xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y)
106	+
107	+	gp <- gpar(fill = fill[i_par], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par])
108	+
109	+	name <- paste0("rose.", i_par)
110	+	grob <- points_to_rose_grob(xy_par, xy_rose, gp, default.units, name)
111	+	gl <- append_gList(gl, grob)
112	+	}
113	+	clippee <- gTree(children = gl)
114	+	clipper <- convert_polygon_df_to_polygon_grob(boundary_df, default.units = "bigpts")
115	+	clippingPathGrob(clippee, clipper,
116	+	use_R4.1_clipping = params$pattern_use_R4.1_clipping,
117	+	png_device = params$pattern_png_device,
118	+	res = params$pattern_res, name = "rose")
119	+	}
120	+
121	+	get_xy_rose <- function(frequency, params, radius_outer, rot) {
122	+	theta <- to_radians(seq.int(from = 0, to = 16 * 360, by = 1))
123	+	x <- radius_outer * cos(frequency * theta) * cos(theta)
124	+	y <- radius_outer * cos(frequency * theta) * sin(theta)
125	+	rose_angle <- rot + params$pattern_angle
126	+	rotate_xy(x, y, rose_angle, 0, 0)
127	+	}
128	+
129	+	points_to_rose_grob <- function(xy_par, xy_rose, gp, default.units, name) {
130	+	points_mat <- as.data.frame(xy_par)
131	+	df_polygon <- as.data.frame(xy_rose)
132	+	l_xy <- lapply(seq(nrow(points_mat)),
133	+	function(i_r) {
134	+	x0 <- points_mat[i_r, 1]
135	+	y0 <- points_mat[i_r, 2]
136	+	df <- df_polygon
137	+	df$x <- df$x + x0
138	+	df$y <- df$y + y0
139	+	df
140	+	})
141	+	df <- do.call(rbind, l_xy)
142	+	if (is.null(df)) {
143	+	nullGrob()
144	+	} else {
145	+	df$id <- rep(seq(nrow(points_mat)), each = nrow(df_polygon))
146	+	pathGrob(x = df$x, y = df$y, id = df$id,
147	+	default.units = default.units, gp = gp, name = name)
148	+	}
149	+	}

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


@@ -236,23 +237,26 @@

}

# create grid of points large enough to cover viewport no matter the angle
get_xy_grid <- function(params, vpm) {
    spacing <- params$pattern_spacing
get_xy_grid <- function(params, vpm, wavelength = FALSE) {
    xoffset <- params$pattern_xoffset
    yoffset <- params$pattern_yoffset
    if (wavelength)
        h_spacing <- params$pattern_wavelength
    else
        h_spacing <- params$pattern_spacing

    gm <- 1.00 # seems to need to be this big so {ggpattern} legends render correctly
    x_adjust <- switch(params$pattern_grid, hex = 0.5 * spacing, 0)
    x_seq <- seq_robust(from = 0, to = gm * vpm$length + x_adjust, by = spacing)
    x_adjust <- switch(params$pattern_grid, hex = 0.5 * h_spacing, 0)
    x_seq <- seq_robust(from = 0, to = gm * vpm$length + x_adjust, by = h_spacing)
    x <- xoffset + vpm$x + c(rev(tail(-x_seq, -1L)), x_seq)
    x_min <- min(x)
    x_max <- max(x)

    # adjust vertical spacing for "hex" pattern
    if (params$pattern_grid == "square")
        v_spacing <- spacing
        v_spacing <- params$pattern_spacing
    else
        v_spacing <- 0.5 * sqrt(3) * spacing
        v_spacing <- 0.5 * sqrt(3) * params$pattern_spacing
    y_seq <- seq_robust(from = 0, to = gm * vpm$length, by = v_spacing)
    # ensure middle y point in a hex grid is an odd number so we don't accidentally offset it
    if (params$pattern_grid != "square" && (length(y_seq) %% 2L == 0L))

@@ -263,7 +267,7 @@


    list(x = x, y = y,
         x_min = x_min, x_max = x_max, y_min = y_min, y_max = y_max,
         h_spacing = spacing, v_spacing = v_spacing
         h_spacing = h_spacing, v_spacing = v_spacing
    )
}


@@ -285,3 +289,15 @@

285	289		concave_xy(n_vertices, polygon_angle, radius_outer, radius_inner)
286	290		}
287	291		}
	292	+
	293	+	assert_rp_shape <- function(shape) {
	294	+	tf <- grepl("^convex[[:digit:]]+$\|^star[[:digit:]]+$\|^square$\|^circle$\|^null$", shape)
	295	+	if (all(tf)) {
	296	+	invisible(NULL)
	297	+	} else {
	298	+	shape <- shape[which(!tf)[1]]
	299	+	msg <- c(paste("Unknown shape", shape),
	300	+	i = 'See `help("grid.pattern_regular_polygon")` for supported shapes')
	301	+	abort(msg)
	302	+	}
	303	+	}

@@ -6,6 +6,9 @@

#' @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 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.

@@ -20,11 +23,14 @@

grid.pattern_gradient <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
                                  fill = gp$fill %||% "grey80", fill2 = "#4169E1",
                                  orientation = "vertical", alpha = gp$alpha %||% NA_real_,
                                  use_R4.1_gradients = getOption("ggpattern_use_R4.1_gradients",
                                                                 getOption("ggpattern_use_R4.1_features")),
                                  aspect_ratio = 1, key_scale_factor = 1, res = 72,
                                  default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
    grid.pattern("gradient", x, y, id,
                 fill = fill, fill2 = fill2,
                 orientation = orientation, alpha = alpha,
                 use_R4.1_gradients = use_R4.1_gradients,
                 aspect_ratio = aspect_ratio, key_scale_factor = key_scale_factor, res = res,
                 default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
}

@@ -66,6 +72,48 @@

66	72		img
67	73		}
68	74
	75	+	create_pattern_gradient <- function(params, boundary_df, aspect_ratio, legend = FALSE) {
	76	+	if (params$pattern_use_R4.1_gradients) {
	77	+	create_gradient_as_geometry(params, boundary_df, aspect_ratio, legend)
	78	+	} else {
	79	+	create_pattern_array(params, boundary_df, aspect_ratio, legend, create_gradient_as_array)
	80	+	}
	81	+	}
	82	+
	83	+	create_gradient_as_geometry <- function(params, boundary_df, aspect_ratio, legend) {
	84	+	orientation <- check_default(params$pattern_orientation,
	85	+	options = c('vertical', 'horizontal', 'radial'))
	86	+	colour1 <- params$pattern_fill
	87	+	colour2 <- params$pattern_fill2
	88	+
	89	+	x_min <- min(boundary_df$x)
	90	+	x_max <- max(boundary_df$x)
	91	+	x_med <- 0.5 * (x_min + x_max)
	92	+	y_min <- min(boundary_df$y)
	93	+	y_max <- max(boundary_df$y)
	94	+	y_med <- 0.5 * (y_min + y_max)
	95	+	x_range <- convertX(unit(x_max - x_min, "npc"), "in")
	96	+	y_range <- convertY(unit(y_max - y_min, "npc"), "in")
	97	+	gradient <- switch(orientation,
	98	+	horizontal = linearGradient(c(colour1, colour2),
	99	+	x1 = x_min, y1 = y_med,
	100	+	x2 = x_max, y2 = y_med),
	101	+	radial = radialGradient(c(colour1, colour2),
	102	+	cx1 = x_med, cy1 = y_med,
	103	+	cx2 = x_med, cy2 = y_med,
	104	+	r2 = 0.5 * max(x_range, y_range),
	105	+	extend = "none"
	106	+	),
	107	+	vertical = linearGradient(c(colour1, colour2),
	108	+	x1 = x_med, y1 = y_min,
	109	+	x2 = x_med, y2 = y_max)
	110	+	)
	111	+
	112	+	gp <- gpar(col = NA, fill = gradient)
	113	+
	114	+	convert_polygon_df_to_polygon_grob(boundary_df, gp = gp)
	115	+	}
	116	+
69	117		#' A shim to go between the main pattern function for an image, and the
70	118		#' specific pattern functon for an image.
71	119		#'

@@ -81,7 +129,8 @@

#' @noRd
create_gradient_as_array <- function(width, height, params, legend) {

  orientation <- check_default(params$pattern_orientation, options = c('vertical', 'horizontal', 'radial'))
  orientation <- check_default(params$pattern_orientation,
                               options = c('vertical', 'horizontal', 'radial'))
  colour1     <- params$pattern_fill
  colour2     <- params$pattern_fill2


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

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 4 files with coverage changes found.

New file R/pattern-both-rose.R

New

Loading file...

New file R/pattern-both-text.R

New

Loading file...

New file R/clippingPathGrob.R

New

Loading file...

New file R/pattern-geometry-wave.R

New

Loading file...

93.28% 95.83% -0.97%

feat: Add 'wave' pattern

trevorld

c1c39ff

CI Passed

Hiding 8 contexual commits

+3 Files

+274

+236

+38

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	+355	+316	ø	+39	^-0.97% 93.28%
Project Totals (37 files)	1,920	1,791	0	129	93.28%

236	237		}
237	238
238	239		# create grid of points large enough to cover viewport no matter the angle
239		-	get_xy_grid <- function(params, vpm) {
240		-	spacing <- params$pattern_spacing
	240	+	get_xy_grid <- function(params, vpm, wavelength = FALSE) {
241	241		xoffset <- params$pattern_xoffset
242	242		yoffset <- params$pattern_yoffset
	243	+	if (wavelength)
	244	+	h_spacing <- params$pattern_wavelength
	245	+	else
	246	+	h_spacing <- params$pattern_spacing
243	247
244	248		gm <- 1.00 # seems to need to be this big so {ggpattern} legends render correctly
245		-	x_adjust <- switch(params$pattern_grid, hex = 0.5 * spacing, 0)
246		-	x_seq <- seq_robust(from = 0, to = gm * vpm$length + x_adjust, by = spacing)
	249	+	x_adjust <- switch(params$pattern_grid, hex = 0.5 * h_spacing, 0)
	250	+	x_seq <- seq_robust(from = 0, to = gm * vpm$length + x_adjust, by = h_spacing)
247	251		x <- xoffset + vpm$x + c(rev(tail(-x_seq, -1L)), x_seq)
248	252		x_min <- min(x)
249	253		x_max <- max(x)
250	254
251	255		# adjust vertical spacing for "hex" pattern
252	256		if (params$pattern_grid == "square")
253		-	v_spacing <- spacing
	257	+	v_spacing <- params$pattern_spacing
254	258		else
255		-	v_spacing <- 0.5 * sqrt(3) * spacing
	259	+	v_spacing <- 0.5 * sqrt(3) * params$pattern_spacing
256	260		y_seq <- seq_robust(from = 0, to = gm * vpm$length, by = v_spacing)
257	261		# ensure middle y point in a hex grid is an odd number so we don't accidentally offset it
258	262		if (params$pattern_grid != "square" && (length(y_seq) %% 2L == 0L))

263	267
264	268		list(x = x, y = y,
265	269		x_min = x_min, x_max = x_max, y_min = y_min, y_max = y_max,
266		-	h_spacing = spacing, v_spacing = v_spacing
	270	+	h_spacing = h_spacing, v_spacing = v_spacing
267	271		)
268	272		}
269	273

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 ... +21 ... c1c39ff`

No flags found

Show failed CI and contexual commits `c`

23 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

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

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

20	23		grid.pattern_gradient <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
21	24		fill = gp$fill %\|\|% "grey80", fill2 = "#4169E1",
22	25		orientation = "vertical", alpha = gp$alpha %\|\|% NA_real_,
	26	+	use_R4.1_gradients = getOption("ggpattern_use_R4.1_gradients",
	27	+	getOption("ggpattern_use_R4.1_features")),
23	28		aspect_ratio = 1, key_scale_factor = 1, res = 72,
24	29		default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
25	30		grid.pattern("gradient", x, y, id,
26	31		fill = fill, fill2 = fill2,
27	32		orientation = orientation, alpha = alpha,
	33	+	use_R4.1_gradients = use_R4.1_gradients,
28	34		aspect_ratio = aspect_ratio, key_scale_factor = key_scale_factor, res = res,
29	35		default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
30	36		}

81	129		#' @noRd
82	130		create_gradient_as_array <- function(width, height, params, legend) {
83	131
84		-	orientation <- check_default(params$pattern_orientation, options = c('vertical', 'horizontal', 'radial'))
	132	+	orientation <- check_default(params$pattern_orientation,
	133	+	options = c('vertical', 'horizontal', 'radial'))
85	134		colour1 <- params$pattern_fill
86	135		colour2 <- params$pattern_fill2
87	136

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 ... +21 ... c1c39ff

No flags found

Show failed CI and contexual commits c 23 Commits

Compare `bb15ee4 ... +21 ... c1c39ff`

Show failed CI and contexual commits `c`

23 Commits