trevorld / gridpattern

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

@@ -0,0 +1,171 @@
Loading
1 +
#' Wave patterned grobs
2 +
#'
3 +
#' `grid.pattern_wave()` draws a wave pattern onto the graphic device.
4 +
#'
5 +
#' @inheritParams grid.pattern_circle
6 +
#' @param amplitude Wave amplitude (\dQuote{snpc} units)
7 +
#' @param frequency Linear frequency (inverse \dQuote{snpc} units)
8 +
#' @param type Either \dQuote{sine} or \dQuote{triangle} (default).
9 +
#' @return A grid grob object invisibly.  If `draw` is `TRUE` then also draws to the graphic device as a side effect.
10 +
#' @examples
11 +
#'   if (require("grid")) {
12 +
#'     x_hex <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6))
13 +
#'     y_hex <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6))
14 +
#'     grid.newpage()
15 +
#'     grid.pattern_wave(x_hex, y_hex, colour = "black", type = "sine",
16 +
#'                       fill = c("red", "blue"), density = 0.4,
17 +
#'                       spacing = 0.15, angle = 0,
18 +
#'                       amplitude = 0.05, frequency = 1 / 0.20)
19 +
#'
20 +
#'     # zig-zag pattern is a wave of `type` "triangle"
21 +
#'     grid.newpage()
22 +
#'     grid.pattern_wave(x_hex, y_hex, colour = "black", type = "triangle",
23 +
#'                         fill = c("red", "blue"), density = 0.4,
24 +
#'                         spacing = 0.15, angle = 0, amplitude = 0.075)
25 +
#'
26 +
#'   }
27 +
#' @export
28 +
grid.pattern_wave <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
29 +
                                colour = gp$col %||% "grey20", fill = gp$fill %||% "grey80", angle = 30,
30 +
                                density = 0.2, spacing = 0.05, xoffset = 0, yoffset = 0,
31 +
                                amplitude = 0.5 * spacing, frequency = 1 / spacing,
32 +
                                alpha = gp$alpha %||% NA_real_, linetype = gp$lty %||% 1, size = gp$lwd %||% 1,
33 +
                                grid = "square", type = "triangle",
34 +
                                default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) {
35 +
    if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color
36 +
    grid.pattern("wave", x, y, id,
37 +
                 colour = colour, fill = fill, angle = angle,
38 +
                 density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset,
39 +
                 amplitude = amplitude, frequency = frequency,
40 +
                 alpha = alpha, linetype = linetype, size = size,
41 +
                 grid = grid, type = type,
42 +
                 default.units = default.units, name = name, gp = gp , draw = draw, vp = vp)
43 +
}
44 +
45 +
create_pattern_wave_via_sf <- function(params, boundary_df, aspect_ratio,
46 +
                                          legend = FALSE) {
47 +
48 +
    if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5)
49 +
        params$pattern_density <- 1 - 1e-6
50 +
    stopifnot(params$pattern_density <= 1)
51 +
52 +
    # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio
53 +
    default.units <- "bigpts"
54 +
    boundary_df <- convert_polygon_df_units(boundary_df, default.units)
55 +
    params <- convert_params_units(params, default.units)
56 +
    vpm <- get_vp_measurements(default.units)
57 +
58 +
    # create grid of points large enough to cover viewport no matter the angle
59 +
    grid_xy <- get_xy_grid(params, vpm)
60 +
61 +
    fill <- alpha(params$pattern_fill, params$pattern_alpha)
62 +
    col  <- alpha(params$pattern_colour, params$pattern_alpha)
63 +
    lwd  <- params$pattern_size * .pt
64 +
    lty  <- params$pattern_linetype
65 +
    density <- params$pattern_density
66 +
67 +
    n_par <- max(lengths(list(fill, col, lwd, lty, density)))
68 +
69 +
    fill <- rep(fill, length.out = n_par)
70 +
    col <- rep(col, length.out = n_par)
71 +
    lwd <- rep(lwd, length.out = n_par)
72 +
    lty <- rep(lty, length.out = n_par)
73 +
    density <- rep(density, length.out = n_par)
74 +
75 +
    gl <- gList()
76 +
    for (i_par in seq_len(n_par)) {
77 +
78 +
        gp <- gpar(col = col[i_par], fill = fill[i_par],
79 +
                   lwd = lwd[i_par], lty = lty[i_par], lineend = 'square')
80 +
81 +
        boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0)
82 +
83 +
        waves_sf <- create_waves_sf(params, grid_xy, vpm, i_par, n_par)
84 +
        clipped_waves_sf_bot <- sf::st_intersection(waves_sf, boundary_sf)
85 +
        name <- paste0("wave.", i_par)
86 +
        grob <- sf_multipolygon_to_polygon_grob(clipped_waves_sf_bot,
87 +
                                                gp, default.units, name)
88 +
        gl <- append_gList(gl, grob)
89 +
    }
90 +
    gTree(children = gl, name = "regular_polygon")
91 +
}
92 +
93 +
create_waves_sf <- function(params, grid_xy, vpm, i_par, n_par) {
94 +
    switch(params$pattern_type,
95 +
           sine = create_sine_waves_sf(params, grid_xy, vpm, i_par, n_par),
96 +
           triangle = create_triangle_waves_sf(params, grid_xy, vpm, i_par, n_par),
97 +
           abort(paste("Don't know how to create wave pattern", dQuote(params$pattern_type))))
98 +
}
99 +
100 +
create_sine_waves_sf <- function(params, grid_xy, vpm, i_par, n_par) {
101 +
    halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density
102 +
    a <- params$pattern_amplitude
103 +
    n_s <- 180L
104 +
    theta <- to_radians(seq(0, by = 360L / n_s, length.out = n_s))
105 +
    y_s <- a * sin(theta)
106 +
    n_y <- length(grid_xy$y)
107 +
    indices_y <- seq(from = i_par, to = n_y, by = n_par)
108 +
    l_waves <- lapply(grid_xy$y[indices_y],
109 +
                      function(y0) {
110 +
                        n_x <- length(grid_xy$x)
111 +
                        xc <- seq(grid_xy$x_min, grid_xy$x_max, length.out = n_s * n_x + 1L)
112 +
                        yc <- y0 + rep(y_s, length.out = n_s * n_x + 1L)
113 +
                        yt <- yc + halfwidth
114 +
                        yb <- yc - halfwidth
115 +
                        x <- c(xc, rev(xc))
116 +
                        y <- c(yt, rev(yb))
117 +
                        xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y)
118 +
                        m <- as.matrix(as.data.frame(xy))
119 +
                        list(rbind(m, m[1,]))
120 +
                      })
121 +
    sf::st_multipolygon(l_waves)
122 +
}
123 +
124 +
create_triangle_waves_sf <- function(params, grid_xy, vpm, i_par, n_par) {
125 +
    halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density
126 +
    a <- params$pattern_amplitude
127 +
    n_y <- length(grid_xy$y)
128 +
    indices_y <- seq(from = i_par, to = n_y, by = n_par)
129 +
    l_waves <- lapply(grid_xy$y[indices_y],
130 +
                      function(y0) {
131 +
                        n_x <- length(grid_xy$x)
132 +
                        xc <- seq(grid_xy$x_min, grid_xy$x_max, length.out = 4L * n_x + 1L)
133 +
                        yc <- y0 + rep(c(0, a, 0, -a), length.out = 4L * n_x + 1L)
134 +
                        yt <- yc + halfwidth
135 +
                        yb <- yc - halfwidth
136 +
                        x <- c(xc, rev(xc))
137 +
                        y <- c(yt, rev(yb))
138 +
                        xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y)
139 +
                        m <- as.matrix(as.data.frame(xy))
140 +
                        list(rbind(m, m[1,]))
141 +
                      })
142 +
    sf::st_multipolygon(l_waves)
143 +
}
144 +
145 +
# # build sf multipolygon 'rect' for each grid_xy$y value
146 +
# create_h_stripes_sf <- function(params, grid_xy, vpm) {
147 +
#     halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density
148 +
#     l_rects <- lapply(grid_xy$y,
149 +
#                       function(y0) {
150 +
#                           x <- c(grid_xy$x_min, grid_xy$x_min, grid_xy$x_max, grid_xy$x_max)
151 +
#                           y <- y0 + c(-1, 1, 1, -1) * halfwidth
152 +
#                           xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y)
153 +
#                           m <- as.matrix(as.data.frame(xy))
154 +
#                           list(rbind(m, m[1,]))
155 +
#                       })
156 +
#     sf::st_multipolygon(l_rects)
157 +
# }
158 +
#
159 +
# # build sf multipolygon 'rect' for each grid_xy$x value
160 +
# create_v_stripes_sf <- function(params, grid_xy, vpm) {
161 +
#     halfwidth <- 0.5 * grid_xy$h_spacing * params$pattern_density
162 +
#     l_rects <- lapply(grid_xy$x,
163 +
#                       function(x0) {
164 +
#                           x <- x0 + c(-1, 1, 1, -1) * halfwidth
165 +
#                           y <- c(grid_xy$y_min, grid_xy$y_min, grid_xy$y_max, grid_xy$y_max)
166 +
#                           xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y)
167 +
#                           m <- as.matrix(as.data.frame(xy))
168 +
#                           list(rbind(m, m[1,]))
169 +
#                       })
170 +
#     sf::st_multipolygon(l_rects)
171 +
# }

@@ -35,6 +35,8 @@
Loading
35 35
#'               See [grid.pattern_stripe()] for more information.}
36 36
#' \item{text}{Text array/geometry patterns.
37 37
#'             See [grid.pattern_text()] for more information.}
38 +
#' \item{wave}{Wave geometry patterns.
39 +
#'               See [grid.pattern_wave()] for more information.}
38 40
#' \item{weave}{Weave geometry patterns.
39 41
#'               See [grid.pattern_weave()] for more information.}
40 42
#' \item{Custom geometry-based patterns}{See \url{https://coolbutuseless.github.io/package/ggpattern/articles/developing-patterns-2.html} for more information.}
@@ -120,7 +122,7 @@
Loading
120 122
#' @export
121 123
names_pattern <- c("ambient", "circle", "crosshatch", "gradient", "image",
122 124
                   "magick", "none", "pch", "placeholder", "plasma", "polygon_tiling",
123 -
                   "regular_polygon", "stripe", "text", "weave")
125 +
                   "regular_polygon", "rose", "stripe", "text", "wave", "weave")
124 126
125 127
#' @rdname grid.pattern
126 128
#' @export
@@ -175,6 +177,7 @@
Loading
175 177
                           rose = create_pattern_rose,
176 178
                           stripe = create_pattern_stripes_via_sf,
177 179
                           text = create_pattern_text,
180 +
                           wave = create_pattern_wave_via_sf,
178 181
                           weave = create_pattern_weave_via_sf),
179 182
                      user_geometry_fns)
180 183
    array_fns <- c(list(ambient = create_pattern_ambient,

@@ -45,7 +45,8 @@
Loading
45 45
    l$pattern_res <- l$pattern_res %||% 72 # in PPI
46 46
47 47
    # Additional ambient defaults
48 -
    l$pattern_frequency <- l$pattern_frequency %||% 0.01 # all
48 +
    l$pattern_frequency <- l$pattern_frequency %||%
49 +
        switch(pattern, ambient = 0.01, rose = 0.1, 1 / l$pattern_spacing)
49 50
    l$pattern_interpolator <- l$pattern_interpolator %||% "quintic" # perlin, simplex, value
50 51
    l$pattern_fractal <- l$pattern_fractal %||%
51 52
        switch(l$pattern_type, worley = "none", "fbm")
@@ -53,7 +54,8 @@
Loading
53 54
    l$pattern_octaves <- l$pattern_octaves %||% 3 # all but white
54 55
    l$pattern_lacunarity <- l$pattern_lacunarity %||% 2 # all but white
55 56
    l$pattern_gain <- l$pattern_gain %||% 0.5 # all but white
56 -
    l$pattern_amplitude <- l$pattern_amplitude %||% 1 # all
57 +
    l$pattern_amplitude <- l$pattern_amplitude %||%
58 +
        switch(pattern, wave = 0.5 * l$pattern_spacing, 1) # all
57 59
    l$pattern_value <- l$pattern_value %||% "cell"
58 60
    l$pattern_distance_ind <- l$pattern_distance_ind %||% c(1, 2)
59 61
    l$pattern_jitter <- l$pattern_jitter %||% 0.45
@@ -80,9 +82,11 @@
Loading
80 82
}
81 83
82 84
convert_params_units <- function(params, units = "bigpts") {
85 +
    params$pattern_amplitude <- convertX(unit(params$pattern_amplitude, "snpc"), units, valueOnly = TRUE)
83 86
    params$pattern_spacing <- convertX(unit(params$pattern_spacing, "snpc"), units, valueOnly = TRUE)
84 87
    params$pattern_xoffset <- convertX(unit(params$pattern_xoffset, "snpc"), units, valueOnly = TRUE)
85 88
    params$pattern_yoffset <- convertX(unit(params$pattern_yoffset, "snpc"), units, valueOnly = TRUE)
89 +
    params$pattern_wavelength <- convertX(unit(1/params$pattern_frequency, "snpc"), units, valueOnly = TRUE)
86 90
    params
87 91
}
88 92
@@ -93,6 +97,7 @@
Loading
93 97
           placeholder = "kitten",
94 98
           polygon_tiling = "square",
95 99
           magick = "hexagons",
100 +
           wave = "triangle",
96 101
           weave = "plain",
97 102
           NA_character_)
98 103
}
Files Coverage
R 93.28%
Project Totals (37 files) 93.28%
Untitled

No yaml found.

Create your codecov.yml to customize your Codecov experience

Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading