trevorld / gridpattern
Showing 3 of 14 files from the diff.

@@ -81,6 +81,4 @@
 81 81 external 82 82 } 83 83 84 - plot_p <- function(xy) grid.points(x = xy$x, y = xy$y, default.units="npc") 85 - 86 84 dist <- function(p1, p2) sqrt((p2$x - p1$x)^2 + (p2$y - p1$y)^2)

@@ -0,0 +1,189 @@
 1 + #' Plotting character patterned grobs 2 + #' 3 + #' grid.pattern_pch() draws a plotting character pattern onto the graphic device. 4 + #' 5 + #' @inheritParams grid.pattern_regular_polygon 6 + #' @param shape An integer from 0 to 25 or NA. 7 + #' See [graphics::points()] for more details. 8 + #' Note we only support these shapes and do not 9 + #' support arbitrary ASCII / Unicode characters. 10 + #' @return A grid grob object invisibly. If draw is TRUE then also draws to the graphic device as a side effect. 11 + #' @seealso [grid.pattern_regular_polygon()] which is used to implement this pattern. 12 + #' @examples 13 + #' if (require("grid")) { 14 + #' x_hex <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) 15 + #' y_hex <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) 16 + #' gp <- gpar(col = "black", fill = "lightblue") 17 + #' 18 + #' # pch 0-6 are simple shapes with no fill 19 + #' grid.pattern_pch(x_hex, y_hex, shape = 0:6, gp = gp, 20 + #' spacing = 0.1, density = 0.4, angle = 0) 21 + #' 22 + #' # pch 7-14 are compound shapes with no fill 23 + #' grid.newpage() 24 + #' grid.pattern_pch(x_hex, y_hex, shape = 7:14, gp = gp, 25 + #' spacing = 0.1, density = 0.4, angle = 0) 26 + #' 27 + #' # pch 15-20 are filled with 'col' 28 + #' grid.newpage() 29 + #' grid.pattern_pch(x_hex, y_hex, shape = 15:20, gp = gp, 30 + #' spacing = 0.1, density = 0.4, angle = 0) 31 + #' 32 + #' # pch 21-25 are filled with 'fill' 33 + #' grid.newpage() 34 + #' grid.pattern_pch(x_hex, y_hex, shape = 21:25, gp = gp, 35 + #' spacing = 0.1, density = 0.4, angle = 0) 36 + #' 37 + #' # using a 'basket' weave type with two shapes 38 + #' grid.newpage() 39 + #' grid.pattern_pch(x_hex, y_hex, shape = c(1,4), gp = gp, 40 + #' type = "basket", 41 + #' spacing = 0.1, density = 0.4, angle = 0) 42 + #' } 43 + #' @export 44 + grid.pattern_pch <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., 45 + colour = gp$col %||% "grey20", 46 + fill = gp$fill %||% "grey80", 47 + angle = 30, density = 0.2, 48 + spacing = 0.05, xoffset = 0, yoffset = 0, 49 + scale = 0.5, shape = 1L, 50 + grid = "square", type = NULL, subtype = NULL, rot = 0, 51 + alpha = gp$alpha %||% NA_real_, linetype = gp$lty %||% 1, 52 + size = gp$lwd %||% 1, 53 + default.units = "npc", name = NULL, 54 + gp = gpar(), draw = TRUE, vp = NULL) { 55 + if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color 56 + grid.pattern("pch", x, y, id, 57 + colour = colour, fill = fill, angle = angle, 58 + density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, 59 + scale = scale, shape = shape, 60 + grid = grid, type = type, subtype = subtype, rot = rot, 61 + alpha = alpha, linetype = linetype, size = size, 62 + default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) 63 + } 64 + 65 + # each pch will be represented by two regular polygons (although one may be "null") 66 + create_pattern_pch <- function(params, boundary_df, aspect_ratio, legend = FALSE) { 67 + # vectorize fill, col, lwd, lty, density, rot, and shape 68 + fill <- alpha(params$pattern_fill, params$pattern_alpha) 69 + col <- alpha(params$pattern_colour, params$pattern_alpha) 70 + lwd <- params$pattern_size 71 + lty <- params$pattern_linetype 72 + 73 + density <- params$pattern_density 74 + rot <- params$pattern_rot 75 + shape <- params$pattern_shape 76 + 77 + n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape))) 78 + 79 + fill <- rep(fill, length.out = n_par) 80 + col <- rep(col, length.out = n_par) 81 + lwd <- rep(lwd, length.out = n_par) 82 + lty <- rep(lty, length.out = n_par) 83 + density <- rep(density, length.out = n_par) 84 + rot <- rep(rot, length.out = n_par) 85 + shape <- rep(shape, length.out = n_par) 86 + 87 + # setup bottom and top regular polygons 88 + pint <- as.integer(shape) 89 + if (!all(is.na(pint))) 90 + stopifnot(any(na_omit(pint) >= 0), any(na_omit(pint) <= 25)) 91 + pch <- ifelse(is.na(pint), "26", as.character(pint)) 92 + pint <- ifelse(is.na(pint), 26L, pint) 93 + 94 + density1 <- ifelse(pint == 4L, 1.414 * density, density) 95 + density1 <- ifelse(pint == 20L, 2/3 * density, density1) 96 + 97 + density2 <- ifelse(pint == 7L | pint == 13L, 1.414 * density, density) 98 + 99 + fill <- ifelse(pint < 21L, col, fill) 100 + fill <- ifelse(pint < 15L, NA_character_, fill) 101 + 102 + col <- ifelse(pint > 14L & pint < 19L, NA_character_, col) 103 + 104 + rot1 <- rot + sapply(pch, get_rot_base) 105 + rot2 <- rot + sapply(pch, get_rot_top) 106 + 107 + shape1 <- sapply(pch, get_shape_base) 108 + shape2 <- sapply(pch, get_shape_top) 109 + 110 + params$pattern_fill <- fill 111 + params$pattern_col <- col 112 + params$pattern_size <- lwd 113 + params$pattern_linetype <- lty 114 + params$pattern_scale <- 0.001 115 + params_base <- params_top <- params 116 + 117 + # bottom regular polygon 118 + params_base$pattern_shape <- shape1 119 + params_base$pattern_rot <- rot1 120 + params_base$pattern_density <- density1 121 + grob_base <- create_pattern_regular_polygon_via_sf(params_base, boundary_df, aspect_ratio, legend) 122 + grob_base <- editGrob(grob_base, name = "pch_base") 123 + 124 + # top regular polygon 125 + params_top$pattern_shape <- shape2 126 + params_top$pattern_rot <- rot2 127 + params_top$pattern_density <- density2 128 + grob_top <- create_pattern_regular_polygon_via_sf(params_top, boundary_df, aspect_ratio, legend) 129 + grob_top <- editGrob(grob_top, name = "pch_top") 130 + 131 + gl <- gList(grob_base, grob_top) 132 + 133 + gTree(children = gl, name = "pch") 134 + } 135 + 136 + get_rot_base <- function(pch) { 137 + switch(pch, 138 + "4" = 45, 139 + "6" = 180, 140 + "25" = 180, 141 + 0) 142 + } 143 + 144 + get_rot_top <- function(pch) { 145 + switch(pch, 146 + "7" = 45, 147 + "11" = 180, 148 + "13" = 45, 149 + 0) 150 + } 151 + 152 + get_shape_base <- function(pch) { 153 + switch(pch, 154 + "0" = "square", 155 + "2" = "convex3", 156 + "3" = "star4", 157 + "4" = "star4", 158 + "5" = "convex4", 159 + "6" = "convex3", 160 + "7" = "square", 161 + "9" = "convex4", 162 + "8" = "star8", 163 + "11" = "convex3", 164 + "12" = "square", 165 + "14" = "square", 166 + "15" = "square", 167 + "17" = "convex3", 168 + "18" = "convex4", 169 + "22" = "square", 170 + "23" = "convex4", 171 + "24" = "convex3", 172 + "25" = "convex3", 173 + "26" = "null", 174 + "circle") 175 + } 176 + 177 + get_shape_top <- function(pch) { 178 + switch(pch, 179 + "7" = "star4", 180 + "9" = "star4", 181 + "10" = "star4", 182 + "11" = "convex3", 183 + "12" = "star4", 184 + "13" = "star4", 185 + "14" = "convex3", 186 + "null") 187 + } 188 + 189 + na_omit <- function(x) Filter(Negate(is.na), x)

@@ -20,6 +20,8 @@
 20 20 #' See [grid.pattern_magick()] for more information.} 21 21 #' \item{none}{Does nothing. 22 22 #' See [grid::grid.null()] for more information.} 23 + #' \item{pch}{Plotting character geometry patterns. 24 + #' See [grid.pattern_pch()] for more information.} 23 25 #' \item{placeholder}{Placeholder image array patterns. 24 26 #' See [grid.pattern_placeholder()] for more information.} 25 27 #' \item{plasma}{Plasma array patterns.
@@ -153,6 +155,7 @@
 153 155 geometry_fns <- c(list(circle = create_pattern_circle_via_sf, 154 156 crosshatch = create_pattern_crosshatch_via_sf, 155 157 none = create_pattern_none, 158 + pch = create_pattern_pch, 156 159 polygon_tiling = create_pattern_polygon_tiling, 157 160 regular_polygon = create_pattern_regular_polygon_via_sf, 158 161 stripe = create_pattern_stripes_via_sf,
Files Coverage
R 94.25%
Project Totals (33 files) 94.25%