trevorld / gridpattern

Compare bb15ee4 ... +21 ... c1c39ff

Showing 13 of 80 files from the diff.
Newly tracked file
R/clippingPathGrob.R created.
Other files ignored by Codecov
README.md has changed.
.Rbuildignore has changed.
NAMESPACE has changed.
.travis.yml was deleted.
README.Rmd has changed.
.appveyor.yml was deleted.
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

@@ -0,0 +1,149 @@
Loading
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 @@
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
@@ -236,23 +237,26 @@
Loading
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,7 +267,7 @@
Loading
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
@@ -285,3 +289,15 @@
Loading
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 @@
Loading
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,11 +23,14 @@
Loading
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
}
@@ -66,6 +72,48 @@
Loading
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 @@
Loading
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,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...

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

23 Commits

Hiding 8 contexual commits
+3 Files
+274
+236
+38
Hiding 12 contexual commits
+1 Files
+81
+80
+1
Files Coverage
R -0.97% 93.28%
Project Totals (37 files) 93.28%
Loading