diff --git a/.Rbuildignore b/.Rbuildignore index ea901b8..68aeee9 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,5 +1,7 @@ -^.appveyor.yml$ -^.travis.yml$ +^\.air.toml$ +^\.claude$ +^\.editorconfig$ +^\.pre-commit-config.yaml$ ^cran-comments.md$ ^LICENSE.md$ ^README.Rmd$ @@ -7,9 +9,10 @@ ^Rakefile$ ^pkgdown$ ^_pkgdown.yml$ -^raw-data$ +^data-raw$ ^codecov.yml$ ^doc$ ^tmp$ ^Meta$ +^\.git$ ^\.github$ diff --git a/.air.toml b/.air.toml new file mode 100644 index 0000000..18b38e5 --- /dev/null +++ b/.air.toml @@ -0,0 +1,6 @@ +[format] +indent-style = "tab" +indent-width = 4 +line-ending = "lf" +line-width = 100 +skip = ["tribble"] diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 0000000..a684a86 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,11 @@ +# https://editorconfig.org/ +root = true + +[*] +charset = utf-8 +end_of_line = lf +insert_final_newline = true +trim_trailing_whitespace = true + +[*.{r,R}] +indent_style = tab diff --git a/.github/workflows/air-check.yaml b/.github/workflows/air-check.yaml new file mode 100644 index 0000000..b73d1f5 --- /dev/null +++ b/.github/workflows/air-check.yaml @@ -0,0 +1,21 @@ +on: + push: + branches: [main, master] + pull_request: + +name: format-check + +permissions: read-all + +jobs: + format-check: + name: format-check + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - name: Install + uses: posit-dev/setup-air@v1 + + - name: Check + run: air format . --check diff --git a/.gitignore b/.gitignore index 21d3567..aadc262 100644 --- a/.gitignore +++ b/.gitignore @@ -1,10 +1,11 @@ README.html codecov.yml *.swp +/.claude/ /doc/ /Meta/ /pkgdown/ /tmp/ -raw-data/*.png +data-raw/*.png vignettes/*.R vignettes/*.html diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml new file mode 100644 index 0000000..13806d5 --- /dev/null +++ b/.pre-commit-config.yaml @@ -0,0 +1,8 @@ +repos: + - repo: local + hooks: + - id: air + name: Format R code with air + entry: air format + language: system + files: \.R$|\.r$ diff --git a/DESCRIPTION b/DESCRIPTION index ab295ce..dd802f8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: gridpattern Type: Package Title: 'grid' Pattern Grobs -Version: 1.3.3-1 +Version: 1.3.3-2 Authors@R: c( person("Trevor L.", "Davis", role=c("aut", "cre"), email="trevor.l.davis@gmail.com", comment = c(ORCID = "0000-0001-6341-4639")), @@ -13,7 +13,7 @@ BugReports: https://github.com/trevorld/gridpattern/issues License: MIT + file LICENSE Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.3 Depends: R (>= 3.4.0) Imports: diff --git a/R/alphaMaskGrob.R b/R/alphaMaskGrob.R index d5240e1..90293f9 100644 --- a/R/alphaMaskGrob.R +++ b/R/alphaMaskGrob.R @@ -47,15 +47,30 @@ #' } #' } #' @export -alphaMaskGrob <- function(maskee, masker, - use_R4.1_masks = getOption("ggpattern_use_R4.1_masks", - getOption("ggpattern_use_R4.1_features")), - png_device = NULL, res = getOption("ggpattern_res", 72), - name = NULL, gp = gpar(), vp = NULL) { - gTree(maskee = maskee, masker = masker, - use_R4.1_masks = use_R4.1_masks, - res = res, png_device = png_device, - name = name, gp = gp, vp = vp, cl = "alpha_mask") +alphaMaskGrob <- function( + maskee, + masker, + use_R4.1_masks = getOption( + "ggpattern_use_R4.1_masks", + getOption("ggpattern_use_R4.1_features") + ), + png_device = NULL, + res = getOption("ggpattern_res", 72), + name = NULL, + gp = gpar(), + vp = NULL +) { + gTree( + maskee = maskee, + masker = masker, + use_R4.1_masks = use_R4.1_masks, + res = res, + png_device = png_device, + name = name, + gp = gp, + vp = vp, + cl = "alpha_mask" + ) } # Avoid R CMD check WARNING on R 4.0 which lacks `mask` argument @@ -63,134 +78,142 @@ vport <- function(...) viewport(...) #' @export makeContent.alpha_mask <- function(x) { - current_dev <- grDevices::dev.cur() - on.exit(grDevices::dev.set(current_dev)) - - use_R4.1_masks <- x$use_R4.1_masks - if (is.null(use_R4.1_masks)) - use_R4.1_masks <- guess_has_R4.1_features("masks") - else - use_R4.1_masks <- as.logical(use_R4.1_masks) - - stopifnot(getRversion() >= '4.1.0' || !use_R4.1_masks) - - if (use_R4.1_masks) { - grob <- grobTree(x$maskee, - vp = vport(mask = x$masker), - name = "alpha_mask") - } else if (is.null(x$png_device) && - getRversion() >= '4.1.0' && - requireNamespace("ragg", quietly = TRUE) && - packageVersion("ragg") >= '1.2.0') { - grob <- gridpattern_mask_agg_capture(x$maskee, x$masker, x$res) - } else { - png_device <- x$png_device %||% default_png_device() - if (device_supports_masks(png_device)) { - grob <- gridpattern_mask_raster_straight(x$maskee, x$masker, x$res, png_device) - } else { - grob <- gridpattern_mask_raster_manual(x$maskee, x$masker, x$res, png_device) - } - } - - gl <- gList(grob) - setChildren(x, gl) + current_dev <- grDevices::dev.cur() + on.exit(grDevices::dev.set(current_dev)) + + use_R4.1_masks <- x$use_R4.1_masks + if (is.null(use_R4.1_masks)) { + use_R4.1_masks <- guess_has_R4.1_features("masks") + } else { + use_R4.1_masks <- as.logical(use_R4.1_masks) + } + + stopifnot(getRversion() >= '4.1.0' || !use_R4.1_masks) + + if (use_R4.1_masks) { + grob <- grobTree(x$maskee, vp = vport(mask = x$masker), name = "alpha_mask") + } else if ( + is.null(x$png_device) && + getRversion() >= '4.1.0' && + requireNamespace("ragg", quietly = TRUE) && + packageVersion("ragg") >= '1.2.0' + ) { + grob <- gridpattern_mask_agg_capture(x$maskee, x$masker, x$res) + } else { + png_device <- x$png_device %||% default_png_device() + if (device_supports_masks(png_device)) { + grob <- gridpattern_mask_raster_straight(x$maskee, x$masker, x$res, png_device) + } else { + grob <- gridpattern_mask_raster_manual(x$maskee, x$masker, x$res, png_device) + } + } + + gl <- gList(grob) + setChildren(x, gl) } device_supports_masks <- function(png_device) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - png_file <- tempfile(fileext = ".png") - on.exit(unlink(png_file), add = TRUE) - png_device(png_file) - value <- guess_has_R4.1_features("masks") - dev.off() - value + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + png_file <- tempfile(fileext = ".png") + on.exit(unlink(png_file), add = TRUE) + png_device(png_file) + value <- guess_has_R4.1_features("masks") + dev.off() + value } gridpattern_mask_agg_capture <- function(maskee, masker, res) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - - ragg::agg_capture(height = height, width = width, res = res, bg = "transparent") - grob <- alphaMaskGrob(maskee, masker, use_R4.1_masks = TRUE) - grid.draw(grob) - raster_masked <- dev.capture(native = FALSE) - dev.off() - grid::rasterGrob(raster_masked) + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + + ragg::agg_capture(height = height, width = width, res = res, bg = "transparent") + grob <- alphaMaskGrob(maskee, masker, use_R4.1_masks = TRUE) + grid.draw(grob) + raster_masked <- dev.capture(native = FALSE) + dev.off() + grid::rasterGrob(raster_masked) } default_png_device <- function() { - if (requireNamespace("ragg", quietly = TRUE)) { - ragg::agg_png - } else { - stopifnot(capabilities("png")) - grDevices::png - } + if (requireNamespace("ragg", quietly = TRUE)) { + ragg::agg_png + } else { + stopifnot(capabilities("png")) + grDevices::png + } } gridpattern_mask_raster_straight <- function(maskee, masker, res, png_device) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - - png_masked <- tempfile(fileext = ".png") - on.exit(unlink(png_masked), add = TRUE) - png_device(png_masked, height = height, width = width, - res = res, bg = "transparent") - grob <- alphaMaskGrob(maskee, masker, use_R4.1_masks = TRUE) - grid.draw(grob) - dev.off() - - raster_masked <- png::readPNG(png_masked, native = FALSE) - grid::rasterGrob(raster_masked) + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + + png_masked <- tempfile(fileext = ".png") + on.exit(unlink(png_masked), add = TRUE) + png_device(png_masked, height = height, width = width, res = res, bg = "transparent") + grob <- alphaMaskGrob(maskee, masker, use_R4.1_masks = TRUE) + grid.draw(grob) + dev.off() + + raster_masked <- png::readPNG(png_masked, native = FALSE) + grid::rasterGrob(raster_masked) } gridpattern_mask_raster_manual <- function(maskee, masker, res, png_device) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - - png_maskee <- tempfile(fileext = ".png") - on.exit(unlink(png_maskee), add = TRUE) - png_device(png_maskee, height = height, width = width, - res = res, bg = "transparent") - grid.draw(maskee) - dev.off() - - png_masker <- tempfile(fileext = ".png") - on.exit(unlink(png_masker), add = TRUE) - png_device(png_masker, height = height, width = width, - res = res, bg = "transparent") - grid.draw(masker) - dev.off() - - raster_maskee <- png::readPNG(png_maskee, native = FALSE) - raster_masker <- png::readPNG(png_masker, native = FALSE) - - stopifnot(length(dim(raster_maskee)) == 3L, - length(dim(raster_masker)) == 3L, - dim(raster_maskee)[3L] >= 3L, - dim(raster_masker)[3L] >= 3L) - if (dim(raster_maskee)[3L] < 4L) { - raster_maskee <- add_alpha_channel(raster_maskee) - } - if (dim(raster_masker)[3L] < 4L) { - raster_masker <- add_alpha_channel(raster_masker) - } - - raster_masked <- raster_maskee - raster_masked[, , 4L] <- raster_maskee[, , 4L] * raster_masker[, , 4L] - - rasterGrob(raster_masked, name = "alpha_mask") + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + + png_maskee <- tempfile(fileext = ".png") + on.exit(unlink(png_maskee), add = TRUE) + png_device(png_maskee, height = height, width = width, res = res, bg = "transparent") + grid.draw(maskee) + dev.off() + + png_masker <- tempfile(fileext = ".png") + on.exit(unlink(png_masker), add = TRUE) + png_device(png_masker, height = height, width = width, res = res, bg = "transparent") + grid.draw(masker) + dev.off() + + raster_maskee <- png::readPNG(png_maskee, native = FALSE) + raster_masker <- png::readPNG(png_masker, native = FALSE) + + stopifnot( + length(dim(raster_maskee)) == 3L, + length(dim(raster_masker)) == 3L, + dim(raster_maskee)[3L] >= 3L, + dim(raster_masker)[3L] >= 3L + ) + if (dim(raster_maskee)[3L] < 4L) { + raster_maskee <- add_alpha_channel(raster_maskee) + } + if (dim(raster_masker)[3L] < 4L) { + raster_masker <- add_alpha_channel(raster_masker) + } + + raster_masked <- raster_maskee + raster_masked[,, 4L] <- raster_maskee[,, 4L] * raster_masker[,, 4L] + + rasterGrob(raster_masked, name = "alpha_mask") } add_alpha_channel <- function(a) { - a_ <- array(NA, dim = c(dim(a)[1], dim(a)[2], 4L)) - a_[, , -4L] <- a - a_[, , 4L] <- 1. - a_ + a_ <- array(NA, dim = c(dim(a)[1], dim(a)[2], 4L)) + a_[,, -4L] <- a + a_[,, 4L] <- 1. + a_ } diff --git a/R/clippingPathGrob.R b/R/clippingPathGrob.R index 68da7be..93e946e 100644 --- a/R/clippingPathGrob.R +++ b/R/clippingPathGrob.R @@ -36,126 +36,147 @@ #' grid.draw(clipped) #' } #' @export -clippingPathGrob <- function(clippee, clipper, - use_R4.1_clipping = getOption("ggpattern_use_R4.1_clipping", - getOption("ggpattern_use_R4.1_features")), - png_device = NULL, res = getOption("ggpattern_res", 72), - name = NULL, gp = gpar(), vp = NULL) { - gTree(clippee = clippee, clipper = clipper, - use_R4.1_clipping = use_R4.1_clipping, - res = res, png_device = png_device, - name = name, gp = gp, vp = vp, cl = "clipping_path") +clippingPathGrob <- function( + clippee, + clipper, + use_R4.1_clipping = getOption( + "ggpattern_use_R4.1_clipping", + getOption("ggpattern_use_R4.1_features") + ), + png_device = NULL, + res = getOption("ggpattern_res", 72), + name = NULL, + gp = gpar(), + vp = NULL +) { + gTree( + clippee = clippee, + clipper = clipper, + use_R4.1_clipping = use_R4.1_clipping, + res = res, + png_device = png_device, + name = name, + gp = gp, + vp = vp, + cl = "clipping_path" + ) } #' @export makeContent.clipping_path <- function(x) { - current_dev <- grDevices::dev.cur() - on.exit(grDevices::dev.set(current_dev)) + current_dev <- grDevices::dev.cur() + on.exit(grDevices::dev.set(current_dev)) - use_R4.1_clipping <- x$use_R4.1_clipping - if (is.null(use_R4.1_clipping)) - use_R4.1_clipping <- guess_has_R4.1_features("clippingPaths") - else - use_R4.1_clipping <- as.logical(use_R4.1_clipping) + use_R4.1_clipping <- x$use_R4.1_clipping + if (is.null(use_R4.1_clipping)) { + use_R4.1_clipping <- guess_has_R4.1_features("clippingPaths") + } else { + use_R4.1_clipping <- as.logical(use_R4.1_clipping) + } - stopifnot(getRversion() >= '4.1.0' || !use_R4.1_clipping) + stopifnot(getRversion() >= '4.1.0' || !use_R4.1_clipping) - if (use_R4.1_clipping) { - grob <- grobTree(x$clippee, - vp = viewport(clip = x$clipper), - name = "clip") - } else if (is.null(x$png_device) && - getRversion() >= '4.1.0' && - requireNamespace("ragg", quietly = TRUE) && - packageVersion("ragg") >= '1.2.0') { - grob <- gridpattern_clip_agg_capture(x$clippee, x$clipper, x$res) - } else { - png_device <- x$png_device %||% default_png_device() - if (device_supports_clipping(png_device)) { - grob <- gridpattern_clip_raster_straight(x$clippee, x$clipper, x$res, png_device) - } else { - grob <- gridpattern_clip_raster_manual(x$clippee, x$clipper, x$res, png_device) - } - } + if (use_R4.1_clipping) { + grob <- grobTree(x$clippee, vp = viewport(clip = x$clipper), name = "clip") + } else if ( + is.null(x$png_device) && + getRversion() >= '4.1.0' && + requireNamespace("ragg", quietly = TRUE) && + packageVersion("ragg") >= '1.2.0' + ) { + grob <- gridpattern_clip_agg_capture(x$clippee, x$clipper, x$res) + } else { + png_device <- x$png_device %||% default_png_device() + if (device_supports_clipping(png_device)) { + grob <- gridpattern_clip_raster_straight(x$clippee, x$clipper, x$res, png_device) + } else { + grob <- gridpattern_clip_raster_manual(x$clippee, x$clipper, x$res, png_device) + } + } - gl <- gList(grob) - setChildren(x, gl) + gl <- gList(grob) + setChildren(x, gl) } device_supports_clipping <- function(png_device) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - png_file <- tempfile(fileext = ".png") - on.exit(unlink(png_file), add = TRUE) - png_device(png_file) - value <- guess_has_R4.1_features("clippingPaths") - dev.off() - value + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + png_file <- tempfile(fileext = ".png") + on.exit(unlink(png_file), add = TRUE) + png_device(png_file) + value <- guess_has_R4.1_features("clippingPaths") + dev.off() + value } gridpattern_clip_agg_capture <- function(clippee, clipper, res) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - ragg::agg_capture(height = height, width = width, res = res, bg = "transparent") - grob <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = TRUE) - grid.draw(grob) - raster_clipped <- dev.capture(native = FALSE) - dev.off() - grid::rasterGrob(raster_clipped) + ragg::agg_capture(height = height, width = width, res = res, bg = "transparent") + grob <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = TRUE) + grid.draw(grob) + raster_clipped <- dev.capture(native = FALSE) + dev.off() + grid::rasterGrob(raster_clipped) } gridpattern_clip_raster_straight <- function(clippee, clipper, res, png_device) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - png_clipped <- tempfile(fileext = ".png") - on.exit(unlink(png_clipped), add = TRUE) - png_device(png_clipped, height = height, width = width, - res = res, bg = "transparent") - grob <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = TRUE) - grid.draw(grob) - dev.off() + png_clipped <- tempfile(fileext = ".png") + on.exit(unlink(png_clipped), add = TRUE) + png_device(png_clipped, height = height, width = width, res = res, bg = "transparent") + grob <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = TRUE) + grid.draw(grob) + dev.off() - raster_clipped <- png::readPNG(png_clipped, native = FALSE) - grid::rasterGrob(raster_clipped) + raster_clipped <- png::readPNG(png_clipped, native = FALSE) + grid::rasterGrob(raster_clipped) } gridpattern_clip_raster_manual <- function(clippee, clipper, res, png_device) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + height <- res * convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + width <- res * convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - png_clippee <- tempfile(fileext = ".png") - on.exit(unlink(png_clippee), add = TRUE) - png_device(png_clippee, height = height, width = width, - res = res, bg = "transparent") - grid.draw(clippee) - dev.off() + png_clippee <- tempfile(fileext = ".png") + on.exit(unlink(png_clippee), add = TRUE) + png_device(png_clippee, height = height, width = width, res = res, bg = "transparent") + grid.draw(clippee) + dev.off() - png_clipper <- tempfile(fileext = ".png") - on.exit(unlink(png_clipper), add = TRUE) - png_device(png_clipper, height = height, width = width, - res = res, bg = "transparent") - pushViewport(viewport(gp = gpar(lwd = 0, col = NA, fill = "black"))) - grid.draw(clipper) - popViewport() - dev.off() + png_clipper <- tempfile(fileext = ".png") + on.exit(unlink(png_clipper), add = TRUE) + png_device(png_clipper, height = height, width = width, res = res, bg = "transparent") + pushViewport(viewport(gp = gpar(lwd = 0, col = NA, fill = "black"))) + grid.draw(clipper) + popViewport() + dev.off() - raster_clippee <- png::readPNG(png_clippee, native = FALSE) - raster_clipper <- png::readPNG(png_clipper, native = FALSE) - clip_region <- apply(raster_clipper, c(1,2), function(x) any(x > 0)) - if (length(dim(raster_clippee) == 2)) { - raster_clippee[!clip_region] <- 0 - } else { - for (j in seq_len(dim(raster_clippee)[3])) { - raster_clippee[!clip_region, j] <- 0 - } - } - rasterGrob(raster_clippee, name = "clip") + raster_clippee <- png::readPNG(png_clippee, native = FALSE) + raster_clipper <- png::readPNG(png_clipper, native = FALSE) + clip_region <- apply(raster_clipper, c(1, 2), function(x) any(x > 0)) + if (length(dim(raster_clippee) == 2)) { + raster_clippee[!clip_region] <- 0 + } else { + for (j in seq_len(dim(raster_clippee)[3])) { + raster_clippee[!clip_region, j] <- 0 + } + } + rasterGrob(raster_clippee, name = "clip") } diff --git a/R/grid-pattern-fill.R b/R/grid-pattern-fill.R index 47762ce..54e09aa 100644 --- a/R/grid-pattern-fill.R +++ b/R/grid-pattern-fill.R @@ -15,14 +15,14 @@ #' stripe_fill <- patternFill("stripe", fill = c("red", "blue")) #' grid.circle(gp = gpar(fill = stripe_fill)) #' } -#' -#' if (guess_has_R4.1_features("patterns") && +#' +#' if (guess_has_R4.1_features("patterns") && #' require("ggplot2", quietly = TRUE) && #' (getRversion() >= "4.2")) { #' grid.newpage() -#' weave_fill <- patternFill("weave", fill = "red", fill2 = "blue", +#' weave_fill <- patternFill("weave", fill = "red", fill2 = "blue", #' colour = "transparent") -#' hex_fill <- patternFill("polygon_tiling", type = "hexagonal", +#' hex_fill <- patternFill("polygon_tiling", type = "hexagonal", #' fill = c("black", "white", "grey"), #' colour = "transparent") #' df <- data.frame(trt = c("a", "b"), outcome = c(1.9, 3.2)) @@ -32,18 +32,33 @@ #' } #' @return A [grid::pattern()] fill object. #' @export -patternFill <- function(..., - x = 0.5, y = 0.5, width = 1, height = 1, - default.units = "npc", - just = "centre", hjust = NULL, vjust = NULL, - group = TRUE) { - stopifnot(getRversion() >= "4.1.0") - args <- list(grob = patternGrob(...), - x = x, y = y, width = width, height = height, - default.units = default.units, - just = just, hjust = hjust, vjust = vjust) - # `group` was introduced in R 4.2 - if (getRversion() >= "4.2.0") - args$group <- group - do.call(grid::pattern, args) +patternFill <- function( + ..., + x = 0.5, + y = 0.5, + width = 1, + height = 1, + default.units = "npc", + just = "centre", + hjust = NULL, + vjust = NULL, + group = TRUE +) { + stopifnot(getRversion() >= "4.1.0") + args <- list( + grob = patternGrob(...), + x = x, + y = y, + width = width, + height = height, + default.units = default.units, + just = just, + hjust = hjust, + vjust = vjust + ) + # `group` was introduced in R 4.2 + if (getRversion() >= "4.2.0") { + args$group <- group + } + do.call(grid::pattern, args) } diff --git a/R/grid-pattern.R b/R/grid-pattern.R index e06a616..1039486 100644 --- a/R/grid-pattern.R +++ b/R/grid-pattern.R @@ -75,7 +75,7 @@ #' #' # Can alternatively use "gpar()" to specify colour and line attributes #' grid::grid.newpage() -#' grid.pattern("stripe", x_hex, y_hex, +#' grid.pattern("stripe", x_hex, y_hex, #' gp = grid::gpar(col="blue", fill="red", lwd=2)) #' #' # 'weave' pattern @@ -114,143 +114,228 @@ #' @seealso \url{https://coolbutuseless.github.io/package/ggpattern/index.html} #' for more details on the `ggpattern` package. #' @export -grid.pattern <- function(pattern = "stripe", - x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - legend = FALSE, prefix = "pattern_", - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grob <- patternGrob(pattern, x, y, id, ..., - legend = legend, prefix = prefix, - default.units = default.units, name = name, gp = gp, vp = vp) - if (draw) grid.draw(grob) - invisible(grob) +grid.pattern <- function( + pattern = "stripe", + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + legend = FALSE, + prefix = "pattern_", + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grob <- patternGrob( + pattern, + x, + y, + id, + ..., + legend = legend, + prefix = prefix, + default.units = default.units, + name = name, + gp = gp, + vp = vp + ) + if (draw) { + grid.draw(grob) + } + invisible(grob) } #' @rdname grid.pattern #' @export -names_pattern <- c("ambient", "aRtsy", "circle", "crosshatch", "fill", "gradient", "image", - "magick", "none", "pch", "placeholder", "plasma", "polygon_tiling", - "regular_polygon", "rose", "stripe", "text", "wave", "weave") +names_pattern <- c( + "ambient", + "aRtsy", + "circle", + "crosshatch", + "fill", + "gradient", + "image", + "magick", + "none", + "pch", + "placeholder", + "plasma", + "polygon_tiling", + "regular_polygon", + "rose", + "stripe", + "text", + "wave", + "weave" +) #' @rdname grid.pattern #' @export -patternGrob <- function(pattern = "stripe", - x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - legend = FALSE, prefix = "pattern_", - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - params <- get_params(..., pattern = pattern, prefix = prefix, gp = gp) - if (!inherits(x, "unit")) x <- unit(x, default.units) - if (!inherits(y, "unit")) y <- unit(y, default.units) +patternGrob <- function( + pattern = "stripe", + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + legend = FALSE, + prefix = "pattern_", + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + params <- get_params(..., pattern = pattern, prefix = prefix, gp = gp) + if (!inherits(x, "unit")) { + x <- unit(x, default.units) + } + if (!inherits(y, "unit")) { + y <- unit(y, default.units) + } - gTree(pattern=pattern, x=x, y=y, id=id, params=params, legend=legend, - name=name, gp=gp, vp=vp, cl="pattern") + gTree( + pattern = pattern, + x = x, + y = y, + id = id, + params = params, + legend = legend, + name = name, + gp = gp, + vp = vp, + cl = "pattern" + ) } #' @export makeContent.pattern <- function(x) { - # avoid weird errors with array patterns if there is an active device open - current_dev <- grDevices::dev.cur() - on.exit(grDevices::dev.set(current_dev)) + # avoid weird errors with array patterns if there is an active device open + current_dev <- grDevices::dev.cur() + on.exit(grDevices::dev.set(current_dev)) - xp <- convertX(x$x, "npc", valueOnly = TRUE) - yp <- convertY(x$y, "npc", valueOnly = TRUE) - id <- x$id - boundary_df <- create_polygon_df(xp, yp, id) + xp <- convertX(x$x, "npc", valueOnly = TRUE) + yp <- convertY(x$y, "npc", valueOnly = TRUE) + id <- x$id + boundary_df <- create_polygon_df(xp, yp, id) - if (!is.na(x$params$pattern_aspect_ratio)) { - aspect_ratio <- x$params$pattern_aspect_ratio - } else { - width <- convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) - height <- convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) - aspect_ratio <- width / height - } + if (!is.na(x$params$pattern_aspect_ratio)) { + aspect_ratio <- x$params$pattern_aspect_ratio + } else { + width <- convertWidth(unit(1, "npc"), "in", valueOnly = TRUE) + height <- convertHeight(unit(1, "npc"), "in", valueOnly = TRUE) + aspect_ratio <- width / height + } - # needs to be called within active graphics device to guess R4.1 capabilities - params <- get_R4.1_params(x$params) + # needs to be called within active graphics device to guess R4.1 capabilities + params <- get_R4.1_params(x$params) - fn <- get_pattern_fn(x$pattern) - grob <- fn(params, boundary_df, aspect_ratio, x$legend) - gl <- gList(grob) - setChildren(x, gl) + fn <- get_pattern_fn(x$pattern) + grob <- fn(params, boundary_df, aspect_ratio, x$legend) + gl <- gList(grob) + setChildren(x, gl) } get_pattern_fn <- function(pattern) { - user_geometry_fns <- getOption("ggpattern_geometry_funcs") - user_array_fns <- getOption("ggpattern_array_funcs") - assert_patterns_unique(user_geometry_fns, user_array_fns) - geometry_fns <- c(list(aRtsy = create_pattern_aRtsy, - circle = create_pattern_circle_via_sf, - crosshatch = create_pattern_crosshatch_via_sf, - fill = create_pattern_fill, - gradient = create_pattern_gradient, - none = create_pattern_none, - pch = create_pattern_pch, - polygon_tiling = create_pattern_polygon_tiling, - regular_polygon = create_pattern_regular_polygon_via_sf, - rose = create_pattern_rose, - stripe = create_pattern_stripes_via_sf, - text = create_pattern_text, - wave = create_pattern_wave_via_sf, - weave = create_pattern_weave_via_sf), - user_geometry_fns) - array_fns <- c(list(ambient = create_pattern_ambient, - image = img_read_as_array_wrapper, - magick = create_magick_pattern_as_array, - placeholder = fetch_placeholder_array, - plasma = create_magick_plasma_as_array), - user_array_fns) - array_fns <- lapply(array_fns, function(fn) { - function(...) create_pattern_array(..., array_fn=fn) - }) - fns <- c(geometry_fns, array_fns) - fns[[pattern]] %||% abort(paste("Don't know the function for pattern", pattern)) + user_geometry_fns <- getOption("ggpattern_geometry_funcs") + user_array_fns <- getOption("ggpattern_array_funcs") + assert_patterns_unique(user_geometry_fns, user_array_fns) + geometry_fns <- c( + list( + aRtsy = create_pattern_aRtsy, + circle = create_pattern_circle_via_sf, + crosshatch = create_pattern_crosshatch_via_sf, + fill = create_pattern_fill, + gradient = create_pattern_gradient, + none = create_pattern_none, + pch = create_pattern_pch, + polygon_tiling = create_pattern_polygon_tiling, + regular_polygon = create_pattern_regular_polygon_via_sf, + rose = create_pattern_rose, + stripe = create_pattern_stripes_via_sf, + text = create_pattern_text, + wave = create_pattern_wave_via_sf, + weave = create_pattern_weave_via_sf + ), + user_geometry_fns + ) + array_fns <- c( + list( + ambient = create_pattern_ambient, + image = img_read_as_array_wrapper, + magick = create_magick_pattern_as_array, + placeholder = fetch_placeholder_array, + plasma = create_magick_plasma_as_array + ), + user_array_fns + ) + array_fns <- lapply(array_fns, function(fn) { + function(...) create_pattern_array(..., array_fn = fn) + }) + fns <- c(geometry_fns, array_fns) + fns[[pattern]] %||% abort(paste("Don't know the function for pattern", pattern)) } assert_patterns_unique <- function(user_geometry_fns, user_array_fns) { - names_geometry <- names(user_geometry_fns) - names_array <- names(user_array_fns) - msg_geometry <- '`options("ggpattern_geometry_funcs")` sets custom "geometry" patterns' - msg_array <- '`options("ggpattern_array_funcs")` sets custom "array" patterns' - # check pattern names not duplicated within custom pattern types - duplicated_geometry <- duplicated(names_geometry) - if (any(duplicated_geometry)) { - name <- names_geometry[which(duplicated_geometry)[1]] - msg <- c(glue('There are multiple custom "geometry" patterns named "{name}"'), - i = msg_geometry) - abort(msg) - } - duplicated_array <- duplicated(names_array) - if (any(duplicated_array)) { - name <- names_array[which(duplicated_array)[1]] - msg <- c(glue('There are multiple custom "array" patterns named "{name}"'), - i = msg_array) - abort(msg) - } - # check pattern names not duplicated between custom pattern types - match_user <- match(names_geometry, names_array) - if (any(!is.na(match_user))) { - index <- which(!is.na(match_user))[1] - name <- names_geometry[index] - msg <- c(glue('There is a custom "geometry" pattern and custom "array" pattern both named "{name}"'), - i = msg_geometry, - i = msg_array) - abort(msg) - } - # check pattern names not duplicated between custom patterns and builtin patterns - match_geometry <- match(names_geometry, names_pattern) - if (any(!is.na(match_geometry))) { - index <- which(!is.na(match_geometry))[1] - name <- names_geometry[index] - msg <- c(glue('There is a custom "geometry" pattern and builtin {{gridpattern}} pattern both named "{name}"'), - i = msg_geometry) - abort(msg) - } - match_array <- match(names_array, names_pattern) - if (any(!is.na(match_array))) { - index <- which(!is.na(match_array))[1] - name <- names_array[index] - msg <- c(glue('There is a custom "array" pattern and builtin {{gridpattern}} pattern both named "{name}"'), - i = msg_array) - abort(msg) - } - invisible(NULL) + names_geometry <- names(user_geometry_fns) + names_array <- names(user_array_fns) + msg_geometry <- '`options("ggpattern_geometry_funcs")` sets custom "geometry" patterns' + msg_array <- '`options("ggpattern_array_funcs")` sets custom "array" patterns' + # check pattern names not duplicated within custom pattern types + duplicated_geometry <- duplicated(names_geometry) + if (any(duplicated_geometry)) { + name <- names_geometry[which(duplicated_geometry)[1]] + msg <- c( + glue('There are multiple custom "geometry" patterns named "{name}"'), + i = msg_geometry + ) + abort(msg) + } + duplicated_array <- duplicated(names_array) + if (any(duplicated_array)) { + name <- names_array[which(duplicated_array)[1]] + msg <- c(glue('There are multiple custom "array" patterns named "{name}"'), i = msg_array) + abort(msg) + } + # check pattern names not duplicated between custom pattern types + match_user <- match(names_geometry, names_array) + if (any(!is.na(match_user))) { + index <- which(!is.na(match_user))[1] + name <- names_geometry[index] + msg <- c( + glue( + 'There is a custom "geometry" pattern and custom "array" pattern both named "{name}"' + ), + i = msg_geometry, + i = msg_array + ) + abort(msg) + } + # check pattern names not duplicated between custom patterns and builtin patterns + match_geometry <- match(names_geometry, names_pattern) + if (any(!is.na(match_geometry))) { + index <- which(!is.na(match_geometry))[1] + name <- names_geometry[index] + msg <- c( + glue( + 'There is a custom "geometry" pattern and builtin {{gridpattern}} pattern both named "{name}"' + ), + i = msg_geometry + ) + abort(msg) + } + match_array <- match(names_array, names_pattern) + if (any(!is.na(match_array))) { + index <- which(!is.na(match_array))[1] + name <- names_array[index] + msg <- c( + glue( + 'There is a custom "array" pattern and builtin {{gridpattern}} pattern both named "{name}"' + ), + i = msg_array + ) + abort(msg) + } + invisible(NULL) } diff --git a/R/mean_col.R b/R/mean_col.R index 13669ed..b2a4e59 100644 --- a/R/mean_col.R +++ b/R/mean_col.R @@ -14,11 +14,11 @@ #' mean_col("red", "blue") #' @export mean_col <- function(...) { - cols <- unlist(list(...)) - m <- grDevices::col2rgb(cols, alpha=TRUE) / 255.0 - # quadratic mean suggested at https://stackoverflow.com/a/29576746 - v <- apply(m, 1, quadratic_mean) - grDevices::rgb(v[1], v[2], v[3], v[4]) + cols <- unlist(list(...)) + m <- grDevices::col2rgb(cols, alpha = TRUE) / 255.0 + # quadratic mean suggested at https://stackoverflow.com/a/29576746 + v <- apply(m, 1, quadratic_mean) + grDevices::rgb(v[1], v[2], v[3], v[4]) } quadratic_mean <- function(x) sqrt(mean(x^2)) diff --git a/R/pattern-array-ambient.R b/R/pattern-array-ambient.R index a633dc7..dc7a6da 100644 --- a/R/pattern-array-ambient.R +++ b/R/pattern-array-ambient.R @@ -22,23 +22,60 @@ #' [ambient::noise_value()], [ambient::noise_white()], and [ambient::noise_worley()]. #' [grid.pattern_plasma()] provides an alternative noise pattern that depends on `magick`. #' @export -grid.pattern_ambient <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - type = "simplex", fill = gp$fill %||% "grey80", fill2 = "#4169E1", - frequency = 0.01, interpolator = "quintic", - fractal = switch(type, worley = "none", "fbm"), - octaves = 3, lacunarity = 2, gain = 0.5, - pertubation = "none", pertubation_amplitude = 1, - value = "cell", distance_ind = c(1, 2), jitter = 0.45, - res = getOption("ggpattern_res", 72), alpha = NA_real_, - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("ambient", x, y, id, - type = type, fill = fill, fill2 = fill2, - frequency = frequency, interpolator = interpolator, fractal = fractal, - octaves = octaves, lacunarity = lacunarity, gain = gain, - pertubation = pertubation, pertubation_amplitude = pertubation_amplitude, - value = value, distance_ind = distance_ind, jitter = jitter, - res = res, alpha = alpha, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_ambient <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + type = "simplex", + fill = gp$fill %||% "grey80", + fill2 = "#4169E1", + frequency = 0.01, + interpolator = "quintic", + fractal = switch(type, worley = "none", "fbm"), + octaves = 3, + lacunarity = 2, + gain = 0.5, + pertubation = "none", + pertubation_amplitude = 1, + value = "cell", + distance_ind = c(1, 2), + jitter = 0.45, + res = getOption("ggpattern_res", 72), + alpha = NA_real_, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "ambient", + x, + y, + id, + type = type, + fill = fill, + fill2 = fill2, + frequency = frequency, + interpolator = interpolator, + fractal = fractal, + octaves = octaves, + lacunarity = lacunarity, + gain = gain, + pertubation = pertubation, + pertubation_amplitude = pertubation_amplitude, + value = value, + distance_ind = distance_ind, + jitter = jitter, + res = res, + alpha = alpha, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } #' Create an array of noise using the 'ambient' package @@ -49,69 +86,70 @@ grid.pattern_ambient <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, #' @param legend logical. If the request to create a pattern comes during #' creation of the legend, then this is TRUE, otherwise FALSE #' -#' @return an RGBA numeric array with dimensions [height, width, 4] +#' @return an RGBA numeric array with dimensions (`height`, `width`, 4) #' @noRd create_pattern_ambient <- function(width, height, params, legend) { + assert_suggested("ambient", "ambient") - assert_suggested("ambient", "ambient") + colour1 <- as.character(params$pattern_fill) + colour2 <- as.character(params$pattern_fill2) - colour1 <- as.character(params$pattern_fill ) - colour2 <- as.character(params$pattern_fill2) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Create a ramp function from these 2 colours + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ramp_func <- grDevices::colorRamp(c(colour1, colour2), alpha = TRUE) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create a ramp function from these 2 colours - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ramp_func <- grDevices::colorRamp(c(colour1, colour2), alpha = TRUE) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Create a noise matrix of the requested dimensions using 'ambient'. + # The contents are normalised to all be in the range [0,1] + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + fn <- ambient_fn(params) + noise_matrix <- fn(dim = c(height, width)) + noise_matrix <- ambient::normalise(noise_matrix) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create a noise matrix of the requested dimensions using 'ambient'. - # The contents are normalised to all be in the range [0,1] - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - fn <- ambient_fn(params) - noise_matrix <- fn(dim = c(height, width)) - noise_matrix <- ambient::normalise(noise_matrix) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Use each value in the noise matrix to lookup a colour using the + # colour ramp function, then ensure the results are an RGBA array of the + # correct dimensions. + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + colour_matrix <- ramp_func(noise_matrix) / 255 + noise_array <- array(colour_matrix, dim = c(height, width, 4)) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Use each value in the noise matrix to lookup a colour using the - # colour ramp function, then ensure the results are an RGBA array of the - # correct dimensions. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - colour_matrix <- ramp_func(noise_matrix)/255 - noise_array <- array(colour_matrix, dim = c(height, width, 4)) - - noise_array + noise_array } ambient_fn <- function(params) { - type <- params$pattern_type - args <- list() - args$frequency <- params$pattern_frequency - args$pertubation <- params$pattern_pertubation - args$pertubation_amplitude <- params$pattern_pertubation_amplitude - if (type %in% c("perlin", "simplex", "value")) { - args$interpolator <- params$pattern_interpolator - } - if (type != "white") { - args$fractal <- params$pattern_fractal - args$octaves <- params$pattern_octaves - args$lacunarity <- params$pattern_lacunarity - args$gain <- params$pattern_gain - } - if (type == "worley") { - args$value <- params$pattern_value - args$distance_ind <- params$pattern_distance_ind - args$jitter <- params$pattern_jitter - } - function(dim) { - args$dim <- dim - fn <- switch(type, - cubic = ambient::noise_cubic, - perlin = ambient::noise_perlin, - simplex = ambient::noise_simplex, - value = ambient::noise_value, - white = ambient::noise_white, - worley = ambient::noise_worley, - abort(glue("Don't know ambient type {type}"))) - do.call(fn, args) - } + type <- params$pattern_type + args <- list() + args$frequency <- params$pattern_frequency + args$pertubation <- params$pattern_pertubation + args$pertubation_amplitude <- params$pattern_pertubation_amplitude + if (type %in% c("perlin", "simplex", "value")) { + args$interpolator <- params$pattern_interpolator + } + if (type != "white") { + args$fractal <- params$pattern_fractal + args$octaves <- params$pattern_octaves + args$lacunarity <- params$pattern_lacunarity + args$gain <- params$pattern_gain + } + if (type == "worley") { + args$value <- params$pattern_value + args$distance_ind <- params$pattern_distance_ind + args$jitter <- params$pattern_jitter + } + function(dim) { + args$dim <- dim + fn <- switch( + type, + cubic = ambient::noise_cubic, + perlin = ambient::noise_perlin, + simplex = ambient::noise_simplex, + value = ambient::noise_value, + white = ambient::noise_white, + worley = ambient::noise_worley, + abort(glue("Don't know ambient type {type}")) + ) + do.call(fn, args) + } } diff --git a/R/pattern-array-image.R b/R/pattern-array-image.R index 5c019a3..6383223 100644 --- a/R/pattern-array-image.R +++ b/R/pattern-array-image.R @@ -41,18 +41,46 @@ #' [reset_image_cache()] resets the image cache used by `grid.pattern_image()` #' and [grid.pattern_placeholder()]. #' @export -grid.pattern_image <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - filename = "", type = "fit", scale = 1, - gravity = switch(type, tile = "southwest", "center"), - filter = "lanczos", - alpha = gp$alpha %||% NA_real_, aspect_ratio = 1, key_scale_factor = 1, - res = getOption("ggpattern_res", 72), - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("image", x, y, id, - filename = filename, type = type, scale = scale, - gravity = gravity, filter = filter, - alpha = alpha, aspect_ratio = aspect_ratio, key_scale_factor = key_scale_factor, res = res, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_image <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + filename = "", + type = "fit", + scale = 1, + gravity = switch(type, tile = "southwest", "center"), + filter = "lanczos", + alpha = gp$alpha %||% NA_real_, + aspect_ratio = 1, + key_scale_factor = 1, + res = getOption("ggpattern_res", 72), + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "image", + x, + y, + id, + filename = filename, + type = type, + scale = scale, + gravity = gravity, + filter = filter, + alpha = alpha, + aspect_ratio = aspect_ratio, + key_scale_factor = key_scale_factor, + res = res, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } #' Read a user specified filename/URL as an image @@ -63,30 +91,29 @@ grid.pattern_image <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, .. #' #' @noRd img_read_as_array_wrapper <- function(width, height, params, legend) { + assert_suggested("magick", "image") - assert_suggested("magick", "image") + filename <- as.character(params$pattern_filename) - filename <- as.character(params$pattern_filename) + fill_type <- tolower(as.character(params$pattern_type)) + fill_type <- check_default(fill_type, options = fill_types) - fill_type <- tolower(as.character(params$pattern_type)) - fill_type <- check_default(fill_type, options = fill_types) + gravity <- tolower(as.character(params$pattern_gravity)) + gravity <- check_default(gravity, tolower(magick::gravity_types()), 'center') - gravity <- tolower(as.character(params$pattern_gravity)) - gravity <- check_default(gravity, tolower(magick::gravity_types()), 'center') + filter <- tolower(as.character(params$pattern_filter)) + filter <- check_default(filter, tolower(magick::filter_types()), 'lanczos') - filter <- tolower(as.character(params$pattern_filter)) - filter <- check_default(filter, tolower(magick::filter_types()), 'lanczos') + scale <- params$pattern_scale + scale <- check_default(scale, default = 1, type = 'numeric') - scale <- params$pattern_scale - scale <- check_default(scale, default = 1, type = 'numeric') - - img_read_as_array( - filename = filename, - width = width, - height = height, - fill_type = fill_type, - gravity = gravity, - filter = filter, - scale = scale - ) + img_read_as_array( + filename = filename, + width = width, + height = height, + fill_type = fill_type, + gravity = gravity, + filter = filter, + scale = scale + ) } diff --git a/R/pattern-array-magick.R b/R/pattern-array-magick.R index 8d5885c..1584683 100644 --- a/R/pattern-array-magick.R +++ b/R/pattern-array-magick.R @@ -22,16 +22,45 @@ #' print(names_magick) #' @seealso The `imagemagick` documentation for more information. #' @export -grid.pattern_magick <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - type = "hexagons", fill = "grey20", scale = 1, filter = "box", - alpha = gp$alpha %||% NA_real_, aspect_ratio = 1, key_scale_factor = 1, - res = getOption("ggpattern_res", 72), - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("magick", x, y, id, - type = type, fill = fill, scale = scale, scale = scale, filter = filter, - alpha = alpha, aspect_ratio = aspect_ratio, - key_scale_factor = key_scale_factor, res = res, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_magick <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + type = "hexagons", + fill = "grey20", + scale = 1, + filter = "box", + alpha = gp$alpha %||% NA_real_, + aspect_ratio = 1, + key_scale_factor = 1, + res = getOption("ggpattern_res", 72), + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "magick", + x, + y, + id, + type = type, + fill = fill, + scale = scale, + scale = scale, + filter = filter, + alpha = alpha, + aspect_ratio = aspect_ratio, + key_scale_factor = key_scale_factor, + res = res, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } ## Names of patterns available in image magick, plus subsets for shaded intensity and stripes @@ -40,37 +69,111 @@ grid.pattern_magick <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, . #' @rdname grid.pattern_magick #' @export names_magick <- c( - "bricks", "checkerboard", "circles", "crosshatch", "crosshatch30", - "crosshatch45", "fishscales", "gray0", "gray5", "gray10", "gray15", - "gray20", "gray25", "gray30", "gray35", "gray40", "gray45", "gray50", - "gray55", "gray60", "gray65", "gray70", "gray75", "gray80", "gray85", - "gray90", "gray95", "gray100", "hexagons", "horizontal", "horizontal2", - "horizontal3", "horizontalsaw", "hs_bdiagonal", "hs_cross", "hs_diagcross", - "hs_fdiagonal", "hs_horizontal", "hs_vertical", "left30", "left45", - "leftshingle", "octagons", "right30", "right45", "rightshingle", - "smallfishscales", "vertical", "vertical2", "vertical3", "verticalbricks", - "verticalleftshingle", "verticalrightshingle", "verticalsaw" + "bricks", + "checkerboard", + "circles", + "crosshatch", + "crosshatch30", + "crosshatch45", + "fishscales", + "gray0", + "gray5", + "gray10", + "gray15", + "gray20", + "gray25", + "gray30", + "gray35", + "gray40", + "gray45", + "gray50", + "gray55", + "gray60", + "gray65", + "gray70", + "gray75", + "gray80", + "gray85", + "gray90", + "gray95", + "gray100", + "hexagons", + "horizontal", + "horizontal2", + "horizontal3", + "horizontalsaw", + "hs_bdiagonal", + "hs_cross", + "hs_diagcross", + "hs_fdiagonal", + "hs_horizontal", + "hs_vertical", + "left30", + "left45", + "leftshingle", + "octagons", + "right30", + "right45", + "rightshingle", + "smallfishscales", + "vertical", + "vertical2", + "vertical3", + "verticalbricks", + "verticalleftshingle", + "verticalrightshingle", + "verticalsaw" ) #' @rdname grid.pattern_magick #' @export names_magick_intensity <- c( - "gray0", "gray5", "gray10", "gray15", - "gray20", "gray25", "gray30", "gray35", "gray40", "gray45", "gray50", - "gray55", "gray60", "gray65", "gray70", "gray75", "gray80", "gray85", - "gray90", "gray95", "gray100" + "gray0", + "gray5", + "gray10", + "gray15", + "gray20", + "gray25", + "gray30", + "gray35", + "gray40", + "gray45", + "gray50", + "gray55", + "gray60", + "gray65", + "gray70", + "gray75", + "gray80", + "gray85", + "gray90", + "gray95", + "gray100" ) #' @rdname grid.pattern_magick #' @export names_magick_stripe <- c( - "crosshatch", "crosshatch30", "crosshatch45", - "horizontal", "horizontal2", "horizontal3", - "hs_bdiagonal", "hs_cross", "hs_diagcross", - "hs_fdiagonal", "hs_horizontal", "hs_vertical", "left30", "left45", - "right30", "right45", - "vertical", "vertical2", "vertical3" + "crosshatch", + "crosshatch30", + "crosshatch45", + "horizontal", + "horizontal2", + "horizontal3", + "hs_bdiagonal", + "hs_cross", + "hs_diagcross", + "hs_fdiagonal", + "hs_horizontal", + "hs_vertical", + "left30", + "left45", + "right30", + "right45", + "vertical", + "vertical2", + "vertical3" ) #' Read a user specified filename as an image @@ -81,31 +184,32 @@ names_magick_stripe <- c( #' #' @noRd create_magick_pattern_as_array <- function(width, height, params, legend) { + assert_suggested("magick", "magick") - assert_suggested("magick", "magick") + if (legend) { + params$pattern_scale <- params$pattern_scale * params$pattern_key_scale_factor + } + type <- check_default( + as.character(params$pattern_type), + options = names_magick, + default = 'hexagons' + ) - if (legend) { - params$pattern_scale <- params$pattern_scale * params$pattern_key_scale_factor - } - type <- check_default(as.character(params$pattern_type), - options = names_magick, - default = 'hexagons') + scale <- check_default(params$pattern_scale, default = 1, type = 'numeric') - scale <- check_default(params$pattern_scale, default = 1, type = 'numeric') + filter <- tolower(as.character(params$pattern_filter)) + filter <- check_default(filter, options = tolower(magick::filter_types()), default = 'box') - filter <- tolower(as.character(params$pattern_filter)) - filter <- check_default(filter, options = tolower(magick::filter_types()), default = 'box') + colour <- as.character(params$pattern_fill) - colour <- as.character(params$pattern_fill) + img <- create_magick_pattern_img_scaled( + width = width, + height = height, + type = type, + colour = colour, + scale = scale, + filter = filter + ) - img <- create_magick_pattern_img_scaled( - width = width, - height = height, - type = type, - colour = colour, - scale = scale, - filter = filter - ) - - convert_img_to_array(img) + convert_img_to_array(img) } diff --git a/R/pattern-array-placeholder.R b/R/pattern-array-placeholder.R index f868d1c..48f3d40 100644 --- a/R/pattern-array-placeholder.R +++ b/R/pattern-array-placeholder.R @@ -18,15 +18,38 @@ #' print(names_placeholder) #' @seealso [reset_image_cache()] resets the image cache used by [grid.pattern_image()] and `grid.pattern_placeholder()`. #' @export -grid.pattern_placeholder <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - type = "bear", alpha = gp$alpha %||% NA_real_, - aspect_ratio = 1, key_scale_factor = 1, - res = getOption("ggpattern_res", 72), - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("placeholder", x, y, id, - type = type, alpha = alpha, - aspect_ratio = aspect_ratio, key_scale_factor = key_scale_factor, res = res, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_placeholder <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + type = "bear", + alpha = gp$alpha %||% NA_real_, + aspect_ratio = 1, + key_scale_factor = 1, + res = getOption("ggpattern_res", 72), + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "placeholder", + x, + y, + id, + type = type, + alpha = alpha, + aspect_ratio = aspect_ratio, + key_scale_factor = key_scale_factor, + res = res, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } ## All placeholder names @@ -34,17 +57,28 @@ grid.pattern_placeholder <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = #' @rdname grid.pattern_placeholder #' @export names_placeholder <- c( - "bear", "bearbw", - "beard", "beardbw", - "cage", "cagebw", - "dummy", "dummybw", - "flickr", "flickrbw", - "keanu", "keanubw", - "kitten", "kittenbw", - "murray", "murraybw", - "picsum", "picsumbw", - "placeholder", "placeholderbw", - "seagal", "seagalbw" + "bear", + "bearbw", + "beard", + "beardbw", + "cage", + "cagebw", + "dummy", + "dummybw", + "flickr", + "flickrbw", + "keanu", + "keanubw", + "kitten", + "kittenbw", + "murray", + "murraybw", + "picsum", + "picsumbw", + "placeholder", + "placeholderbw", + "seagal", + "seagalbw" ) #' Fetch a placeholder image of the correct dimensions @@ -71,41 +105,40 @@ names_placeholder <- c( #' #' @noRd fetch_placeholder_img <- function(width = 100, height = 100, type = 'dummy') { + width <- as.integer(width) + height <- as.integer(height) - width <- as.integer(width) - height <- as.integer(height) + img_url <- switch( + type, + bear = glue("https://placebear.com/{width}/{height}"), + bearbw = glue("https://placebear.com/g/{width}/{height}"), + beard = glue("https://placebeard.it/{width}/{height}"), + beardbw = glue("https://placebeard.it/g/{width}/{height}"), + cage = glue("https://placecage.lucidinternets.com/{width}/{height}"), + cagebw = glue("https://placecage.lucidinternets.com/g/{width}/{height}"), + dummy = glue("https://dummyimage.com/{width}x{height}"), + dummybw = glue("https://dummyimage.com/{width}x{height}/fff/000"), + flickr = glue("https://loremflickr.com/{width}/{height}"), + flickrbw = glue("https://loremflickr.com/g/{width}/{height}/all"), + keanu = glue("https://placekeanu.com/{width}/{height}"), + keanubw = glue("https://placekeanu.com/{width}/{height}/g"), + kitten = glue("https://placecats.com/{width}/{height}"), + kittenbw = glue("https://placecats.com/g/{width}/{height}"), + murray = glue("https://fillmurray.lucidinternets.com/{width}/{height}"), + murraybw = glue("https://fillmurray.lucidinternets.com/g/{width}/{height}"), + picsum = glue("https://picsum.photos/{width}/{height}"), + picsumbw = glue("https://picsum.photos/{width}/{height}?grayscale"), + placeholderbw = glue("https://placehold.co/{width}x{height}/000000/FFFFFF/png"), + placeholder = glue("https://placehold.co/{width}x{height}/png"), + seagal = glue("https://www.stevensegallery.lucidinternets.com/{width}/{height}"), + seagalbw = glue("https://www.stevensegallery.lucidinternets.com/g/{width}/{height}"), + { + warn(glue("Unknown placeholder type '{type}' using 'bear' instead")) + glue("https://dummyimage.com/{width}x{height}") + } + ) - img_url <- switch( - type, - bear = glue("https://placebear.com/{width}/{height}"), - bearbw = glue("https://placebear.com/g/{width}/{height}"), - beard = glue("https://placebeard.it/{width}/{height}"), - beardbw = glue("https://placebeard.it/g/{width}/{height}"), - cage = glue("https://placecage.lucidinternets.com/{width}/{height}"), - cagebw = glue("https://placecage.lucidinternets.com/g/{width}/{height}"), - dummy = glue("https://dummyimage.com/{width}x{height}"), - dummybw = glue("https://dummyimage.com/{width}x{height}/fff/000"), - flickr = glue("https://loremflickr.com/{width}/{height}"), - flickrbw = glue("https://loremflickr.com/g/{width}/{height}/all"), - keanu = glue("https://placekeanu.com/{width}/{height}"), - keanubw = glue("https://placekeanu.com/{width}/{height}/g"), - kitten = glue("https://placecats.com/{width}/{height}"), - kittenbw = glue("https://placecats.com/g/{width}/{height}"), - murray = glue("https://fillmurray.lucidinternets.com/{width}/{height}"), - murraybw = glue("https://fillmurray.lucidinternets.com/g/{width}/{height}"), - picsum = glue("https://picsum.photos/{width}/{height}"), - picsumbw = glue("https://picsum.photos/{width}/{height}?grayscale"), - placeholderbw = glue("https://placehold.co/{width}x{height}/000000/FFFFFF/png"), - placeholder = glue("https://placehold.co/{width}x{height}/png"), - seagal = glue("https://www.stevensegallery.lucidinternets.com/{width}/{height}"), - seagalbw = glue("https://www.stevensegallery.lucidinternets.com/g/{width}/{height}"), - { - warn(glue("Unknown placeholder type '{type}' using 'bear' instead")) - glue("https://dummyimage.com/{width}x{height}") - } - ) - - img_read_memoised(filename = img_url) + img_read_memoised(filename = img_url) } #' Fetch a placeholder image of the correct size and return as an array @@ -116,16 +149,19 @@ fetch_placeholder_img <- function(width = 100, height = 100, type = 'dummy') { #' #' @noRd fetch_placeholder_array <- function(width, height, params, legend) { + assert_suggested("magick", "placeholder") - assert_suggested("magick", "placeholder") - - if (legend) { - img <- magick::image_blank(width, height) - return(convert_img_to_array(img)) - } + if (legend) { + img <- magick::image_blank(width, height) + return(convert_img_to_array(img)) + } - placeholder_type <- check_default(as.character(params$pattern_type), default = 'kitten', type = 'char') - img <- fetch_placeholder_img(width = width, height = height, type = placeholder_type) + placeholder_type <- check_default( + as.character(params$pattern_type), + default = 'kitten', + type = 'char' + ) + img <- fetch_placeholder_img(width = width, height = height, type = placeholder_type) - convert_img_to_array(img) + convert_img_to_array(img) } diff --git a/R/pattern-array-plasma.R b/R/pattern-array-plasma.R index c1aa0f0..83ff8b8 100644 --- a/R/pattern-array-plasma.R +++ b/R/pattern-array-plasma.R @@ -14,15 +14,40 @@ #' @seealso [grid.pattern_ambient()] provides a noise pattern using the `ambient` package. #' Pseudorandom seeds for the plasma pattern may be set via [magick::magick_set_seed()]. #' @export -grid.pattern_plasma <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - fill = gp$fill %||% "grey80", scale = 1, alpha = gp$alpha %||% NA_real_, - aspect_ratio = 1, key_scale_factor = 1, - res = getOption("ggpattern_res", 72), - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("plasma", x, y, id, - fill = fill, scale = scale, alpha = alpha, - aspect_ratio = aspect_ratio, key_scale_factor = key_scale_factor, res = res, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_plasma <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + fill = gp$fill %||% "grey80", + scale = 1, + alpha = gp$alpha %||% NA_real_, + aspect_ratio = 1, + key_scale_factor = 1, + res = getOption("ggpattern_res", 72), + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "plasma", + x, + y, + id, + fill = fill, + scale = scale, + alpha = alpha, + aspect_ratio = aspect_ratio, + key_scale_factor = key_scale_factor, + res = res, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } #' Read a user specified filename as an image @@ -32,18 +57,17 @@ grid.pattern_plasma <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, . #' @return array #' @noRd create_magick_plasma_as_array <- function(width, height, params, legend) { + assert_suggested("magick", "plasma") - assert_suggested("magick", "plasma") + colour <- as.character(params$pattern_fill) - colour <- as.character(params$pattern_fill) + img <- create_magick_plasma_img( + width = width, + height = height, + colour = colour + ) - img <- create_magick_plasma_img( - width = width, - height = height, - colour = colour - ) - - convert_img_to_array(img) + convert_img_to_array(img) } #' Create plasma using imagemagick @@ -54,24 +78,23 @@ create_magick_plasma_as_array <- function(width, height, params, legend) { #' @param colour colour #' #' @noRd -create_magick_plasma_img <- function(width=100, height=100, colour) { - - colour <- convert_r_colour_to_magick_colour(colour) +create_magick_plasma_img <- function(width = 100, height = 100, colour) { + colour <- convert_r_colour_to_magick_colour(colour) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create a pattern image of the required size - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pseudo <- "plasma:" - img <- magick::image_blank(width, height, pseudo_image = pseudo) - img <- magick::image_convert(img, colorspace = 'gray', depth = 8) - img <- magick::image_blur(img, radius = 2) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Create a pattern image of the required size + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + pseudo <- "plasma:" + img <- magick::image_blank(width, height, pseudo_image = pseudo) + img <- magick::image_convert(img, colorspace = 'gray', depth = 8) + img <- magick::image_blur(img, radius = 2) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Make the white transparent - # Colorize the black pixels into the desired colour - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - img <- magick::image_transparent(img, 'white') - img <- magick::image_colorize(img, opacity = 50, colour) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Make the white transparent + # Colorize the black pixels into the desired colour + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + img <- magick::image_transparent(img, 'white') + img <- magick::image_colorize(img, opacity = 50, colour) - img + img } diff --git a/R/pattern-both-gradient.R b/R/pattern-both-gradient.R index bed3a3c..7f6f652 100644 --- a/R/pattern-both-gradient.R +++ b/R/pattern-both-gradient.R @@ -24,20 +24,47 @@ #' grid.pattern_gradient(x_hex, y_hex, fill = "green", orientation = "radial") #' } #' @export -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 = getOption("ggpattern_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) +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 = getOption("ggpattern_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 + ) } #' create a gradient image as an array @@ -49,74 +76,99 @@ grid.pattern_gradient <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, #' @return magick image #' #' @noRd -create_gradient_img <- function(width = 100, - height = 100, - colour1 = 'red', - colour2 = 'blue', - orientation = 'vertical') { +create_gradient_img <- function( + width = 100, + height = 100, + colour1 = 'red', + colour2 = 'blue', + orientation = 'vertical' +) { + colour1 <- convert_r_colour_to_magick_colour(colour1) + colour2 <- convert_r_colour_to_magick_colour(colour2) + colour_spec <- paste0(colour2, "-", colour1) - colour1 <- convert_r_colour_to_magick_colour(colour1) - colour2 <- convert_r_colour_to_magick_colour(colour2) - colour_spec <- paste0(colour2, "-", colour1) + if (orientation == 'radial') { + colour_spec <- paste0(colour1, "-", colour2) + pseudo <- paste0('radial-gradient:', colour_spec) + img <- magick::image_blank(width, height, pseudo_image = pseudo) + } else if (orientation == 'vertical') { + pseudo <- paste0('gradient:', colour_spec) + img <- magick::image_blank(width, height, pseudo_image = pseudo) + } else if (orientation == 'horizontal') { + pseudo <- paste0('gradient:', colour_spec) + img <- magick::image_blank(height, width, pseudo_image = pseudo) + img <- magick::image_rotate(img, 90) + } else { + abort(paste0("create_gradient_img() - Orientation not supported: ", orientation)) + } - if (orientation == 'radial') { - colour_spec <- paste0(colour1, "-", colour2) - pseudo <- paste0('radial-gradient:', colour_spec) - img <- magick::image_blank(width, height, pseudo_image = pseudo) - } else if (orientation == 'vertical') { - pseudo <- paste0('gradient:', colour_spec) - img <- magick::image_blank(width, height, pseudo_image = pseudo) - } else if (orientation == 'horizontal') { - pseudo <- paste0('gradient:', colour_spec) - img <- magick::image_blank(height, width, pseudo_image = pseudo) - img <- magick::image_rotate(img, 90) - } else { - abort(paste0("create_gradient_img() - Orientation not supported: ", orientation)) - } - - img + img } create_pattern_gradient <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - if (params$pattern_use_R4.1_gradients) { - create_gradient_as_geometry(params, boundary_df, aspect_ratio, legend) - } else { - create_pattern_array(params, boundary_df, aspect_ratio, legend, create_gradient_as_array) - } + if (params$pattern_use_R4.1_gradients) { + create_gradient_as_geometry(params, boundary_df, aspect_ratio, legend) + } else { + create_pattern_array(params, boundary_df, aspect_ratio, legend, create_gradient_as_array) + } } create_gradient_as_geometry <- function(params, boundary_df, aspect_ratio, legend) { - orientation <- check_default(params$pattern_orientation, - options = c('vertical', 'horizontal', 'radial')) - colour1 <- params$pattern_fill - colour2 <- params$pattern_fill2 + orientation <- check_default( + params$pattern_orientation, + options = c('vertical', 'horizontal', 'radial') + ) + colour1 <- params$pattern_fill + colour2 <- params$pattern_fill2 - x_min <- min(boundary_df$x) - x_max <- max(boundary_df$x) - y_min <- min(boundary_df$y) - y_max <- max(boundary_df$y) - x_range <- convertX(unit(x_max - x_min, "npc"), "in", valueOnly = TRUE) - y_range <- convertY(unit(y_max - y_min, "npc"), "in", valueOnly = TRUE) - if (x_range == 0 || y_range == 0) - return(nullGrob()) + x_min <- min(boundary_df$x) + x_max <- max(boundary_df$x) + y_min <- min(boundary_df$y) + y_max <- max(boundary_df$y) + x_range <- convertX(unit(x_max - x_min, "npc"), "in", valueOnly = TRUE) + y_range <- convertY(unit(y_max - y_min, "npc"), "in", valueOnly = TRUE) + if (x_range == 0 || y_range == 0) { + return(nullGrob()) + } - if (x_range > y_range) - r2 <- 0.5 * x_range / y_range - else - r2 <- 0.5 * y_range / x_range + if (x_range > y_range) { + r2 <- 0.5 * x_range / y_range + } else { + r2 <- 0.5 * y_range / x_range + } - gradient <- switch(orientation, - horizontal = linearGradient(c(colour1, colour2), extend = "pad", - x1 = 0, y1 = 0.5, x2 = 1, y2 = 0.5), - radial = radialGradient(c(colour1, colour2), extend = "pad", - cx1 = 0.5, cy1 = 0.5, cx2 = 0.5, cy2 = 0.5, - r1 = 0, r2 = r2), - vertical = linearGradient(c(colour1, colour2), extend = "pad", - x1 = 0.5, y1 = 0, x2 = 0.5, y2 = 1) - ) - gp <- gpar(col = NA, fill = gradient) + gradient <- switch( + orientation, + horizontal = linearGradient( + c(colour1, colour2), + extend = "pad", + x1 = 0, + y1 = 0.5, + x2 = 1, + y2 = 0.5 + ), + radial = radialGradient( + c(colour1, colour2), + extend = "pad", + cx1 = 0.5, + cy1 = 0.5, + cx2 = 0.5, + cy2 = 0.5, + r1 = 0, + r2 = r2 + ), + vertical = linearGradient( + c(colour1, colour2), + extend = "pad", + x1 = 0.5, + y1 = 0, + x2 = 0.5, + y2 = 1 + ) + ) + gp <- gpar(col = NA, fill = gradient) - convert_polygon_df_to_polygon_grob(boundary_df, gp = gp) + convert_polygon_df_to_polygon_grob(boundary_df, gp = gp) } #' A shim to go between the main pattern function for an image, and the @@ -133,21 +185,22 @@ create_gradient_as_geometry <- function(params, boundary_df, aspect_ratio, legen #' #' @noRd create_gradient_as_array <- function(width, height, params, legend) { + assert_suggested("magick", "gradient") - assert_suggested("magick", "gradient") - - orientation <- check_default(params$pattern_orientation, - options = c('vertical', 'horizontal', 'radial')) - colour1 <- params$pattern_fill - colour2 <- params$pattern_fill2 + orientation <- check_default( + params$pattern_orientation, + options = c('vertical', 'horizontal', 'radial') + ) + colour1 <- params$pattern_fill + colour2 <- params$pattern_fill2 - img <- create_gradient_img( - width = width, - height = height, - colour1 = colour1, - colour2 = colour2, - orientation = orientation - ) + img <- create_gradient_img( + width = width, + height = height, + colour1 = colour1, + colour2 = colour2, + orientation = orientation + ) - convert_img_to_array(img) + convert_img_to_array(img) } diff --git a/R/pattern-both-rose.R b/R/pattern-both-rose.R index 25eff9a..568b06f 100644 --- a/R/pattern-both-rose.R +++ b/R/pattern-both-rose.R @@ -30,129 +30,186 @@ #' frequency = c(3/2, 7/3, 5/4, 3/7), gp = gp) #' } #' @export -grid.pattern_rose <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - fill = gp$fill %||% "grey80", - angle = 30, density = 0.2, - spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - frequency = 0.1, - grid = "square", type = NULL, subtype = NULL, - rot = 0, - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - use_R4.1_masks = getOption("ggpattern_use_R4.1_masks", - getOption("ggpattern_use_R4.1_features")), - png_device = NULL, res = getOption("ggpattern_res", 72), - default.units = "npc", name = NULL, - gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("rose", x, y, id, - colour = colour, fill = fill, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - scale = scale, frequency = frequency, - grid = grid, type = type, subtype = subtype, rot = rot, - use_R4.1_masks = use_R4.1_masks, png_device = png_device, res = res, - alpha = alpha, linetype = linetype, linewidth = linewidth, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_rose <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + frequency = 0.1, + grid = "square", + type = NULL, + subtype = NULL, + rot = 0, + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + use_R4.1_masks = getOption( + "ggpattern_use_R4.1_masks", + getOption("ggpattern_use_R4.1_features") + ), + png_device = NULL, + res = getOption("ggpattern_res", 72), + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "rose", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + scale = scale, + frequency = frequency, + grid = grid, + type = type, + subtype = subtype, + rot = rot, + use_R4.1_masks = use_R4.1_masks, + png_device = png_device, + res = res, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } create_pattern_rose <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio - default.units <- "bigpts" - boundary_df <- convert_polygon_df_units(boundary_df, default.units) - params <- convert_params_units(params, default.units) - vpm <- get_vp_measurements(default.units) - - spacing <- params$pattern_spacing - grid <- params$pattern_grid - - # create grid of points large enough to cover viewport no matter the angle - grid_xy <- get_xy_grid(params, vpm) - - # construct grobs using subsets if certain inputs are vectorized - fill <- update_alpha(params$pattern_fill, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth * .pt - lty <- params$pattern_linetype - - density <- params$pattern_density - rot <- params$pattern_rot - frequency <- params$pattern_frequency - - n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, frequency))) - - fill <- rep_len_fill(fill, n_par) - col <- rep_len(col, n_par) - lwd <- rep_len(lwd, n_par) - lty <- rep_len(lty, n_par) - density <- rep_len(density, n_par) - rot <- rep_len(rot, n_par) - frequency <- rep_len(frequency, n_par) - - density_max <- max(density) - - # compute regular polygon relative coordinates which we will center on points - radius_mult <- switch(grid, hex = 0.578, 0.5) - radius_max <- radius_mult * spacing * density_max - - # compute pattern matrix of graphical elements (e.g. fill colors) - if (is.null(params$pattern_type) || is.na(params$pattern_type)) - params$pattern_type <- switch(grid, square = "square", "hex") - m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par) - - gl <- gList() - for (i_par in seq(n_par)) { - radius_outer <- radius_mult * spacing * density[i_par] - xy_rose <- get_xy_rose(frequency[i_par], params, radius_outer, rot[i_par]) - xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing) - if (length(xy_par$x) == 0) next - - # rotate by 'angle' - xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y) - - gp <- gpar(fill = fill[[i_par]], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par]) - - name <- paste0("rose.", i_par) - grob <- points_to_rose_grob(xy_par, xy_rose, gp, default.units, name) - gl <- append_gList(gl, grob) - } - maskee <- gTree(children = gl) - masker <- convert_polygon_df_to_polygon_grob(boundary_df, default.units = "bigpts", - gp = gpar(fill = "white", col = NA, lwd = 0)) - alphaMaskGrob(maskee, masker, - use_R4.1_masks = params$pattern_use_R4.1_masks, - png_device = params$pattern_png_device, - res = params$pattern_res, name = "rose") + # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio + default.units <- "bigpts" + boundary_df <- convert_polygon_df_units(boundary_df, default.units) + params <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) + + spacing <- params$pattern_spacing + grid <- params$pattern_grid + + # create grid of points large enough to cover viewport no matter the angle + grid_xy <- get_xy_grid(params, vpm) + + # construct grobs using subsets if certain inputs are vectorized + fill <- update_alpha(params$pattern_fill, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth * .pt + lty <- params$pattern_linetype + + density <- params$pattern_density + rot <- params$pattern_rot + frequency <- params$pattern_frequency + + n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, frequency))) + + fill <- rep_len_fill(fill, n_par) + col <- rep_len(col, n_par) + lwd <- rep_len(lwd, n_par) + lty <- rep_len(lty, n_par) + density <- rep_len(density, n_par) + rot <- rep_len(rot, n_par) + frequency <- rep_len(frequency, n_par) + + density_max <- max(density) + + # compute regular polygon relative coordinates which we will center on points + radius_mult <- switch(grid, hex = 0.578, 0.5) + radius_max <- radius_mult * spacing * density_max + + # compute pattern matrix of graphical elements (e.g. fill colors) + if (is.null(params$pattern_type) || is.na(params$pattern_type)) { + params$pattern_type <- switch(grid, square = "square", "hex") + } + m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par) + + gl <- gList() + for (i_par in seq(n_par)) { + radius_outer <- radius_mult * spacing * density[i_par] + xy_rose <- get_xy_rose(frequency[i_par], params, radius_outer, rot[i_par]) + xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing) + if (length(xy_par$x) == 0) { + next + } + + # rotate by 'angle' + xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y) + + gp <- gpar(fill = fill[[i_par]], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par]) + + name <- paste0("rose.", i_par) + grob <- points_to_rose_grob(xy_par, xy_rose, gp, default.units, name) + gl <- append_gList(gl, grob) + } + maskee <- gTree(children = gl) + masker <- convert_polygon_df_to_polygon_grob( + boundary_df, + default.units = "bigpts", + gp = gpar(fill = "white", col = NA, lwd = 0) + ) + alphaMaskGrob( + maskee, + masker, + use_R4.1_masks = params$pattern_use_R4.1_masks, + png_device = params$pattern_png_device, + res = params$pattern_res, + name = "rose" + ) } get_xy_rose <- function(frequency, params, radius_outer, rot) { - theta <- to_radians(seq.int(from = 0, to = 12 * 360, by = 3)) - x <- radius_outer * cos(frequency * theta) * cos(theta) - y <- radius_outer * cos(frequency * theta) * sin(theta) - rose_angle <- rot + params$pattern_angle - rotate_xy(x, y, rose_angle, 0, 0) + theta <- to_radians(seq.int(from = 0, to = 12 * 360, by = 3)) + x <- radius_outer * cos(frequency * theta) * cos(theta) + y <- radius_outer * cos(frequency * theta) * sin(theta) + rose_angle <- rot + params$pattern_angle + rotate_xy(x, y, rose_angle, 0, 0) } points_to_rose_grob <- function(xy_par, xy_rose, gp, default.units, name) { - points_mat <- as.data.frame(xy_par) - df_polygon <- as.data.frame(xy_rose) - l_xy <- lapply(seq(nrow(points_mat)), - function(i_r) { - x0 <- points_mat[i_r, 1] - y0 <- points_mat[i_r, 2] - df <- df_polygon - df$x <- df$x + x0 - df$y <- df$y + y0 - df - }) - df <- do.call(rbind, l_xy) - if (is.null(df)) { - nullGrob() - } else { - df$id <- rep(seq(nrow(points_mat)), each = nrow(df_polygon)) - pathGrob(x = df$x, y = df$y, id = df$id, - default.units = default.units, gp = gp, name = name) - } + points_mat <- as.data.frame(xy_par) + df_polygon <- as.data.frame(xy_rose) + l_xy <- lapply(seq(nrow(points_mat)), function(i_r) { + x0 <- points_mat[i_r, 1] + y0 <- points_mat[i_r, 2] + df <- df_polygon + df$x <- df$x + x0 + df$y <- df$y + y0 + df + }) + df <- do.call(rbind, l_xy) + if (is.null(df)) { + nullGrob() + } else { + df$id <- rep(seq(nrow(points_mat)), each = nrow(df_polygon)) + pathGrob( + x = df$x, + y = df$y, + id = df$id, + default.units = default.units, + gp = gp, + name = name + ) + } } diff --git a/R/pattern-both-text.R b/R/pattern-both-text.R index ed4a8dd..a7e2b2d 100644 --- a/R/pattern-both-text.R +++ b/R/pattern-both-text.R @@ -23,97 +23,160 @@ #' size = 18, spacing = 0.1, angle = 0) #' } #' @export -grid.pattern_text <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - angle = 30, - spacing = 0.05, - xoffset = 0, yoffset = 0, units = "snpc", - scale = 0.5, - shape = "X", - grid = "square", type = NULL, subtype = NULL, rot = 0, - alpha = gp$alpha %||% NA_real_, - size = gp$fontsize %||% 12, - fontfamily = gp$fontfamily %||% "sans", - fontface = gp$fontface %||% "plain", - use_R4.1_masks = getOption("ggpattern_use_R4.1_masks", - getOption("ggpattern_use_R4.1_features")), - png_device = NULL, res = getOption("ggpattern_res", 72), - default.units = "npc", name = NULL, - gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("text", x, y, id, - colour = colour, angle = angle, - spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - scale = scale, shape = shape, - grid = grid, type = type, subtype = subtype, rot = rot, - alpha = alpha, size = size, fontfamily = fontfamily, fontface = fontface, - use_R4.1_masks = use_R4.1_masks, png_device = png_device, res = res, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_text <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + angle = 30, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + scale = 0.5, + shape = "X", + grid = "square", + type = NULL, + subtype = NULL, + rot = 0, + alpha = gp$alpha %||% NA_real_, + size = gp$fontsize %||% 12, + fontfamily = gp$fontfamily %||% "sans", + fontface = gp$fontface %||% "plain", + use_R4.1_masks = getOption( + "ggpattern_use_R4.1_masks", + getOption("ggpattern_use_R4.1_features") + ), + png_device = NULL, + res = getOption("ggpattern_res", 72), + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "text", + x, + y, + id, + colour = colour, + angle = angle, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + scale = scale, + shape = shape, + grid = grid, + type = type, + subtype = subtype, + rot = rot, + alpha = alpha, + size = size, + fontfamily = fontfamily, + fontface = fontface, + use_R4.1_masks = use_R4.1_masks, + png_device = png_device, + res = res, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } create_pattern_text <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio - default.units <- "bigpts" - boundary_df <- convert_polygon_df_units(boundary_df, default.units) - params <- convert_params_units(params, default.units) - vpm <- get_vp_measurements(default.units) + # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio + default.units <- "bigpts" + boundary_df <- convert_polygon_df_units(boundary_df, default.units) + params <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) - spacing <- params$pattern_spacing - grid <- params$pattern_grid + spacing <- params$pattern_spacing + grid <- params$pattern_grid - # create grid of points large enough to cover viewport no matter the angle - grid_xy <- get_xy_grid(params, vpm) + # create grid of points large enough to cover viewport no matter the angle + grid_xy <- get_xy_grid(params, vpm) - # vectorize fill, col, lwd, lty, density, rot, and shape - col <- update_alpha_col(params$pattern_colour, params$pattern_alpha) - fontsize <- params$pattern_size - fontfamily <- params$pattern_fontfamily - fontface <- params$pattern_fontface + # vectorize fill, col, lwd, lty, density, rot, and shape + col <- update_alpha_col(params$pattern_colour, params$pattern_alpha) + fontsize <- params$pattern_size + fontfamily <- params$pattern_fontfamily + fontface <- params$pattern_fontface - rot <- params$pattern_rot + params$pattern_angle - shape <- params$pattern_shape + rot <- params$pattern_rot + params$pattern_angle + shape <- params$pattern_shape - n_par <- max(lengths(list(col, fontsize, fontfamily, fontface, rot, shape))) + n_par <- max(lengths(list(col, fontsize, fontfamily, fontface, rot, shape))) - col <- rep_len(col, n_par) - fontsize <- rep_len(fontsize, n_par) - fontfamily <- rep_len(fontfamily, n_par) - fontface <- rep_len(fontface, n_par) - rot <- rep_len(rot, n_par) - shape <- rep_len(shape, n_par) + col <- rep_len(col, n_par) + fontsize <- rep_len(fontsize, n_par) + fontfamily <- rep_len(fontfamily, n_par) + fontface <- rep_len(fontface, n_par) + rot <- rep_len(rot, n_par) + shape <- rep_len(shape, n_par) - # compute pattern matrix of graphical elements (e.g. fill colors) - if (is.null(params$pattern_type) || is.na(params$pattern_type)) - params$pattern_type <- switch(grid, square = "square", "hex") - m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par) + # compute pattern matrix of graphical elements (e.g. fill colors) + if (is.null(params$pattern_type) || is.na(params$pattern_type)) { + params$pattern_type <- switch(grid, square = "square", "hex") + } + m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par) - gl <- gList() - for (i_par in seq(n_par)) { - if (shape[i_par] == "null") next - xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing) - if (length(xy_par$x) == 0) next + gl <- gList() + for (i_par in seq(n_par)) { + if (shape[i_par] == "null") { + next + } + xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing) + if (length(xy_par$x) == 0) { + next + } - # rotate by 'angle' - xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y) + # rotate by 'angle' + xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y) - gp <- gpar(col = col[i_par], fontsize = fontsize[i_par], - fontfamily = fontfamily[i_par], fontface = fontface[i_par]) + gp <- gpar( + col = col[i_par], + fontsize = fontsize[i_par], + fontfamily = fontfamily[i_par], + fontface = fontface[i_par] + ) - # create grob for interior polygons - name <- paste0("text.", i_par) + # create grob for interior polygons + name <- paste0("text.", i_par) - grob <- textGrob(label = shape[i_par], x = xy_par$x, y = xy_par$y, - rot = rot[i_par], just = "center", default.units = "bigpts", - name = name, gp = gp) + grob <- textGrob( + label = shape[i_par], + x = xy_par$x, + y = xy_par$y, + rot = rot[i_par], + just = "center", + default.units = "bigpts", + name = name, + gp = gp + ) - gl <- append_gList(gl, grob) - } - maskee <- gTree(children = gl) - masker <- convert_polygon_df_to_polygon_grob(boundary_df, default.units = "bigpts", - gp = gpar(fill = "white", col = NA, lwd = 0)) - png_device <- params$pattern_png_device - alphaMaskGrob(maskee, masker, - use_R4.1_masks = params$pattern_use_R4.1_masks, - png_device = png_device, - res = params$pattern_res, name = "text") + gl <- append_gList(gl, grob) + } + maskee <- gTree(children = gl) + masker <- convert_polygon_df_to_polygon_grob( + boundary_df, + default.units = "bigpts", + gp = gpar(fill = "white", col = NA, lwd = 0) + ) + png_device <- params$pattern_png_device + alphaMaskGrob( + maskee, + masker, + use_R4.1_masks = params$pattern_use_R4.1_masks, + png_device = png_device, + res = params$pattern_res, + name = "text" + ) } diff --git a/R/pattern-geometry-circle.R b/R/pattern-geometry-circle.R index 9643f8b..466ece3 100644 --- a/R/pattern-geometry-circle.R +++ b/R/pattern-geometry-circle.R @@ -44,27 +44,70 @@ #' @seealso #' See [grid.pattern_regular_polygon()] for a more general case of this pattern. #' @export -grid.pattern_circle <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", fill = gp$fill %||% "grey80", angle = 30, - density = 0.2, spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - grid = "square", type = NULL, subtype = NULL, - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("circle", x, y, id, - colour = colour, fill = fill, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - alpha = alpha, linetype = linetype, linewidth = linewidth, - grid = grid, type = type, subtype = subtype, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_circle <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + grid = "square", + type = NULL, + subtype = NULL, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "circle", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + grid = grid, + type = type, + subtype = subtype, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } create_pattern_circle_via_sf <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - params$pattern_shape <- "circle" - grob <- create_pattern_regular_polygon_via_sf(params, boundary_df, aspect_ratio, legend = legend) - grob <- editGrob(grob, name = "circle") - grob + params$pattern_shape <- "circle" + grob <- create_pattern_regular_polygon_via_sf( + params, + boundary_df, + aspect_ratio, + legend = legend + ) + grob <- editGrob(grob, name = "circle") + grob } diff --git a/R/pattern-geometry-crosshatch.R b/R/pattern-geometry-crosshatch.R index 8ad07d3..66c93eb 100644 --- a/R/pattern-geometry-crosshatch.R +++ b/R/pattern-geometry-crosshatch.R @@ -16,96 +16,131 @@ #' @seealso [grid.pattern_weave()] which interweaves two sets of lines. #' For a single set of lines use [grid.pattern_stripe()]. #' @export -grid.pattern_crosshatch <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - fill = gp$fill %||% "grey80", fill2 = fill, - angle = 30, density = 0.2, - spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - grid = "square", - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("crosshatch", x, y, id, - colour = colour, fill = fill, fill2 = fill2, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - alpha = alpha, linetype = linetype, linewidth = linewidth, - grid = grid, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_crosshatch <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + fill2 = fill, + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + grid = "square", + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "crosshatch", + x, + y, + id, + colour = colour, + fill = fill, + fill2 = fill2, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + grid = grid, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } create_pattern_crosshatch_via_sf <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - create_crosshatch_via_sf_helper(params, boundary_df, add_top_hatch = TRUE) + create_crosshatch_via_sf_helper(params, boundary_df, add_top_hatch = TRUE) } create_crosshatch_via_sf_helper <- function(params, boundary_df, add_top_hatch = TRUE) { + if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5) { + params$pattern_density <- 1 - 1e-6 + } + stopifnot(params$pattern_density <= 1) - if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5) - params$pattern_density <- 1 - 1e-6 - stopifnot(params$pattern_density <= 1) + # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio + default.units <- "bigpts" + boundary_df <- convert_polygon_df_units(boundary_df, default.units) + params <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) - # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio - default.units <- "bigpts" - boundary_df <- convert_polygon_df_units(boundary_df, default.units) - params <- convert_params_units(params, default.units) - vpm <- get_vp_measurements(default.units) + # create grid of points large enough to cover viewport no matter the angle + grid_xy <- get_xy_grid(params, vpm) - # create grid of points large enough to cover viewport no matter the angle - grid_xy <- get_xy_grid(params, vpm) + fill <- update_alpha(params$pattern_fill, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth * .pt + lty <- params$pattern_linetype + gp <- gpar(col = col, fill = fill, lwd = lwd, lty = lty, lineend = 'square') - fill <- update_alpha(params$pattern_fill, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth * .pt - lty <- params$pattern_linetype - gp <- gpar(col = col, fill = fill, lwd = lwd, lty = lty, lineend = 'square') + boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) - boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) + stripes_sf_bot <- create_h_stripes_sf(params, grid_xy, vpm) + clipped_stripes_sf_bot <- sf::st_intersection(stripes_sf_bot, boundary_sf) + grob <- sf_multipolygon_to_polygon_grob(clipped_stripes_sf_bot, gp, default.units, "stripe") - stripes_sf_bot <- create_h_stripes_sf(params, grid_xy, vpm) - clipped_stripes_sf_bot <- sf::st_intersection(stripes_sf_bot, boundary_sf) - grob <- sf_multipolygon_to_polygon_grob(clipped_stripes_sf_bot, - gp, default.units, "stripe") + if (add_top_hatch) { + gp$fill <- update_alpha(params$pattern_fill2, params$pattern_alpha) - if (add_top_hatch) { - gp$fill <- update_alpha(params$pattern_fill2, params$pattern_alpha) + stripes_sf_top <- create_v_stripes_sf(params, grid_xy, vpm) + clipped_stripes_sf_top <- sf::st_intersection(stripes_sf_top, boundary_sf) + grob_top <- sf_multipolygon_to_polygon_grob( + clipped_stripes_sf_top, + gp, + default.units, + "top" + ) - stripes_sf_top <- create_v_stripes_sf(params, grid_xy, vpm) - clipped_stripes_sf_top <- sf::st_intersection(stripes_sf_top, boundary_sf) - grob_top <- sf_multipolygon_to_polygon_grob(clipped_stripes_sf_top, - gp, default.units, "top") - - grob <- editGrob(grob, name = "bottom") - grob <- grobTree(grob, grob_top, name = "crosshatch") - } - grob + grob <- editGrob(grob, name = "bottom") + grob <- grobTree(grob, grob_top, name = "crosshatch") + } + grob } # build sf multipolygon 'rect' for each grid_xy$y value create_h_stripes_sf <- function(params, grid_xy, vpm) { - halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density - l_rects <- lapply(grid_xy$y, - function(y0) { - x <- c(grid_xy$x_min, grid_xy$x_min, grid_xy$x_max, grid_xy$x_max) - y <- y0 + c(-1, 1, 1, -1) * halfwidth - xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) - m <- as.matrix(as.data.frame(xy)) - list(rbind(m, m[1,])) - }) - sf::st_multipolygon(l_rects) + halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density + l_rects <- lapply(grid_xy$y, function(y0) { + x <- c(grid_xy$x_min, grid_xy$x_min, grid_xy$x_max, grid_xy$x_max) + y <- y0 + c(-1, 1, 1, -1) * halfwidth + xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) + m <- as.matrix(as.data.frame(xy)) + list(rbind(m, m[1, ])) + }) + sf::st_multipolygon(l_rects) } # build sf multipolygon 'rect' for each grid_xy$x value create_v_stripes_sf <- function(params, grid_xy, vpm) { - halfwidth <- 0.5 * grid_xy$h_spacing * params$pattern_density - l_rects <- lapply(grid_xy$x, - function(x0) { - x <- x0 + c(-1, 1, 1, -1) * halfwidth - y <- c(grid_xy$y_min, grid_xy$y_min, grid_xy$y_max, grid_xy$y_max) - xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) - m <- as.matrix(as.data.frame(xy)) - list(rbind(m, m[1,])) - }) - sf::st_multipolygon(l_rects) + halfwidth <- 0.5 * grid_xy$h_spacing * params$pattern_density + l_rects <- lapply(grid_xy$x, function(x0) { + x <- x0 + c(-1, 1, 1, -1) * halfwidth + y <- c(grid_xy$y_min, grid_xy$y_min, grid_xy$y_max, grid_xy$y_max) + xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) + m <- as.matrix(as.data.frame(xy)) + list(rbind(m, m[1, ])) + }) + sf::st_multipolygon(l_rects) } diff --git a/R/pattern-geometry-fill.R b/R/pattern-geometry-fill.R index a4d004e..e90ac80 100644 --- a/R/pattern-geometry-fill.R +++ b/R/pattern-geometry-fill.R @@ -8,13 +8,12 @@ #' #' @return grid grob objects. #' @noRd -create_pattern_fill <- function(params, boundary_df, aspect_ratio, - legend = FALSE) { - alpha <- ifelse(is.na(params$pattern_alpha), 1, params$pattern_alpha) - fill <- update_alpha(params$pattern_fill, alpha) - gp <- grid::gpar(col = NA_character_, fill = fill) +create_pattern_fill <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + alpha <- ifelse(is.na(params$pattern_alpha), 1, params$pattern_alpha) + fill <- update_alpha(params$pattern_fill, alpha) + gp <- grid::gpar(col = NA_character_, fill = fill) - convert_polygon_df_to_polygon_grob(boundary_df, gp = gp) + convert_polygon_df_to_polygon_grob(boundary_df, gp = gp) } #' Grobs with a simple fill pattern @@ -36,11 +35,30 @@ create_pattern_fill <- function(params, boundary_df, aspect_ratio, #' } #' @seealso [grid::grid.polygon()] #' @export -grid.pattern_fill <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - fill = gp$fill %||% "grey80", - alpha = gp$alpha %||% NA_real_, - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("fill", x, y, id, - fill = fill, alpha = alpha, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_fill <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + fill = gp$fill %||% "grey80", + alpha = gp$alpha %||% NA_real_, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "fill", + x, + y, + id, + fill = fill, + alpha = alpha, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } diff --git a/R/pattern-geometry-none.R b/R/pattern-geometry-none.R index cfbc10e..e9d90e9 100644 --- a/R/pattern-geometry-none.R +++ b/R/pattern-geometry-none.R @@ -8,9 +8,8 @@ #' #' @return grid grob objects. #' @noRd -create_pattern_none <- function(params, boundary_df, aspect_ratio, - legend = FALSE) { - grid::nullGrob() +create_pattern_none <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + grid::nullGrob() } #' Grobs without any pattern @@ -26,8 +25,26 @@ create_pattern_none <- function(params, boundary_df, aspect_ratio, #' grid.pattern_none(x_hex, y_hex) #' @seealso [grid::grid.null()] #' @export -grid.pattern_none <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("none", x, y, id, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_none <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "none", + x, + y, + id, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } diff --git a/R/pattern-geometry-pch.R b/R/pattern-geometry-pch.R index 0d56334..e5fa9f6 100644 --- a/R/pattern-geometry-pch.R +++ b/R/pattern-geometry-pch.R @@ -45,152 +45,193 @@ #' spacing = 0.1, density = 0.4, angle = 0) #' } #' @export -grid.pattern_pch <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - fill = gp$fill %||% "grey80", - angle = 30, density = 0.2, - spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - scale = 0.5, shape = 1L, - grid = "square", type = NULL, subtype = NULL, rot = 0, - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - default.units = "npc", name = NULL, - gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("pch", x, y, id, - colour = colour, fill = fill, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - scale = scale, shape = shape, - grid = grid, type = type, subtype = subtype, rot = rot, - alpha = alpha, linetype = linetype, linewidth = linewidth, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_pch <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + scale = 0.5, + shape = 1L, + grid = "square", + type = NULL, + subtype = NULL, + rot = 0, + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "pch", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + scale = scale, + shape = shape, + grid = grid, + type = type, + subtype = subtype, + rot = rot, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } # each pch will be represented by two regular polygons (although one may be "null") create_pattern_pch <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - # vectorize fill, col, lwd, lty, density, rot, and shape - fill <- update_alpha(params$pattern_fill, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth - lty <- params$pattern_linetype - params$pattern_alpha <- NA_real_ - - density <- params$pattern_density - rot <- params$pattern_rot - shape <- params$pattern_shape - - n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape))) - - fill <- rep_len_fill(fill, n_par) - col <- rep_len(col, n_par) - lwd <- rep_len(lwd, n_par) - lty <- rep_len(lty, n_par) - density <- rep_len(density, n_par) - rot <- rep_len(rot, n_par) - shape <- rep_len(shape, n_par) - - # setup bottom and top regular polygons - pint <- as.integer(shape) - if (!all(is.na(pint))) - stopifnot(any(na_omit(pint) >= 0), any(na_omit(pint) <= 25)) - pch <- ifelse(is.na(pint), "26", as.character(pint)) - pint <- ifelse(is.na(pint), 26L, pint) - - density1 <- ifelse(pint == 4L, 1.414 * density, density) - density1 <- ifelse(pint == 20L, 2/3 * density, density1) - - density2 <- ifelse(pint == 7L | pint == 13L, 1.414 * density, density) - - fill <- ifelse(pint < 21L, col, fill) - fill <- ifelse(pint < 15L, NA_character_, fill) - - col <- ifelse(pint > 14L & pint < 19L, NA_character_, col) - - rot1 <- rot + sapply(pch, get_rot_base) - rot2 <- rot + sapply(pch, get_rot_top) - - shape1 <- sapply(pch, get_shape_base) - shape2 <- sapply(pch, get_shape_top) - - params$pattern_fill <- fill - params$pattern_col <- col - params$pattern_linewidth <- lwd - params$pattern_linetype <- lty - params$pattern_scale <- 0.001 - params_base <- params_top <- params - - # bottom regular polygon - params_base$pattern_shape <- shape1 - params_base$pattern_rot <- rot1 - params_base$pattern_density <- density1 - grob_base <- create_pattern_regular_polygon_via_sf(params_base, boundary_df, aspect_ratio, legend) - grob_base <- editGrob(grob_base, name = "pch_base") - - # top regular polygon - params_top$pattern_shape <- shape2 - params_top$pattern_rot <- rot2 - params_top$pattern_density <- density2 - grob_top <- create_pattern_regular_polygon_via_sf(params_top, boundary_df, aspect_ratio, legend) - grob_top <- editGrob(grob_top, name = "pch_top") - - gl <- gList(grob_base, grob_top) - - gTree(children = gl, name = "pch") + # vectorize fill, col, lwd, lty, density, rot, and shape + fill <- update_alpha(params$pattern_fill, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth + lty <- params$pattern_linetype + params$pattern_alpha <- NA_real_ + + density <- params$pattern_density + rot <- params$pattern_rot + shape <- params$pattern_shape + + n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape))) + + fill <- rep_len_fill(fill, n_par) + col <- rep_len(col, n_par) + lwd <- rep_len(lwd, n_par) + lty <- rep_len(lty, n_par) + density <- rep_len(density, n_par) + rot <- rep_len(rot, n_par) + shape <- rep_len(shape, n_par) + + # setup bottom and top regular polygons + pint <- as.integer(shape) + if (!all(is.na(pint))) { + stopifnot(any(na_omit(pint) >= 0), any(na_omit(pint) <= 25)) + } + pch <- ifelse(is.na(pint), "26", as.character(pint)) + pint <- ifelse(is.na(pint), 26L, pint) + + density1 <- ifelse(pint == 4L, 1.414 * density, density) + density1 <- ifelse(pint == 20L, 2 / 3 * density, density1) + + density2 <- ifelse(pint == 7L | pint == 13L, 1.414 * density, density) + + fill <- ifelse(pint < 21L, col, fill) + fill <- ifelse(pint < 15L, NA_character_, fill) + + col <- ifelse(pint > 14L & pint < 19L, NA_character_, col) + + rot1 <- rot + sapply(pch, get_rot_base) + rot2 <- rot + sapply(pch, get_rot_top) + + shape1 <- sapply(pch, get_shape_base) + shape2 <- sapply(pch, get_shape_top) + + params$pattern_fill <- fill + params$pattern_col <- col + params$pattern_linewidth <- lwd + params$pattern_linetype <- lty + params$pattern_scale <- 0.001 + params_base <- params_top <- params + + # bottom regular polygon + params_base$pattern_shape <- shape1 + params_base$pattern_rot <- rot1 + params_base$pattern_density <- density1 + grob_base <- create_pattern_regular_polygon_via_sf( + params_base, + boundary_df, + aspect_ratio, + legend + ) + grob_base <- editGrob(grob_base, name = "pch_base") + + # top regular polygon + params_top$pattern_shape <- shape2 + params_top$pattern_rot <- rot2 + params_top$pattern_density <- density2 + grob_top <- create_pattern_regular_polygon_via_sf(params_top, boundary_df, aspect_ratio, legend) + grob_top <- editGrob(grob_top, name = "pch_top") + + gl <- gList(grob_base, grob_top) + + gTree(children = gl, name = "pch") } get_rot_base <- function(pch) { - switch(pch, - "4" = 45, - "6" = 180, - "25" = 180, - 0) + switch(pch, "4" = 45, "6" = 180, "25" = 180, 0) } get_rot_top <- function(pch) { - switch(pch, - "7" = 45, - "11" = 180, - "13" = 45, - 0) + switch(pch, "7" = 45, "11" = 180, "13" = 45, 0) } get_shape_base <- function(pch) { - switch(pch, - "0" = "square", - "2" = "convex3", - "3" = "star4", - "4" = "star4", - "5" = "convex4", - "6" = "convex3", - "7" = "square", - "9" = "convex4", - "8" = "star8", - "11" = "convex3", - "12" = "square", - "14" = "square", - "15" = "square", - "17" = "convex3", - "18" = "convex4", - "22" = "square", - "23" = "convex4", - "24" = "convex3", - "25" = "convex3", - "26" = "null", - "circle") + switch( + pch, + "0" = "square", + "2" = "convex3", + "3" = "star4", + "4" = "star4", + "5" = "convex4", + "6" = "convex3", + "7" = "square", + "9" = "convex4", + "8" = "star8", + "11" = "convex3", + "12" = "square", + "14" = "square", + "15" = "square", + "17" = "convex3", + "18" = "convex4", + "22" = "square", + "23" = "convex4", + "24" = "convex3", + "25" = "convex3", + "26" = "null", + "circle" + ) } get_shape_top <- function(pch) { - switch(pch, - "7" = "star4", - "9" = "star4", - "10" = "star4", - "11" = "convex3", - "12" = "star4", - "13" = "star4", - "14" = "convex3", - "null") + switch( + pch, + "7" = "star4", + "9" = "star4", + "10" = "star4", + "11" = "convex3", + "12" = "star4", + "13" = "star4", + "14" = "convex3", + "null" + ) } na_omit <- function(x) Filter(Negate(is.na), x) diff --git a/R/pattern-geometry-regular_polygon.R b/R/pattern-geometry-regular_polygon.R index d45ed8d..d908da9 100644 --- a/R/pattern-geometry-regular_polygon.R +++ b/R/pattern-geometry-regular_polygon.R @@ -64,279 +64,361 @@ #' density = 1.0, spacing = 0.1, #' shape = "convex3", grid = "hex") #' @export -grid.pattern_regular_polygon <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - fill = gp$fill %||% "grey80", - angle = 30, density = 0.2, - spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - scale = 0.5, shape = "convex4", - grid = "square", type = NULL, subtype = NULL, rot = 0, - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - default.units = "npc", name = NULL, - gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("regular_polygon", x, y, id, - colour = colour, fill = fill, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - scale = scale, shape = shape, - grid = grid, type = type, subtype = subtype, rot = rot, - alpha = alpha, linetype = linetype, linewidth = linewidth, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_regular_polygon <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + scale = 0.5, + shape = "convex4", + grid = "square", + type = NULL, + subtype = NULL, + rot = 0, + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "regular_polygon", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + scale = scale, + shape = shape, + grid = grid, + type = type, + subtype = subtype, + rot = rot, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } -create_pattern_regular_polygon_via_sf <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio - default.units <- "bigpts" - boundary_df <- convert_polygon_df_units(boundary_df, default.units) - params <- convert_params_units(params, default.units) - vpm <- get_vp_measurements(default.units) +create_pattern_regular_polygon_via_sf <- function( + params, + boundary_df, + aspect_ratio, + legend = FALSE +) { + # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio + default.units <- "bigpts" + boundary_df <- convert_polygon_df_units(boundary_df, default.units) + params <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) - spacing <- params$pattern_spacing - grid <- params$pattern_grid + spacing <- params$pattern_spacing + grid <- params$pattern_grid - # create grid of points large enough to cover viewport no matter the angle - grid_xy <- get_xy_grid(params, vpm) + # create grid of points large enough to cover viewport no matter the angle + grid_xy <- get_xy_grid(params, vpm) - # construct grobs using subsets if certain inputs are vectorized - fill <- update_alpha(params$pattern_fill, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth * .pt - lty <- params$pattern_linetype + # construct grobs using subsets if certain inputs are vectorized + fill <- update_alpha(params$pattern_fill, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth * .pt + lty <- params$pattern_linetype - density <- params$pattern_density - rot <- params$pattern_rot - shape <- params$pattern_shape - assert_rp_shape(shape) + 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))) + n_par <- max(lengths(list(fill, col, lwd, lty, density, rot, shape))) - fill <- rep_len_fill(fill, n_par) - col <- rep_len(col, n_par) - lwd <- rep_len(lwd, n_par) - lty <- rep_len(lty, n_par) - density <- rep_len(density, n_par) - rot <- rep_len(rot, n_par) - shape <- rep_len(shape, n_par) + fill <- rep_len_fill(fill, n_par) + col <- rep_len(col, n_par) + lwd <- rep_len(lwd, n_par) + lty <- rep_len(lty, n_par) + density <- rep_len(density, n_par) + rot <- rep_len(rot, n_par) + shape <- rep_len(shape, n_par) - density <- ifelse(shape %in% c("square", "tetrakis_left", "tetrakis_right"), - 1.414 * density, density) - # avoid overlap errors when density == 1 due to machine precision issues - if (grid == "square") - density <- ifelse(nigh(density, 1), 0.9999, density) - if (grepl("^hex", grid) && n_par < 3L) - density <- ifelse(nigh(density, 1), 0.994, density) - density_max <- max(density) + density <- ifelse( + shape %in% c("square", "tetrakis_left", "tetrakis_right"), + 1.414 * density, + density + ) + # avoid overlap errors when density == 1 due to machine precision issues + if (grid == "square") { + density <- ifelse(nigh(density, 1), 0.9999, density) + } + if (grepl("^hex", grid) && n_par < 3L) { + density <- ifelse(nigh(density, 1), 0.994, density) + } + density_max <- max(density) - # compute regular polygon relative coordinates which we will center on points - radius_mult <- switch(grid, - hex = 0.578, - 0.5) - radius_max <- radius_mult * spacing * density_max + # compute regular polygon relative coordinates which we will center on points + radius_mult <- switch(grid, hex = 0.578, 0.5) + radius_max <- radius_mult * spacing * density_max - #### add fudge factor? - boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) - expanded_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = radius_max) - contracted_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = -radius_max) + #### add fudge factor? + boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) + expanded_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = radius_max) + contracted_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = -radius_max) - # compute pattern matrix of graphical elements (e.g. fill colors) - if (is.null(params$pattern_type) || is.na(params$pattern_type)) - params$pattern_type <- switch(grid, square = "square", "hex") - m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par) + # compute pattern matrix of graphical elements (e.g. fill colors) + if (is.null(params$pattern_type) || is.na(params$pattern_type)) { + params$pattern_type <- switch(grid, square = "square", "hex") + } + m_pat <- get_pattern_matrix(params$pattern_type, params$pattern_subtype, grid_xy, n_par) - gl <- gList() - for (i_par in seq(n_par)) { - if (shape[i_par] == "null") next - radius_outer <- radius_mult * spacing * density[i_par] - xy_polygon <- get_xy_polygon(shape[i_par], params, radius_outer, rot[i_par]) - xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing) - if (length(xy_par$x) == 0) next + gl <- gList() + for (i_par in seq(n_par)) { + if (shape[i_par] == "null") { + next + } + radius_outer <- radius_mult * spacing * density[i_par] + xy_polygon <- get_xy_polygon(shape[i_par], params, radius_outer, rot[i_par]) + xy_par <- get_xy_par(grid_xy, i_par, m_pat, grid, spacing) + if (length(xy_par$x) == 0) { + next + } - # rotate by 'angle' - xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y) + # rotate by 'angle' + xy_par <- rotate_xy(xy_par$x, xy_par$y, params$pattern_angle, vpm$x, vpm$y) - # test if polygons within/near boundary - points_sf <- sf::st_multipoint(as.matrix(as.data.frame(xy_par))) - all_points_sf <- sf::st_intersection(expanded_sf, points_sf) - interior_points_sf <- sf::st_intersection(all_points_sf, contracted_sf) - exterior_points_sf <- sf::st_difference(all_points_sf, contracted_sf) + # test if polygons within/near boundary + points_sf <- sf::st_multipoint(as.matrix(as.data.frame(xy_par))) + all_points_sf <- sf::st_intersection(expanded_sf, points_sf) + interior_points_sf <- sf::st_intersection(all_points_sf, contracted_sf) + exterior_points_sf <- sf::st_difference(all_points_sf, contracted_sf) - gp <- gpar(fill = fill[[i_par]], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par]) + gp <- gpar(fill = fill[[i_par]], col = col[i_par], lwd = lwd[i_par], lty = lty[i_par]) - # create grob for interior polygons - name <- paste0("interior.", i_par) - if (shape[i_par] == "circle") { - grob <- sf_points_to_circle_grob(interior_points_sf, radius_outer, - gp, default.units, name) - } else { - grob <- sf_points_to_polygon_grob(interior_points_sf, xy_polygon, - gp, default.units, name) - } - gl <- append_gList(gl, grob) + # create grob for interior polygons + name <- paste0("interior.", i_par) + if (shape[i_par] == "circle") { + grob <- sf_points_to_circle_grob( + interior_points_sf, + radius_outer, + gp, + default.units, + name + ) + } else { + grob <- sf_points_to_polygon_grob( + interior_points_sf, + xy_polygon, + gp, + default.units, + name + ) + } + gl <- append_gList(gl, grob) - # create grob for exterior polygons - polygons_sf <- sf_points_to_sf_multipolygon(exterior_points_sf, xy_polygon) - exterior_multipolygon <- sf::st_intersection(polygons_sf, boundary_sf) - name <- paste0("boundary.", i_par) - grob <- sf_multipolygon_to_polygon_grob(exterior_multipolygon, - gp, default.units, name) - gl <- append_gList(gl, grob) - } - gTree(children = gl, name = "regular_polygon") + # create grob for exterior polygons + polygons_sf <- sf_points_to_sf_multipolygon(exterior_points_sf, xy_polygon) + exterior_multipolygon <- sf::st_intersection(polygons_sf, boundary_sf) + name <- paste0("boundary.", i_par) + grob <- sf_multipolygon_to_polygon_grob(exterior_multipolygon, gp, default.units, name) + gl <- append_gList(gl, grob) + } + gTree(children = gl, name = "regular_polygon") } get_pattern_matrix <- function(type, subtype, grid_xy, n_par) { - nrow <- length(grid_xy$y) - ncol <- length(grid_xy$x) - if (is_pattern_square(type)) { - if (is.null(subtype) || is.na(subtype)) { - if (type %in% names_weave) { - subtype <- NULL - } else { - subtype <- n_par - } - } - if (type %in% names_weave && n_par > 2) { - abort(c(glue("pattern_type '{type}' can't arrange more than two elements"), - i = glue("We detected {n_par} elements requested"))) - } - m_pat <- pattern_square(type, subtype, nrow = nrow, ncol = ncol) - } else { - if (is.null(subtype) || is.na(subtype)) - subtype <- n_par - m_pat <- pattern_hex(type, subtype, nrow = nrow, ncol = ncol) - } - m_pat + nrow <- length(grid_xy$y) + ncol <- length(grid_xy$x) + if (is_pattern_square(type)) { + if (is.null(subtype) || is.na(subtype)) { + if (type %in% names_weave) { + subtype <- NULL + } else { + subtype <- n_par + } + } + if (type %in% names_weave && n_par > 2) { + abort(c( + glue("pattern_type '{type}' can't arrange more than two elements"), + i = glue("We detected {n_par} elements requested") + )) + } + m_pat <- pattern_square(type, subtype, nrow = nrow, ncol = ncol) + } else { + if (is.null(subtype) || is.na(subtype)) { + subtype <- n_par + } + m_pat <- pattern_hex(type, subtype, nrow = nrow, ncol = ncol) + } + m_pat } get_xy_par <- function(grid_xy, i_par, m_pat, grid, spacing) { - if (grid == "square") { - get_xy_par_square(grid_xy, i_par, m_pat) - } else if (grid == "elongated_triangle") { - get_xy_par_el_tri(grid_xy, i_par, m_pat, spacing) - } else { - get_xy_par_hex(grid_xy, i_par, m_pat, spacing) - } + if (grid == "square") { + get_xy_par_square(grid_xy, i_par, m_pat) + } else if (grid == "elongated_triangle") { + get_xy_par_el_tri(grid_xy, i_par, m_pat, spacing) + } else { + get_xy_par_hex(grid_xy, i_par, m_pat, spacing) + } } get_xy_par_square <- function(grid_xy, i_par, m_pat) { - x <- numeric(0) - y <- numeric(0) - for (i in seq_along(grid_xy$y)) { - indices_x <- which(m_pat[i,] == i_par) - x <- c(x, grid_xy$x[indices_x]) - y <- c(y, rep(grid_xy$y[i], length(indices_x))) - } - list(x = x, y = y) + x <- numeric(0) + y <- numeric(0) + for (i in seq_along(grid_xy$y)) { + indices_x <- which(m_pat[i, ] == i_par) + x <- c(x, grid_xy$x[indices_x]) + y <- c(y, rep(grid_xy$y[i], length(indices_x))) + } + list(x = x, y = y) } get_xy_par_hex <- function(grid_xy, i_par, m_pat, spacing = 1) { - x <- numeric(0) - y <- numeric(0) - for (i in seq_along(grid_xy$y)) { - indices_x <- which(m_pat[i,] == i_par) - if (i %% 2) - x_offset <- 0 - else - x_offset <- -0.5 * spacing - x <- c(x, x_offset + grid_xy$x[indices_x]) - y <- c(y, rep(grid_xy$y[i], length(indices_x))) - } - list(x = x, y = y) + x <- numeric(0) + y <- numeric(0) + for (i in seq_along(grid_xy$y)) { + indices_x <- which(m_pat[i, ] == i_par) + if (i %% 2) { + x_offset <- 0 + } else { + x_offset <- -0.5 * spacing + } + x <- c(x, x_offset + grid_xy$x[indices_x]) + y <- c(y, rep(grid_xy$y[i], length(indices_x))) + } + list(x = x, y = y) } get_xy_par_el_tri <- function(grid_xy, i_par, m_pat, spacing = 1) { - x <- numeric(0) - y <- numeric(0) - for (i in seq_along(grid_xy$y)) { - indices_x <- which(m_pat[i,] == i_par) - if (i %% 4 == 3 || i %% 4 == 0) - x_offset <- 0 - else - x_offset <- -0.5 * spacing - x <- c(x, x_offset + grid_xy$x[indices_x]) - y <- c(y, rep(grid_xy$y[i], length(indices_x))) - } - list(x = x, y = y) + x <- numeric(0) + y <- numeric(0) + for (i in seq_along(grid_xy$y)) { + indices_x <- which(m_pat[i, ] == i_par) + if (i %% 4 == 3 || i %% 4 == 0) { + x_offset <- 0 + } else { + x_offset <- -0.5 * spacing + } + x <- c(x, x_offset + grid_xy$x[indices_x]) + y <- c(y, rep(grid_xy$y[i], length(indices_x))) + } + list(x = x, y = y) } # create grid of points large enough to cover viewport no matter the angle 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 + 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 * h_spacing, - elongated_triangle = 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) + gm <- 1.00 # seems to need to be this big so {ggpattern} legends render correctly + x_adjust <- switch( + params$pattern_grid, + hex = 0.5 * h_spacing, + elongated_triangle = 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 <- params$pattern_spacing - } else if (params$pattern_grid == "elongated_triangle") { - v_spacing <- (0.5 + 0.25 * sqrt(3)) * params$pattern_spacing - } else { - 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)) - y_seq <- c(y_seq, y_seq[length(y_seq)] + v_spacing) - y <- yoffset + vpm$y + c(rev(tail(-y_seq, -1L)), y_seq) - if (params$pattern_grid == "elongated_triangle") { - y <- y + rep(c(0, -0.15 * v_spacing), length.out = length(y)) - } - y_min <- min(y) - y_max <- max(y) + # adjust vertical spacing for "hex" pattern + if (params$pattern_grid == "square") { + v_spacing <- params$pattern_spacing + } else if (params$pattern_grid == "elongated_triangle") { + v_spacing <- (0.5 + 0.25 * sqrt(3)) * params$pattern_spacing + } else { + 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)) { + y_seq <- c(y_seq, y_seq[length(y_seq)] + v_spacing) + } + y <- yoffset + vpm$y + c(rev(tail(-y_seq, -1L)), y_seq) + if (params$pattern_grid == "elongated_triangle") { + y <- y + rep(c(0, -0.15 * v_spacing), length.out = length(y)) + } + y_min <- min(y) + y_max <- max(y) - list(x = x, y = y, - x_min = x_min, x_max = x_max, y_min = y_min, y_max = y_max, - h_spacing = h_spacing, v_spacing = v_spacing - ) + list( + x = x, + y = y, + x_min = x_min, + x_max = x_max, + y_min = y_min, + y_max = y_max, + h_spacing = h_spacing, + v_spacing = v_spacing + ) } get_xy_polygon <- function(shape, params, radius_outer, rot) { - if (shape %in% c("square", "tetrakis_left", "tetrakis_right")) { - rot <- rot + 45 - } - if (shape == "square") - shape <- "convex4" - polygon_angle <- 90 + rot + params$pattern_angle - if (shape == "circle") { - # grid::grobPoints.circle() defaults to regular polygon with 100 vertices - convex_xy(100, polygon_angle, radius_outer) - } else if (grepl("convex", shape)) { - n_vertices <- get_n_vertices(shape) - convex_xy(n_vertices, polygon_angle, radius_outer) - } else if (shape == "rhombille_rhombus") { - rhombus_xy(polygon_angle, radius_outer) - } else if (shape == "tetrakis_left") { - tetrakis_left_xy(polygon_angle, radius_outer) - } else if (shape == "tetrakis_right") { - tetrakis_right_xy(polygon_angle, radius_outer) - } else { - n_vertices <- get_n_vertices(shape) - radius_inner <- params$pattern_scale * radius_outer - concave_xy(n_vertices, polygon_angle, radius_outer, radius_inner) - } + if (shape %in% c("square", "tetrakis_left", "tetrakis_right")) { + rot <- rot + 45 + } + if (shape == "square") { + shape <- "convex4" + } + polygon_angle <- 90 + rot + params$pattern_angle + if (shape == "circle") { + # grid::grobPoints.circle() defaults to regular polygon with 100 vertices + convex_xy(100, polygon_angle, radius_outer) + } else if (grepl("convex", shape)) { + n_vertices <- get_n_vertices(shape) + convex_xy(n_vertices, polygon_angle, radius_outer) + } else if (shape == "rhombille_rhombus") { + rhombus_xy(polygon_angle, radius_outer) + } else if (shape == "tetrakis_left") { + tetrakis_left_xy(polygon_angle, radius_outer) + } else if (shape == "tetrakis_right") { + tetrakis_right_xy(polygon_angle, radius_outer) + } else { + n_vertices <- get_n_vertices(shape) + radius_inner <- params$pattern_scale * radius_outer + concave_xy(n_vertices, polygon_angle, radius_outer, radius_inner) + } } assert_rp_shape <- function(shape) { - tf <- grepl("^convex[[:digit:]]+$|^star[[:digit:]]+$|^square$|^circle$|^null$|^tetrakis_left$|^tetrakis_right$|^rhombille_rhombus$", shape) - if (all(tf)) { - invisible(NULL) - } else { - shape <- shape[which(!tf)[1]] - msg <- c(paste("Unknown shape", shape), - i = 'See `help("grid.pattern_regular_polygon")` for supported shapes') - abort(msg) - } + tf <- grepl( + "^convex[[:digit:]]+$|^star[[:digit:]]+$|^square$|^circle$|^null$|^tetrakis_left$|^tetrakis_right$|^rhombille_rhombus$", + shape + ) + if (all(tf)) { + invisible(NULL) + } else { + shape <- shape[which(!tf)[1]] + msg <- c( + paste("Unknown shape", shape), + i = 'See `help("grid.pattern_regular_polygon")` for supported shapes' + ) + abort(msg) + } } diff --git a/R/pattern-geometry-stripe.R b/R/pattern-geometry-stripe.R index a8e3430..7664f6a 100644 --- a/R/pattern-geometry-stripe.R +++ b/R/pattern-geometry-stripe.R @@ -16,25 +16,58 @@ #' gp = grid::gpar(col = "blue", fill = "yellow")) #' @seealso `[grid.pattern_crosshatch()]` and `[grid.pattern_weave()]` for overlaying stripes. #' @export -grid.pattern_stripe <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", fill = gp$fill %||% "grey80", angle = 30, - density = 0.2, spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - grid = "square", - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("stripe", x, y, id, - colour = colour, fill = fill, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - alpha = alpha, linetype = linetype, linewidth = linewidth, - grid = grid, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_stripe <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + grid = "square", + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "stripe", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + grid = grid, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } -create_pattern_stripes_via_sf <- function(params, boundary_df, aspect_ratio, - legend = FALSE) { - create_crosshatch_via_sf_helper(params, boundary_df, add_top_hatch = FALSE) +create_pattern_stripes_via_sf <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + create_crosshatch_via_sf_helper(params, boundary_df, add_top_hatch = FALSE) } diff --git a/R/pattern-geometry-tiling.R b/R/pattern-geometry-tiling.R index 3f51a9c..4829c22 100644 --- a/R/pattern-geometry-tiling.R +++ b/R/pattern-geometry-tiling.R @@ -82,998 +82,1848 @@ #' grid.pattern_polygon_tiling(x_hex, y_hex, type = "rhombille", #' spacing = 0.2, gp = gp3) #' @export -grid.pattern_polygon_tiling <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - fill = gp$fill %||% "grey80", - angle = 30, spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - type = "square", - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - default.units = "npc", name = NULL, - gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("polygon_tiling", x, y, id, - colour = colour, fill = fill, angle = angle, - spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - type = type, - alpha = alpha, linetype = linetype, linewidth = linewidth, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_polygon_tiling <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + type = "square", + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "polygon_tiling", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + type = type, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } #' @rdname grid.pattern_polygon_tiling #' @export -names_polygon_tiling <- c("elongated_triangular", - "herringbone", - "hexagonal", - "pythagorean", - "rhombitrihexagonal", - "rhombille", - "snub_square", - "snub_trihexagonal", - "square", - "tetrakis_square", - "triangular", - "trihexagonal", - "truncated_square", - "truncated_hexagonal", - "truncated_trihexagonal", - "2*.2**.2*.2**", - "2**.3**.12*", - "3.3.3.3**", - "3.3*.3.3**", - "3.3.3.12*.3.3.12*", - "3.3.8*.3.4.3.8*", - "3.3.8*.4**.8*", - "3.4.6.3.12*", - "3.4.8.3.8*", - "3.6*.6**", - "4.2*.4.2**", - "4.4*.4**", - "4.6.4*.6", - "4.6*.4.6*.4.6*", - "4.8*.4**.8*", - "6.6*.6.6*", - "8.4*.8.4*", - "9.3.9.3*", - "12.3*.12.3*", - "12.12.4*", - "18.18.3*") +names_polygon_tiling <- c( + "elongated_triangular", + "herringbone", + "hexagonal", + "pythagorean", + "rhombitrihexagonal", + "rhombille", + "snub_square", + "snub_trihexagonal", + "square", + "tetrakis_square", + "triangular", + "trihexagonal", + "truncated_square", + "truncated_hexagonal", + "truncated_trihexagonal", + "2*.2**.2*.2**", + "2**.3**.12*", + "3.3.3.3**", + "3.3*.3.3**", + "3.3.3.12*.3.3.12*", + "3.3.8*.3.4.3.8*", + "3.3.8*.4**.8*", + "3.4.6.3.12*", + "3.4.8.3.8*", + "3.6*.6**", + "4.2*.4.2**", + "4.4*.4**", + "4.6.4*.6", + "4.6*.4.6*.4.6*", + "4.8*.4**.8*", + "6.6*.6.6*", + "8.4*.8.4*", + "9.3.9.3*", + "12.3*.12.3*", + "12.12.4*", + "18.18.3*" +) create_pattern_polygon_tiling <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - type <- tolower(params$pattern_type) + type <- tolower(params$pattern_type) - xyi <- boundary_df + xyi <- boundary_df - fill <- update_alpha(params$pattern_fill, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth - lty <- params$pattern_linetype - stopifnot(length(fill) < 4L, max(lengths(list(col, lwd, lty))) == 1L) - gp <- gpar(fill = fill, col = col, lwd = lwd, lty = lty) + fill <- update_alpha(params$pattern_fill, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth + lty <- params$pattern_linetype + stopifnot(length(fill) < 4L, max(lengths(list(col, lwd, lty))) == 1L) + gp <- gpar(fill = fill, col = col, lwd = lwd, lty = lty) - angle <- params$pattern_angle - spacing <- params$pattern_spacing - units <- params$pattern_units + angle <- params$pattern_angle + spacing <- params$pattern_spacing + units <- params$pattern_units - fn <- switch(type, - elongated_triangular = create_el_tri_tiling, - herringbone = create_herringbone_tiling, - hexagonal = create_hexagonal_tiling, - pythagorean = create_pythagorean_tiling, - snub_square = create_snub_square_tiling, - snub_trihexagonal = create_snub_trihex_tiling, - square = create_square_tiling, - rhombille = create_rhombille_tiling, - rhombitrihexagonal = create_rhombitrihexagonal_tiling, - tetrakis_square = create_tetrakis_tiling, - triangular = create_triangular_tiling, - trihexagonal = create_trihexagonal_tiling, - truncated_hexagonal = create_trunc_hex_tiling, - truncated_square = create_trunc_square_tiling, - truncated_trihexagonal = create_trunc_trihex_tiling, - `2*.2**.2*.2**` = create_2_53.2__233.2_53.2__233_tiling, - `2**.3**.12*` = create_2__.3__.12__tiling, - `3.3.3.3**` = create_3.3.3.3___tiling, - `3.3*.3.3**` = create_3.3_30.3.3_30_tiling, - `3.3.3.12*.3.3.12*` = create_3.3.3.12_30.3.3.12_30_tiling, - `3.4.6.3.12*` = create_3.4.6.3.12_30_tiling, - `3.3.8*.3.4.3.8*` = create_3.3.8_15.3.4.3.8_15_tiling, - `3.3.8*.4**.8*` = create_3.3.8_15.4__60.8_15_tiling, - `3.4.8.3.8*` = create_3.4.8.3.8_15_tiling, - `3.6*.6**` = create_3.6_30.6__30_tiling, - `4.2*.4.2**` = create_4.2_60.4.2__240_tiling, - `4.4*.4**` = create_4.4_30.4__30_tiling, - `4.6.4*.6` = create_4.6.4_30.6_tiling, - `4.6*.4.6*.4.6*` = create_4.6_30.4.6_30.4.6_30_tiling, - `4.8*.4**.8*` = create_4.8_.4__.8__tiling, - `6.6*.6.6*` = create_6.6_60.6.6_60_tiling, - `8.4*.8.4*` = create_8.4_45.8.4_45_tiling, - `9.3.9.3*` = create_9.3.9.3_40_tiling, - `12.3*.12.3*` = create_12.3_30.12.3_30_tiling, - `12.12.4*` = create_12.12.4_60_tiling, - `18.18.3*` = create_18.18.3__tiling, - abort(paste("Don't know how to do tiling", type))) - gTree(children = fn(xyi, gp, spacing, units, angle), name = "polygon_tiling") + fn <- switch( + type, + elongated_triangular = create_el_tri_tiling, + herringbone = create_herringbone_tiling, + hexagonal = create_hexagonal_tiling, + pythagorean = create_pythagorean_tiling, + snub_square = create_snub_square_tiling, + snub_trihexagonal = create_snub_trihex_tiling, + square = create_square_tiling, + rhombille = create_rhombille_tiling, + rhombitrihexagonal = create_rhombitrihexagonal_tiling, + tetrakis_square = create_tetrakis_tiling, + triangular = create_triangular_tiling, + trihexagonal = create_trihexagonal_tiling, + truncated_hexagonal = create_trunc_hex_tiling, + truncated_square = create_trunc_square_tiling, + truncated_trihexagonal = create_trunc_trihex_tiling, + `2*.2**.2*.2**` = create_2_53.2__233.2_53.2__233_tiling, + `2**.3**.12*` = create_2__.3__.12__tiling, + `3.3.3.3**` = create_3.3.3.3___tiling, + `3.3*.3.3**` = create_3.3_30.3.3_30_tiling, + `3.3.3.12*.3.3.12*` = create_3.3.3.12_30.3.3.12_30_tiling, + `3.4.6.3.12*` = create_3.4.6.3.12_30_tiling, + `3.3.8*.3.4.3.8*` = create_3.3.8_15.3.4.3.8_15_tiling, + `3.3.8*.4**.8*` = create_3.3.8_15.4__60.8_15_tiling, + `3.4.8.3.8*` = create_3.4.8.3.8_15_tiling, + `3.6*.6**` = create_3.6_30.6__30_tiling, + `4.2*.4.2**` = create_4.2_60.4.2__240_tiling, + `4.4*.4**` = create_4.4_30.4__30_tiling, + `4.6.4*.6` = create_4.6.4_30.6_tiling, + `4.6*.4.6*.4.6*` = create_4.6_30.4.6_30.4.6_30_tiling, + `4.8*.4**.8*` = create_4.8_.4__.8__tiling, + `6.6*.6.6*` = create_6.6_60.6.6_60_tiling, + `8.4*.8.4*` = create_8.4_45.8.4_45_tiling, + `9.3.9.3*` = create_9.3.9.3_40_tiling, + `12.3*.12.3*` = create_12.3_30.12.3_30_tiling, + `12.12.4*` = create_12.12.4_60_tiling, + `18.18.3*` = create_18.18.3__tiling, + abort(paste("Don't know how to do tiling", type)) + ) + gTree(children = fn(xyi, gp, spacing, units, angle), name = "polygon_tiling") } create_3.3.3.12_30.3.3.12_30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_dod <- gp_bg <- gp - if (n_col == 2L) { - gp_bg$fill <- gp_star$fill <- gp$fill[1L] - gp_dod$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_bg$fill <- gp$fill[3] - gp_dod$fill <- gp$fill[2] - gp_star$fill <- gp$fill[1] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - dodecagons <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - grid = "hex_circle", - shape = "convex12", density = 1.034, rot = 15, - spacing = spacing, units = units, - angle = angle, gp = gp_dod, - name = "dodecagons") - scale <- star_scale(12, 60, external = TRUE) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - grid = "hex_circle", - shape = "star12", density = 1.034, rot = 15, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, dodecagons, stars) + n_col <- length(gp$fill) + gp_star <- gp_dod <- gp_bg <- gp + if (n_col == 2L) { + gp_bg$fill <- gp_star$fill <- gp$fill[1L] + gp_dod$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[3] + gp_dod$fill <- gp$fill[2] + gp_star$fill <- gp$fill[1] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + dodecagons <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + grid = "hex_circle", + shape = "convex12", + density = 1.034, + rot = 15, + spacing = spacing, + units = units, + angle = angle, + gp = gp_dod, + name = "dodecagons" + ) + scale <- star_scale(12, 60, external = TRUE) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + grid = "hex_circle", + shape = "star12", + density = 1.034, + rot = 15, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, dodecagons, stars) } create_3.3.8_15.4__60.8_15_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star8 <- gp_star4 <- gp_sq <- gp - if (n_col == 2L) { - gp_sq$fill <- gp_star4$fill <- gp$fill[1L] - gp_star8$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_sq$fill <- gp$fill[2] - gp_star4$fill <- gp$fill[1] - gp_star8$fill <- gp$fill[3] - } - sq <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "square", density = 1, - spacing = spacing, units = units, - angle = angle, gp = gp_sq, - name = "background_color") - scale <- star_scale(4, 60) - star4 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star4", density = 1.14, rot = 45, - spacing = spacing, units = units, - xoffset = spacing / 2, yoffset = spacing / 2, - angle = angle, gp = gp_star4, name = "star4") - scale <- star_scale(8, 15) - star8 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star8", density = 1.082, rot = 22.5, - spacing = spacing, units = units, - angle = angle, gp = gp_star8, - scale = scale, name = "star8") - gList(sq, star4, star8) + n_col <- length(gp$fill) + gp_star8 <- gp_star4 <- gp_sq <- gp + if (n_col == 2L) { + gp_sq$fill <- gp_star4$fill <- gp$fill[1L] + gp_star8$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_sq$fill <- gp$fill[2] + gp_star4$fill <- gp$fill[1] + gp_star8$fill <- gp$fill[3] + } + sq <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "square", + density = 1, + spacing = spacing, + units = units, + angle = angle, + gp = gp_sq, + name = "background_color" + ) + scale <- star_scale(4, 60) + star4 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star4", + density = 1.14, + rot = 45, + spacing = spacing, + units = units, + xoffset = spacing / 2, + yoffset = spacing / 2, + angle = angle, + gp = gp_star4, + name = "star4" + ) + scale <- star_scale(8, 15) + star8 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star8", + density = 1.082, + rot = 22.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star8, + scale = scale, + name = "star8" + ) + gList(sq, star4, star8) } create_3.3.8_15.3.4.3.8_15_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_oct <- gp_bg <- gp - if (n_col == 2L) { - gp_bg$fill <- gp_star$fill <- gp$fill[1L] - gp_oct$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_bg$fill <- gp$fill[3] - gp_oct$fill <- gp$fill[1] - gp_star$fill <- gp$fill[2] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - octagons <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex8", density = 1.082, rot = 22.5, - spacing = spacing, units = units, - angle = angle, gp = gp_oct, - name = "octagons") - scale <- star_scale(8, 60, external = TRUE) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star8", density = 1.082, rot = 22.5, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, octagons, stars) + n_col <- length(gp$fill) + gp_star <- gp_oct <- gp_bg <- gp + if (n_col == 2L) { + gp_bg$fill <- gp_star$fill <- gp$fill[1L] + gp_oct$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[3] + gp_oct$fill <- gp$fill[1] + gp_star$fill <- gp$fill[2] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + octagons <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex8", + density = 1.082, + rot = 22.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_oct, + name = "octagons" + ) + scale <- star_scale(8, 60, external = TRUE) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star8", + density = 1.082, + rot = 22.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, octagons, stars) } create_3.4.8.3.8_15_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_oct <- gp_bg <- gp - if (n_col == 2L) { - gp_bg$fill <- gp_star$fill <- gp$fill[2L] - gp_oct$fill <- gp$fill[1L] - } else if (n_col == 3L) { - gp_bg$fill <- gp$fill[2] - gp_oct$fill <- gp$fill[c(1,3)] - gp_star$fill <- gp$fill[2] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - octagons <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex8", density = 1.082, rot = 22.5, - spacing = spacing, units = units, - angle = angle, gp = gp_oct, - name = "octagons") - scale <- star_scale(8, 60, external = TRUE) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = c("null", "star8"), density = 1.082, rot = 22.5, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, octagons, stars) + n_col <- length(gp$fill) + gp_star <- gp_oct <- gp_bg <- gp + if (n_col == 2L) { + gp_bg$fill <- gp_star$fill <- gp$fill[2L] + gp_oct$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[2] + gp_oct$fill <- gp$fill[c(1, 3)] + gp_star$fill <- gp$fill[2] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + octagons <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex8", + density = 1.082, + rot = 22.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_oct, + name = "octagons" + ) + scale <- star_scale(8, 60, external = TRUE) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = c("null", "star8"), + density = 1.082, + rot = 22.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, octagons, stars) } create_4.2_60.4.2__240_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_rh <- gp_sq1 <- gp_sq2 <- gp - if (n_col == 2L) { - gp_sq1$fill <- gp_sq2$fill <- gp$fill[1L] - gp_rh$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_sq2$fill <- gp$fill[3] - gp_sq1$fill <- gp$fill[2] - gp_rh$fill <- gp$fill[1] - } - dens_sq <- 0.73 - squares.1 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex4", density = dens_sq, rot = 60, - spacing = spacing, units = units, - angle = angle, gp = gp_sq1, - name = "squares.1") - squares.2 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex4", density = dens_sq, rot = -60, - xoffset = 0.5 * spacing, yoffset = 0.5 * spacing, - spacing = spacing, units = units, - angle = angle, gp = gp_sq2, - name = "squares.2") - scale <- star_scale(2, 60) - dens_rh <- 0.88 - rhombi.1 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star2", density = dens_rh, rot = 45, - spacing = spacing, units = units, - angle = angle, gp = gp_rh, - xoffset = 0.5 * spacing, - scale = scale, name = "rhombi.1") - rhombi.2 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star2", density = dens_rh, rot = -45, - spacing = spacing, units = units, - angle = angle, gp = gp_rh, - yoffset = 0.5 * spacing, - scale = scale, name = "rhombi.2") - gList(squares.1, squares.2, rhombi.1, rhombi.2) + n_col <- length(gp$fill) + gp_rh <- gp_sq1 <- gp_sq2 <- gp + if (n_col == 2L) { + gp_sq1$fill <- gp_sq2$fill <- gp$fill[1L] + gp_rh$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_sq2$fill <- gp$fill[3] + gp_sq1$fill <- gp$fill[2] + gp_rh$fill <- gp$fill[1] + } + dens_sq <- 0.73 + squares.1 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex4", + density = dens_sq, + rot = 60, + spacing = spacing, + units = units, + angle = angle, + gp = gp_sq1, + name = "squares.1" + ) + squares.2 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex4", + density = dens_sq, + rot = -60, + xoffset = 0.5 * spacing, + yoffset = 0.5 * spacing, + spacing = spacing, + units = units, + angle = angle, + gp = gp_sq2, + name = "squares.2" + ) + scale <- star_scale(2, 60) + dens_rh <- 0.88 + rhombi.1 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star2", + density = dens_rh, + rot = 45, + spacing = spacing, + units = units, + angle = angle, + gp = gp_rh, + xoffset = 0.5 * spacing, + scale = scale, + name = "rhombi.1" + ) + rhombi.2 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star2", + density = dens_rh, + rot = -45, + spacing = spacing, + units = units, + angle = angle, + gp = gp_rh, + yoffset = 0.5 * spacing, + scale = scale, + name = "rhombi.2" + ) + gList(squares.1, squares.2, rhombi.1, rhombi.2) } create_2_53.2__233.2_53.2__233_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_rh1 <- gp_rh2 <- gp_rh3 <- gp_rh4 <- gp - if (n_col == 2L) { - gp_rh1$fill <- gp_rh2$fill <- gp$fill[1L] - gp_rh3$fill <- gp_rh4$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_rh1$fill <- gp$fill[2:3] - gp_rh2$fill <- gp$fill[3:2] - gp_rh3$fill <- gp$fill[1] - gp_rh4$fill <- gp$fill[1] - } - rhombi.1 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star2", density = 1, scale = 0.5, - spacing = spacing, units = units, - angle = angle, gp = gp_rh1, - name = "rhombi.1", type = "horizontal") - rhombi.2 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star2", density = 1, scale = 0.5, - xoffset = 0.5 * spacing, - spacing = spacing, units = units, - angle = angle, gp = gp_rh2, - name = "rhombi.2", type = "horizontal") - rhombi.3 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star2", density = 1, scale = 0.5, - spacing = spacing, units = units, - angle = angle, gp = gp_rh3, - xoffset = 0.25 * spacing, yoffset = 0.5 * spacing, - scale = scale, name = "rhombi.3") - rhombi.4 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star2", density = 1, scale = 0.5, - spacing = spacing, units = units, - angle = angle, gp = gp_rh4, - xoffset = 0.75 * spacing, yoffset = 0.5 * spacing, - scale = scale, name = "rhombi.4") - gList(rhombi.1, rhombi.2, rhombi.3, rhombi.4) + n_col <- length(gp$fill) + gp_rh1 <- gp_rh2 <- gp_rh3 <- gp_rh4 <- gp + if (n_col == 2L) { + gp_rh1$fill <- gp_rh2$fill <- gp$fill[1L] + gp_rh3$fill <- gp_rh4$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_rh1$fill <- gp$fill[2:3] + gp_rh2$fill <- gp$fill[3:2] + gp_rh3$fill <- gp$fill[1] + gp_rh4$fill <- gp$fill[1] + } + rhombi.1 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star2", + density = 1, + scale = 0.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_rh1, + name = "rhombi.1", + type = "horizontal" + ) + rhombi.2 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star2", + density = 1, + scale = 0.5, + xoffset = 0.5 * spacing, + spacing = spacing, + units = units, + angle = angle, + gp = gp_rh2, + name = "rhombi.2", + type = "horizontal" + ) + rhombi.3 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star2", + density = 1, + scale = 0.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_rh3, + xoffset = 0.25 * spacing, + yoffset = 0.5 * spacing, + scale = scale, + name = "rhombi.3" + ) + rhombi.4 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star2", + density = 1, + scale = 0.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_rh4, + xoffset = 0.75 * spacing, + yoffset = 0.5 * spacing, + scale = scale, + name = "rhombi.4" + ) + gList(rhombi.1, rhombi.2, rhombi.3, rhombi.4) } create_4.6_30.4.6_30.4.6_30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_bg <- gp - gp_bg$fill <- gp$fill[1L] - if (n_col > 1L) - gp_star$fill <- rev(gp$fill[-1L]) - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - scale <- star_scale(6, 30) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star6", density = 1, grid = "hex", - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, stars) + n_col <- length(gp$fill) + gp_star <- gp_bg <- gp + gp_bg$fill <- gp$fill[1L] + if (n_col > 1L) { + gp_star$fill <- rev(gp$fill[-1L]) + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + scale <- star_scale(6, 30) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star6", + density = 1, + grid = "hex", + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, stars) } create_8.4_45.8.4_45_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_oct <- gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - if (n_col == 2L) { - gp_oct$fill <- gp$fill[-n_col] - } else if (n_col == 3L) { - gp_oct$fill <- rep(gp$fill[-n_col], each = 2) - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - subtype <- if (n_col > 2) "2134" else NULL - octs <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = c("convex8", "null"), density = 1.41, - spacing = spacing, units = units, - angle = angle, gp = gp_oct, - type = "square_tiling", subtype = subtype, - scale = scale, name = "octagons") - gList(bg, octs) + n_col <- length(gp$fill) + gp_oct <- gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + if (n_col == 2L) { + gp_oct$fill <- gp$fill[-n_col] + } else if (n_col == 3L) { + gp_oct$fill <- rep(gp$fill[-n_col], each = 2) + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + subtype <- if (n_col > 2) "2134" else NULL + octs <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = c("convex8", "null"), + density = 1.41, + spacing = spacing, + units = units, + angle = angle, + gp = gp_oct, + type = "square_tiling", + subtype = subtype, + scale = scale, + name = "octagons" + ) + gList(bg, octs) } create_12.3_30.12.3_30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_dod <- gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - if (n_col > 1L) - gp_dod$fill <- gp$fill[-n_col] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - dodecagons <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex12", density = 1, - spacing = spacing, units = units, - angle = angle, gp = gp_dod, - scale = scale, name = "dodecagons") - gList(bg, dodecagons) + n_col <- length(gp$fill) + gp_dod <- gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + if (n_col > 1L) { + gp_dod$fill <- gp$fill[-n_col] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + dodecagons <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex12", + density = 1, + spacing = spacing, + units = units, + angle = angle, + gp = gp_dod, + scale = scale, + name = "dodecagons" + ) + gList(bg, dodecagons) } create_12.12.4_60_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_dod <- gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - if (n_col > 1L) - gp_dod$fill <- gp$fill[-n_col] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - dodecagons <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex12", density = 1.035, rot = 15, - spacing = spacing, units = units, - angle = angle, gp = gp_dod, - scale = scale, name = "dodecagons") - gList(bg, dodecagons) + n_col <- length(gp$fill) + gp_dod <- gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + if (n_col > 1L) { + gp_dod$fill <- gp$fill[-n_col] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + dodecagons <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex12", + density = 1.035, + rot = 15, + spacing = spacing, + units = units, + angle = angle, + gp = gp_dod, + scale = scale, + name = "dodecagons" + ) + gList(bg, dodecagons) } create_4.8_.4__.8__tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_dod <- gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - if (n_col > 1L) - gp_dod$fill <- gp$fill[1:2] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - scale <- star_scale(8, 90, external = TRUE) - polygons <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = c("star8", "convex4"), density = c(1.53, 1.2), - rot = c(22.5, 0), - spacing = spacing, units = units, - angle = angle, gp = gp_dod, - scale = scale, name = "polygons") - gList(bg, polygons) + n_col <- length(gp$fill) + gp_dod <- gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + if (n_col > 1L) { + gp_dod$fill <- gp$fill[1:2] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + scale <- star_scale(8, 90, external = TRUE) + polygons <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = c("star8", "convex4"), + density = c(1.53, 1.2), + rot = c(22.5, 0), + spacing = spacing, + units = units, + angle = angle, + gp = gp_dod, + scale = scale, + name = "polygons" + ) + gList(bg, polygons) } create_18.18.3__tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_dod <- gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - if (n_col > 1L) - gp_dod$fill <- rev(gp$fill[-n_col]) - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - eighteen <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex18", density = 1.014, grid = "hex_circle", - spacing = spacing, units = units, - angle = angle, gp = gp_dod, - scale = scale, name = "eighteen-sided") - gList(bg, eighteen) + n_col <- length(gp$fill) + gp_dod <- gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + if (n_col > 1L) { + gp_dod$fill <- rev(gp$fill[-n_col]) + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + eighteen <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex18", + density = 1.014, + grid = "hex_circle", + spacing = spacing, + units = units, + angle = angle, + gp = gp_dod, + scale = scale, + name = "eighteen-sided" + ) + gList(bg, eighteen) } create_3.6_30.6__30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_bg <- gp - if (n_col == 2L) { - gp_bg$fill <- gp$fill[2L] - gp_star$fill <- rev(gp$fill[1L]) - } else if (n_col == 3L) { - gp_bg$fill <- gp$fill[2L] - gp_star$fill <- gp$fill[c(3, 1)] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - scale <- star_scale(6, 30) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star6", density = 1.30, rot = -22.0, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, grid = "hex", name = "stars") - gList(bg, stars) + n_col <- length(gp$fill) + gp_star <- gp_bg <- gp + if (n_col == 2L) { + gp_bg$fill <- gp$fill[2L] + gp_star$fill <- rev(gp$fill[1L]) + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[2L] + gp_star$fill <- gp$fill[c(3, 1)] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + scale <- star_scale(6, 30) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star6", + density = 1.30, + rot = -22.0, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + grid = "hex", + name = "stars" + ) + gList(bg, stars) } create_4.4_30.4__30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_bg <- gp - if (n_col == 2L) { - gp_star$fill <- gp$fill[1] - gp_bg$fill <- gp$fill[2] - } else if (n_col == 3L) { - gp_star$fill <- gp$fill[2:3] - gp_bg$fill <- gp$fill[1] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - scale <- star_scale(4, 30) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star4", density = 1.60, rot = -9.5, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, stars) + n_col <- length(gp$fill) + gp_star <- gp_bg <- gp + if (n_col == 2L) { + gp_star$fill <- gp$fill[1] + gp_bg$fill <- gp$fill[2] + } else if (n_col == 3L) { + gp_star$fill <- gp$fill[2:3] + gp_bg$fill <- gp$fill[1] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + scale <- star_scale(4, 30) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star4", + density = 1.60, + rot = -9.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, stars) } create_3.3_30.3.3_30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_bg <- gp - if (n_col == 2L) { - gp_star$fill <- gp$fill[1L] - gp_bg$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_star$fill <- gp$fill[c(3L, 1L)] - gp_bg$fill <- gp$fill[2L] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - scale <- star_scale(3, 30) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star3", density = 1.57, - grid = "hex_circle", rot = 30, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, stars) + n_col <- length(gp$fill) + gp_star <- gp_bg <- gp + if (n_col == 2L) { + gp_star$fill <- gp$fill[1L] + gp_bg$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_star$fill <- gp$fill[c(3L, 1L)] + gp_bg$fill <- gp$fill[2L] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + scale <- star_scale(3, 30) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star3", + density = 1.57, + grid = "hex_circle", + rot = 30, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, stars) } create_3.3.3.3___tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_tri <- gp_bg <- gp - if (n_col == 2L) { - gp_tri$fill <- gp$fill[1L] - gp_bg$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_tri$fill <- gp$fill[c(3L, 1L)] - gp_bg$fill <- gp$fill[2L] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - triangles <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex3", density = 1.33, - grid = "hex_circle", rot = 30, - spacing = spacing, units = units, - angle = angle, gp = gp_tri, - scale = scale, name = "triangles") - gList(bg, triangles) + n_col <- length(gp$fill) + gp_tri <- gp_bg <- gp + if (n_col == 2L) { + gp_tri$fill <- gp$fill[1L] + gp_bg$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_tri$fill <- gp$fill[c(3L, 1L)] + gp_bg$fill <- gp$fill[2L] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + triangles <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex3", + density = 1.33, + grid = "hex_circle", + rot = 30, + spacing = spacing, + units = units, + angle = angle, + gp = gp_tri, + scale = scale, + name = "triangles" + ) + gList(bg, triangles) } create_6.6_60.6.6_60_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_star <- gp_bg <- gp - if (n_col == 2L) { - gp_star$fill <- gp$fill[1L] - gp_bg$fill <- gp$fill[2L] - } else if (n_col == 3L) { - gp_star$fill <- gp$fill[c(3L, 1L)] - gp_bg$fill <- gp$fill[2L] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - scale <- star_scale(6, 120, external = TRUE) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star6", density = 1, - grid = "hex_circle", rot = 30, - spacing = spacing, units = units, - angle = angle, gp = gp_star, - scale = scale, name = "stars") - gList(bg, stars) + n_col <- length(gp$fill) + gp_star <- gp_bg <- gp + if (n_col == 2L) { + gp_star$fill <- gp$fill[1L] + gp_bg$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_star$fill <- gp$fill[c(3L, 1L)] + gp_bg$fill <- gp$fill[2L] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + scale <- star_scale(6, 120, external = TRUE) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star6", + density = 1, + grid = "hex_circle", + rot = 30, + spacing = spacing, + units = units, + angle = angle, + gp = gp_star, + scale = scale, + name = "stars" + ) + gList(bg, stars) } create_herringbone_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - fill2 <- gp$fill[1L] - if (n_col > 1L) - gp$fill <- gp$fill[-1L] - grob <- patternGrob("weave", xyi$x, xyi$y, xyi$id, - type = "twill", subtype = "2/2(1)", - density = 1, fill2 = fill2, - spacing = spacing, units = units, - angle = angle + 45, gp = gp, - name = "rectangles") - gList(grob) + n_col <- length(gp$fill) + fill2 <- gp$fill[1L] + if (n_col > 1L) { + gp$fill <- gp$fill[-1L] + } + grob <- patternGrob( + "weave", + xyi$x, + xyi$y, + xyi$id, + type = "twill", + subtype = "2/2(1)", + density = 1, + fill2 = fill2, + spacing = spacing, + units = units, + angle = angle + 45, + gp = gp, + name = "rectangles" + ) + gList(grob) } create_hexagonal_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - if (n_col == 2L) - gp$fill <- rev(gp$fill) - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex6", density = 1, grid = "hex", - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "hexagons") - gList(grob) + n_col <- length(gp$fill) + if (n_col == 2L) { + gp$fill <- rev(gp$fill) + } + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex6", + density = 1, + grid = "hex", + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "hexagons" + ) + gList(grob) } create_el_tri_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - if (n_col == 2L) { - gp_bg$fill <- gp$fill[2L] - gp$fill <- rep(c(gp$fill[1L], gp$fill[2L]), each = 2) - } else if (n_col == 3L) { - gp_bg$fill <- gp$fill[1L] - gp$fill <- c(gp$fill[2L], gp$fill[3L], gp$fill[1L], gp$fill[1L]) - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = rep(c("convex4", "convex3"), each = 2), - density = rep(c(1.41, 1.15), each = 2), - grid = "elongated_triangle", - type = "square_tiling", subtype = "3412", - rot = rep(c(45, 0), each = 2), - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "squares_and_triangles") - gList(bg, grob) + n_col <- length(gp$fill) + gp_bg <- gp + if (n_col == 2L) { + gp_bg$fill <- gp$fill[2L] + gp$fill <- rep(c(gp$fill[1L], gp$fill[2L]), each = 2) + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[1L] + gp$fill <- c(gp$fill[2L], gp$fill[3L], gp$fill[1L], gp$fill[1L]) + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = rep(c("convex4", "convex3"), each = 2), + density = rep(c(1.41, 1.15), each = 2), + grid = "elongated_triangle", + type = "square_tiling", + subtype = "3412", + rot = rep(c(45, 0), each = 2), + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "squares_and_triangles" + ) + gList(bg, grob) } create_pythagorean_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col == 2L) - gp$fill <- gp$fill[1L] - else if (n_col == 3L) - gp$fill <- gp$fill[2:1] - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex4", density = 1.222, rot = 15, - spacing = spacing, units = units, - angle = angle - 60, gp = gp, - name = "squares_larger") - gList(bg, grob) + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col == 2L) { + gp$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp$fill <- gp$fill[2:1] + } + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex4", + density = 1.222, + rot = 15, + spacing = spacing, + units = units, + angle = angle - 60, + gp = gp, + name = "squares_larger" + ) + gList(bg, grob) } create_rhombitrihexagonal_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_sq <- gp_bg - gp_dd <- gp_bg - gp_bg$fill <- gp$fill[n_col] - if (n_col == 2L) { - gp_sq$fill <- gp$fill[1L] - gp_dd$fill <- gp$fill[1L] - } - else if (n_col == 3L) { - gp_bg$fill <- gp$fill[2L] - gp_sq$fill <- gp$fill[3L] - gp_dd$fill <- gp$fill[1L] - } - # hexagons - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - # squares - stripe1 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle, - grid = "hex_circle", density = 0.25, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.1") - stripe2 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle + 60, - grid = "hex_circle", density = 0.25, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.2") - stripe3 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle - 60, - grid = "hex_circle", density = 0.25, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.3") - # dodecagons - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex12", density = 0.82, rot = 15, - grid = "hex_circle", - spacing = spacing, units = units, - angle = angle, gp = gp_dd, - name = "dodecagons") - gList(bg, stripe1, stripe2, stripe3, grob) + n_col <- length(gp$fill) + gp_bg <- gp + gp_sq <- gp_bg + gp_dd <- gp_bg + gp_bg$fill <- gp$fill[n_col] + if (n_col == 2L) { + gp_sq$fill <- gp$fill[1L] + gp_dd$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[2L] + gp_sq$fill <- gp$fill[3L] + gp_dd$fill <- gp$fill[1L] + } + # hexagons + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + # squares + stripe1 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle, + grid = "hex_circle", + density = 0.25, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.1" + ) + stripe2 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle + 60, + grid = "hex_circle", + density = 0.25, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.2" + ) + stripe3 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle - 60, + grid = "hex_circle", + density = 0.25, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.3" + ) + # dodecagons + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex12", + density = 0.82, + rot = 15, + grid = "hex_circle", + spacing = spacing, + units = units, + angle = angle, + gp = gp_dd, + name = "dodecagons" + ) + gList(bg, stripe1, stripe2, stripe3, grob) } create_3.4.6.3.12_30_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp_sq <- gp_dd <- gp - if (n_col == 2L) { - gp_bg$fill <- gp$fill[1L] - gp_sq$fill <- gp_dd$fill <- gp$fill[2L] - } - else if (n_col == 3L) { - gp_bg$fill <- gp$fill[1L] - gp_dd$fill <- gp$fill[2L] - gp_sq$fill <- gp$fill[3L] - } - # hexagons - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - # squares - stripe1 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle, - grid = "hex_circle", density = 0.25, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.1") - stripe2 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle + 60, - grid = "hex_circle", density = 0.25, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.2") - stripe3 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle - 60, - grid = "hex_circle", density = 0.25, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.3") - # triangles - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex12", density = 0.82, rot = 15, - grid = "hex_circle", - spacing = spacing, units = units, - angle = angle, gp = gp_dd, - name = "dodecagons") - # twelve-pointed stars - scale <- star_scale(12, 30) - stars <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star12", density = 0.82, rot = 15, - grid = "hex_circle", scale = scale, - spacing = spacing, units = units, - angle = angle, gp = gp_bg, - name = "stars") - gList(bg, stripe1, stripe2, stripe3, grob, stars) + n_col <- length(gp$fill) + gp_bg <- gp_sq <- gp_dd <- gp + if (n_col == 2L) { + gp_bg$fill <- gp$fill[1L] + gp_sq$fill <- gp_dd$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp_bg$fill <- gp$fill[1L] + gp_dd$fill <- gp$fill[2L] + gp_sq$fill <- gp$fill[3L] + } + # hexagons + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + # squares + stripe1 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle, + grid = "hex_circle", + density = 0.25, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.1" + ) + stripe2 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle + 60, + grid = "hex_circle", + density = 0.25, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.2" + ) + stripe3 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle - 60, + grid = "hex_circle", + density = 0.25, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.3" + ) + # triangles + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex12", + density = 0.82, + rot = 15, + grid = "hex_circle", + spacing = spacing, + units = units, + angle = angle, + gp = gp_dd, + name = "dodecagons" + ) + # twelve-pointed stars + scale <- star_scale(12, 30) + stars <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star12", + density = 0.82, + rot = 15, + grid = "hex_circle", + scale = scale, + spacing = spacing, + units = units, + angle = angle, + gp = gp_bg, + name = "stars" + ) + gList(bg, stripe1, stripe2, stripe3, grob, stars) } create_snub_square_tiling <- function(xyi, gp, spacing, units, angle) { - scale_star <- star_scale(4, 90 + 60, external = TRUE) - n_col <- length(gp$fill) - gp_sq <- gp_sq2 <- gp_tri <- gp - if (n_col == 2) { - gp_sq2$fill <- gp_sq$fill <- gp$fill[1L] - gp_tri$fill <- gp$fill[2L] - } else if (n_col == 3) { - gp_tri$fill <- gp$fill[1L] - gp_sq$fill <- gp$fill[2L] - gp_sq2$fill <- gp$fill[3L] - } - sq1 <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", - gp = gp_sq, name = "squares.1") - tri <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star4", scale = scale_star, - angle = angle, rot = 15, - spacing = spacing, units = units, - density = 1.41, gp = gp_tri, name = "triangles") - sq2 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex4", scale = scale_star, - angle = angle, rot = 60, - spacing = spacing, units = units, - density = scale_star * 1.41, gp = gp_sq2, name = "squares.2") - gList(sq1, tri, sq2) + scale_star <- star_scale(4, 90 + 60, external = TRUE) + n_col <- length(gp$fill) + gp_sq <- gp_sq2 <- gp_tri <- gp + if (n_col == 2) { + gp_sq2$fill <- gp_sq$fill <- gp$fill[1L] + gp_tri$fill <- gp$fill[2L] + } else if (n_col == 3) { + gp_tri$fill <- gp$fill[1L] + gp_sq$fill <- gp$fill[2L] + gp_sq2$fill <- gp$fill[3L] + } + sq1 <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_sq, name = "squares.1") + tri <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star4", + scale = scale_star, + angle = angle, + rot = 15, + spacing = spacing, + units = units, + density = 1.41, + gp = gp_tri, + name = "triangles" + ) + sq2 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex4", + scale = scale_star, + angle = angle, + rot = 60, + spacing = spacing, + units = units, + density = scale_star * 1.41, + gp = gp_sq2, + name = "squares.2" + ) + gList(sq1, tri, sq2) } create_snub_trihex_tiling <- function(xyi, gp, spacing, units, angle) { - scale_star <- star_scale(6, 60 + 60, external = TRUE) - n_col <- length(gp$fill) - gp_tri1 <- gp_tri2 <- gp_hex <- gp - if (n_col == 2) { - gp_tri1$fill <- gp_tri2$fill <- gp$fill[1L] - gp_hex$fill <- gp$fill[2L] - } else if (n_col == 3) { - gp_tri2$fill <- gp$fill[1L] - gp_hex$fill <- gp$fill[2L] - gp_tri1$fill <- gp$fill[3L] - } - tri1 <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", - gp = gp_tri1, name = "triangles.1") - tri2 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star6", scale = scale_star, - grid = "hex_circle", - angle = angle, rot = 19, - spacing = spacing, units = units, - density = 1.305, gp = gp_tri2, name = "triangles.2") - hex <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex6", grid = "hex_circle", - angle = angle, rot = 49, - spacing = spacing, units = units, - density = scale_star * 1.305, gp = gp_hex, name = "hexagons") - gList(tri1, tri2, hex) + scale_star <- star_scale(6, 60 + 60, external = TRUE) + n_col <- length(gp$fill) + gp_tri1 <- gp_tri2 <- gp_hex <- gp + if (n_col == 2) { + gp_tri1$fill <- gp_tri2$fill <- gp$fill[1L] + gp_hex$fill <- gp$fill[2L] + } else if (n_col == 3) { + gp_tri2$fill <- gp$fill[1L] + gp_hex$fill <- gp$fill[2L] + gp_tri1$fill <- gp$fill[3L] + } + tri1 <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_tri1, + name = "triangles.1" + ) + tri2 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star6", + scale = scale_star, + grid = "hex_circle", + angle = angle, + rot = 19, + spacing = spacing, + units = units, + density = 1.305, + gp = gp_tri2, + name = "triangles.2" + ) + hex <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex6", + grid = "hex_circle", + angle = angle, + rot = 49, + spacing = spacing, + units = units, + density = scale_star * 1.305, + gp = gp_hex, + name = "hexagons" + ) + gList(tri1, tri2, hex) } create_square_tiling <- function(xyi, gp, spacing, units, angle) { - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "square", density = 1, - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "squares") - gList(grob) + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "square", + density = 1, + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "squares" + ) + gList(grob) } create_rhombille_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_rh1 <- gp_rh2 <- gp_rh3 <- gp - if (n_col == 2) { - gp_rh1$fill <- gp_rh2$fill <- gp$fill[1L] - gp_rh3$fill <- gp$fill[2L] - } else if (n_col == 3) { - gp_rh1$fill <- gp$fill[1L] - gp_rh2$fill <- gp$fill[2L] - gp_rh3$fill <- gp$fill[3L] - } - rh1 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "rhombille_rhombus", grid = "hex", - angle = angle, rot = -120, - spacing = spacing, units = units, density = 1, - gp = gp_rh1, name = "rhombi.1") - rh2 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "rhombille_rhombus", grid = "hex", - angle = angle, rot = 120, - spacing = spacing, units = units, density = 1, - gp = gp_rh2, name = "rhombi.2") - rh3 <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "rhombille_rhombus", grid = "hex", - angle = angle, rot = 0, - spacing = spacing, units = units, density = 1, - gp = gp_rh3, name = "rhombi.3") - gList(rh1, rh2, rh3) + n_col <- length(gp$fill) + gp_rh1 <- gp_rh2 <- gp_rh3 <- gp + if (n_col == 2) { + gp_rh1$fill <- gp_rh2$fill <- gp$fill[1L] + gp_rh3$fill <- gp$fill[2L] + } else if (n_col == 3) { + gp_rh1$fill <- gp$fill[1L] + gp_rh2$fill <- gp$fill[2L] + gp_rh3$fill <- gp$fill[3L] + } + rh1 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "rhombille_rhombus", + grid = "hex", + angle = angle, + rot = -120, + spacing = spacing, + units = units, + density = 1, + gp = gp_rh1, + name = "rhombi.1" + ) + rh2 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "rhombille_rhombus", + grid = "hex", + angle = angle, + rot = 120, + spacing = spacing, + units = units, + density = 1, + gp = gp_rh2, + name = "rhombi.2" + ) + rh3 <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "rhombille_rhombus", + grid = "hex", + angle = angle, + rot = 0, + spacing = spacing, + units = units, + density = 1, + gp = gp_rh3, + name = "rhombi.3" + ) + gList(rh1, rh2, rh3) } create_9.3.9.3_40_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_non <- gp_tri <- gp_star3 <- gp - if (n_col == 2) { - gp_non$fill <- gp$fill[1L] - gp_star3$fill <- gp_tri$fill <- gp$fill[2L] - } else if (n_col == 3) { - gp_non$fill <- gp$fill[1L] - gp_star3$fill <- gp$fill[2L] - gp_tri$fill <- gp$fill[3L] - } - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_star3, - name = "background_color") - stripe <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - grid = "hex_circle", yoffset = 0.24 * spacing, - angle = angle, - spacing = spacing, units = units, density = 0.35, - gp = gp_tri, name = "stripes") - non <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex9", grid = "hex_circle", - angle = angle, rot = 0, - spacing = spacing, units = units, density = 1.01, - gp = gp_non, name = "nonagons") - gList(bg, stripe, non) + n_col <- length(gp$fill) + gp_non <- gp_tri <- gp_star3 <- gp + if (n_col == 2) { + gp_non$fill <- gp$fill[1L] + gp_star3$fill <- gp_tri$fill <- gp$fill[2L] + } else if (n_col == 3) { + gp_non$fill <- gp$fill[1L] + gp_star3$fill <- gp$fill[2L] + gp_tri$fill <- gp$fill[3L] + } + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_star3, + name = "background_color" + ) + stripe <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + grid = "hex_circle", + yoffset = 0.24 * spacing, + angle = angle, + spacing = spacing, + units = units, + density = 0.35, + gp = gp_tri, + name = "stripes" + ) + non <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex9", + grid = "hex_circle", + angle = angle, + rot = 0, + spacing = spacing, + units = units, + density = 1.01, + gp = gp_non, + name = "nonagons" + ) + gList(bg, stripe, non) } create_tetrakis_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_tri1 <- gp_tri2 <- gp_tri3 <- gp - if (n_col == 2) { - gp_tri1$fill <- gp$fill[1L] - gp_tri2$fill <- gp_tri3$fill <- gp$fill[2L] - } else if (n_col == 3) { - gp_tri1$fill <- gp$fill[1L] - gp_tri2$fill <- gp$fill[2L] - gp_tri3$fill <- gp$fill[3L] - } - tri1.a <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_left", - angle = angle, rot = 0, - spacing = spacing, units = units, density = 1, - gp = gp_tri1, name = "triangles.1.a") - tri1.b <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_left", - angle = angle, rot = 90, - spacing = spacing, units = units, density = 1, - gp = gp_tri1, name = "triangles.1.b") - tri1.c <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_left", - angle = angle, rot = 180, - spacing = spacing, units = units, density = 1, - gp = gp_tri1, name = "triangles.1.c") - tri1.d <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_left", - angle = angle, rot = 270, - spacing = spacing, units = units, density = 1, - gp = gp_tri1, name = "triangles.1.d") - tri2.a <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_right", - angle = angle, rot = 0, - spacing = spacing, units = units, density = 1, - gp = gp_tri2, name = "triangles.2.a") - tri2.b <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_right", - angle = angle, rot = 180, - spacing = spacing, units = units, density = 1, - gp = gp_tri2, name = "triangles.2.b") - tri3.a <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_right", - angle = angle, rot = 90, - spacing = spacing, units = units, density = 1, - gp = gp_tri3, name = "triangles.3.a") - tri3.b <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "tetrakis_right", - angle = angle, rot = 270, - spacing = spacing, units = units, density = 1, - gp = gp_tri3, name = "triangles.3.b") - gList(tri1.a, tri1.b, tri1.c, tri1.d, tri2.a, tri2.b, tri3.a, tri3.b) + n_col <- length(gp$fill) + gp_tri1 <- gp_tri2 <- gp_tri3 <- gp + if (n_col == 2) { + gp_tri1$fill <- gp$fill[1L] + gp_tri2$fill <- gp_tri3$fill <- gp$fill[2L] + } else if (n_col == 3) { + gp_tri1$fill <- gp$fill[1L] + gp_tri2$fill <- gp$fill[2L] + gp_tri3$fill <- gp$fill[3L] + } + tri1.a <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_left", + angle = angle, + rot = 0, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri1, + name = "triangles.1.a" + ) + tri1.b <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_left", + angle = angle, + rot = 90, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri1, + name = "triangles.1.b" + ) + tri1.c <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_left", + angle = angle, + rot = 180, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri1, + name = "triangles.1.c" + ) + tri1.d <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_left", + angle = angle, + rot = 270, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri1, + name = "triangles.1.d" + ) + tri2.a <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_right", + angle = angle, + rot = 0, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri2, + name = "triangles.2.a" + ) + tri2.b <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_right", + angle = angle, + rot = 180, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri2, + name = "triangles.2.b" + ) + tri3.a <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_right", + angle = angle, + rot = 90, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri3, + name = "triangles.3.a" + ) + tri3.b <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "tetrakis_right", + angle = angle, + rot = 270, + spacing = spacing, + units = units, + density = 1, + gp = gp_tri3, + name = "triangles.3.b" + ) + gList(tri1.a, tri1.b, tri1.c, tri1.d, tri2.a, tri2.b, tri3.a, tri3.b) } create_triangular_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[1] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col == 2L) - gp$fill <- gp$fill[2L] - else if (n_col == 3L) - gp$fill <- gp$fill[3:2] - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex3", density = 1, grid = "hex", rot = 180, - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "triangles") - gList(bg, grob) + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[1] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col == 2L) { + gp$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp$fill <- gp$fill[3:2] + } + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex3", + density = 1, + grid = "hex", + rot = 180, + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "triangles" + ) + gList(bg, grob) } create_2__.3__.12__tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[1] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col > 1L) - gp$fill <- rev(gp$fill[-1L]) - scale <- star_scale(12, 60, external = TRUE) - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "star12", density = 1.034, rot = 15, - grid = "hex_circle", scale = scale, - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "dodecagons") - gList(bg, grob) + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[1] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col > 1L) { + gp$fill <- rev(gp$fill[-1L]) + } + scale <- star_scale(12, 60, external = TRUE) + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "star12", + density = 1.034, + rot = 15, + grid = "hex_circle", + scale = scale, + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "dodecagons" + ) + gList(bg, grob) } create_trunc_hex_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col == 2L) - gp$fill <- gp$fill[1L] - else if (n_col == 3L) - gp$fill <- gp$fill[2:1] + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col == 2L) { + gp$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp$fill <- gp$fill[2:1] + } - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex12", density = 1.034, rot = 15, - grid = "hex_circle", - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "dodecagons") - gList(bg, grob) + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex12", + density = 1.034, + rot = 15, + grid = "hex_circle", + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "dodecagons" + ) + gList(bg, grob) } create_trunc_square_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col == 2L) - gp$fill <- gp$fill[1L] - else if (n_col == 3L) - gp$fill <- gp$fill[1:2] + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col == 2L) { + gp$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp$fill <- gp$fill[1:2] + } - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex8", density = 1.082, rot = 22.5, - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "octagons") - gList(bg, grob) + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex8", + density = 1.082, + rot = 22.5, + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "octagons" + ) + gList(bg, grob) } create_4.6.4_30.6_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[1L] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col == 2L) - gp$fill <- gp$fill[2L] - else if (n_col == 3L) - gp$fill <- gp$fill[2:3] + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[1L] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col == 2L) { + gp$fill <- gp$fill[2L] + } else if (n_col == 3L) { + gp$fill <- gp$fill[2:3] + } - scale <- star_scale(4, 120, external = TRUE) - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = c("star4", "convex4"), density = c(1.2, 0.8), - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "stars_and_squares", scale = scale) - gList(bg, grob) + scale <- star_scale(4, 120, external = TRUE) + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = c("star4", "convex4"), + density = c(1.2, 0.8), + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "stars_and_squares", + scale = scale + ) + gList(bg, grob) } create_trunc_trihex_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_sq <- gp_bg - gp_hx <- gp_bg - gp_bg$fill <- gp$fill[n_col] - if (n_col == 2L) { - gp_bg$fill <- gp$fill[1L] - gp_sq$fill <- gp$fill[2L] - gp_hx$fill <- gp$fill[1L] - } - else if (n_col == 3L) { - gp_sq$fill <- gp$fill[2L] - gp_hx$fill <- gp$fill[1L] - } - # triangles - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - # squares - stripe1 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle, - grid = "hex_circle", density = 0.42, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.1") - stripe2 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle + 60, - grid = "hex_circle", density = 0.42, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.2") - stripe3 <- patternGrob("stripe", xyi$x, xyi$y, xyi$id, - angle = angle - 60, - grid = "hex_circle", density = 0.42, - spacing = spacing, units = units, - gp = gp_sq, name = "square_stripes.3") - # hexagons - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex6", density = 0.75, - grid = "hex_circle", - spacing = spacing, units = units, - angle = angle, gp = gp_hx, - name = "hexagons") - gList(bg, stripe1, stripe2, stripe3, grob) + n_col <- length(gp$fill) + gp_bg <- gp + gp_sq <- gp_bg + gp_hx <- gp_bg + gp_bg$fill <- gp$fill[n_col] + if (n_col == 2L) { + gp_bg$fill <- gp$fill[1L] + gp_sq$fill <- gp$fill[2L] + gp_hx$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp_sq$fill <- gp$fill[2L] + gp_hx$fill <- gp$fill[1L] + } + # triangles + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + # squares + stripe1 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle, + grid = "hex_circle", + density = 0.42, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.1" + ) + stripe2 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle + 60, + grid = "hex_circle", + density = 0.42, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.2" + ) + stripe3 <- patternGrob( + "stripe", + xyi$x, + xyi$y, + xyi$id, + angle = angle - 60, + grid = "hex_circle", + density = 0.42, + spacing = spacing, + units = units, + gp = gp_sq, + name = "square_stripes.3" + ) + # hexagons + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex6", + density = 0.75, + grid = "hex_circle", + spacing = spacing, + units = units, + angle = angle, + gp = gp_hx, + name = "hexagons" + ) + gList(bg, stripe1, stripe2, stripe3, grob) } create_trihexagonal_tiling <- function(xyi, gp, spacing, units, angle) { - n_col <- length(gp$fill) - gp_bg <- gp - gp_bg$fill <- gp$fill[n_col] - bg <- polygonGrob(xyi$x, xyi$y, xyi$id, default.units = "npc", gp = gp_bg, - name = "background_color") - if (n_col == 2L) - gp$fill <- gp$fill[1L] - else if (n_col == 3L) - gp$fill <- gp$fill[2:1] - grob <- patternGrob("regular_polygon", xyi$x, xyi$y, xyi$id, - shape = "convex6", density = 1, rot = 30, - grid = "hex_circle", - spacing = spacing, units = units, - angle = angle, gp = gp, - name = "hexagons") - gList(bg, grob) + n_col <- length(gp$fill) + gp_bg <- gp + gp_bg$fill <- gp$fill[n_col] + bg <- polygonGrob( + xyi$x, + xyi$y, + xyi$id, + default.units = "npc", + gp = gp_bg, + name = "background_color" + ) + if (n_col == 2L) { + gp$fill <- gp$fill[1L] + } else if (n_col == 3L) { + gp$fill <- gp$fill[2:1] + } + grob <- patternGrob( + "regular_polygon", + xyi$x, + xyi$y, + xyi$id, + shape = "convex6", + density = 1, + rot = 30, + grid = "hex_circle", + spacing = spacing, + units = units, + angle = angle, + gp = gp, + name = "hexagons" + ) + gList(bg, grob) } diff --git a/R/pattern-geometry-wave.R b/R/pattern-geometry-wave.R index 47a1a02..24211e4 100644 --- a/R/pattern-geometry-wave.R +++ b/R/pattern-geometry-wave.R @@ -24,124 +24,164 @@ #' spacing = 0.15, angle = 0, amplitude = 0.075) #' @seealso Use [grid.pattern_stripe()] for straight lines instead of waves. #' @export -grid.pattern_wave <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", fill = gp$fill %||% "grey80", angle = 30, - density = 0.2, spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - amplitude = 0.5 * spacing, frequency = 1 / spacing, - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - grid = "square", type = "triangle", - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("wave", x, y, id, - colour = colour, fill = fill, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - amplitude = amplitude, frequency = frequency, - alpha = alpha, linetype = linetype, linewidth = linewidth, - grid = grid, type = type, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_wave <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + amplitude = 0.5 * spacing, + frequency = 1 / spacing, + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + grid = "square", + type = "triangle", + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "wave", + x, + y, + id, + colour = colour, + fill = fill, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + amplitude = amplitude, + frequency = frequency, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + grid = grid, + type = type, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } -create_pattern_wave_via_sf <- function(params, boundary_df, aspect_ratio, - legend = FALSE) { +create_pattern_wave_via_sf <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5) { + params$pattern_density <- 1 - 1e-6 + } + stopifnot(params$pattern_density <= 1) - if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5) - params$pattern_density <- 1 - 1e-6 - stopifnot(params$pattern_density <= 1) + # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio + default.units <- "bigpts" + boundary_df <- convert_polygon_df_units(boundary_df, default.units) + params <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) - # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio - default.units <- "bigpts" - boundary_df <- convert_polygon_df_units(boundary_df, default.units) - params <- convert_params_units(params, default.units) - vpm <- get_vp_measurements(default.units) + # create grid of points large enough to cover viewport no matter the angle + grid_xy <- get_xy_grid(params, vpm, wavelength = TRUE) - # create grid of points large enough to cover viewport no matter the angle - grid_xy <- get_xy_grid(params, vpm, wavelength = TRUE) + fill <- update_alpha(params$pattern_fill, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth * .pt + lty <- params$pattern_linetype + density <- params$pattern_density - fill <- update_alpha(params$pattern_fill, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth * .pt - lty <- params$pattern_linetype - density <- params$pattern_density + n_par <- max(lengths(list(fill, col, lwd, lty, density))) - n_par <- max(lengths(list(fill, col, lwd, lty, density))) + fill <- rep_len_fill(fill, n_par) + col <- rep_len(col, n_par) + lwd <- rep_len(lwd, n_par) + lty <- rep_len(lty, n_par) + density <- rep_len(density, n_par) - fill <- rep_len_fill(fill, n_par) - col <- rep_len(col, n_par) - lwd <- rep_len(lwd, n_par) - lty <- rep_len(lty, n_par) - density <- rep_len(density, n_par) + gl <- gList() + for (i_par in seq_len(n_par)) { + gp <- gpar( + col = col[i_par], + fill = fill[[i_par]], + lwd = lwd[i_par], + lty = lty[i_par], + lineend = 'square' + ) - gl <- gList() - for (i_par in seq_len(n_par)) { + boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) - gp <- gpar(col = col[i_par], fill = fill[[i_par]], - lwd = lwd[i_par], lty = lty[i_par], lineend = 'square') - - boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) - - waves_sf <- create_waves_sf(params, grid_xy, vpm, i_par, n_par) - clipped_waves_sf_bot <- sf::st_intersection(waves_sf, boundary_sf) - name <- paste0("wave.", i_par) - grob <- sf_multipolygon_to_polygon_grob(clipped_waves_sf_bot, - gp, default.units, name) - gl <- append_gList(gl, grob) - } - gTree(children = gl, name = "regular_polygon") + waves_sf <- create_waves_sf(params, grid_xy, vpm, i_par, n_par) + clipped_waves_sf_bot <- sf::st_intersection(waves_sf, boundary_sf) + name <- paste0("wave.", i_par) + grob <- sf_multipolygon_to_polygon_grob(clipped_waves_sf_bot, gp, default.units, name) + gl <- append_gList(gl, grob) + } + gTree(children = gl, name = "regular_polygon") } create_waves_sf <- function(params, grid_xy, vpm, i_par, n_par) { - switch(params$pattern_type, - sine = create_sine_waves_sf(params, grid_xy, vpm, i_par, n_par), - triangle = create_triangle_waves_sf(params, grid_xy, vpm, i_par, n_par), - abort(paste("Don't know how to create wave pattern", dQuote(params$pattern_type)))) + switch( + params$pattern_type, + sine = create_sine_waves_sf(params, grid_xy, vpm, i_par, n_par), + triangle = create_triangle_waves_sf(params, grid_xy, vpm, i_par, n_par), + abort(paste("Don't know how to create wave pattern", dQuote(params$pattern_type))) + ) } create_sine_waves_sf <- function(params, grid_xy, vpm, i_par, n_par) { - halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density - a <- params$pattern_amplitude - n_s <- 180L - theta <- to_radians(seq(0, by = 360L / n_s, length.out = n_s)) - y_s <- a * sin(theta) - n_y <- length(grid_xy$y) - indices_y <- seq(from = i_par, to = n_y, by = n_par) - l_waves <- lapply(grid_xy$y[indices_y], - function(y0) { - n_x <- length(grid_xy$x) - xc <- seq(grid_xy$x_min, grid_xy$x_max, length.out = n_s * n_x + 1L) - yc <- y0 + rep(y_s, length.out = n_s * n_x + 1L) - yt <- yc + halfwidth - yb <- yc - halfwidth - x <- c(xc, rev(xc)) - y <- c(yt, rev(yb)) - xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) - m <- as.matrix(as.data.frame(xy)) - list(rbind(m, m[1,])) - }) - sf::st_multipolygon(l_waves) + halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density + a <- params$pattern_amplitude + n_s <- 180L + theta <- to_radians(seq(0, by = 360L / n_s, length.out = n_s)) + y_s <- a * sin(theta) + n_y <- length(grid_xy$y) + indices_y <- seq(from = i_par, to = n_y, by = n_par) + l_waves <- lapply(grid_xy$y[indices_y], function(y0) { + n_x <- length(grid_xy$x) + xc <- seq(grid_xy$x_min, grid_xy$x_max, length.out = n_s * n_x + 1L) + yc <- y0 + rep(y_s, length.out = n_s * n_x + 1L) + yt <- yc + halfwidth + yb <- yc - halfwidth + x <- c(xc, rev(xc)) + y <- c(yt, rev(yb)) + xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) + m <- as.matrix(as.data.frame(xy)) + list(rbind(m, m[1, ])) + }) + sf::st_multipolygon(l_waves) } create_triangle_waves_sf <- function(params, grid_xy, vpm, i_par, n_par) { - halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density - a <- params$pattern_amplitude - n_y <- length(grid_xy$y) - indices_y <- seq(from = i_par, to = n_y, by = n_par) - l_waves <- lapply(grid_xy$y[indices_y], - function(y0) { - n_x <- length(grid_xy$x) - xc <- seq(grid_xy$x_min, grid_xy$x_max, length.out = 4L * n_x + 1L) - yc <- y0 + rep(c(0, a, 0, -a), length.out = 4L * n_x + 1L) - yt <- yc + halfwidth - yb <- yc - halfwidth - x <- c(xc, rev(xc)) - y <- c(yt, rev(yb)) - xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) - m <- as.matrix(as.data.frame(xy)) - list(rbind(m, m[1,])) - }) - sf::st_multipolygon(l_waves) + halfwidth <- 0.5 * grid_xy$v_spacing * params$pattern_density + a <- params$pattern_amplitude + n_y <- length(grid_xy$y) + indices_y <- seq(from = i_par, to = n_y, by = n_par) + l_waves <- lapply(grid_xy$y[indices_y], function(y0) { + n_x <- length(grid_xy$x) + xc <- seq(grid_xy$x_min, grid_xy$x_max, length.out = 4L * n_x + 1L) + yc <- y0 + rep(c(0, a, 0, -a), length.out = 4L * n_x + 1L) + yt <- yc + halfwidth + yb <- yc - halfwidth + x <- c(xc, rev(xc)) + y <- c(yt, rev(yb)) + xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) + m <- as.matrix(as.data.frame(xy)) + list(rbind(m, m[1, ])) + }) + sf::st_multipolygon(l_waves) } # # build sf multipolygon 'rect' for each grid_xy$y value diff --git a/R/pattern-geometry-weave.R b/R/pattern-geometry-weave.R index 1b1e338..1d20632 100644 --- a/R/pattern-geometry-weave.R +++ b/R/pattern-geometry-weave.R @@ -39,98 +39,148 @@ #' fill2 = "yellow", gp = gp, spacing = 0.05, density = 1.0) #' @seealso [pattern_weave()] #' @export -grid.pattern_weave <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - colour = gp$col %||% "grey20", - fill = gp$fill %||% "grey80", fill2 = fill, - angle = 30, density = 0.2, - spacing = 0.05, xoffset = 0, yoffset = 0, units = "snpc", - alpha = gp$alpha %||% NA_real_, - linetype = gp$lty %||% 1, - linewidth = size %||% gp$lwd %||% 1, - size = NULL, - grid = "square", type = "plain", subtype = NA, - default.units = "npc", name = NULL, - gp = gpar(), draw = TRUE, vp = NULL) { - if (missing(colour) && hasName(l <- list(...), "color")) colour <- l$color - grid.pattern("weave", x, y, id, - colour = colour, fill = fill, fill2 = fill2, angle = angle, - density = density, spacing = spacing, xoffset = xoffset, yoffset = yoffset, units = units, - alpha = alpha, linetype = linetype, linewidth = linewidth, - grid = grid, type = type, subtype = subtype, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_weave <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + colour = gp$col %||% "grey20", + fill = gp$fill %||% "grey80", + fill2 = fill, + angle = 30, + density = 0.2, + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + alpha = gp$alpha %||% NA_real_, + linetype = gp$lty %||% 1, + linewidth = size %||% gp$lwd %||% 1, + size = NULL, + grid = "square", + type = "plain", + subtype = NA, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + if (missing(colour) && hasName(l <- list(...), "color")) { + colour <- l$color + } + grid.pattern( + "weave", + x, + y, + id, + colour = colour, + fill = fill, + fill2 = fill2, + angle = angle, + density = density, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + alpha = alpha, + linetype = linetype, + linewidth = linewidth, + grid = grid, + type = type, + subtype = subtype, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } create_pattern_weave_via_sf <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - # 'weft' 'yarns' will just be normal (horizontal) stripes - grob_weft <- create_crosshatch_via_sf_helper(params, boundary_df, add_top_hatch = FALSE) - grob_weft <- editGrob(grob_weft, name = "weft") - # we'll compute 'covered' and 'uncovered' 'warp' rectangles to represent warp 'yarns' - l <- create_warp_via_sf(params, boundary_df) - grobTree(l$warp_covered, grob_weft, l$warp_uncovered, name = "weave") + # 'weft' 'yarns' will just be normal (horizontal) stripes + grob_weft <- create_crosshatch_via_sf_helper(params, boundary_df, add_top_hatch = FALSE) + grob_weft <- editGrob(grob_weft, name = "weft") + # we'll compute 'covered' and 'uncovered' 'warp' rectangles to represent warp 'yarns' + l <- create_warp_via_sf(params, boundary_df) + grobTree(l$warp_covered, grob_weft, l$warp_uncovered, name = "weave") } create_warp_via_sf <- function(params, boundary_df) { - if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5) - params$pattern_density <- 1 - 1e-6 - stopifnot(params$pattern_density <= 1) + if (abs(params$pattern_density - 1) < .Machine$double.eps^0.5) { + params$pattern_density <- 1 - 1e-6 + } + stopifnot(params$pattern_density <= 1) - # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio - default.units <- "bigpts" - boundary_df <- convert_polygon_df_units(boundary_df, default.units) - params <- convert_params_units(params, default.units) - vpm <- get_vp_measurements(default.units) + # work in 'bigpts' instead 'npc' / 'snpc' units so we don't worry about the aspect ratio + default.units <- "bigpts" + boundary_df <- convert_polygon_df_units(boundary_df, default.units) + params <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) - # create grid of points large enough to cover viewport no matter the angle - grid_xy <- get_xy_grid(params, vpm) + # create grid of points large enough to cover viewport no matter the angle + grid_xy <- get_xy_grid(params, vpm) - fill <- update_alpha(params$pattern_fill2, params$pattern_alpha) - col <- update_alpha(params$pattern_colour, params$pattern_alpha) - lwd <- params$pattern_linewidth * .pt - lty <- params$pattern_linetype - gp <- gpar(col = col, fill = fill, lwd = lwd, lty = lty, lineend = 'square') + fill <- update_alpha(params$pattern_fill2, params$pattern_alpha) + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + lwd <- params$pattern_linewidth * .pt + lty <- params$pattern_linetype + gp <- gpar(col = col, fill = fill, lwd = lwd, lty = lty, lineend = 'square') - m_weave <- pattern_weave(params$pattern_type, params$pattern_subtype, - nrow = length(grid_xy$y), ncol = length(grid_xy$x)) + m_weave <- pattern_weave( + params$pattern_type, + params$pattern_subtype, + nrow = length(grid_xy$y), + ncol = length(grid_xy$x) + ) - # compute vertical stripes clipped to boundary - boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) - stripes_sf <- create_v_stripes_sf(params, grid_xy, vpm) - clipped_stripes_sf <- sf::st_intersection(stripes_sf, boundary_sf) + # compute vertical stripes clipped to boundary + boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df, buffer_dist = 0) + stripes_sf <- create_v_stripes_sf(params, grid_xy, vpm) + clipped_stripes_sf <- sf::st_intersection(stripes_sf, boundary_sf) - # compute warp squares covered by weft lines - warp_covered_sf <- create_warp_covered_sf(params, grid_xy, vpm, m_weave) - warp_covered_sf <- sf::st_buffer(warp_covered_sf, dist = 0) - clipped_covered_sf <- sf::st_intersection(clipped_stripes_sf, warp_covered_sf) + # compute warp squares covered by weft lines + warp_covered_sf <- create_warp_covered_sf(params, grid_xy, vpm, m_weave) + warp_covered_sf <- sf::st_buffer(warp_covered_sf, dist = 0) + clipped_covered_sf <- sf::st_intersection(clipped_stripes_sf, warp_covered_sf) - # warp rectangles not covered by weft lines is just stripes minus under squares - buffered_covered_sf <- sf::st_buffer(clipped_covered_sf, vpm$length / 1e9) - clipped_uncovered_sf <- sf::st_difference(clipped_stripes_sf, buffered_covered_sf) + # warp rectangles not covered by weft lines is just stripes minus under squares + buffered_covered_sf <- sf::st_buffer(clipped_covered_sf, vpm$length / 1e9) + clipped_uncovered_sf <- sf::st_difference(clipped_stripes_sf, buffered_covered_sf) - grob_uncovered <- sf_multipolygon_to_polygon_grob(clipped_uncovered_sf, - gp, default.units, "warp_uncovered") + grob_uncovered <- sf_multipolygon_to_polygon_grob( + clipped_uncovered_sf, + gp, + default.units, + "warp_uncovered" + ) - grob_covered <- sf_multipolygon_to_polygon_grob(clipped_covered_sf, - gp, default.units, "warp_covered") + grob_covered <- sf_multipolygon_to_polygon_grob( + clipped_covered_sf, + gp, + default.units, + "warp_covered" + ) - list(warp_uncovered = grob_uncovered, warp_covered = grob_covered) + list(warp_uncovered = grob_uncovered, warp_covered = grob_covered) } create_warp_covered_sf <- function(params, grid_xy, vpm, m_weave) { - halfwidth <- 0.5 * grid_xy$h_spacing * params$pattern_density - # need list of lists each containing a five row matrix of rectangle vertices - l_rects <- list() - for (i in seq_len(nrow(m_weave))) { - for (j in seq_len(ncol(m_weave))) { - if (!m_weave[i, j]) { - x0 <- grid_xy$x[j] - y0 <- grid_xy$y[i] - x <- x0 + c(-1, -1, 1, 1) * halfwidth - y <- y0 + c(-1, 1, 1, -1) * halfwidth - xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) - m <- as.matrix(as.data.frame(xy)) - l_rects <- append(l_rects, list(list(rbind(m, m[1,])))) - } - } - } - sf::st_multipolygon(l_rects) + halfwidth <- 0.5 * grid_xy$h_spacing * params$pattern_density + # need list of lists each containing a five row matrix of rectangle vertices + l_rects <- list() + for (i in seq_len(nrow(m_weave))) { + for (j in seq_len(ncol(m_weave))) { + if (!m_weave[i, j]) { + x0 <- grid_xy$x[j] + y0 <- grid_xy$y[i] + x <- x0 + c(-1, -1, 1, 1) * halfwidth + y <- y0 + c(-1, 1, 1, -1) * halfwidth + xy <- rotate_xy(x, y, params$pattern_angle, vpm$x, vpm$y) + m <- as.matrix(as.data.frame(xy)) + l_rects <- append(l_rects, list(list(rbind(m, m[1, ])))) + } + } + } + sf::st_multipolygon(l_rects) } diff --git a/R/pattern-pattern-aRtsy.R b/R/pattern-pattern-aRtsy.R index b15834e..5b2c66a 100644 --- a/R/pattern-pattern-aRtsy.R +++ b/R/pattern-pattern-aRtsy.R @@ -8,26 +8,27 @@ #' #' @return grid grob objects. #' @noRd -create_pattern_aRtsy <- function(params, boundary_df, aspect_ratio, - legend = FALSE) { - assert_suggested("aRtsy", "aRtsy") - requireNamespace("aRtsy", quietly = TRUE) - stopifnot(guess_has_R4.1_features("patterns")) - alpha <- ifelse(is.na(params$pattern_alpha), 1, params$pattern_alpha) - colors <- update_alpha(params$pattern_fill, alpha) - fn_name <- paste0("canvas_", params$pattern_type) - fn <- utils::getFromNamespace(fn_name, "aRtsy") - args <- list() - nformals <- names(formals(fn)) - if ("color" %in% nformals) { # e.g. `canvas_maze()` - args$color <- colors - } - if ("colors" %in% nformals) { # e.g. most canvas functions - args$colors <- colors - } - pat <- ggplot2pat(do.call(fn, args)) - gp <- grid::gpar(col = NA_character_, fill = pat) - convert_polygon_df_to_polygon_grob(boundary_df, gp = gp) +create_pattern_aRtsy <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + assert_suggested("aRtsy", "aRtsy") + requireNamespace("aRtsy", quietly = TRUE) + stopifnot(guess_has_R4.1_features("patterns")) + alpha <- ifelse(is.na(params$pattern_alpha), 1, params$pattern_alpha) + colors <- update_alpha(params$pattern_fill, alpha) + fn_name <- paste0("canvas_", params$pattern_type) + fn <- utils::getFromNamespace(fn_name, "aRtsy") + args <- list() + nformals <- names(formals(fn)) + if ("color" %in% nformals) { + # e.g. `canvas_maze()` + args$color <- colors + } + if ("colors" %in% nformals) { + # e.g. most canvas functions + args$colors <- colors + } + pat <- ggplot2pat(do.call(fn, args)) + gp <- grid::gpar(col = NA_character_, fill = pat) + convert_polygon_df_to_polygon_grob(boundary_df, gp = gp) } #' Grobs with patterns powered by the aRtsy package @@ -57,21 +58,41 @@ create_pattern_aRtsy <- function(params, boundary_df, aspect_ratio, #' } #' @seealso for more information about the `aRtsy` package. #' @export -grid.pattern_aRtsy <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ..., - type = "strokes", - fill = gp$fill %||% "grey80", - alpha = gp$alpha %||% NA_real_, - default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, vp = NULL) { - grid.pattern("aRtsy", x, y, id, - type = type, fill = fill, alpha = alpha, - default.units = default.units, name = name, gp = gp , draw = draw, vp = vp) +grid.pattern_aRtsy <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + type = "strokes", + fill = gp$fill %||% "grey80", + alpha = gp$alpha %||% NA_real_, + default.units = "npc", + name = NULL, + gp = gpar(), + draw = TRUE, + vp = NULL +) { + grid.pattern( + "aRtsy", + x, + y, + id, + type = type, + fill = fill, + alpha = alpha, + default.units = default.units, + name = name, + gp = gp, + draw = draw, + vp = vp + ) } #' @rdname grid.pattern_aRtsy #' @export names_aRtsy <- function() { - assert_suggested("aRtsy", "aRtsy") - requireNamespace("aRtsy", quietly = TRUE) - fns <- grep("^canvas", getNamespaceExports("aRtsy"), value = TRUE) - gsub("^canvas_", "", fns) + assert_suggested("aRtsy", "aRtsy") + requireNamespace("aRtsy", quietly = TRUE) + fns <- grep("^canvas", getNamespaceExports("aRtsy"), value = TRUE) + gsub("^canvas_", "", fns) } diff --git a/R/pattern_hex.R b/R/pattern_hex.R index 4bf46d1..f5be659 100644 --- a/R/pattern_hex.R +++ b/R/pattern_hex.R @@ -51,99 +51,106 @@ #' \url{https://en.wikipedia.org/wiki/Hexagonal_tiling#Uniform_colorings}. #' @export pattern_hex <- function(type = "hex", subtype = NULL, nrow = 5L, ncol = 5L) { - if (is.null(subtype) || is.na(subtype)) subtype <- 2L - stopifnot(is_integer(subtype)) - n <- as.integer(subtype) - if (type == "hex") { - if (n < 4L) { - type <- "hex1" - } else if (n == 4L) { - type <- "hex2" - } else if (n == 7L) { - type <- "hex3" - } else { - type <- "hex_skew" - } - } - m <- switch(type, - hex_skew = pattern_hex_skew(n, nrow, ncol), - hex1 = pattern_hex1(n, nrow, ncol), - hex2 = pattern_hex2(n, nrow, ncol), - hex3 = pattern_hex3(n, nrow, ncol), - abort(paste("Don't know hex pattern type", type))) - class(m) <- c("pattern_hex", "matrix", "array") - m + if (is.null(subtype) || is.na(subtype)) { + subtype <- 2L + } + stopifnot(is_integer(subtype)) + n <- as.integer(subtype) + if (type == "hex") { + if (n < 4L) { + type <- "hex1" + } else if (n == 4L) { + type <- "hex2" + } else if (n == 7L) { + type <- "hex3" + } else { + type <- "hex_skew" + } + } + m <- switch( + type, + hex_skew = pattern_hex_skew(n, nrow, ncol), + hex1 = pattern_hex1(n, nrow, ncol), + hex2 = pattern_hex2(n, nrow, ncol), + hex3 = pattern_hex3(n, nrow, ncol), + abort(paste("Don't know hex pattern type", type)) + ) + class(m) <- c("pattern_hex", "matrix", "array") + m } pattern_hex_skew <- function(n = NULL, nrow = 5L, ncol = 5L) { - m <- matrix(1L, nrow = nrow, ncol = ncol) - if (n == 1L) return(m) - s <- seq.int(n) - skip <- 0L - for (i in seq.int(nrow)) { - step <- skip + i - 1L - v <- rep_len(cycle_elements(s, step), ncol) - m[i, ] <- v - if (i %% 2 == 0) skip <- skip + 1L - } - m + m <- matrix(1L, nrow = nrow, ncol = ncol) + if (n == 1L) { + return(m) + } + s <- seq.int(n) + skip <- 0L + for (i in seq.int(nrow)) { + step <- skip + i - 1L + v <- rep_len(cycle_elements(s, step), ncol) + m[i, ] <- v + if (i %% 2 == 0) skip <- skip + 1L + } + m } pattern_hex1 <- function(n, nrow, ncol) { - stopifnot(n < 4L) - if (n == 2L) { - m <- pattern_hex_skew(3L, nrow, ncol) - indices <- which(m == 3L) - m[indices] <- 2L - m - } else { - pattern_hex_skew(n, nrow, ncol) - } + stopifnot(n < 4L) + if (n == 2L) { + m <- pattern_hex_skew(3L, nrow, ncol) + indices <- which(m == 3L) + m[indices] <- 2L + m + } else { + pattern_hex_skew(n, nrow, ncol) + } } pattern_hex2 <- function(n, nrow, ncol) { - stopifnot(n == 2L || n == 4L) - m <- matrix(2L, nrow = nrow, ncol = ncol) - v1 <- rep_len(1:2, ncol) - v3 <- rep_len(2:1, ncol) - for (i in seq.int(nrow)) { - im <- i %% 4L - if (im == 1L) { - m[i, ] <- v1 - } else if (im == 3L) { - m[i, ] <- v3 - } - } - if (n == 4L) { - v2 <- rep_len(3:4, ncol) - v4 <- rep_len(4:3, ncol) - for (i in seq.int(nrow)) { - im <- i %% 4L - if (im == 2L) { - m[i, ] <- v2 - } else if (im == 0L) { - m[i, ] <- v4 - } - } - } - m + stopifnot(n == 2L || n == 4L) + m <- matrix(2L, nrow = nrow, ncol = ncol) + v1 <- rep_len(1:2, ncol) + v3 <- rep_len(2:1, ncol) + for (i in seq.int(nrow)) { + im <- i %% 4L + if (im == 1L) { + m[i, ] <- v1 + } else if (im == 3L) { + m[i, ] <- v3 + } + } + if (n == 4L) { + v2 <- rep_len(3:4, ncol) + v4 <- rep_len(4:3, ncol) + for (i in seq.int(nrow)) { + im <- i %% 4L + if (im == 2L) { + m[i, ] <- v2 + } else if (im == 0L) { + m[i, ] <- v4 + } + } + } + m } pattern_hex3 <- function(n, nrow, ncol) { - stopifnot(n == 2L || n == 7L) - m <- matrix(1L, nrow = nrow, ncol = ncol) - if (n == 2L) - s <- c(1L, rep_len(2L, 6L)) - else - s <- seq.int(7L) - skip <- 0L - for (i in seq.int(nrow)) { - step <- skip + 4 * (i - 1L) - v <- rep_len(cycle_elements(s, step), ncol) - m[i, ] <- v - if (i %% 2 == 0) skip <- skip + 1L - } - m + stopifnot(n == 2L || n == 7L) + m <- matrix(1L, nrow = nrow, ncol = ncol) + if (n == 2L) { + s <- c(1L, rep_len(2L, 6L)) + } else { + s <- seq.int(7L) + } + skip <- 0L + for (i in seq.int(nrow)) { + step <- skip + 4 * (i - 1L) + v <- rep_len(cycle_elements(s, step), ncol) + m[i, ] <- v + if (i %% 2 == 0) skip <- skip + 1L + } + m } #' @rdname pattern_hex @@ -152,15 +159,16 @@ names_hex <- c("hex", "hex1", "hex2", "hex3", "hex_skew") #' @export print.pattern_hex <- function(x, ...) { - d <- dim(x) - x <- matrix(int_to_char(x), nrow = d[1], ncol = d[2]) - cat("/", rep("-", 2 * ncol(x)), "\\", "\n", sep = "") - for (i in rev(seq_len(nrow(x)))) { - if (i %% 2 == 1) - cat("|", paste0(" ", x[i, ]), "|", "\n", sep = "") - else - cat("|", paste0(x[i, ], " "), "|", "\n", sep = "") - } - cat("\\", rep("-", 2 * ncol(x)), "/", "\n", sep = "") - invisible(NULL) + d <- dim(x) + x <- matrix(int_to_char(x), nrow = d[1], ncol = d[2]) + cat("/", rep("-", 2 * ncol(x)), "\\", "\n", sep = "") + for (i in rev(seq_len(nrow(x)))) { + if (i %% 2 == 1) { + cat("|", paste0(" ", x[i, ]), "|", "\n", sep = "") + } else { + cat("|", paste0(x[i, ], " "), "|", "\n", sep = "") + } + } + cat("\\", rep("-", 2 * ncol(x)), "/", "\n", sep = "") + invisible(NULL) } diff --git a/R/pattern_square.R b/R/pattern_square.R index 1ae59ab..4e7ebc2 100644 --- a/R/pattern_square.R +++ b/R/pattern_square.R @@ -79,135 +79,155 @@ #' [pattern_weave()] for more information on "weave" patterns. #' @export pattern_square <- function(type = "diagonal", subtype = NULL, nrow = 5L, ncol = 5L) { - if (type %in% names_weave) { - v <- as.integer(!pattern_weave(type, subtype, nrow, ncol)) + 1L - m <- matrix(v, nrow = nrow, ncol = ncol) - } else { - m <- switch(type, - diagonal = pattern_diagonal(subtype, nrow, ncol), - diagonal_skew = pattern_diagonal(subtype, nrow, ncol, skew = TRUE), - horizontal = pattern_horizontal(subtype, nrow, ncol), - square = pattern_square_type(subtype, nrow, ncol), - square_tiling = pattern_square_tiling(subtype, nrow, ncol), - vertical = pattern_vertical(subtype, nrow, ncol), - abort(paste("Don't recognize square pattern type", type)) - ) - } - class(m) <- c("pattern_square", "matrix", "array") - m + if (type %in% names_weave) { + v <- as.integer(!pattern_weave(type, subtype, nrow, ncol)) + 1L + m <- matrix(v, nrow = nrow, ncol = ncol) + } else { + m <- switch( + type, + diagonal = pattern_diagonal(subtype, nrow, ncol), + diagonal_skew = pattern_diagonal(subtype, nrow, ncol, skew = TRUE), + horizontal = pattern_horizontal(subtype, nrow, ncol), + square = pattern_square_type(subtype, nrow, ncol), + square_tiling = pattern_square_tiling(subtype, nrow, ncol), + vertical = pattern_vertical(subtype, nrow, ncol), + abort(paste("Don't recognize square pattern type", type)) + ) + } + class(m) <- c("pattern_square", "matrix", "array") + m } #' @rdname pattern_square #' @export -names_square <- c("diagonal", "diagonal_skew", "horizontal", - "square", "square_tiling", "vertical") +names_square <- c("diagonal", "diagonal_skew", "horizontal", "square", "square_tiling", "vertical") pattern_diagonal <- function(subtype = NULL, nrow = 5L, ncol = 5L, skew = FALSE) { - if (is.null(subtype) || is.na(subtype)) subtype <- 3L - stopifnot(is_integer(subtype)) - m <- matrix(1L, nrow = nrow, ncol = ncol) - n <- as.integer(subtype) - if (n == 1L) return(m) - s <- seq.int(n) - for (e in s) { - step <- ifelse(skew, -(e - 1L), e - 1L) - v <- rep(cycle_elements(s, step), length.out = ncol) - for (i in seq(e, nrow, n)) { - m[i, ] <- v - } - } - m + if (is.null(subtype) || is.na(subtype)) { + subtype <- 3L + } + stopifnot(is_integer(subtype)) + m <- matrix(1L, nrow = nrow, ncol = ncol) + n <- as.integer(subtype) + if (n == 1L) { + return(m) + } + s <- seq.int(n) + for (e in s) { + step <- ifelse(skew, -(e - 1L), e - 1L) + v <- rep(cycle_elements(s, step), length.out = ncol) + for (i in seq(e, nrow, n)) { + m[i, ] <- v + } + } + m } pattern_horizontal <- function(subtype = NULL, nrow = 5L, ncol = 5L) { - if (is.null(subtype) || is.na(subtype)) subtype <- 3L - stopifnot(is_integer(subtype)) - n <- as.integer(subtype) - if (nrow > 2L && n > 1L) { - v1 <- rev(rep(c(seq.int(n, 2L, -1L), 1L), length.out = nrow %/% 2)) - v2 <- rep(seq.int(n), length.out = (nrow %/% 2) + (nrow %% 2)) - v <- c(v1, v2) - } else { - s <- seq.int(n) - v <- rep(s, length.out = nrow) - } - v <- rep.int(v, ncol) - matrix(v, nrow = nrow, ncol = ncol) + if (is.null(subtype) || is.na(subtype)) { + subtype <- 3L + } + stopifnot(is_integer(subtype)) + n <- as.integer(subtype) + if (nrow > 2L && n > 1L) { + v1 <- rev(rep(c(seq.int(n, 2L, -1L), 1L), length.out = nrow %/% 2)) + v2 <- rep(seq.int(n), length.out = (nrow %/% 2) + (nrow %% 2)) + v <- c(v1, v2) + } else { + s <- seq.int(n) + v <- rep(s, length.out = nrow) + } + v <- rep.int(v, ncol) + matrix(v, nrow = nrow, ncol = ncol) } pattern_square_type <- function(subtype, nrow, ncol) { - if (is.null(subtype) || is.na(subtype)) subtype <- 3L - stopifnot(is_integer(subtype)) - n <- as.integer(subtype) - if (n <= 4) - pattern_square_tiling(n, nrow, ncol) - else - pattern_diagonal(n, nrow, ncol) + if (is.null(subtype) || is.na(subtype)) { + subtype <- 3L + } + stopifnot(is_integer(subtype)) + n <- as.integer(subtype) + if (n <= 4) { + pattern_square_tiling(n, nrow, ncol) + } else { + pattern_diagonal(n, nrow, ncol) + } } pattern_square_tiling <- function(subtype, nrow, ncol) { - if (is.null(subtype) || is.na(subtype)) subtype <- 3L - stopifnot(is_integer(subtype)) - if (is.character(subtype)) subtype <- strsplit(subtype, "")[[1]] - m <- matrix(1L, nrow = nrow, ncol = ncol) - n <- as.integer(subtype) - if (all(n == 1L)) return(m) - if (length(n) == 1L) { - n <- switch(as.character(subtype), - `1` = c(1L, 1L, 1L, 1L), - `2` = c(2L, 1L, 1L, 2L), - `3` = c(1L, 2L, 3L, 1L), - `4` = 1:4, - n) - } - n <- rep_len(n, 4) - vt <- rep_len(n[1:2], ncol) - vb <- rep_len(n[3:4], ncol) - for (i in seq_len(nrow)) { - if (i %% 2 == 1) - m[i, ] <- vb - else - m[i, ] <- vt - } - m + if (is.null(subtype) || is.na(subtype)) { + subtype <- 3L + } + stopifnot(is_integer(subtype)) + if (is.character(subtype)) { + subtype <- strsplit(subtype, "")[[1]] + } + m <- matrix(1L, nrow = nrow, ncol = ncol) + n <- as.integer(subtype) + if (all(n == 1L)) { + return(m) + } + if (length(n) == 1L) { + n <- switch( + as.character(subtype), + `1` = c(1L, 1L, 1L, 1L), + `2` = c(2L, 1L, 1L, 2L), + `3` = c(1L, 2L, 3L, 1L), + `4` = 1:4, + n + ) + } + n <- rep_len(n, 4) + vt <- rep_len(n[1:2], ncol) + vb <- rep_len(n[3:4], ncol) + for (i in seq_len(nrow)) { + if (i %% 2 == 1) { + m[i, ] <- vb + } else { + m[i, ] <- vt + } + } + m } pattern_vertical <- function(subtype = NULL, nrow = 5L, ncol = 5L) { - if (is.null(subtype) || is.na(subtype)) subtype <- 3L - stopifnot(is_integer(subtype)) - n <- as.integer(subtype) - if (ncol > 2L && n > 1L) { - v1 <- rev(rep(c(seq.int(n, 2L, -1L), 1L), length.out = ncol %/% 2)) - v2 <- rep(seq.int(n), length.out = (ncol %/% 2) + (ncol %% 2)) - v <- c(v1, v2) - } else { - s <- seq.int(n) - v <- rep(s, length.out = ncol) - } - v <- rep.int(v, nrow) - matrix(v, nrow = nrow, ncol = ncol, byrow = TRUE) + if (is.null(subtype) || is.na(subtype)) { + subtype <- 3L + } + stopifnot(is_integer(subtype)) + n <- as.integer(subtype) + if (ncol > 2L && n > 1L) { + v1 <- rev(rep(c(seq.int(n, 2L, -1L), 1L), length.out = ncol %/% 2)) + v2 <- rep(seq.int(n), length.out = (ncol %/% 2) + (ncol %% 2)) + v <- c(v1, v2) + } else { + s <- seq.int(n) + v <- rep(s, length.out = ncol) + } + v <- rep.int(v, nrow) + matrix(v, nrow = nrow, ncol = ncol, byrow = TRUE) } #' @export print.pattern_square <- function(x, ...) { - d <- dim(x) - x <- matrix(int_to_char(x), nrow = d[1], ncol = d[2]) - cat("/", rep("-", ncol(x)), "\\", "\n") - for (i in rev(seq_len(nrow(x)))) { - cat("|", x[i, ], "|", "\n") - } - cat("\\", rep("-", ncol(x)), "/", "\n") - invisible(NULL) + d <- dim(x) + x <- matrix(int_to_char(x), nrow = d[1], ncol = d[2]) + cat("/", rep("-", ncol(x)), "\\", "\n") + for (i in rev(seq_len(nrow(x)))) { + cat("|", x[i, ], "|", "\n") + } + cat("\\", rep("-", ncol(x)), "/", "\n") + invisible(NULL) } is_pattern_square <- function(type) { - (type %in% names_weave) || (type %in% names_square) + (type %in% names_weave) || (type %in% names_square) } int_to_char <- function(x) { - stopifnot(max(x) < 36L) - char <- as.character(x) - indices <- which(x > 9L) - char[indices] <- LETTERS[x[indices] - 9L] - char + stopifnot(max(x) < 36L) + char <- as.character(x) + indices <- which(x > 9L) + char[indices] <- LETTERS[x[indices] - 9L] + char } diff --git a/R/pattern_weave.R b/R/pattern_weave.R index 545fc45..5c43afa 100644 --- a/R/pattern_weave.R +++ b/R/pattern_weave.R @@ -88,105 +88,112 @@ #' for further information on "satin" weaves. #' @export pattern_weave <- function(type = "plain", subtype = NULL, nrow = 5L, ncol = 5L) { - spec <- get_weave_spec(type, subtype) + spec <- get_weave_spec(type, subtype) - if (is_twill(type)) - m <- pattern_weave_twill(spec, nrow, ncol) - else - m <- pattern_weave_matt(spec, nrow, ncol) - class(m) <- c("pattern_weave", "matrix", "array") - m + if (is_twill(type)) { + m <- pattern_weave_twill(spec, nrow, ncol) + } else { + m <- pattern_weave_matt(spec, nrow, ncol) + } + class(m) <- c("pattern_weave", "matrix", "array") + m } # rep_each(1:2, 1:4) -> c(1, 2,2, 1,1,1, 2,2,2,2) rep_each <- function(x, each) { - n <- max(lengths(list(x, each))) - x <- rep_len(x, n) - each <- rep_len(each, n) - unlist(lapply(seq.int(n), function(i) rep_len(x[i], each[i]))) + n <- max(lengths(list(x, each))) + x <- rep_len(x, n) + each <- rep_len(each, n) + unlist(lapply(seq.int(n), function(i) rep_len(x[i], each[i]))) } pattern_weave_matt <- function(spec, nrow, ncol) { - m <- matrix(FALSE, nrow = nrow, ncol = ncol) - v <- rep_each(c(TRUE, FALSE), spec$up_down) - v <- rep_len(v, nrow) - not_v <- !v - repeat_up_down <- rep_each(c(TRUE, FALSE), spec$up_down_reps) - repeat_up_down <- rep_len(repeat_up_down, ncol) - for (j in seq.int(ncol)) { - if (repeat_up_down[j]) - m[, j] <- v - else - m[, j] <- not_v - } - m + m <- matrix(FALSE, nrow = nrow, ncol = ncol) + v <- rep_each(c(TRUE, FALSE), spec$up_down) + v <- rep_len(v, nrow) + not_v <- !v + repeat_up_down <- rep_each(c(TRUE, FALSE), spec$up_down_reps) + repeat_up_down <- rep_len(repeat_up_down, ncol) + for (j in seq.int(ncol)) { + if (repeat_up_down[j]) { + m[, j] <- v + } else { + m[, j] <- not_v + } + } + m } pattern_weave_twill <- function(spec, nrow, ncol) { - m <- matrix(FALSE, nrow = nrow, ncol = ncol) - skip <- 0L - v0 <- rep_each(c(TRUE, FALSE), spec$up_down) - for (j in seq_len(ncol)) { - v <- cycle_elements(v0, -skip) - if (spec$zigzag) - v <- add_zigzag(v) - if (spec$herringbone) - v <- add_herringbone(v) - v <- rep_len(v, nrow) - m[, j] <- v - skip <- skip + spec$move - } - m + m <- matrix(FALSE, nrow = nrow, ncol = ncol) + skip <- 0L + v0 <- rep_each(c(TRUE, FALSE), spec$up_down) + for (j in seq_len(ncol)) { + v <- cycle_elements(v0, -skip) + if (spec$zigzag) { + v <- add_zigzag(v) + } + if (spec$herringbone) { + v <- add_herringbone(v) + } + v <- rep_len(v, nrow) + m[, j] <- v + skip <- skip + spec$move + } + m } #' @export print.pattern_weave <- function(x, ...) { - indices_x <- which(x) - indices_o <- which(!x) - x[indices_x] <- "X" - x[indices_o] <- " " - cat("/", rep_len("-", ncol(x)), "\\", "\n") - for (i in rev(seq_len(nrow(x)))) { - cat("|", x[i, ], "|", "\n") - } - cat("\\", rep_len("-", ncol(x)), "/", "\n") - invisible(NULL) + indices_x <- which(x) + indices_o <- which(!x) + x[indices_x] <- "X" + x[indices_o] <- " " + cat("/", rep_len("-", ncol(x)), "\\", "\n") + for (i in rev(seq_len(nrow(x)))) { + cat("|", x[i, ], "|", "\n") + } + cat("\\", rep_len("-", ncol(x)), "/", "\n") + invisible(NULL) } #' @rdname pattern_weave #' @export -names_weave <- c("basket", - "matt", - "matt_irregular", - "plain", - "rib_warp", - "satin", - "twill", - "twill_elongated", - "twill_herringbone", - "twill_zigzag") +names_weave <- c( + "basket", + "matt", + "matt_irregular", + "plain", + "rib_warp", + "satin", + "twill", + "twill_elongated", + "twill_herringbone", + "twill_zigzag" +) get_weave_spec <- function(type = "plain", subtype = NULL) { - if (!is.null(subtype) && is.na(subtype)) subtype <- NULL - switch(type, - # cases of irregular matt weave - basket = get_weave_spec_matt(subtype %||% 2L), - plain = get_weave_spec_matt(subtype %||% 1L), - matt = get_weave_spec_matt(subtype %||% 3L), - matt_irregular = get_weave_spec_matt(subtype %||% "3/2(4+2)"), - rib_warp = get_weave_spec_matt(subtype %||% 2L, - warp = TRUE), + if (!is.null(subtype) && is.na(subtype)) { + subtype <- NULL + } + switch( + type, + # cases of irregular matt weave + basket = get_weave_spec_matt(subtype %||% 2L), + plain = get_weave_spec_matt(subtype %||% 1L), + matt = get_weave_spec_matt(subtype %||% 3L), + matt_irregular = get_weave_spec_matt(subtype %||% "3/2(4+2)"), + rib_warp = get_weave_spec_matt(subtype %||% 2L, warp = TRUE), - # cases of elongated twill weave - satin = get_weave_spec_twill(subtype %||% 5L), - twill = get_weave_spec_twill(subtype %||% "2/1"), - twill_elongated = get_weave_spec_twill(subtype %||% "4/3(2)"), - twill_zigzag = get_weave_spec_twill(subtype %||% "4/3(2)", - zigzag = TRUE), - twill_herringbone = get_weave_spec_twill(subtype %||% "4/3(2)", - herringbone = TRUE), + # cases of elongated twill weave + satin = get_weave_spec_twill(subtype %||% 5L), + twill = get_weave_spec_twill(subtype %||% "2/1"), + twill_elongated = get_weave_spec_twill(subtype %||% "4/3(2)"), + twill_zigzag = get_weave_spec_twill(subtype %||% "4/3(2)", zigzag = TRUE), + twill_herringbone = get_weave_spec_twill(subtype %||% "4/3(2)", herringbone = TRUE), - abort(paste("Don't know weave type", type))) + abort(paste("Don't know weave type", type)) + ) } is_twill <- function(type) grepl("^twill|^satin", type) @@ -194,71 +201,79 @@ is_twill <- function(type) grepl("^twill|^satin", type) # elongated twill U/D(M) # U = number warp up, D = number warp down, M = move number get_weave_spec_twill <- function(subtype = "2/1(2)", zigzag = FALSE, herringbone = FALSE) { - if (is_integer(subtype)) - subtype <- n_to_twill(subtype) - if (is_ud(subtype)) - subtype <- ud_to_twill(subtype) + if (is_integer(subtype)) { + subtype <- n_to_twill(subtype) + } + if (is_ud(subtype)) { + subtype <- ud_to_twill(subtype) + } - up_down <- get_ud(subtype) - move <- get_extra(subtype) - list(up_down = up_down, move = move, herringbone = herringbone, zigzag = zigzag) + up_down <- get_ud(subtype) + move <- get_extra(subtype) + list(up_down = up_down, move = move, herringbone = herringbone, zigzag = zigzag) } # irregular matt U/D(L+R) # U = number warp up, D = number warp down, # L = number of warp up in repeat, R = number of warp down in repeat get_weave_spec_matt <- function(subtype = "3/3(4+2)", warp = FALSE) { - if (is_integer(subtype)) - subtype <- n_to_matt(subtype, warp = warp) - if (is_ud(subtype)) - subtype <- ud_to_matt(subtype, warp = warp) + if (is_integer(subtype)) { + subtype <- n_to_matt(subtype, warp = warp) + } + if (is_ud(subtype)) { + subtype <- ud_to_matt(subtype, warp = warp) + } - up_down <- get_ud(subtype) - reps <- get_extra(subtype) - list(up_down = up_down, up_down_reps = reps) + up_down <- get_ud(subtype) + reps <- get_extra(subtype) + list(up_down = up_down, up_down_reps = reps) } n_to_matt <- function(n = 1L, warp = FALSE) { - n <- as.integer(n) - if (warp) - glue("{n}/{n}(1+1)") - else - glue("{n}/{n}({n}+{n})") + n <- as.integer(n) + if (warp) { + glue("{n}/{n}(1+1)") + } else { + glue("{n}/{n}({n}+{n})") + } } ud_to_matt <- function(ud = "2/1", warp = FALSE) { - v_ud <- get_ud(ud) - if (warp) - glue("{ud}(1+1)") - else - glue("{ud}({paste(v_ud, collapse='+')})") + v_ud <- get_ud(ud) + if (warp) { + glue("{ud}(1+1)") + } else { + glue("{ud}({paste(v_ud, collapse='+')})") + } } # satin is special case of twill elongated # legal satin move is not one, repeat number, repeat number minus one, (multiple of) a factor of repeat number # legal: 5:2 | 7:2,3 | 8:3 | 9:2,4 | 10:3 | 11:2,3,4,5 | 12:5 | 13: 2,3,4,5,6 | 14:3,5 n_to_twill <- function(n = 1L) { - n <- as.integer(n) - if (n < 5L) { - move <- 1L - } else { - move <- switch(as.character(n), - "5" = 2L, - "6" = 1L, # no legal satin move - "7" = 3L, - "8" = 3L, - "9" = 4L, - "10" = 3L, - "11" = 5L, - "12" = 5L, - "13" = 6L, - "14" = 5L, - n - 1L) - } - glue("{n-1}/1({move})") + n <- as.integer(n) + if (n < 5L) { + move <- 1L + } else { + move <- switch( + as.character(n), + "5" = 2L, + "6" = 1L, # no legal satin move + "7" = 3L, + "8" = 3L, + "9" = 4L, + "10" = 3L, + "11" = 5L, + "12" = 5L, + "13" = 6L, + "14" = 5L, + n - 1L + ) + } + glue("{n-1}/1({move})") } ud_to_twill <- function(ud = "2/1") { - glue("{ud}(1)") + glue("{ud}(1)") } is_integer <- function(s) is.integer(s) || grepl("^[[:digit:]]+$", s) @@ -268,17 +283,19 @@ is_ud <- function(ud) grepl("^[[:digit:]]+/[[:digit:]]+(\\*[[:digit:]]+/[[:digit # "5/1(4+2)" -> c(5L, 1L) or "5/1(3)" -> c(5L, 1L) get_ud <- function(ude) { - ud <- as.integer(strsplit(gsub("\\(.*", "", ude), "/|\\*")[[1]]) - stopifnot(length(ud) %% 2L == 0L) - ud + ud <- as.integer(strsplit(gsub("\\(.*", "", ude), "/|\\*")[[1]]) + stopifnot(length(ud) %% 2L == 0L) + ud } # "5/1(4+2)" -> c(4L, 2L) or "5/1(3)" -> c(3L) -get_extra <- function(ude) as.integer(strsplit(gsub("[[:digit:]/*]+\\((.*)\\)", "\\1", ude), "\\+")[[1]]) +get_extra <- function(ude) { + as.integer(strsplit(gsub("[[:digit:]/*]+\\((.*)\\)", "\\1", ude), "\\+")[[1]]) +} add_zigzag <- function(x) { - n <- length(x) - c(x, rev(x[-n]), x[n]) + n <- length(x) + c(x, rev(x[-n]), x[n]) } add_herringbone <- function(x) c(x, !rev(x)) diff --git a/R/reset_image_cache.R b/R/reset_image_cache.R index 10f7707..c2766d0 100644 --- a/R/reset_image_cache.R +++ b/R/reset_image_cache.R @@ -5,5 +5,5 @@ #' `reset_image_cache()` resets this cache. #' @export reset_image_cache <- function() { - memoise::forget(img_read_memoised) + memoise::forget(img_read_memoised) } diff --git a/R/standalone-guess_has_R4.1_features.R b/R/standalone-guess_has_R4.1_features.R index e5e564e..417f371 100644 --- a/R/standalone-guess_has_R4.1_features.R +++ b/R/standalone-guess_has_R4.1_features.R @@ -43,77 +43,91 @@ #' #' @keywords internal #' @noRd -guess_has_R4.1_features <- function(features = c("clippingPaths", "gradients", "masks", "patterns")) { - if (getRversion() < "4.1.0") - return(FALSE) +guess_has_R4.1_features <- function( + features = c("clippingPaths", "gradients", "masks", "patterns") +) { + if (getRversion() < "4.1.0") { + return(FALSE) + } - # In R 4.2 `dev.capabilities()` can confirm/deny R 4.1 graphic feature support - # if active graphics device has implemented this feature - if (getRversion() >= "4.2.0") { - dev_capabilities <- grDevices::dev.capabilities() - if (confirm_via_dev_capabilities(features, dev_capabilities)) - return(TRUE) - if (deny_via_dev_capabilities(features, dev_capabilities)) - return(FALSE) - } + # In R 4.2 `dev.capabilities()` can confirm/deny R 4.1 graphic feature support + # if active graphics device has implemented this feature + if (getRversion() >= "4.2.0") { + dev_capabilities <- grDevices::dev.capabilities() + if (confirm_via_dev_capabilities(features, dev_capabilities)) { + return(TRUE) + } + if (deny_via_dev_capabilities(features, dev_capabilities)) { + return(FALSE) + } + } - device <- names(grDevices::dev.cur()) - if (device %in% c("cairo_pdf", "cairo_ps", "pdf", "svg", "X11cairo")) { - TRUE - } else if (device %in% c("bmp", "jpeg", "png", "tiff")) { - # on unix non-"cairo" type have different device names from "cairo" type - # but on Windows can't distinguish between `type = "windows"` or `type = "cairo"` - .Platform$OS.type == "unix" - } else if (device %in% c("agg_jpeg", "agg_ppm", "agg_png", "agg_tiff")) { - utils::packageVersion("ragg") >= "1.2.0" - } else if (device == "devSVG") { - # `vdiffr:::svglite()` has name "devSVG_vdiffr" since v1.0.6 - utils::packageVersion("svglite") >= "2.1.0" - } else { - FALSE - } + device <- names(grDevices::dev.cur()) + if (device %in% c("cairo_pdf", "cairo_ps", "pdf", "svg", "X11cairo")) { + TRUE + } else if (device %in% c("bmp", "jpeg", "png", "tiff")) { + # on unix non-"cairo" type have different device names from "cairo" type + # but on Windows can't distinguish between `type = "windows"` or `type = "cairo"` + .Platform$OS.type == "unix" + } else if (device %in% c("agg_jpeg", "agg_ppm", "agg_png", "agg_tiff")) { + utils::packageVersion("ragg") >= "1.2.0" + } else if (device == "devSVG") { + # `vdiffr:::svglite()` has name "devSVG_vdiffr" since v1.0.6 + utils::packageVersion("svglite") >= "2.1.0" + } else { + FALSE + } } # Will always return FALSE if called within R 4.1 # or if graphics device hasn't been updated to provide this information # even if the device had been updated to provide R 4.1 graphic feature support -confirm_via_dev_capabilities <- function(features = c("clippingPaths", "gradients", "masks", "patterns"), - dev_capabilities = grDevices::dev.capabilities()) { - for (feature in features) { - if (!confirm_feature(feature, dev_capabilities)) - return(FALSE) - } - TRUE +confirm_via_dev_capabilities <- function( + features = c("clippingPaths", "gradients", "masks", "patterns"), + dev_capabilities = grDevices::dev.capabilities() +) { + for (feature in features) { + if (!confirm_feature(feature, dev_capabilities)) { + return(FALSE) + } + } + TRUE } confirm_feature <- function(feature, dev_capabilities) { - switch(feature, - clippingPaths = isTRUE(dev_capabilities$clippingPaths), - gradients = all(c("LinearGradient", "RadialGradient") %in% dev_capabilities$patterns), - masks = "alpha" %in% dev_capabilities$masks, - patterns = "TilingPattern" %in% dev_capabilities$patterns - ) + switch( + feature, + clippingPaths = isTRUE(dev_capabilities$clippingPaths), + gradients = all(c("LinearGradient", "RadialGradient") %in% dev_capabilities$patterns), + masks = "alpha" %in% dev_capabilities$masks, + patterns = "TilingPattern" %in% dev_capabilities$patterns + ) } # Will return `TRUE` if `dev.capabilities()` explicitly indicates # the given features are not supported (versus merely missing a positive indication) -deny_via_dev_capabilities <- function(features = c("clippingPaths", "gradients", "masks", "patterns"), - dev_capabilities = grDevices::dev.capabilities()) { - for (feature in features) { - if (deny_feature(feature, dev_capabilities)) - return(TRUE) - } - FALSE +deny_via_dev_capabilities <- function( + features = c("clippingPaths", "gradients", "masks", "patterns"), + dev_capabilities = grDevices::dev.capabilities() +) { + for (feature in features) { + if (deny_feature(feature, dev_capabilities)) { + return(TRUE) + } + } + FALSE } deny_feature <- function(feature, dev_capabilities) { - switch(feature, - clippingPaths = isFALSE(dev_capabilities$clippingPaths), - gradients = !is.na(dev_capabilities$patterns) && - !all(c("LinearGradient", "RadialGradient") %in% dev_capabilities$patterns), - masks = !is.na(dev_capabilities$masks) && !("alpha" %in% dev_capabilities$masks), - patterns = !is.na(dev_capabilities$patterns) && !("TilingPattern" %in% dev_capabilities$patterns) - ) + switch( + feature, + clippingPaths = isFALSE(dev_capabilities$clippingPaths), + gradients = !is.na(dev_capabilities$patterns) && + !all(c("LinearGradient", "RadialGradient") %in% dev_capabilities$patterns), + masks = !is.na(dev_capabilities$masks) && !("alpha" %in% dev_capabilities$masks), + patterns = !is.na(dev_capabilities$patterns) && + !("TilingPattern" %in% dev_capabilities$patterns) + ) } # nocov end diff --git a/R/standalone-update_alpha.R b/R/standalone-update_alpha.R index 69cf5a4..7663676 100644 --- a/R/standalone-update_alpha.R +++ b/R/standalone-update_alpha.R @@ -45,34 +45,34 @@ # Tweaked by Trevor L. Davis to remove external dependencies # and work better for {ggpattern} / {gridpattern} use cases. update_alpha <- function(fill, alpha) { - if (!is.list(fill)) { - # Happy path of no patterns - update_alpha_col(fill, alpha) - } else if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) { - # Path with patterns - update_pattern_alpha(fill, alpha) - } else if (is.list(fill) && length(fill) == 1L && !any(vapply(fill, is_pattern, logical(1)))) { - # List of length one of (possibly multiple) colours - update_alpha_col(fill[[1L]], alpha) - } else { - # We are either dealing with faulty fill specification - stop("`fill` must be a vector of colours or list of objects.") - } + if (!is.list(fill)) { + # Happy path of no patterns + update_alpha_col(fill, alpha) + } else if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) { + # Path with patterns + update_pattern_alpha(fill, alpha) + } else if (is.list(fill) && length(fill) == 1L && !any(vapply(fill, is_pattern, logical(1)))) { + # List of length one of (possibly multiple) colours + update_alpha_col(fill[[1L]], alpha) + } else { + # We are either dealing with faulty fill specification + stop("`fill` must be a vector of colours or list of objects.") + } } # Similar to grid:::is.pattern is_pattern <- function(x) { - inherits(x, "GridPattern") + inherits(x, "GridPattern") } # replacement for `scales::alpha()` that only depends on {grDevices} update_alpha_col <- function(colour, alpha = NA_real_) { - n <- max(lengths(list(colour, alpha))) - colour <- rep_len(colour, n) - alpha <- rep_len(alpha, n) - m <- grDevices::col2rgb(colour, alpha = TRUE) / 255.0 - m[4, ] <- ifelse(is.na(alpha), m[4, ], alpha) - apply(m, 2, function(x) grDevices::rgb(x[1], x[2], x[3], x[4])) + n <- max(lengths(list(colour, alpha))) + colour <- rep_len(colour, n) + alpha <- rep_len(alpha, n) + m <- grDevices::col2rgb(colour, alpha = TRUE) / 255.0 + m[4, ] <- ifelse(is.na(alpha), m[4, ], alpha) + apply(m, 2, function(x) grDevices::rgb(x[1], x[2], x[3], x[4])) } #' Modify transparency for patterns @@ -87,46 +87,45 @@ update_alpha_col <- function(colour, alpha = NA_real_) { #' @return `x` with modified transparency #' @noRd update_pattern_alpha <- function(x, alpha, ...) { - UseMethod("update_pattern_alpha") + UseMethod("update_pattern_alpha") } #' @export update_pattern_alpha.default <- function(x, alpha, ..., name = NULL) { - if (!is.atomic(x)) { - stop("Can't apply `update_pattern_alpha()` to this object.") - } - grid::pattern(grid::rectGrob(name = name), - gp = grid::gpar(fill = update_alpha_col(x, alpha))) + if (!is.atomic(x)) { + stop("Can't apply `update_pattern_alpha()` to this object.") + } + grid::pattern(grid::rectGrob(name = name), gp = grid::gpar(fill = update_alpha_col(x, alpha))) } #' @export update_pattern_alpha.GridPattern <- function(x, alpha, ...) { - x$colours <- update_alpha_col(x$colours, alpha[1]) - x + x$colours <- update_alpha_col(x$colours, alpha[1]) + x } #' @export update_pattern_alpha.GridTilingPattern <- function(x, alpha, ...) { - if (all(is.na(alpha) | alpha == 1)) { - return(x) - } - grob <- rlang::env_get(environment(x$f), "grob") - gp <- grid::gpar(fill = update_alpha_col("white", alpha)) - mask <- grid::as.mask(grid::rectGrob(gp = gp)) - if (is.null(grob$vp)) { - grob$vp <- grid::viewport(mask = mask) - } else { - grob$vp <- grid::editViewport(grob$vp, mask = mask) - } - new_env <- new.env(parent = environment(x$f)) - rlang::env_bind(new_env, grob = grob) - environment(x$f) <- new_env - x + if (all(is.na(alpha) | alpha == 1)) { + return(x) + } + grob <- rlang::env_get(environment(x$f), "grob") + gp <- grid::gpar(fill = update_alpha_col("white", alpha)) + mask <- grid::as.mask(grid::rectGrob(gp = gp)) + if (is.null(grob$vp)) { + grob$vp <- grid::viewport(mask = mask) + } else { + grob$vp <- grid::editViewport(grob$vp, mask = mask) + } + new_env <- new.env(parent = environment(x$f)) + rlang::env_bind(new_env, grob = grob) + environment(x$f) <- new_env + x } #' @export update_pattern_alpha.list <- function(x, alpha, ...) { - Map(update_pattern_alpha, x = x, alpha = alpha) + Map(update_pattern_alpha, x = x, alpha = alpha) } # nocov end diff --git a/R/star_scale.R b/R/star_scale.R index 2ad8efb..1f9803e 100644 --- a/R/star_scale.R +++ b/R/star_scale.R @@ -29,77 +29,82 @@ #' spacing = 0.2, density = 0.8) #' @export star_scale <- function(n_vertices, angle, external = FALSE) { - if (external) - angle <- external_to_internal(n_vertices, angle) - if (n_vertices == 2) - return(star_scale2(angle)) - stopifnot(angle >= 0, angle <= 180 * (1 - 2/n_vertices)) - # we'll work with external degree - angle <- internal_to_external(n_vertices, angle) - t <- 360 / n_vertices - xy1 <- list(x = 1, y = 0) - xy2 <- list(x = to_x(t, 1), y = to_y(t, 1)) - xyc <- list(x = mean(c(xy1$x, xy2$x)), y = mean(c(xy1$y, xy2$y))) - xyf <- list(x = to_x(t/2, 1), y = to_y(t/2, 1)) - dist_f <- dist(xyf, xyc) - a2 <- dist(xy1, xyc) - beta <- (180 - angle) / 2 - b <- a2 * sin(to_radians(beta)) / sin(to_radians(angle/2)) - r <- 1 - b - dist_f - stopifnot(r >= 0) - r + if (external) { + angle <- external_to_internal(n_vertices, angle) + } + if (n_vertices == 2) { + return(star_scale2(angle)) + } + stopifnot(angle >= 0, angle <= 180 * (1 - 2 / n_vertices)) + # we'll work with external degree + angle <- internal_to_external(n_vertices, angle) + t <- 360 / n_vertices + xy1 <- list(x = 1, y = 0) + xy2 <- list(x = to_x(t, 1), y = to_y(t, 1)) + xyc <- list(x = mean(c(xy1$x, xy2$x)), y = mean(c(xy1$y, xy2$y))) + xyf <- list(x = to_x(t / 2, 1), y = to_y(t / 2, 1)) + dist_f <- dist(xyf, xyc) + a2 <- dist(xy1, xyc) + beta <- (180 - angle) / 2 + b <- a2 * sin(to_radians(beta)) / sin(to_radians(angle / 2)) + r <- 1 - b - dist_f + stopifnot(r >= 0) + r } star_scale2 <- function(angle) { - stopifnot(angle >= 0, angle <= 90) - a1 <- angle / 2 - a2 <- 180 - 90 - a1 - r <- sin(to_radians(a1)) / sin(to_radians(a2)) - stopifnot(r >= 0) - r + stopifnot(angle >= 0, angle <= 90) + a1 <- angle / 2 + a2 <- 180 - 90 - a1 + r <- sin(to_radians(a1)) / sin(to_radians(a2)) + stopifnot(r >= 0) + r } #' @rdname star_scale #' @export star_angle <- function(n_vertices, scale, external = FALSE) { - stopifnot(scale >= 0, scale <= 1) - if (n_vertices == 2) - return(star_angle2(scale, external)) - t <- 360 / n_vertices - xy1 <- list(x = 1, y = 0) - xy2 <- list(x = to_x(t, 1), y = to_y(t, 1)) - xyv <- list(x = to_x(t/2, scale), y = to_y(t/2, scale)) - xyc <- list(x = mean(c(xy1$x, xy2$x)), y = mean(c(xy1$y, xy2$y))) - a2 <- dist(xy1, xyc) - c <- dist(xyv, xy1) - d <- to_degrees(2 * asin(a2 / c)) - if (!external) - d <- external_to_internal(n_vertices, d) - d + stopifnot(scale >= 0, scale <= 1) + if (n_vertices == 2) { + return(star_angle2(scale, external)) + } + t <- 360 / n_vertices + xy1 <- list(x = 1, y = 0) + xy2 <- list(x = to_x(t, 1), y = to_y(t, 1)) + xyv <- list(x = to_x(t / 2, scale), y = to_y(t / 2, scale)) + xyc <- list(x = mean(c(xy1$x, xy2$x)), y = mean(c(xy1$y, xy2$y))) + a2 <- dist(xy1, xyc) + c <- dist(xyv, xy1) + d <- to_degrees(2 * asin(a2 / c)) + if (!external) { + d <- external_to_internal(n_vertices, d) + } + d } star_angle2 <- function(scale, external = FALSE) { - d <- sqrt(1 + scale^2) - d <- 2 * to_degrees(asin(scale / d)) - if (external) - d <- internal_to_external(2, d) - d + d <- sqrt(1 + scale^2) + d <- 2 * to_degrees(asin(scale / d)) + if (external) { + d <- internal_to_external(2, d) + } + d } external_to_internal <- function(n_vertices, external) { - n <- 2 * n_vertices # exterior plus interior vertices - total <- (n - 2) * 180 - inverse <- 360 - external - internal <- (total - n_vertices * inverse) / n_vertices - internal + n <- 2 * n_vertices # exterior plus interior vertices + total <- (n - 2) * 180 + inverse <- 360 - external + internal <- (total - n_vertices * inverse) / n_vertices + internal } internal_to_external <- function(n_vertices, internal) { - n <- 2 * n_vertices # exterior plus interior vertices - total <- (n - 2) * 180 - inverse <- (total - n_vertices * internal) / n_vertices - external <- 360 - inverse - external + n <- 2 * n_vertices # exterior plus interior vertices + total <- (n - 2) * 180 + inverse <- (total - n_vertices * internal) / n_vertices + external <- 360 - inverse + external } dist <- function(p1, p2) sqrt((p2$x - p1$x)^2 + (p2$y - p1$y)^2) diff --git a/R/utils-array.R b/R/utils-array.R index c11f8c9..414c6bb 100644 --- a/R/utils-array.R +++ b/R/utils-array.R @@ -9,114 +9,127 @@ #' @return rasterGrob #' #' @noRd -create_pattern_array <- function(params, boundary_df, aspect_ratio, legend, - array_fn = create_magick_pattern_as_array) { +create_pattern_array <- function( + params, + boundary_df, + aspect_ratio, + legend, + array_fn = create_magick_pattern_as_array +) { + if (anyNA(boundary_df$x) || anyNA(boundary_df$y)) { + return(grid::nullGrob()) + } - if (anyNA(boundary_df$x) || anyNA(boundary_df$y)) { - return(grid::nullGrob()) - } + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # What is the size of the bounding box of the boundary for this pattern? + # Calculate the centre (x,y) and (width,height) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + npc_xrange <- range(boundary_df$x, na.rm = TRUE) + npc_yrange <- range(boundary_df$y, na.rm = TRUE) + npc_width <- abs(diff(npc_xrange)) + npc_height <- abs(diff(npc_yrange)) + npc_x <- mean(npc_xrange) + npc_y <- mean(npc_yrange) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # What is the size of the bounding box of the boundary for this pattern? - # Calculate the centre (x,y) and (width,height) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - npc_xrange <- range(boundary_df$x, na.rm = TRUE) - npc_yrange <- range(boundary_df$y, na.rm = TRUE) - npc_width <- abs(diff(npc_xrange)) - npc_height <- abs(diff(npc_yrange)) - npc_x <- mean(npc_xrange) - npc_y <- mean(npc_yrange) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Calculate the dimensions of the bounding box and use the integer + # values of these to define the image dimensions + # res of 72 DPI is the imagemagick default + # Ideally could detect resolution of graphics device and use that as default... + # NB. large pixel sizes can cause errors with getting 'placeholder' images + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + res <- params$pattern_res # defaults to 72 DPI + 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 <- as.integer(res * in_width) + arr_height <- as.integer(res * in_height) + if (arr_width == 0L || arr_height == 0L) { + return(nullGrob(name = params$pattern)) + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Calculate the dimensions of the bounding box and use the integer - # values of these to define the image dimensions - # res of 72 DPI is the imagemagick default - # Ideally could detect resolution of graphics device and use that as default... - # NB. large pixel sizes can cause errors with getting 'placeholder' images - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - res <- params$pattern_res # defaults to 72 DPI - 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 <- as.integer(res * in_width) - arr_height <- as.integer(res * in_height) - if (arr_width == 0L || arr_height == 0L) - return(nullGrob(name = params$pattern)) + # Override type for better looking legend when tiling + if (legend) { + if (params$pattern_type %in% c('tile', 'none')) { + params$pattern_type <- 'fit' + } + } - # Override type for better looking legend when tiling - if (legend) { - if (params$pattern_type %in% c('tile', 'none')) { - params$pattern_type <- 'fit' - } - } + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # The image and the boundary_df bbox are coincident. To mask the image, + # scale the boundary_df to encompass the full 'npc' range from 0 to 1. + # An alpha mask will be created to encompass the whole of the image, and + # the resulting image will be placed at the bbox location. + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + scaled_boundary_df <- boundary_df + scaled_boundary_df$x <- (scaled_boundary_df$x - npc_xrange[1]) / npc_width + scaled_boundary_df$y <- (scaled_boundary_df$y - npc_yrange[1]) / npc_height - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # The image and the boundary_df bbox are coincident. To mask the image, - # scale the boundary_df to encompass the full 'npc' range from 0 to 1. - # An alpha mask will be created to encompass the whole of the image, and - # the resulting image will be placed at the bbox location. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - scaled_boundary_df <- boundary_df - scaled_boundary_df$x <- (scaled_boundary_df$x - npc_xrange[1]) / npc_width - scaled_boundary_df$y <- (scaled_boundary_df$y - npc_yrange[1]) / npc_height + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # check for issues e.g. Zero area regions + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if (any(is.nan(scaled_boundary_df$x)) || any(is.nan(scaled_boundary_df$y))) { + return(grid::nullGrob()) + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # check for issues e.g. Zero area regions - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (any(is.nan(scaled_boundary_df$x)) || any(is.nan(scaled_boundary_df$y))) { - return(grid::nullGrob()) - } + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Fetch an image of the required dimensions. + # Create a mask of the required dimensions from the scaled boundary_df + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + rgba_arr <- array_fn(arr_width, arr_height, params, legend) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Fetch an image of the required dimensions. - # Create a mask of the required dimensions from the scaled boundary_df - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - rgba_arr <- array_fn(arr_width, arr_height, params, legend) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Sanity check the array conforms to what we want. This is especially + # important as we're allowing users to generate arrays for patterns + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if ( + !(is.array(rgba_arr) && + is.numeric(rgba_arr) && + length(dim(rgba_arr) == 3) && + dim(rgba_arr)[3] == 4 && + dim(rgba_arr)[1] == arr_height && + dim(rgba_arr)[2] == arr_width && + !anyNA(rgba_arr) && + min(rgba_arr) >= 0 && + max(rgba_arr) <= 1) + ) { + warn(glue( + "create_pattern_array(): Expecting a numeric RGBA array with dim = c({arr_height}, {arr_width}, 4) ", + "but instead got a {deparse(class(rgba_arr))} ", + "of type {typeof(rgba_arr)} with dimensions {deparse(dim(rgba_arr))}" + )) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Sanity check the array conforms to what we want. This is especially - # important as we're allowing users to generate arrays for patterns - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (!(is.array(rgba_arr) && - is.numeric(rgba_arr) && - length(dim(rgba_arr) == 3) && - dim(rgba_arr)[3] == 4 && - dim(rgba_arr)[1] == arr_height && - dim(rgba_arr)[2] == arr_width && - !anyNA(rgba_arr) && - min(rgba_arr) >= 0 && - max(rgba_arr) <= 1)) { + rgba_arr <- array(c(0, 1), dim = c(arr_height, arr_width, 4)) + } - warn(glue("create_pattern_array(): Expecting a numeric RGBA array with dim = c({arr_height}, {arr_width}, 4) ", - "but instead got a {deparse(class(rgba_arr))} ", - "of type {typeof(rgba_arr)} with dimensions {deparse(dim(rgba_arr))}")) + boundary_mask <- convert_polygon_df_to_alpha_channel( + scaled_boundary_df, + width = arr_width, + height = arr_height + ) - rgba_arr <- array(c(0, 1), dim = c(arr_height, arr_width, 4)) - } + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Stack the current image array with an alpha channel. + # Using a custom version of `abind::abind()` so I could avoid having it + # as another package dependency + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if (is.na(params$pattern_alpha)) { + alpha <- 1 + } else { + alpha <- params$pattern_alpha + } + rgba_arr[,, 4] <- rgba_arr[,, 4] * boundary_mask * alpha - boundary_mask <- convert_polygon_df_to_alpha_channel(scaled_boundary_df, width = arr_width, height = arr_height) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Stack the current image array with an alpha channel. - # Using a custom version of `abind::abind()` so I could avoid having it - # as another package dependency - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (is.na(params$pattern_alpha)) - alpha <- 1 - else - alpha <- params$pattern_alpha - rgba_arr[,,4] <- rgba_arr[,,4] * boundary_mask * alpha - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create a rasterGrob image at the location of the 'boundary_df' bounding box. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - raster_grob <- rasterGrob( - rgba_arr, - x = npc_x, - y = npc_y, - width = npc_width, - height = npc_height, - name = params$pattern - ) - raster_grob + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Create a rasterGrob image at the location of the 'boundary_df' bounding box. + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + raster_grob <- rasterGrob( + rgba_arr, + x = npc_x, + y = npc_y, + width = npc_width, + height = npc_height, + name = params$pattern + ) + raster_grob } diff --git a/R/utils-geometry.R b/R/utils-geometry.R index aa1348e..8944a49 100644 --- a/R/utils-geometry.R +++ b/R/utils-geometry.R @@ -4,112 +4,115 @@ to_degrees <- function(t) 180 * t / pi # polar coordinates <-> cartesian coordinates to_x <- function(t, r) { - r * cos(to_radians(t)) + r * cos(to_radians(t)) } to_y <- function(t, r) { - r * sin(to_radians(t)) + r * sin(to_radians(t)) } to_theta <- function(x, y) { - to_degrees(atan2(y, x)) + to_degrees(atan2(y, x)) } to_radius <- function(x, y) { - sqrt(x^2 + y^2) + sqrt(x^2 + y^2) } # rotate (x,y) `t` degrees centered around (x0, y0) rotate_xy <- function(x, y, theta = 0, x0 = NULL, y0 = NULL) { - x0 <- x0 %||% mean(x) - y0 <- y0 %||% mean(y) - xc <- x - x0 - yc <- y - y0 - theta <- to_theta(xc, yc) + theta - radius <- to_radius(xc, yc) - x1 <- to_x(theta, radius) + x0 - y1 <- to_y(theta, radius) + y0 - list(x = x1, y = y1) + x0 <- x0 %||% mean(x) + y0 <- y0 %||% mean(y) + xc <- x - x0 + yc <- y - y0 + theta <- to_theta(xc, yc) + theta + radius <- to_radius(xc, yc) + x1 <- to_x(theta, radius) + x0 + y1 <- to_y(theta, radius) + y0 + list(x = x1, y = y1) } # (x,y) coordinates of convex regular polygon centered at (0, 0) convex_xy <- function(n_vertices, theta = 90, radius_outer = 0.5) { - t <- theta + seq(0, 360, length.out = n_vertices + 1) - x <- to_x(t, radius_outer) - y <- to_y(t, radius_outer) - list(x = head(x, -1), - y = head(y, -1)) + t <- theta + seq(0, 360, length.out = n_vertices + 1) + x <- to_x(t, radius_outer) + y <- to_y(t, radius_outer) + list(x = head(x, -1), y = head(y, -1)) } # (x,y)coordinates of rhombus quadrilateral rhombus_xy <- function(theta = 90, radius_outer = 0.5) { - t <- theta + c(0, -60, 0, 60) - r <- c(0, rep(radius_outer, 3)) - x <- to_x(t, r) - y <- to_y(t, r) - list(x = x, y = y) + t <- theta + c(0, -60, 0, 60) + r <- c(0, rep(radius_outer, 3)) + x <- to_x(t, r) + y <- to_y(t, r) + list(x = x, y = y) } # (x,y) coordinates of "left" Tetrakis triangle tetrakis_left_xy <- function(theta = 90, radius_outer = 0.5) { - t <- c(90, 135) - r <- c(1e-6, radius_outer) + t <- c(90, 135) + r <- c(1e-6, radius_outer) - x <- to_x(t, r) - y <- to_y(t, r) - x <- c(x, x[1]) - y <- c(y, y[2]) - rotate_xy(x, y, theta - 135, 0, 0) + x <- to_x(t, r) + y <- to_y(t, r) + x <- c(x, x[1]) + y <- c(y, y[2]) + rotate_xy(x, y, theta - 135, 0, 0) } # (x,y) coordinates of "right" Tetrakis triangle tetrakis_right_xy <- function(theta = 90, radius_outer = 0.5) { - t <- c(90, 45) - r <- c(1e-6, radius_outer) + t <- c(90, 45) + r <- c(1e-6, radius_outer) - x <- to_x(t, r) - y <- to_y(t, r) - x <- c(x, x[1]) - y <- c(y, y[2]) - rotate_xy(x, y, theta - 135, 0, 0) + x <- to_x(t, r) + y <- to_y(t, r) + x <- c(x, x[1]) + y <- c(y, y[2]) + rotate_xy(x, y, theta - 135, 0, 0) } # (x,y) coordinates of concave (star) regular polygon centered at (0, 0) -concave_xy <- function(n_vertices, theta = 90, radius_outer = 0.5, - radius_inner = 0.5 * radius_outer) { - t_outer <- theta + seq(0, 360, length.out = n_vertices + 1) - n_degrees <- 360 / n_vertices / 2 - t_inner <- theta + seq(n_degrees, 360 - n_degrees, length.out = n_vertices) - x_outer <- to_x(t_outer, radius_outer) - x_inner <- to_x(t_inner, radius_inner) - y_outer <- to_y(t_outer, radius_outer) - y_inner <- to_y(t_inner, radius_inner) - x <- splice(x_outer, x_inner) - y <- splice(y_outer, y_inner) - list(x = head(x, -1), - y = head(y, -1)) +concave_xy <- function( + n_vertices, + theta = 90, + radius_outer = 0.5, + radius_inner = 0.5 * radius_outer +) { + t_outer <- theta + seq(0, 360, length.out = n_vertices + 1) + n_degrees <- 360 / n_vertices / 2 + t_inner <- theta + seq(n_degrees, 360 - n_degrees, length.out = n_vertices) + x_outer <- to_x(t_outer, radius_outer) + x_inner <- to_x(t_inner, radius_inner) + y_outer <- to_y(t_outer, radius_outer) + y_inner <- to_y(t_inner, radius_inner) + x <- splice(x_outer, x_inner) + y <- splice(y_outer, y_inner) + list(x = head(x, -1), y = head(y, -1)) } splice <- function(x0, x1) { - vec <- as.numeric() - for (ii in seq_along(x1)) { - vec <- append(vec, x0[ii]) - vec <- append(vec, x1[ii]) - } - append(vec, x0[ii+1]) + vec <- as.numeric() + for (ii in seq_along(x1)) { + vec <- append(vec, x0[ii]) + vec <- append(vec, x1[ii]) + } + append(vec, x0[ii + 1]) } get_n_vertices <- function(shape) { - as.numeric(gsub("convex|concave|star", "", shape)) + as.numeric(gsub("convex|concave|star", "", shape)) } # returns numeric(0) if 'from' greater than 'to' -seq_robust <- function(from = 1, to = 1, by = ((to - from)/(length.out - 1)), length.out = NULL) { - if (from > to) { - numeric(0) - } else { - if (is.null(length.out)) - seq(from, to, by) - else - seq(from, to, by, length.out) - } +seq_robust <- function(from = 1, to = 1, by = ((to - from) / (length.out - 1)), length.out = NULL) { + if (from > to) { + numeric(0) + } else { + if (is.null(length.out)) { + seq(from, to, by) + } else { + seq(from, to, by, length.out) + } + } } # cycle_elements(1:5, -2) = c(4, 5, 1, 2, 3) @@ -118,22 +121,23 @@ seq_robust <- function(from = 1, to = 1, by = ((to - from)/(length.out - 1)), le # cycle_elements(1:5, 1) = c(2, 3, 4, 5, 1) # cycle_elements(1:5, 2) = c(3, 4, 5, 1, 2) cycle_elements <- function(x, n = 1) { - l <- length(x) - if (l < 2 || n == l || n == 0 || n == -l) - return(x) - if (n > 0) { - if (n < l) { - c(x[(n+1):l], x[1:n]) - } else { - cycle_elements(x, n-l) - } - } else { - if (-l < n) { - c(x[(l+n+1):l], x[1:(l+n)]) - } else { - cycle_elements(x, n+l) - } - } + l <- length(x) + if (l < 2 || n == l || n == 0 || n == -l) { + return(x) + } + if (n > 0) { + if (n < l) { + c(x[(n + 1):l], x[1:n]) + } else { + cycle_elements(x, n - l) + } + } else { + if (-l < n) { + c(x[(l + n + 1):l], x[1:(l + n)]) + } else { + cycle_elements(x, n + l) + } + } } nigh <- function(x, y) abs(x - y) < .Machine$double.eps^0.5 diff --git a/R/utils-ggpattern.R b/R/utils-ggpattern.R index 854d389..cd0a1d7 100644 --- a/R/utils-ggpattern.R +++ b/R/utils-ggpattern.R @@ -18,39 +18,38 @@ #' if given, otherwise the first element in \code{options}. #' @noRd check_default <- function(x, options = NULL, default = NULL, type = NULL, prefix = "") { + stopifnot(is.null(options) || is.atomic(options)) - stopifnot(is.null(options) || is.atomic(options)) + default <- default %||% (options[1]) + if (is.null(default) || length(default) != 1) { + abort("check_default(): Must specify 'default' or 'options'") + } - default <- default %||% (options[1]) - if (is.null(default) || length(default) != 1) { - abort("check_default(): Must specify 'default' or 'options'") - } + if (length(x) != 1) { + res <- default + } else if (!is.null(options) && !x %in% options) { + res <- default + } else { + res <- x + } - if (length(x) != 1) { - res <- default - } else if (!is.null(options) && !x %in% options) { - res <- default - } else { - res <- x - } + if (!is.null(type)) { + res <- switch( + type, + numeric = , + number = , + float = , + num = ifelse(is.numeric(res), res, default), + character = , + chr = , + char = ifelse(is.character(res), res, default), + { + abort(paste0("check_default(): Don't know how to check for type: ", type)) + } + ) + } - if (!is.null(type)) { - res <- switch( - type, - numeric =, - number =, - float =, - num = ifelse(is.numeric (res), res, default), - character = , - chr = , - char = ifelse(is.character(res), res, default), - { - abort(paste0("check_default(): Don't know how to check for type: ", type)) - } - ) - } - - res + res } #' abind clone for adding a matrix to an array @@ -63,15 +62,14 @@ check_default <- function(x, options = NULL, default = NULL, type = NULL, prefix #' @return new array with matrix added as a new plane at the end of the array #' @noRd my_abind <- function(arr, mat) { + stopifnot(is.array(arr)) + stopifnot(is.matrix(mat)) + if (!identical(utils::head(dim(arr), -1), dim(mat))) { + abort(glue("Dimension missmatch. Array: {deparse(dim(arr))} Matrix: {deparse(dim(mat))}")) + } - stopifnot(is.array(arr)) - stopifnot(is.matrix(mat)) - if (!identical(utils::head(dim(arr), -1), dim(mat))) { - abort(glue("Dimension missmatch. Array: {deparse(dim(arr))} Matrix: {deparse(dim(mat))}")) - } - - new_dim <- dim(arr) - new_dim[3] <- new_dim[3] + 1 + new_dim <- dim(arr) + new_dim[3] <- new_dim[3] + 1 - array(c(arr, mat), dim = new_dim) + array(c(arr, mat), dim = new_dim) } diff --git a/R/utils-ggplot2.R b/R/utils-ggplot2.R index af6b77d..380abe5 100644 --- a/R/utils-ggplot2.R +++ b/R/utils-ggplot2.R @@ -2,39 +2,45 @@ # Fast data.frame constructor and indexing # No checking, recycling etc. unless asked for new_data_frame <- function(x = list(), n = NULL) { - if (length(x) != 0 && is.null(names(x))) { - abort("Elements must be named") - } - lengths <- vapply(x, length, integer(1)) - if (is.null(n)) { - n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths) - } - for (i in seq_along(x)) { - if (lengths[i] == n) next - if (lengths[i] != 1) { - abort("Elements must equal the number of rows or 1") - } - x[[i]] <- rep(x[[i]], n) - } + if (length(x) != 0 && is.null(names(x))) { + abort("Elements must be named") + } + lengths <- vapply(x, length, integer(1)) + if (is.null(n)) { + n <- if (length(x) == 0 || min(lengths) == 0) 0 else max(lengths) + } + for (i in seq_along(x)) { + if (lengths[i] == n) { + next + } + if (lengths[i] != 1) { + abort("Elements must equal the number of rows or 1") + } + x[[i]] <- rep(x[[i]], n) + } - class(x) <- "data.frame" + class(x) <- "data.frame" - attr(x, "row.names") <- .set_row_names(n) - x + attr(x, "row.names") <- .set_row_names(n) + x } data_frame <- function(...) { - new_data_frame(list(...)) + new_data_frame(list(...)) } .pt <- 2.845276 # ggplot2 constant ggplot2pat <- function(gg) { - stopifnot(getRversion() >= "4.1.0", - requireNamespace("ggplot2", quietly = TRUE), - requireNamespace("gtable", quietly = TRUE)) - gg <- suppressMessages(gg + - ggplot2::scale_x_continuous(expand=c(0, 0)) + - ggplot2::scale_y_continuous(expand=c(0, 0))) - grob <- gtable::gtable_filter(ggplot2::ggplotGrob(gg), "panel") - pat <- grid::pattern(grob) - pat + stopifnot( + getRversion() >= "4.1.0", + requireNamespace("ggplot2", quietly = TRUE), + requireNamespace("gtable", quietly = TRUE) + ) + gg <- suppressMessages( + gg + + ggplot2::scale_x_continuous(expand = c(0, 0)) + + ggplot2::scale_y_continuous(expand = c(0, 0)) + ) + grob <- gtable::gtable_filter(ggplot2::ggplotGrob(gg), "panel") + pat <- grid::pattern(grob) + pat } diff --git a/R/utils-grid.R b/R/utils-grid.R index 7fccbbc..23ae349 100644 --- a/R/utils-grid.R +++ b/R/utils-grid.R @@ -1,22 +1,23 @@ # c() and append() don't directly work with grid::gList() lists append_gList <- function(gl, grob) { - gl[[length(gl) + 1L]] <- grob - gl + gl[[length(gl) + 1L]] <- grob + gl } rep_len_fill <- function(x, length.out) { - if (inherits(x, "GridPattern")) - rep_len(list(x), length.out) - else - rep_len(x, length.out) + if (inherits(x, "GridPattern")) { + rep_len(list(x), length.out) + } else { + rep_len(x, length.out) + } } # get width, height, length, and center cooordinates of the viewport in `units` units get_vp_measurements <- function(units = "bigpts") { - width <- convertWidth(unit(1, "npc"), units, valueOnly = TRUE) - height <- convertHeight(unit(1, "npc"), units, valueOnly = TRUE) - length <- max(width, height) - 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) + width <- convertWidth(unit(1, "npc"), units, valueOnly = TRUE) + height <- convertHeight(unit(1, "npc"), units, valueOnly = TRUE) + length <- max(width, height) + 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) } diff --git a/R/utils-magick-fill.R b/R/utils-magick-fill.R index 643265f..db5ac0a 100644 --- a/R/utils-magick-fill.R +++ b/R/utils-magick-fill.R @@ -17,12 +17,11 @@ fill_types <- c('fit', 'expand', 'squish', 'none', 'tile') #' }) #' @noRd fill_area_with_img_fit <- function(img, width, height, gravity = 'Center', filter = 'lanczos') { + geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = TRUE) + img <- magick::image_resize(img, geometry = geometry, filter = filter) + img <- magick::image_extent(img, geometry, gravity = gravity) - geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = TRUE) - img <- magick::image_resize(img, geometry = geometry, filter=filter) - img <- magick::image_extent(img, geometry, gravity = gravity) - - img + img } #' Resize image, ignoring aspect, such that both the target width and height is achieved. @@ -41,11 +40,14 @@ fill_area_with_img_fit <- function(img, width, height, gravity = 'Center', filte #' fill_area_with_img_squish(img, 100, 400) #' }) #' @noRd -fill_area_with_img_squish <- function(img, width, height, filter='lanczos') { - geometry <- magick::geometry_size_pixels(width = width, height = height, - preserve_aspect = FALSE) - img <- magick::image_resize(img, geometry = geometry, filter=filter) - img +fill_area_with_img_squish <- function(img, width, height, filter = 'lanczos') { + geometry <- magick::geometry_size_pixels( + width = width, + height = height, + preserve_aspect = FALSE + ) + img <- magick::image_resize(img, geometry = geometry, filter = filter) + img } @@ -65,30 +67,38 @@ fill_area_with_img_squish <- function(img, width, height, filter='lanczos') { #' fill_area_with_img_expand(img, 100, 400) #' }) #' @noRd -fill_area_with_img_expand <- function(img, width, height, gravity = 'Center', filter='lanczos') { - img_info <- magick::image_info(img) - img_aspect <- img_info$width/img_info$height - area_aspect <- width/height - if (area_aspect > img_aspect) { - scale_width <- width - scale_height <- width / img_aspect - } else if (area_aspect < img_aspect) { - scale_height <- height - scale_width <- height * img_aspect - } else { - scale_height <- height - scale_width <- width - } - - # expand - geometry <- magick::geometry_size_pixels(width = scale_width, height = scale_height, preserve_aspect = FALSE) - img <- magick::image_resize(img, geometry = geometry, filter=filter) - - # crop - geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = FALSE) - img <- magick::image_crop(img, geometry = geometry, gravity = gravity) - - img +fill_area_with_img_expand <- function(img, width, height, gravity = 'Center', filter = 'lanczos') { + img_info <- magick::image_info(img) + img_aspect <- img_info$width / img_info$height + area_aspect <- width / height + if (area_aspect > img_aspect) { + scale_width <- width + scale_height <- width / img_aspect + } else if (area_aspect < img_aspect) { + scale_height <- height + scale_width <- height * img_aspect + } else { + scale_height <- height + scale_width <- width + } + + # expand + geometry <- magick::geometry_size_pixels( + width = scale_width, + height = scale_height, + preserve_aspect = FALSE + ) + img <- magick::image_resize(img, geometry = geometry, filter = filter) + + # crop + geometry <- magick::geometry_size_pixels( + width = width, + height = height, + preserve_aspect = FALSE + ) + img <- magick::image_crop(img, geometry = geometry, gravity = gravity) + + img } @@ -108,62 +118,75 @@ fill_area_with_img_expand <- function(img, width, height, gravity = 'Center', fi #' fill_area_with_img_none(img, 100, 400) #' }) #' @noRd -fill_area_with_img_none <- function(img, width, height, gravity = 'Center', - filter = 'lanczos', scale = 1) { - +fill_area_with_img_none <- function( + img, + width, + height, + gravity = 'Center', + filter = 'lanczos', + scale = 1 +) { + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Scale if requested + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + scale <- update_scale(scale, img, width, height) + if (scale != 1) { + geometry <- magick::geometry_size_percent(width = scale * 100) + img <- magick::image_resize(img, geometry, filter = filter) + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Scale if requested - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - scale <- update_scale(scale, img, width, height) - if (scale != 1) { - geometry <- magick::geometry_size_percent(width = scale * 100) - img <- magick::image_resize(img, geometry, filter = filter) - } + geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = TRUE) + img <- magick::image_extent(img, geometry, gravity = gravity) - - geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = TRUE) - img <- magick::image_extent(img, geometry, gravity = gravity) - - img + img } # if `scale == -1` scale to img width, if `scale == -2` scale to img height update_scale <- function(scale, img, width, height) { - if (scale == -1) { - info <- magick::image_info(img) - width/info$width - } else if (scale == -2) { - info <- magick::image_info(img) - height/info$height - } else { - scale - } + if (scale == -1) { + info <- magick::image_info(img) + width / info$width + } else if (scale == -2) { + info <- magick::image_info(img) + height / info$height + } else { + scale + } } #' Tile image to fill the specified area #' #' @return magick image of the required dimensions #' @noRd -fill_area_with_img_tile <- function(img, width, height, gravity = "SouthWest", filter = filter, scale = 1) { - - scale <- update_scale(scale, img, width, height) - if (scale != 1) { - geometry <- magick::geometry_size_percent(width = scale * 100) - img <- magick::image_resize(img, geometry, filter = filter) - } +fill_area_with_img_tile <- function( + img, + width, + height, + gravity = "SouthWest", + filter = filter, + scale = 1 +) { + scale <- update_scale(scale, img, width, height) + if (scale != 1) { + geometry <- magick::geometry_size_percent(width = scale * 100) + img <- magick::image_resize(img, geometry, filter = filter) + } - img_info <- magick::image_info(img) - n_width <- width %/% img_info$width + as.integer(width %% img_info$width > 0) - n_height <- height %/% img_info$height + as.integer(height %% img_info$height > 0) - rows <- magick::image_append(rep(img, n_width)) - tiled <- magick::image_append(rep(rows, n_height), stack=TRUE) + img_info <- magick::image_info(img) + n_width <- width %/% img_info$width + as.integer(width %% img_info$width > 0) + n_height <- height %/% img_info$height + as.integer(height %% img_info$height > 0) + rows <- magick::image_append(rep(img, n_width)) + tiled <- magick::image_append(rep(rows, n_height), stack = TRUE) - geometry <- magick::geometry_size_pixels(width = width, height = height, preserve_aspect = FALSE) + geometry <- magick::geometry_size_pixels( + width = width, + height = height, + preserve_aspect = FALSE + ) - cropped <- magick::image_crop(tiled, geometry = geometry, gravity = gravity) + cropped <- magick::image_crop(tiled, geometry = geometry, gravity = gravity) - cropped + cropped } #' Fill an area with a magick image @@ -196,29 +219,52 @@ fill_area_with_img_tile <- function(img, width, height, gravity = "SouthWest", f #' fill_area_with_img(img, 100, 400, type = 'squish') #' }) #' @noRd -fill_area_with_img <- function(img, width, height, type='squish', - gravity = 'Center', filter='lanczos', - scale = 1) { - - if (length(width) != 1 || length(height) != 1 || - is.na(width) || is.na(height) || - width <= 0 || height <= 0) { - return(img) - } - - type <- check_default(type, fill_types) - - switch( - type, - fit = fill_area_with_img_fit (img, width, height, gravity = gravity, filter = filter), - expand = fill_area_with_img_expand(img, width, height, gravity = gravity, filter = filter), - squish = fill_area_with_img_squish(img, width, height , filter = filter), - none = fill_area_with_img_none (img, width, height, gravity = gravity, filter = filter, scale = scale), - tile = fill_area_with_img_tile (img, width, height, gravity = gravity, filter = filter, scale = scale), - { - warn("fill_area_with_img(): resize not understood: '", type, - "', using 'squish'") - fill_area_with_img_squish(img, width, height) - } - ) +fill_area_with_img <- function( + img, + width, + height, + type = 'squish', + gravity = 'Center', + filter = 'lanczos', + scale = 1 +) { + if ( + length(width) != 1 || + length(height) != 1 || + is.na(width) || + is.na(height) || + width <= 0 || + height <= 0 + ) { + return(img) + } + + type <- check_default(type, fill_types) + + switch( + type, + fit = fill_area_with_img_fit(img, width, height, gravity = gravity, filter = filter), + expand = fill_area_with_img_expand(img, width, height, gravity = gravity, filter = filter), + squish = fill_area_with_img_squish(img, width, height, filter = filter), + none = fill_area_with_img_none( + img, + width, + height, + gravity = gravity, + filter = filter, + scale = scale + ), + tile = fill_area_with_img_tile( + img, + width, + height, + gravity = gravity, + filter = filter, + scale = scale + ), + { + warn("fill_area_with_img(): resize not understood: '", type, "', using 'squish'") + fill_area_with_img_squish(img, width, height) + } + ) } diff --git a/R/utils-magick-misc.R b/R/utils-magick-misc.R index a1666e2..f790f28 100644 --- a/R/utils-magick-misc.R +++ b/R/utils-magick-misc.R @@ -7,11 +7,11 @@ #' #' @noRd convert_r_colour_to_magick_colour <- function(col) { - if (is.null(col) || is.na(col) || length(col) == 0 || col == "transparent") { - return('none') - } - col_rgb <- col2rgb(col, alpha = TRUE) - rgb(col_rgb[1,], col_rgb[2,], col_rgb[3,], col_rgb[4,], maxColorValue = 255) + if (is.null(col) || is.na(col) || length(col) == 0 || col == "transparent") { + return('none') + } + col_rgb <- col2rgb(col, alpha = TRUE) + rgb(col_rgb[1, ], col_rgb[2, ], col_rgb[3, ], col_rgb[4, ], maxColorValue = 255) } #' Convert a magick image to an RGBA array. @@ -20,45 +20,44 @@ convert_r_colour_to_magick_colour <- function(col) { #' #' @param img magick image #' -#' @return RGBA array with all values in range [0, 1] +#' @return RGBA array with all values in range `[0, 1]` #' #' @noRd convert_img_to_array <- function(img) { - - stopifnot(inherits(img, 'magick-image')) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # extract the RGB array from that image - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - arr <- as.numeric(magick::image_data(img)) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # If this is a grey image (i.e. a 2d matrix), then promote it - # to a 3d array by copying the grey into R,G and B planes - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (length(dim(arr)) == 2) { - arr <- array(c(arr, arr, arr), dim = c(dim(arr), 3)) - } - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Add an alpha channel if there isn't one already - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (dim(arr)[3] == 3) { - alpha_matrix <- matrix(1, nrow=dim(arr)[1], ncol = dim(arr)[2]) - arr <- my_abind(arr, alpha_matrix) - } - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Sanity check: Assert everything image is RGBA - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - stopifnot(dim(arr)[3] == 4) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Transpose the image if requested. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # if (transpose) { - # arr <- aperm(arr, c(2, 1, 3)) - # } - - arr + stopifnot(inherits(img, 'magick-image')) + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # extract the RGB array from that image + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + arr <- as.numeric(magick::image_data(img)) + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # If this is a grey image (i.e. a 2d matrix), then promote it + # to a 3d array by copying the grey into R,G and B planes + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if (length(dim(arr)) == 2) { + arr <- array(c(arr, arr, arr), dim = c(dim(arr), 3)) + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Add an alpha channel if there isn't one already + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if (dim(arr)[3] == 3) { + alpha_matrix <- matrix(1, nrow = dim(arr)[1], ncol = dim(arr)[2]) + arr <- my_abind(arr, alpha_matrix) + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Sanity check: Assert everything image is RGBA + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + stopifnot(dim(arr)[3] == 4) + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Transpose the image if requested. + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # if (transpose) { + # arr <- aperm(arr, c(2, 1, 3)) + # } + + arr } diff --git a/R/utils-magick-pattern.R b/R/utils-magick-pattern.R index d8a0ba3..35f3ce6 100644 --- a/R/utils-magick-pattern.R +++ b/R/utils-magick-pattern.R @@ -9,41 +9,44 @@ #' @param colour colour used to draw the pattern #' #' @noRd -create_magick_pattern_img <- function(width=100, height=100, type = 'hexagons', - colour = 'black') { +create_magick_pattern_img <- function( + width = 100, + height = 100, + type = 'hexagons', + colour = 'black' +) { + type <- check_default(tolower(type), names_magick, default = 'checkerboard') + colour <- convert_r_colour_to_magick_colour(colour) - type <- check_default(tolower(type), names_magick, default = 'checkerboard') - colour <- convert_r_colour_to_magick_colour(colour) + if (width == 0 || height == 0) { + warn("create_magick_pattern_img(): zero size") + return(magick::image_blank(10, 10)) + } - if (width == 0 || height == 0) { - warn("create_magick_pattern_img(): zero size") - return(magick::image_blank(10, 10)) - } + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Create a pattern image of the required size + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + pseudo <- paste0("pattern:", type) + img <- magick::image_blank(width, height, pseudo_image = pseudo) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create a pattern image of the required size - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pseudo <- paste0("pattern:", type) - img <- magick::image_blank(width, height, pseudo_image = pseudo) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # The checkerboard is the only(?) pattern which isn't pure black and white. + # for the sake of consistency it will be thresholded from its original + # two-level gray colours into pure black and white. + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if (type %in% 'checkerboard') { + img <- magick::image_threshold(img, type = 'black') + img <- magick::image_threshold(img, type = 'white') + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # The checkerboard is the only(?) pattern which isn't pure black and white. - # for the sake of consistency it will be thresholded from its original - # two-level gray colours into pure black and white. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (type %in% 'checkerboard') { - img <- magick::image_threshold(img, type = 'black') - img <- magick::image_threshold(img, type = 'white') - } + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Make the white transparent + # Colourie the black pixels into the desired colour + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + img <- magick::image_transparent(img, 'white') + img <- magick::image_colorize(img, opacity = 100, colour) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Make the white transparent - # Colourie the black pixels into the desired colour - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - img <- magick::image_transparent(img, 'white') - img <- magick::image_colorize(img, opacity = 100, colour) - - img + img } #' Create a scaled version one of imagemagick's internal patterns @@ -57,31 +60,32 @@ create_magick_pattern_img <- function(width=100, height=100, type = 'hexagons', #' of filters. #' #' @noRd -create_magick_pattern_img_scaled <- function(width = 100, - height = 100, - type = 'hexagons', - colour = 'black', - scale = 1, - filter = 'box') { - - scale <- check_default(scale, default = 1, type = 'numeric') +create_magick_pattern_img_scaled <- function( + width = 100, + height = 100, + type = 'hexagons', + colour = 'black', + scale = 1, + filter = 'box' +) { + scale <- check_default(scale, default = 1, type = 'numeric') - if (scale < 0.01 || scale > 100) { - scale <- 1 - } + if (scale < 0.01 || scale > 100) { + scale <- 1 + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Create a scaled version of the pattern - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - new_width <- width /scale - new_height <- height/scale + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Create a scaled version of the pattern + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + new_width <- width / scale + new_height <- height / scale - img <- create_magick_pattern_img(new_width, new_height, type = type, colour = colour) + img <- create_magick_pattern_img(new_width, new_height, type = type, colour = colour) - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Which we'll scale back down to the original size - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - img <- fill_area_with_img_squish(img, width, height, filter = filter) + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Which we'll scale back down to the original size + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + img <- fill_area_with_img_squish(img, width, height, filter = filter) - img + img } diff --git a/R/utils-magick-read.R b/R/utils-magick-read.R index b7a65c8..ace02a3 100644 --- a/R/utils-magick-read.R +++ b/R/utils-magick-read.R @@ -5,25 +5,26 @@ #' @return magick image #' @noRd img_read <- function(filename) { - if (identical(filename, '')) { - return(magick::image_blank(100, 100, color = 'none')) - } - if (is.null(filename) || length(filename)== 0 || is.na(filename) || filename == '') { - abort(paste0("bad filename: ", deparse(filename))) - } + if (identical(filename, '')) { + return(magick::image_blank(100, 100, color = 'none')) + } + if (is.null(filename) || length(filename) == 0 || is.na(filename) || filename == '') { + abort(paste0("bad filename: ", deparse(filename))) + } - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Fetch the URL as an image - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - img <- tryCatch( - {magick::image_read(filename)}, - error = function(cond) { - msg <- c(glue("couldn't read {shQuote(filename)}"), - i = cond$message) - abort(msg) - } - ) - img + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Fetch the URL as an image + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + img <- tryCatch( + { + magick::image_read(filename) + }, + error = function(cond) { + msg <- c(glue("couldn't read {shQuote(filename)}"), i = cond$message) + abort(msg) + } + ) + img } #' Fetch a given path or URL as a 3D RGB array of values @@ -42,18 +43,30 @@ img_read <- function(filename) { #' be an unsaturated RGB image. #' #' @noRd -img_read_as_array <- function(filename, width = NULL, height = NULL, - fill_type = 'squish', gravity = 'Center', - scale = 1, filter = 'lanczos') { +img_read_as_array <- function( + filename, + width = NULL, + height = NULL, + fill_type = 'squish', + gravity = 'Center', + scale = 1, + filter = 'lanczos' +) { + img <- img_read_memoised(filename) - img <- img_read_memoised(filename) + if (is.null(img)) { + abort(glue("couldn't read {shQuote(filename)}")) + } - if (is.null(img)) { - abort(glue("couldn't read {shQuote(filename)}")) - } + img <- fill_area_with_img( + img, + width, + height, + type = fill_type, + gravity = gravity, + filter = filter, + scale = scale + ) - img <- fill_area_with_img(img, width, height, type = fill_type, gravity = gravity, - filter = filter, scale = scale) - - convert_img_to_array(img) + convert_img_to_array(img) } diff --git a/R/utils-misc.R b/R/utils-misc.R index d5f4ae5..a66ae88 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -1,9 +1,13 @@ assert_suggested <- function(package, pattern) { - if (!requireNamespace(package, quietly = TRUE)) { - abort(c(glue("The suggested package {{{package}}} must be installed ", - 'in order to use the "{pattern}" pattern.'), - i = glue('Install with the command `install.packages("{package}")`'))) - } + if (!requireNamespace(package, quietly = TRUE)) { + abort(c( + glue( + "The suggested package {{{package}}} must be installed ", + 'in order to use the "{pattern}" pattern.' + ), + i = glue('Install with the command `install.packages("{package}")`') + )) + } } # base R's Cairo/Quartz devices as well as {ragg} / {svglite} / {vdiffr} devices @@ -11,24 +15,41 @@ assert_suggested <- function(package, pattern) { # Notably `pdf()` is a device that does not... # Any other devices to add? device_supports_unicode <- function() { - device <- names(grDevices::dev.cur()) - unicode_devices <- c("agg_capture", "agg_jpeg", "agg_ppm", "agg_png", "agg_record", "agg_tiff", # {ragg} - "devSVG", "devSVG_vdiffr", # {svglite} / {vdiffr} - "quartz", "quartz_off_screen", # Quartz - "cairo_pdf", "cairo_ps", "svg", "X11cairo") # Cairo - if (any(vapply(unicode_devices, function(x) grepl(paste0("^", x), device), - FUN.VALUE = logical(1L)))) { - TRUE - } else if (device %in% c("bmp", "jpeg", "png", "tiff")) { - # on unix non-"cairo" type have different device names from "cairo" type - # but on Windows can't distinguish between `type = "windows"` or `type = "cairo"` - # Windows device doesn't support new patterns feature - if (getRversion() >= "4.2.0") { - "LinearGradient" %in% grDevices::dev.capabilities()$patterns - } else { - .Platform$OS.type == "unix" - } - } else { - FALSE - } + device <- names(grDevices::dev.cur()) + unicode_devices <- c( + "agg_capture", + "agg_jpeg", + "agg_ppm", + "agg_png", + "agg_record", + "agg_tiff", # {ragg} + "devSVG", + "devSVG_vdiffr", # {svglite} / {vdiffr} + "quartz", + "quartz_off_screen", # Quartz + "cairo_pdf", + "cairo_ps", + "svg", + "X11cairo" + ) # Cairo + if ( + any(vapply( + unicode_devices, + function(x) grepl(paste0("^", x), device), + FUN.VALUE = logical(1L) + )) + ) { + TRUE + } else if (device %in% c("bmp", "jpeg", "png", "tiff")) { + # on unix non-"cairo" type have different device names from "cairo" type + # but on Windows can't distinguish between `type = "windows"` or `type = "cairo"` + # Windows device doesn't support new patterns feature + if (getRversion() >= "4.2.0") { + "LinearGradient" %in% grDevices::dev.capabilities()$patterns + } else { + .Platform$OS.type == "unix" + } + } else { + FALSE + } } diff --git a/R/utils-params.R b/R/utils-params.R index 07d6672..36a1bba 100644 --- a/R/utils-params.R +++ b/R/utils-params.R @@ -1,114 +1,141 @@ # returns list of pattern parameters using defaults if necessary get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar()) { - l <- list(...) - if (length(l)) names(l) <- paste0(prefix, names(l)) - l$pattern <- pattern + l <- list(...) + if (length(l)) { + names(l) <- paste0(prefix, names(l)) + } + l$pattern <- pattern - # possibly get from gpar() - l$pattern_alpha <- l$pattern_alpha %||% gp$alpha %||% NA_real_ - l$pattern_colour <- l$pattern_colour %||% l$pattern_color %||% gp$col %||% "grey20" - l$pattern_fill <- l[["pattern_fill"]] %||% gp$fill %||% "grey80" - l$pattern_linetype <- l$pattern_linetype %||% gp$lty %||% 1 - l$pattern_linewidth <- l$pattern_linewidth %||% l$pattern_size %||% gp$lwd %||% 1 - if (pattern == "text") - l$pattern_size <- l$pattern_size %||% gp$fontsize %||% 12 - else - l$pattern_size <- l$pattern_size %||% gp$lwd %||% 1 - l$pattern_fontfamily <- l$pattern_fontfamily %||% gp$fontfamily %||% "sans" - l$pattern_fontface <- l$pattern_fontface %||% gp$fontface %||% "plain" + # possibly get from gpar() + l$pattern_alpha <- l$pattern_alpha %||% gp$alpha %||% NA_real_ + l$pattern_colour <- l$pattern_colour %||% l$pattern_color %||% gp$col %||% "grey20" + l$pattern_fill <- l[["pattern_fill"]] %||% gp$fill %||% "grey80" + l$pattern_linetype <- l$pattern_linetype %||% gp$lty %||% 1 + l$pattern_linewidth <- l$pattern_linewidth %||% l$pattern_size %||% gp$lwd %||% 1 + if (pattern == "text") { + l$pattern_size <- l$pattern_size %||% gp$fontsize %||% 12 + } else { + l$pattern_size <- l$pattern_size %||% gp$lwd %||% 1 + } + l$pattern_fontfamily <- l$pattern_fontfamily %||% gp$fontfamily %||% "sans" + l$pattern_fontface <- l$pattern_fontface %||% gp$fontface %||% "plain" - # never get from gpar() - l$pattern_angle <- l$pattern_angle %||% 30 - l$pattern_aspect_ratio <- l$pattern_aspect_ratio %||% NA_real_ - l$pattern_density <- l$pattern_density %||% 0.2 - l$pattern_filename <- l$pattern_filename %||% "" - l$pattern_fill2 <- l$pattern_fill2 %||% - switch(pattern, crosshatch = l$pattern_fill, "#4169E1") - l$pattern_filter <- l$pattern_filter %||% - switch(pattern, magick = "box", "lanczos") - l$pattern_grid <- l$pattern_grid %||% "square" - l$pattern_key_scale_factor <- l$pattern_key_scale_factor %||% 1 - l$pattern_orientation <- l$pattern_orientation %||% "vertical" - l$pattern_rot <- l$pattern_rot %||% 0 - l$pattern_shape <- l$pattern_shape %||% - switch(pattern, regular_polygon = "convex4", 1) - l$pattern_scale <- l$pattern_scale %||% - switch(pattern, regular_polygon = 0.5, 1) - l$pattern_spacing <- l$pattern_spacing %||% 0.05 - # l$pattern_subtype <- l$pattern_subtype - l$pattern_type <- l$pattern_type %||% default_pattern_type(pattern) - if (is.na(l$pattern_type)) - l$pattern_type <- default_pattern_type(pattern) - l$pattern_units <- l$pattern_units %||% "snpc" - l$pattern_xoffset <- l$pattern_xoffset %||% 0 - l$pattern_yoffset <- l$pattern_yoffset %||% 0 + # never get from gpar() + l$pattern_angle <- l$pattern_angle %||% 30 + l$pattern_aspect_ratio <- l$pattern_aspect_ratio %||% NA_real_ + l$pattern_density <- l$pattern_density %||% 0.2 + l$pattern_filename <- l$pattern_filename %||% "" + l$pattern_fill2 <- l$pattern_fill2 %||% + switch(pattern, crosshatch = l$pattern_fill, "#4169E1") + l$pattern_filter <- l$pattern_filter %||% + switch(pattern, magick = "box", "lanczos") + l$pattern_grid <- l$pattern_grid %||% "square" + l$pattern_key_scale_factor <- l$pattern_key_scale_factor %||% 1 + l$pattern_orientation <- l$pattern_orientation %||% "vertical" + l$pattern_rot <- l$pattern_rot %||% 0 + l$pattern_shape <- l$pattern_shape %||% + switch(pattern, regular_polygon = "convex4", 1) + l$pattern_scale <- l$pattern_scale %||% + switch(pattern, regular_polygon = 0.5, 1) + l$pattern_spacing <- l$pattern_spacing %||% 0.05 + # l$pattern_subtype <- l$pattern_subtype + l$pattern_type <- l$pattern_type %||% default_pattern_type(pattern) + if (is.na(l$pattern_type)) { + l$pattern_type <- default_pattern_type(pattern) + } + l$pattern_units <- l$pattern_units %||% "snpc" + l$pattern_xoffset <- l$pattern_xoffset %||% 0 + l$pattern_yoffset <- l$pattern_yoffset %||% 0 - l$pattern_gravity <- l$pattern_gravity %||% - switch(l$pattern_type, tile = "southwest", "center") - if (is.na(l$pattern_gravity)) - l$pattern_gravity <- switch(l$pattern_type, tile = "southwest", "center") + l$pattern_gravity <- l$pattern_gravity %||% + switch(l$pattern_type, tile = "southwest", "center") + if (is.na(l$pattern_gravity)) { + l$pattern_gravity <- switch(l$pattern_type, tile = "southwest", "center") + } - l$pattern_res <- l$pattern_res %||% getOption("ggpattern_res", 72) # in PPI + l$pattern_res <- l$pattern_res %||% getOption("ggpattern_res", 72) # in PPI - # Additional ambient defaults - l$pattern_frequency <- l$pattern_frequency %||% - switch(pattern, ambient = 0.01, rose = 0.1, 1 / l$pattern_spacing) - l$pattern_interpolator <- l$pattern_interpolator %||% "quintic" # perlin, simplex, value - l$pattern_fractal <- l$pattern_fractal %||% - switch(l$pattern_type, worley = "none", "fbm") - l$pattern_pertubation <- l$pattern_pertubation %||% "none" # all - l$pattern_octaves <- l$pattern_octaves %||% 3 # all but white - l$pattern_lacunarity <- l$pattern_lacunarity %||% 2 # all but white - l$pattern_gain <- l$pattern_gain %||% 0.5 # all but white - l$pattern_amplitude <- l$pattern_amplitude %||% - switch(pattern, wave = 0.5 * l$pattern_spacing, 1) # all - l$pattern_value <- l$pattern_value %||% "cell" - l$pattern_distance_ind <- l$pattern_distance_ind %||% c(1, 2) - l$pattern_jitter <- l$pattern_jitter %||% 0.45 + # Additional ambient defaults + l$pattern_frequency <- l$pattern_frequency %||% + switch(pattern, ambient = 0.01, rose = 0.1, 1 / l$pattern_spacing) + l$pattern_interpolator <- l$pattern_interpolator %||% "quintic" # perlin, simplex, value + l$pattern_fractal <- l$pattern_fractal %||% + switch(l$pattern_type, worley = "none", "fbm") + l$pattern_pertubation <- l$pattern_pertubation %||% "none" # all + l$pattern_octaves <- l$pattern_octaves %||% 3 # all but white + l$pattern_lacunarity <- l$pattern_lacunarity %||% 2 # all but white + l$pattern_gain <- l$pattern_gain %||% 0.5 # all but white + l$pattern_amplitude <- l$pattern_amplitude %||% + switch(pattern, wave = 0.5 * l$pattern_spacing, 1) # all + l$pattern_value <- l$pattern_value %||% "cell" + l$pattern_distance_ind <- l$pattern_distance_ind %||% c(1, 2) + l$pattern_jitter <- l$pattern_jitter %||% 0.45 - l + l } get_R4.1_params <- function(l) { - # R 4.1 features - l$pattern_use_R4.1_clipping <- l$pattern_use_R4.1_clipping %||% - getOption("ggpattern_use_R4.1_clipping") %||% - getOption("ggpattern_use_R4.1_features") %||% - guess_has_R4.1_features("clippingPaths") - l$pattern_use_R4.1_gradients <- l$pattern_use_R4.1_gradients %||% - getOption("ggpattern_use_R4.1_gradients") %||% - getOption("ggpattern_use_R4.1_features") %||% - guess_has_R4.1_features("gradients") - l$pattern_use_R4.1_masks <- l$pattern_use_R4.1_masks %||% - getOption("ggpattern_use_R4.1_masks") %||% - getOption("ggpattern_use_R4.1_features") %||% - guess_has_R4.1_features("masks") - l$pattern_use_R4.1_patterns <- l$pattern_use_R4.1_patterns %||% - getOption("ggpattern_use_R4.1_patterns") %||% - getOption("ggpattern_use_R4.1_features") %||% - guess_has_R4.1_features("patterns") - l + # R 4.1 features + l$pattern_use_R4.1_clipping <- l$pattern_use_R4.1_clipping %||% + getOption("ggpattern_use_R4.1_clipping") %||% + getOption("ggpattern_use_R4.1_features") %||% + guess_has_R4.1_features("clippingPaths") + l$pattern_use_R4.1_gradients <- l$pattern_use_R4.1_gradients %||% + getOption("ggpattern_use_R4.1_gradients") %||% + getOption("ggpattern_use_R4.1_features") %||% + guess_has_R4.1_features("gradients") + l$pattern_use_R4.1_masks <- l$pattern_use_R4.1_masks %||% + getOption("ggpattern_use_R4.1_masks") %||% + getOption("ggpattern_use_R4.1_features") %||% + guess_has_R4.1_features("masks") + l$pattern_use_R4.1_patterns <- l$pattern_use_R4.1_patterns %||% + getOption("ggpattern_use_R4.1_patterns") %||% + getOption("ggpattern_use_R4.1_features") %||% + guess_has_R4.1_features("patterns") + l } convert_params_units <- function(params, units = "bigpts") { - p_units <- params$pattern_units - params$pattern_amplitude <- convertX(unit(params$pattern_amplitude, p_units), units, valueOnly = TRUE) - params$pattern_spacing <- convertX(unit(params$pattern_spacing, p_units), units, valueOnly = TRUE) - params$pattern_xoffset <- convertX(unit(params$pattern_xoffset, p_units), units, valueOnly = TRUE) - params$pattern_yoffset <- convertX(unit(params$pattern_yoffset, p_units), units, valueOnly = TRUE) - params$pattern_wavelength <- convertX(unit(1/params$pattern_frequency, p_units), units, valueOnly = TRUE) - params + p_units <- params$pattern_units + params$pattern_amplitude <- convertX( + unit(params$pattern_amplitude, p_units), + units, + valueOnly = TRUE + ) + params$pattern_spacing <- convertX( + unit(params$pattern_spacing, p_units), + units, + valueOnly = TRUE + ) + params$pattern_xoffset <- convertX( + unit(params$pattern_xoffset, p_units), + units, + valueOnly = TRUE + ) + params$pattern_yoffset <- convertX( + unit(params$pattern_yoffset, p_units), + units, + valueOnly = TRUE + ) + params$pattern_wavelength <- convertX( + unit(1 / params$pattern_frequency, p_units), + units, + valueOnly = TRUE + ) + params } default_pattern_type <- function(pattern) { - switch(pattern, - ambient = "simplex", - aRtsy = "strokes", - image = "fit", - placeholder = "bear", - polygon_tiling = "square", - magick = "hexagons", - wave = "triangle", - weave = "plain", - NA_character_) + switch( + pattern, + ambient = "simplex", + aRtsy = "strokes", + image = "fit", + placeholder = "bear", + polygon_tiling = "square", + magick = "hexagons", + wave = "triangle", + weave = "plain", + NA_character_ + ) } diff --git a/R/utils-polygon_df.R b/R/utils-polygon_df.R index 834fa5e..b1953d7 100644 --- a/R/utils-polygon_df.R +++ b/R/utils-polygon_df.R @@ -12,18 +12,18 @@ #' #' @noRd create_polygon_df <- function(x, y, id = 1L) { - data_frame( - x = x, - y = y, - id = id - ) + data_frame( + x = x, + y = y, + id = id + ) } # Convert units from 'npc' to another {grid} unit convert_polygon_df_units <- function(df, units = "bigpts") { - df$x <- convertX(unit(df$x, "npc"), units, valueOnly = TRUE) - df$y <- convertY(unit(df$y, "npc"), units, valueOnly = TRUE) - df + df$x <- convertX(unit(df$x, "npc"), units, valueOnly = TRUE) + df$y <- convertY(unit(df$y, "npc"), units, valueOnly = TRUE) + df } #' Convert a \code{polygon_df} to \code{grid::polygonGrob} object @@ -36,19 +36,17 @@ convert_polygon_df_units <- function(df, units = "bigpts") { #' #' @noRd convert_polygon_df_to_polygon_grob <- function(polygon_df, default.units = 'npc', gp = gpar()) { - - - if (is.null(polygon_df) || nrow(polygon_df) < 3) { - return(grid::nullGrob()) - } - - grid::polygonGrob( - x = polygon_df$x, - y = polygon_df$y, - id = polygon_df$id, - default.units = default.units, - gp = gp - ) + if (is.null(polygon_df) || nrow(polygon_df) < 3) { + return(grid::nullGrob()) + } + + grid::polygonGrob( + x = polygon_df$x, + y = polygon_df$y, + id = polygon_df$id, + default.units = default.units, + gp = gp + ) } #' Convert a \code{polygon_df} to an \code{sf} POLYGON/MULTIPOLYGON @@ -59,38 +57,36 @@ convert_polygon_df_to_polygon_grob <- function(polygon_df, default.units = 'npc' #' @return sf polygon object #' @noRd convert_polygon_df_to_polygon_sf <- function(polygon_df, buffer_dist = 0) { + if (is.null(polygon_df) || nrow(polygon_df) < 3 || anyNA(polygon_df$x) || anyNA(polygon_df$y)) { + return(sf::st_polygon()) + } - if (is.null(polygon_df) || nrow(polygon_df) < 3 || - anyNA(polygon_df$x) || anyNA(polygon_df$y)) { - return(sf::st_polygon()) - } - - polys <- split(polygon_df, polygon_df$id) + polys <- split(polygon_df, polygon_df$id) - create_coords <- function(poly) { - xs <- poly$x - ys <- poly$y + create_coords <- function(poly) { + xs <- poly$x + ys <- poly$y - # {sf} wants explicitly closed polygons, so set the last point - # to be the same as the first - if (xs[1] != tail(xs, 1) || ys[1] != tail(ys, 1)) { - xs <- c(xs, xs[1]) - ys <- c(ys, ys[1]) - } + # {sf} wants explicitly closed polygons, so set the last point + # to be the same as the first + if (xs[1] != tail(xs, 1) || ys[1] != tail(ys, 1)) { + xs <- c(xs, xs[1]) + ys <- c(ys, ys[1]) + } - list(cbind(xs, ys)) - } + list(cbind(xs, ys)) + } - all_coords <- lapply(polys, create_coords) + all_coords <- lapply(polys, create_coords) - res <- sf::st_multipolygon(all_coords) + res <- sf::st_multipolygon(all_coords) - # perform a zero-buffer operation to remove self-intersection - # As suggested here: - # - https://gis.stackexchange.com/questions/163445/getting-topologyexception-input-geom-1-is-invalid-which-is-due-to-self-intersec#163480 - # https://gis.stackexchange.com/questions/223252/how-to-overcome-invalid-input-geom-and-self-intersection-when-intersecting-shape - res <- sf::st_buffer(res, buffer_dist) - res + # perform a zero-buffer operation to remove self-intersection + # As suggested here: + # - https://gis.stackexchange.com/questions/163445/getting-topologyexception-input-geom-1-is-invalid-which-is-due-to-self-intersec#163480 + # https://gis.stackexchange.com/questions/223252/how-to-overcome-invalid-input-geom-and-self-intersection-when-intersecting-shape + res <- sf::st_buffer(res, buffer_dist) + res } #' Convert a sf GEOMETRYCOLLECTION/POLYGON/MULTIPOLYGON into a polygon_df @@ -101,39 +97,57 @@ convert_polygon_df_to_polygon_sf <- function(polygon_df, buffer_dist = 0) { #' #' @noRd convert_polygon_sf_to_polygon_df <- function(mp) { - mat <- as.matrix(mp) - if (sf::st_is_empty(mp)) - return(mat) - if (!inherits(mp, c('POLYGON', 'MULTIPOLYGON', 'GEOMETRYCOLLECTION', - 'MULTILINESTRING', 'MULTIPOINT', 'LINESTRING', 'POINT'))) { - warn(paste("convert_polygon_sf_to_polygon_df():", - "Not GEOMETRYCOLLECTION, POLYGON, or MULTIPOLYGON:", - deparse(class(mp)))) - } - if (!inherits(mp, c('POLYGON', 'MULTIPOLYGON', 'GEOMETRYCOLLECTION'))) { - return(NULL) - } - - poly_lengths <- get_poly_lengths(mp) - id <- rep.int(seq_along(poly_lengths), times = poly_lengths) - - create_polygon_df(x=mat[,1], y=mat[,2], id=id) + mat <- as.matrix(mp) + if (sf::st_is_empty(mp)) { + return(mat) + } + if ( + !inherits( + mp, + c( + 'POLYGON', + 'MULTIPOLYGON', + 'GEOMETRYCOLLECTION', + 'MULTILINESTRING', + 'MULTIPOINT', + 'LINESTRING', + 'POINT' + ) + ) + ) { + warn(paste( + "convert_polygon_sf_to_polygon_df():", + "Not GEOMETRYCOLLECTION, POLYGON, or MULTIPOLYGON:", + deparse(class(mp)) + )) + } + if (!inherits(mp, c('POLYGON', 'MULTIPOLYGON', 'GEOMETRYCOLLECTION'))) { + return(NULL) + } + + poly_lengths <- get_poly_lengths(mp) + id <- rep.int(seq_along(poly_lengths), times = poly_lengths) + + create_polygon_df(x = mat[, 1], y = mat[, 2], id = id) } get_poly_lengths <- function(sf_object) { - if (inherits(sf_object, c('POLYGON', 'LINESTRING', 'POINT'))) { - nrow(as.matrix(sf_object)) - } else if (inherits(sf_object, c('MULTIPOLYGON', 'MULTILINESTRING', 'MULTIPOINT'))) { - if (max(lengths(sf_object)) > 1L) - abort("There is a MULTIPOLYGON/MULTILINESTRING/MULTIPOINT with length greater than 1") - vapply(sf_object, function(x) nrow(as.matrix(x[[1]])), integer(1)) - } else if (inherits(sf_object, 'GEOMETRYCOLLECTION')) { - vapply(sf_object, get_poly_lengths, integer(1)) - } else { - abort(paste("convert_polygon_sf_to_polygon_df():", - "Not GEOMETRYCOLLECTION, POLYGON, or MULTIPOLYGON:", - deparse(class(sf_object)))) - } + if (inherits(sf_object, c('POLYGON', 'LINESTRING', 'POINT'))) { + nrow(as.matrix(sf_object)) + } else if (inherits(sf_object, c('MULTIPOLYGON', 'MULTILINESTRING', 'MULTIPOINT'))) { + if (max(lengths(sf_object)) > 1L) { + abort("There is a MULTIPOLYGON/MULTILINESTRING/MULTIPOINT with length greater than 1") + } + vapply(sf_object, function(x) nrow(as.matrix(x[[1]])), integer(1)) + } else if (inherits(sf_object, 'GEOMETRYCOLLECTION')) { + vapply(sf_object, get_poly_lengths, integer(1)) + } else { + abort(paste( + "convert_polygon_sf_to_polygon_df():", + "Not GEOMETRYCOLLECTION, POLYGON, or MULTIPOLYGON:", + deparse(class(sf_object)) + )) + } } #' Convert a polygon to an alpha mask @@ -148,33 +162,35 @@ get_poly_lengths <- function(sf_object) { #' #' @noRd convert_polygon_df_to_alpha_channel <- function(polygon_df, width, height) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Convert the polygon to an actual grob, coloured 'black' - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - gp <- gpar(fill = 'black') - boundary_grob <- convert_polygon_df_to_polygon_grob(polygon_df, gp=gp) - - # Note `ragg::agg_capture()`'s non-"native" format is a matrix of color strings - # while `png::readPNG()`'s non-"native" format is an array of numeric values - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Save the grob as an image of the given size - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - png_file <- tempfile(fileext = ".png") - png(png_file, width=width, height=height) - grid.draw(boundary_grob) - dev.off() - - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - # Load the file and convert o a numeric matrix with values 0/1 depending - # on whether the pixel is white or black. - #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - alpha_channel <- png::readPNG(png_file, native = FALSE) - alpha_channel <- alpha_channel[,,1] < 0.5 - storage.mode(alpha_channel) <- 'numeric' - - # t(alpha_channel) - alpha_channel + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Convert the polygon to an actual grob, coloured 'black' + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + gp <- gpar(fill = 'black') + boundary_grob <- convert_polygon_df_to_polygon_grob(polygon_df, gp = gp) + + # Note `ragg::agg_capture()`'s non-"native" format is a matrix of color strings + # while `png::readPNG()`'s non-"native" format is an array of numeric values + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Save the grob as an image of the given size + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + png_file <- tempfile(fileext = ".png") + png(png_file, width = width, height = height) + grid.draw(boundary_grob) + dev.off() + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # Load the file and convert o a numeric matrix with values 0/1 depending + # on whether the pixel is white or black. + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + alpha_channel <- png::readPNG(png_file, native = FALSE) + alpha_channel <- alpha_channel[,, 1] < 0.5 + storage.mode(alpha_channel) <- 'numeric' + + # t(alpha_channel) + alpha_channel } diff --git a/R/utils-sf.R b/R/utils-sf.R index 47f1881..960f863 100644 --- a/R/utils-sf.R +++ b/R/utils-sf.R @@ -1,64 +1,93 @@ -sf_multipolygon_to_polygon_grob <- function(multipolygons_sf, gp = gpar(), - default.units = "npc", name = NULL) { - df <- convert_polygon_sf_to_polygon_df(multipolygons_sf) - if (is.null(df)) { - nullGrob() - } else { - polygonGrob(x = df$x, y = df$y, id = df$id, - default.units = default.units, gp = gp, name = name) - } +sf_multipolygon_to_polygon_grob <- function( + multipolygons_sf, + gp = gpar(), + default.units = "npc", + name = NULL +) { + df <- convert_polygon_sf_to_polygon_df(multipolygons_sf) + if (is.null(df)) { + nullGrob() + } else { + polygonGrob( + x = df$x, + y = df$y, + id = df$id, + default.units = default.units, + gp = gp, + name = name + ) + } } # build a circle of radius `r` centered on each point in `sf_points` -sf_points_to_circle_grob <- function(sf_points, r, gp = gpar(), - default.units = "npc", name = NULL) { - points_mat <- as.matrix(sf_points) - if (is.null(points_mat) || nrow(points_mat) == 0) { - nullGrob() - } else { - circleGrob(x = points_mat[, 1], y = points_mat[, 2], r = r, - default.units = default.units, gp = gp, name = name) - } +sf_points_to_circle_grob <- function( + sf_points, + r, + gp = gpar(), + default.units = "npc", + name = NULL +) { + points_mat <- as.matrix(sf_points) + if (is.null(points_mat) || nrow(points_mat) == 0) { + nullGrob() + } else { + circleGrob( + x = points_mat[, 1], + y = points_mat[, 2], + r = r, + default.units = default.units, + gp = gp, + name = name + ) + } } # `xy_polygon` has `x` and `y` elements which will be added to each point in `sf_points` -sf_points_to_polygon_grob <- function(sf_points, xy_polygon, gp = gpar(), - default.units = "npc", name = NULL) { - points_mat <- as.matrix(sf_points) - df_polygon <- as.data.frame(xy_polygon) - l_xy <- lapply(seq(nrow(points_mat)), - function(i_r) { - x0 <- points_mat[i_r, 1] - y0 <- points_mat[i_r, 2] - df <- df_polygon - df$x <- df$x + x0 - df$y <- df$y + y0 - df - }) - df <- do.call(rbind, l_xy) - if (is.null(df)) { - nullGrob() - } else { - df$id <- rep(seq(nrow(points_mat)), each = nrow(df_polygon)) - polygonGrob(x = df$x, y = df$y, id = df$id, - default.units = default.units, gp = gp, name = name) - } +sf_points_to_polygon_grob <- function( + sf_points, + xy_polygon, + gp = gpar(), + default.units = "npc", + name = NULL +) { + points_mat <- as.matrix(sf_points) + df_polygon <- as.data.frame(xy_polygon) + l_xy <- lapply(seq(nrow(points_mat)), function(i_r) { + x0 <- points_mat[i_r, 1] + y0 <- points_mat[i_r, 2] + df <- df_polygon + df$x <- df$x + x0 + df$y <- df$y + y0 + df + }) + df <- do.call(rbind, l_xy) + if (is.null(df)) { + nullGrob() + } else { + df$id <- rep(seq(nrow(points_mat)), each = nrow(df_polygon)) + polygonGrob( + x = df$x, + y = df$y, + id = df$id, + default.units = default.units, + gp = gp, + name = name + ) + } } # `xy_polygon` has `x` and `y` elements which will be added to each point in `sf_points` sf_points_to_sf_multipolygon <- function(sf_points, xy_polygon) { - points_mat <- as.matrix(sf_points) - df_polygon <- as.data.frame(xy_polygon) - df_polygon <- rbind(df_polygon, df_polygon[1L, ]) - l_xy <- lapply(seq(nrow(points_mat)), - function(i_r) { - x0 <- points_mat[i_r, 1] - y0 <- points_mat[i_r, 2] - df <- df_polygon - df$x <- df$x + x0 - df$y <- df$y + y0 - list(as.matrix(df)) - }) - sf::st_multipolygon(l_xy) + points_mat <- as.matrix(sf_points) + df_polygon <- as.data.frame(xy_polygon) + df_polygon <- rbind(df_polygon, df_polygon[1L, ]) + l_xy <- lapply(seq(nrow(points_mat)), function(i_r) { + x0 <- points_mat[i_r, 1] + y0 <- points_mat[i_r, 2] + df <- df_polygon + df$x <- df$x + x0 + df$y <- df$y + y0 + list(as.matrix(df)) + }) + sf::st_multipolygon(l_xy) } - diff --git a/R/zzz.R b/R/zzz.R index c70f7de..831f061 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -9,7 +9,7 @@ img_read_memoised <- img_read # Modify function at load time .onLoad <- function(libname, pkgname) { - img_read_memoised <<- memoise::memoise(img_read) + img_read_memoised <<- memoise::memoise(img_read) } #' @import grid diff --git a/data-raw/logo.R b/data-raw/logo.R new file mode 100644 index 0000000..f9ca1f8 --- /dev/null +++ b/data-raw/logo.R @@ -0,0 +1,144 @@ +library("grid") +library("gridpattern") +library("piecepackr") +library("polyclip") + +draw_logo <- function(bleed = FALSE, cut = FALSE) { + x_hex <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + y_hex <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + + hex_xy <- list(x = x_hex, y = y_hex) + bot_xy <- list(x = c(0, 0, 1, 1), y = 0 / 4 + c(0, 1 / 4, 1 / 4, 0)) + low_xy <- list(x = c(0, 0, 1, 1), y = 1 / 4 + c(0, 1 / 4, 1 / 4, 0)) + hih_xy <- list(x = c(0, 0, 1, 1), y = 2 / 4 + c(0, 1 / 4, 1 / 4, 0)) + top_xy <- list(x = c(0, 0, 1, 1), y = 3 / 4 + c(0, 1 / 4, 1 / 4, 0)) + if (bleed) { + bot_xy$y <- bot_xy$y + c(0, 1, 1, 0) / 8 + top_xy$y <- top_xy$y - c(1, 0, 0, 1) / 8 + } + + bd_bot <- polyclip(hex_xy, bot_xy, "intersection")[[1]] + bd_low <- polyclip(hex_xy, low_xy, "intersection")[[1]] + bd_hih <- polyclip(hex_xy, hih_xy, "intersection")[[1]] + bd_top <- polyclip(hex_xy, top_xy, "intersection")[[1]] + + # colorblind accessible scheme https://jfly.uni-koeln.de/color/ + blue <- grDevices::rgb(0.35, 0.70, 0.90) + yellow <- grDevices::rgb(0.95, 0.90, 0.25) + red <- grDevices::rgb(0.80, 0.40, 0.00) + green <- grDevices::rgb(0.00, 0.60, 0.50) + orange <- grDevices::rgb(0.90, 0.60, 0.00) + + w <- 4.5 + + grid.newpage() + gp <- gpar(fill = yellow, col = "black") + # grid.polygon(bd_bot$x, bd_bot$y, gp = gpar(fill = "white", col = NA)) + grid.pattern_weave( + bd_bot$x, + bd_bot$y, + fill2 = blue, + type = "satin", + density = 0.3, + angle = 45, + gp = gp + ) + gp <- gpar(fill = c(yellow, orange, red), col = "black") + grid.pattern_regular_polygon( + bd_top$x, + bd_top$y, + shape = "convex3", + density = 1.33, + grid = "hex_circle", + gp = gp, + spacing = 0.05, + rot = 30, + angle = 0 + ) + pushViewport(viewport(height = unit(w, "inches"))) + gp <- gpar(fill = c(yellow, blue), col = "black") + grid.pattern_regular_polygon( + bd_low$x, + bd_low$y, + shape = "square", + density = 1, + angle = 0, + spacing = 0.125, + gp = gp + ) + gp <- gpar(fill = c(yellow, orange, red), col = "black") + grid.pattern_regular_polygon( + bd_hih$x, + bd_hih$y, + shape = "convex6", + density = 1, + angle = 0, + grid = "hex", + spacing = 0.175, + gp = gp, + yoffset = -0.03, + xoffset = -0.01 + ) + # grid.polygon(bd_top$x, bd_top$y, gp = gpar(fill = "white", col = NA)) + popViewport() + + pushViewport(viewport(width = unit(w, "inches"), height = unit(w, "inches"))) + gp = gpar(col = "black", fontsize = 50, fontfamily = "sans", fontface = "bold") + yoffset <- 0.002 + grid.text("g", x = 0.23, y = 0.625 + yoffset, gp = gp) + grid.text("r", x = 0.40, y = 0.625 + yoffset, gp = gp) + grid.text("i", x = 0.58, y = 0.625 + yoffset, gp = gp) + grid.text("d", x = 0.75, y = 0.625 + yoffset, gp = gp) + + xr <- range(x_hex) + step <- (xr[2] - xr[1]) / 7 + x <- seq(xr[1] + step / 2, by = step, length.out = 7) + yoffset <- -0.001 + gp = gpar(col = "black", fontsize = 48, fontfamily = "sans", fontface = "bold") + grid.text("p", x = x[1], y = 0.375 + yoffset, gp = gp) + grid.text("a", x = x[2], y = 0.375 + yoffset, gp = gp) + grid.text("t", x = x[3], y = 0.375 + yoffset, gp = gp) + grid.text("t", x = x[4], y = 0.375 + yoffset, gp = gp) + grid.text("e", x = x[5], y = 0.375 + yoffset, gp = gp) + grid.text("r", x = x[6], y = 0.375 + yoffset, gp = gp) + grid.text("n", x = x[7], y = 0.375 + yoffset, gp = gp) + popViewport() + + if (!isTRUE(bleed) || isTRUE(cut)) { + pushViewport(viewport(width = unit(w, "inches"), height = unit(w, "inches"))) + hex <- pp_shape("convex6") + grid.draw(hex$shape(gp = gpar(fill = NA, col = "white", lwd = 4))) + if (!isTRUE(bleed)) { + grid.draw(hex$mat(mat_width = 0.01, gp = gpar(fill = "black", col = NA))) + } + popViewport() + if (isTRUE(bleed)) { + pushViewport(viewport(width = unit(5 / 6, "npc"), height = unit(5 / 6, "npc"))) + grid.draw(hex$shape(gp = gpar(fill = "transparent", col = "orange"))) + popViewport() + } + } +} + +# svg("man/figures/logo.svg", width = w, height = w, bg = "transparent") +# draw_logo() +# dev.off() +# +# png("man/figures/logo.png", width = w, height = w, units = "in", res = 72, bg = "transparent") +# draw_logo() +# dev.off() + +png( + "raw-data/sticker_with_cutline.png", + width = 5.125, + height = 5.125, + units = "in", + res = 150, + bg = "white" +) +draw_logo(bleed = TRUE, cut = TRUE) +dev.off() + +png("raw-data/sticker.png", width = 5.125, height = 5.125, units = "in", res = 150, bg = "white") +draw_logo(bleed = TRUE, cut = FALSE) +dev.off() diff --git a/man/grid.pattern.Rd b/man/grid.pattern.Rd index 25e1c01..10fb403 100644 --- a/man/grid.pattern.Rd +++ b/man/grid.pattern.Rd @@ -140,7 +140,7 @@ See \code{\link[=grid.pattern_weave]{grid.pattern_weave()}} for more information # Can alternatively use "gpar()" to specify colour and line attributes grid::grid.newpage() - grid.pattern("stripe", x_hex, y_hex, + grid.pattern("stripe", x_hex, y_hex, gp = grid::gpar(col="blue", fill="red", lwd=2)) # 'weave' pattern diff --git a/man/patternFill.Rd b/man/patternFill.Rd index ed9999a..43f42f6 100644 --- a/man/patternFill.Rd +++ b/man/patternFill.Rd @@ -42,14 +42,14 @@ if (guess_has_R4.1_features("patterns") && stripe_fill <- patternFill("stripe", fill = c("red", "blue")) grid.circle(gp = gpar(fill = stripe_fill)) } - -if (guess_has_R4.1_features("patterns") && + +if (guess_has_R4.1_features("patterns") && require("ggplot2", quietly = TRUE) && (getRversion() >= "4.2")) { grid.newpage() - weave_fill <- patternFill("weave", fill = "red", fill2 = "blue", + weave_fill <- patternFill("weave", fill = "red", fill2 = "blue", colour = "transparent") - hex_fill <- patternFill("polygon_tiling", type = "hexagonal", + hex_fill <- patternFill("polygon_tiling", type = "hexagonal", fill = c("black", "white", "grey"), colour = "transparent") df <- data.frame(trt = c("a", "b"), outcome = c(1.9, 3.2)) diff --git a/raw-data/logo.R b/raw-data/logo.R deleted file mode 100644 index 607d33c..0000000 --- a/raw-data/logo.R +++ /dev/null @@ -1,106 +0,0 @@ -library("grid") -library("gridpattern") -library("piecepackr") -library("polyclip") - -draw_logo <- function(bleed = FALSE, cut = FALSE) { -x_hex <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) -y_hex <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - -hex_xy <- list(x = x_hex, y = y_hex) -bot_xy <- list(x = c(0, 0, 1, 1), y = 0/4 + c(0, 1/4, 1/4, 0)) -low_xy <- list(x = c(0, 0, 1, 1), y = 1/4 + c(0, 1/4, 1/4, 0)) -hih_xy <- list(x = c(0, 0, 1, 1), y = 2/4 + c(0, 1/4, 1/4, 0)) -top_xy <- list(x = c(0, 0, 1, 1), y = 3/4 + c(0, 1/4, 1/4, 0)) -if (bleed) { - bot_xy$y <- bot_xy$y + c(0, 1, 1, 0) / 8 - top_xy$y <- top_xy$y - c(1, 0, 0, 1) / 8 -} - -bd_bot <- polyclip(hex_xy, bot_xy, "intersection")[[1]] -bd_low <- polyclip(hex_xy, low_xy, "intersection")[[1]] -bd_hih <- polyclip(hex_xy, hih_xy, "intersection")[[1]] -bd_top <- polyclip(hex_xy, top_xy, "intersection")[[1]] - -# colorblind accessible scheme https://jfly.uni-koeln.de/color/ -blue <- grDevices::rgb(0.35, 0.70, 0.90) -yellow <- grDevices::rgb(0.95, 0.90, 0.25) -red <- grDevices::rgb(0.80, 0.40, 0.00) -green <- grDevices::rgb(0.00, 0.60, 0.50) -orange <- grDevices::rgb(0.90, 0.60, 0.00) - -w <- 4.5 - -grid.newpage() -gp <- gpar(fill = yellow, col = "black") -# grid.polygon(bd_bot$x, bd_bot$y, gp = gpar(fill = "white", col = NA)) -grid.pattern_weave(bd_bot$x, bd_bot$y, fill2 = blue, - type = "satin", density=0.3, angle = 45, gp=gp) -gp <- gpar(fill = c(yellow, orange, red), col = "black") -grid.pattern_regular_polygon(bd_top$x, bd_top$y, shape = "convex3", density = 1.33, - grid = "hex_circle", gp = gp, - spacing = 0.05, rot = 30, angle = 0) -pushViewport(viewport(height = unit(w, "inches"))) -gp <- gpar(fill = c(yellow, blue), col = "black") -grid.pattern_regular_polygon(bd_low$x, bd_low$y, shape = "square", - density = 1, angle = 0, spacing=0.125, gp = gp) -gp <- gpar(fill = c(yellow, orange, red), col = "black") -grid.pattern_regular_polygon(bd_hih$x, bd_hih$y, shape = "convex6", - density = 1, angle = 0, grid = "hex", spacing=0.175, gp = gp, - yoffset = -0.03, xoffset = -0.01) -# grid.polygon(bd_top$x, bd_top$y, gp = gpar(fill = "white", col = NA)) -popViewport() - -pushViewport(viewport(width=unit(w, "inches"), height = unit(w, "inches"))) -gp = gpar(col = "black", fontsize = 50, fontfamily = "sans", fontface = "bold") -yoffset <- 0.002 -grid.text("g", x=0.23, y=0.625 + yoffset, gp = gp) -grid.text("r", x=0.40, y=0.625 + yoffset, gp = gp) -grid.text("i", x=0.58, y=0.625 + yoffset, gp = gp) -grid.text("d", x=0.75, y=0.625 + yoffset, gp = gp) - -xr <- range(x_hex) -step <- (xr[2] - xr[1]) / 7 -x <- seq(xr[1] + step / 2, by = step, length.out = 7) -yoffset <- -0.001 -gp = gpar(col = "black", fontsize = 48, fontfamily = "sans", fontface = "bold") -grid.text("p", x=x[1], y=0.375 + yoffset, gp = gp) -grid.text("a", x=x[2], y=0.375 + yoffset, gp = gp) -grid.text("t", x=x[3], y=0.375 + yoffset, gp = gp) -grid.text("t", x=x[4], y=0.375 + yoffset, gp = gp) -grid.text("e", x=x[5], y=0.375 + yoffset, gp = gp) -grid.text("r", x=x[6], y=0.375 + yoffset, gp = gp) -grid.text("n", x=x[7], y=0.375 + yoffset, gp = gp) -popViewport() - -if (!isTRUE(bleed) || isTRUE(cut)) { - pushViewport(viewport(width=unit(w, "inches"), height = unit(w, "inches"))) - hex <- pp_shape("convex6") - grid.draw(hex$shape(gp = gpar(fill = NA, col = "white", lwd=4))) - if(!isTRUE(bleed)) { - grid.draw(hex$mat(mat_width = 0.01, gp = gpar(fill = "black", col = NA))) - } - popViewport() - if (isTRUE(bleed)) { - pushViewport(viewport(width=unit(5/6, "npc"), height=unit(5/6, "npc"))) - grid.draw(hex$shape(gp = gpar(fill="transparent", col="orange"))) - popViewport() - } -} -} - -# svg("man/figures/logo.svg", width = w, height = w, bg = "transparent") -# draw_logo() -# dev.off() -# -# png("man/figures/logo.png", width = w, height = w, units = "in", res = 72, bg = "transparent") -# draw_logo() -# dev.off() - -png("raw-data/sticker_with_cutline.png", width = 5.125, height = 5.125, units = "in", res = 150, bg = "white") -draw_logo(bleed = TRUE, cut = TRUE) -dev.off() - -png("raw-data/sticker.png", width = 5.125, height = 5.125, units = "in", res = 150, bg = "white") -draw_logo(bleed = TRUE, cut = FALSE) -dev.off() diff --git a/tests/testthat/test_aRtsy.R b/tests/testthat/test_aRtsy.R index 254f469..677f7a4 100644 --- a/tests/testthat/test_aRtsy.R +++ b/tests/testthat/test_aRtsy.R @@ -1,23 +1,23 @@ test_that("aRtsy patterns works as expected", { - skip_on_ci() - skip_on_cran() - skip_if_not_installed("aRtsy") - skip_if_not(getRversion() >= "4.3.0") - skip_if_not(isTRUE(all(capabilities(c("cairo", "png"))))) + skip_on_ci() + skip_on_cran() + skip_if_not_installed("aRtsy") + skip_if_not(getRversion() >= "4.3.0") + skip_if_not(isTRUE(all(capabilities(c("cairo", "png"))))) - f <- tempfile(fileext = ".png") - png(f, type = "cairo") - grid.pattern_aRtsy(type = "maze") - dev.off() - expect_true(file.size(f) > 0) - unlink(f) + f <- tempfile(fileext = ".png") + png(f, type = "cairo") + grid.pattern_aRtsy(type = "maze") + dev.off() + expect_true(file.size(f) > 0) + unlink(f) - f <- tempfile(fileext = ".png") - png(f, type = "cairo") - grid.pattern_aRtsy(type = "strokes") - dev.off() - expect_true(file.size(f) > 0) - unlink(f) + f <- tempfile(fileext = ".png") + png(f, type = "cairo") + grid.pattern_aRtsy(type = "strokes") + dev.off() + expect_true(file.size(f) > 0) + unlink(f) - expect_true(length(names_aRtsy()) >= 34L) + expect_true(length(names_aRtsy()) >= 34L) }) diff --git a/tests/testthat/test_array.R b/tests/testthat/test_array.R index c48d779..565cf9f 100644 --- a/tests/testthat/test_array.R +++ b/tests/testthat/test_array.R @@ -1,174 +1,213 @@ test_raster <- function(ref_png, fn, update = FALSE) { - f <- file.path("../figs/array", ref_png) - if (update) my_png(f, fn) - ref <- magick::image_read(f) - - tmpfile <- tempfile(fileext = ".png") - my_png(tmpfile, fn) - image <- magick::image_read(tmpfile) - unlink(tmpfile) - - diff <- magick::image_compare(image, ref, "AE") - bool <- attr(diff, "distortion") < 0.01 - if (!bool) { - grDevices::dev.new() - grid::pushViewport(grid::viewport(x = 0.25, width = 0.5)) - grid::grid.raster(ref) - grid::popViewport() - grid::pushViewport(grid::viewport(x = 0.75, width = 0.5)) - grid::grid.raster(image) - grid::popViewport() - } - expect_true(bool) + f <- file.path("../figs/array", ref_png) + if (update) { + my_png(f, fn) + } + ref <- magick::image_read(f) + + tmpfile <- tempfile(fileext = ".png") + my_png(tmpfile, fn) + image <- magick::image_read(tmpfile) + unlink(tmpfile) + + diff <- magick::image_compare(image, ref, "AE") + bool <- attr(diff, "distortion") < 0.01 + if (!bool) { + grDevices::dev.new() + grid::pushViewport(grid::viewport(x = 0.25, width = 0.5)) + grid::grid.raster(ref) + grid::popViewport() + grid::pushViewport(grid::viewport(x = 0.75, width = 0.5)) + grid::grid.raster(image) + grid::popViewport() + } + expect_true(bool) } my_png <- function(f, fn) { - current_dev <- grDevices::dev.cur() - if (current_dev > 1) on.exit(grDevices::dev.set(current_dev)) - grDevices::png(f, type = "cairo", width = 240, height = 240) - fn() - grDevices::dev.off() + current_dev <- grDevices::dev.cur() + if (current_dev > 1) { + on.exit(grDevices::dev.set(current_dev)) + } + grDevices::png(f, type = "cairo", width = 240, height = 240) + fn() + grDevices::dev.off() } test_that("array patterns works as expected", { - skip_on_ci() - skip_on_cran() - skip_if_not(capabilities("cairo")) - skip_if_not_installed("magick", "2.7.4") - skip_if_not_installed("ragg") - - x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - test_raster("gradient.png", - function() grid.pattern_gradient(x, y, fill="blue", fill2="green", - orientation="radial", use_R4.1_gradients = FALSE)) - test_raster("gradient_horizontal.png", - function() grid.pattern_gradient(x, y, fill="blue", fill2="green", - orientation="horizontal", use_R4.1_gradients = FALSE)) - logo_filename <- system.file("img", "Rlogo.png" , package="png") - test_raster("image.png", function() { - grid.pattern_image(x, y, filename=logo_filename, type="fit") - }) - test_raster("image_expand.png", function() { - grid.pattern_image(x, y, filename=logo_filename, type="expand") - }) - test_raster("image_tile.png", function() { - grid.pattern_image(x, y, filename=logo_filename, type="tile", scale=-2) - }) - test_raster("image_none.png", function() { - grid.pattern_image(x, y, filename=logo_filename, type="none", scale=-1) - }) - test_raster("image_squish.png", function() { - grid.pattern_image(x, y, filename=logo_filename, type="squish") - }) - test_raster("magick.png", - function() grid.pattern_magick(x, y, type="octagons", fill="blue", scale=2)) - test_raster("placeholder.png", - function() grid.pattern_placeholder(x, y, type="bear")) - - test_raster("plasma_zero.png", - function() grid.pattern_plasma(x = c(0.5, 0.5, 0.5, 0.5), - y = c(0, 1, 1, 0), fill = "green")) - - test_raster("plasma.png", - function() { - magick::magick_set_seed(42) # introduced in v2.7.4 - grid.pattern_plasma(x, y, fill = "green") - }) - - playing_card_symbols <- c("\u2660", "\u2665", "\u2666", "\u2663") - test_raster("text.png", - function() grid.pattern_text(x, y, shape = playing_card_symbols, - colour = c("black", "red", "red", "black"), - use_R4.1_masks = TRUE, - size = 18, spacing = 0.1, angle = 0)) - - gp <- gpar(fill = c("blue", "red", "yellow", "green"), col = "black") - test_raster("rose.png", - function() grid.pattern_rose(x, y, - spacing = 0.15, density = 0.5, angle = 0, - use_R4.1_masks = NULL, - frequency = 1:4, gp = gp)) - - create_pattern_simple <- function(width, height, params, legend) { - choice <- params$pattern_type - if (is.null(choice) || is.na(choice) || !is.character(choice)) { - choice <- 'a' - } - values <- switch( - choice, - a = rep(c(0, 1, 0, 1, 1, 0, 0, 1, 1, 1), each = 3), - b = rep(c(1, 0, 0, 1, 0.5, 0.5, 1, 1, 0, 0, 0, 0, 0, 0.5), each = 7), - c = rep(seq(0, 1, 0.05), each = 7), - rep(c(0, 1, 0, 1, 1, 0, 0, 1, 1, 1), each = 3) - ) - simple_array <- array(values, dim = c(height, width, 4)) - - simple_array - } - options(ggpattern_array_funcs = list(simple = create_pattern_simple)) - test_raster("simple.png", function() grid.pattern("simple", x, y, type = "b")) - - # clippingPathGrob() - clippee <- patternGrob("circle", gp = gpar(col = "black", fill = "yellow"), - spacing = 0.1, density = 0.5) - angle <- seq(2 * pi / 4, by = 2 * pi / 6, length.out = 7) - x_hex_outer <- 0.5 + 0.5 * cos(angle) - y_hex_outer <- 0.5 + 0.5 * sin(angle) - x_hex_inner <- 0.5 + 0.25 * cos(rev(angle)) - y_hex_inner <- 0.5 + 0.25 * sin(rev(angle)) - clipper <- grid::pathGrob(x = c(x_hex_outer, x_hex_inner), - y = c(y_hex_outer, y_hex_inner), - id = rep(1:2, each = 7), - rule = "evenodd") - - clipped <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = FALSE, - png_device = grDevices::png) - test_raster("clipGrob_cairo.png", function() grid.draw(clipped)) - - clipped <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = NULL) - test_raster("clipGrob_feature.png", function() grid.draw(clipped)) - - png_device <- default_png_device() - test_raster("clipGrob_manual.png", function() { - clipped <- gridpattern_clip_raster_manual(clippee, clipper, 72, png_device) - grid.draw(clipped) - }) - - clipped <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = FALSE) - test_raster("clipGrob_ragg.png", function() grid.draw(clipped)) - - # alphaMaskGrob() - clippee2 <- rectGrob(gp = gpar(fill = "blue", col = NA)) - clipper2 <- editGrob(clipper, gp = gpar(col = NA, fill = "black")) - clipper3 <- editGrob(clipper2, gp = gpar(col = "black", lwd=20, fill = rgb(0, 0, 0, 0.5))) - - masked <- alphaMaskGrob(clippee2, clipper3, use_R4.1_masks = FALSE, png_device = grDevices::png) - test_raster("alphaMaskGrob_cairo.png", function() { - grid.draw(masked) - }) - - masked <- alphaMaskGrob(clippee2, clipper3, use_R4.1_masks = NULL) - test_raster("alphaMaskGrob_feature.png", function() grid.draw(masked)) - - test_raster("alphaMaskGrob_manual.png", function() { - masked <- gridpattern_mask_raster_manual(clippee2, clipper3, 72, png_device) - grid.draw(masked) - }) - - masked <- alphaMaskGrob(clippee, clipper2, use_R4.1_masks = FALSE) - test_raster("alphaMaskGrob_ragg.png", function() grid.draw(masked)) - - # ambient - skip_if_not_installed("ambient") - test_raster("ambient.png", - function() { - set.seed(42) - grid.pattern_ambient(x, y, fill = "green", fill2 = "blue") - }) - test_raster("ambient_worley.png", - function() { - set.seed(42) - grid.pattern_ambient(x, y, type = "worley", fill = "green", fill2 = "blue") - }) + skip_on_ci() + skip_on_cran() + skip_if_not(capabilities("cairo")) + skip_if_not_installed("magick", "2.7.4") + skip_if_not_installed("ragg") + + x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + test_raster("gradient.png", function() { + grid.pattern_gradient( + x, + y, + fill = "blue", + fill2 = "green", + orientation = "radial", + use_R4.1_gradients = FALSE + ) + }) + test_raster("gradient_horizontal.png", function() { + grid.pattern_gradient( + x, + y, + fill = "blue", + fill2 = "green", + orientation = "horizontal", + use_R4.1_gradients = FALSE + ) + }) + logo_filename <- system.file("img", "Rlogo.png", package = "png") + test_raster("image.png", function() { + grid.pattern_image(x, y, filename = logo_filename, type = "fit") + }) + test_raster("image_expand.png", function() { + grid.pattern_image(x, y, filename = logo_filename, type = "expand") + }) + test_raster("image_tile.png", function() { + grid.pattern_image(x, y, filename = logo_filename, type = "tile", scale = -2) + }) + test_raster("image_none.png", function() { + grid.pattern_image(x, y, filename = logo_filename, type = "none", scale = -1) + }) + test_raster("image_squish.png", function() { + grid.pattern_image(x, y, filename = logo_filename, type = "squish") + }) + test_raster("magick.png", function() { + grid.pattern_magick(x, y, type = "octagons", fill = "blue", scale = 2) + }) + test_raster("placeholder.png", function() grid.pattern_placeholder(x, y, type = "bear")) + + test_raster("plasma_zero.png", function() { + grid.pattern_plasma(x = c(0.5, 0.5, 0.5, 0.5), y = c(0, 1, 1, 0), fill = "green") + }) + + test_raster("plasma.png", function() { + magick::magick_set_seed(42) # introduced in v2.7.4 + grid.pattern_plasma(x, y, fill = "green") + }) + + playing_card_symbols <- c("\u2660", "\u2665", "\u2666", "\u2663") + test_raster("text.png", function() { + grid.pattern_text( + x, + y, + shape = playing_card_symbols, + colour = c("black", "red", "red", "black"), + use_R4.1_masks = TRUE, + size = 18, + spacing = 0.1, + angle = 0 + ) + }) + + gp <- gpar(fill = c("blue", "red", "yellow", "green"), col = "black") + test_raster("rose.png", function() { + grid.pattern_rose( + x, + y, + spacing = 0.15, + density = 0.5, + angle = 0, + use_R4.1_masks = NULL, + frequency = 1:4, + gp = gp + ) + }) + + create_pattern_simple <- function(width, height, params, legend) { + choice <- params$pattern_type + if (is.null(choice) || is.na(choice) || !is.character(choice)) { + choice <- 'a' + } + values <- switch( + choice, + a = rep(c(0, 1, 0, 1, 1, 0, 0, 1, 1, 1), each = 3), + b = rep(c(1, 0, 0, 1, 0.5, 0.5, 1, 1, 0, 0, 0, 0, 0, 0.5), each = 7), + c = rep(seq(0, 1, 0.05), each = 7), + rep(c(0, 1, 0, 1, 1, 0, 0, 1, 1, 1), each = 3) + ) + simple_array <- array(values, dim = c(height, width, 4)) + + simple_array + } + options(ggpattern_array_funcs = list(simple = create_pattern_simple)) + test_raster("simple.png", function() grid.pattern("simple", x, y, type = "b")) + + # clippingPathGrob() + clippee <- patternGrob( + "circle", + gp = gpar(col = "black", fill = "yellow"), + spacing = 0.1, + density = 0.5 + ) + angle <- seq(2 * pi / 4, by = 2 * pi / 6, length.out = 7) + x_hex_outer <- 0.5 + 0.5 * cos(angle) + y_hex_outer <- 0.5 + 0.5 * sin(angle) + x_hex_inner <- 0.5 + 0.25 * cos(rev(angle)) + y_hex_inner <- 0.5 + 0.25 * sin(rev(angle)) + clipper <- grid::pathGrob( + x = c(x_hex_outer, x_hex_inner), + y = c(y_hex_outer, y_hex_inner), + id = rep(1:2, each = 7), + rule = "evenodd" + ) + + clipped <- clippingPathGrob( + clippee, + clipper, + use_R4.1_clipping = FALSE, + png_device = grDevices::png + ) + test_raster("clipGrob_cairo.png", function() grid.draw(clipped)) + + clipped <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = NULL) + test_raster("clipGrob_feature.png", function() grid.draw(clipped)) + + png_device <- default_png_device() + test_raster("clipGrob_manual.png", function() { + clipped <- gridpattern_clip_raster_manual(clippee, clipper, 72, png_device) + grid.draw(clipped) + }) + + clipped <- clippingPathGrob(clippee, clipper, use_R4.1_clipping = FALSE) + test_raster("clipGrob_ragg.png", function() grid.draw(clipped)) + + # alphaMaskGrob() + clippee2 <- rectGrob(gp = gpar(fill = "blue", col = NA)) + clipper2 <- editGrob(clipper, gp = gpar(col = NA, fill = "black")) + clipper3 <- editGrob(clipper2, gp = gpar(col = "black", lwd = 20, fill = rgb(0, 0, 0, 0.5))) + + masked <- alphaMaskGrob(clippee2, clipper3, use_R4.1_masks = FALSE, png_device = grDevices::png) + test_raster("alphaMaskGrob_cairo.png", function() { + grid.draw(masked) + }) + + masked <- alphaMaskGrob(clippee2, clipper3, use_R4.1_masks = NULL) + test_raster("alphaMaskGrob_feature.png", function() grid.draw(masked)) + + test_raster("alphaMaskGrob_manual.png", function() { + masked <- gridpattern_mask_raster_manual(clippee2, clipper3, 72, png_device) + grid.draw(masked) + }) + + masked <- alphaMaskGrob(clippee, clipper2, use_R4.1_masks = FALSE) + test_raster("alphaMaskGrob_ragg.png", function() grid.draw(masked)) + + # ambient + skip_if_not_installed("ambient") + test_raster("ambient.png", function() { + set.seed(42) + grid.pattern_ambient(x, y, fill = "green", fill2 = "blue") + }) + test_raster("ambient_worley.png", function() { + set.seed(42) + grid.pattern_ambient(x, y, type = "worley", fill = "green", fill2 = "blue") + }) }) diff --git a/tests/testthat/test_geometry.R b/tests/testthat/test_geometry.R index 92e7555..c7593df 100644 --- a/tests/testthat/test_geometry.R +++ b/tests/testthat/test_geometry.R @@ -1,98 +1,161 @@ context("geometry") test_that("geometry helpers work as expected", { - xy <- rotate_xy(c(0, 1), c(0, 1), 90) - expect_equal(xy$x, c(1, 0)) - expect_equal(xy$y, c(0, 1)) + xy <- rotate_xy(c(0, 1), c(0, 1), 90) + expect_equal(xy$x, c(1, 0)) + expect_equal(xy$y, c(0, 1)) }) test_that("geometry patterns work as expected", { - - png_file <- tempfile(fileext = ".png") - png(png_file) - expect_error(grid.pattern_crosshatch(x, y, density = 1.1)) - expect_error(grid.pattern_stripe(x, y, density = 1.1)) - dev.off() - unlink(png_file) - - skip_if_not_installed("vdiffr") - skip_on_ci() - library("vdiffr") - - expect_doppelganger("default", grid.pattern) - - x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - expect_doppelganger("circle", function() - grid.pattern_circle(x, y, color="blue", fill="yellow", size = 2, density = 0.5)) - - expect_doppelganger("crosshatch", function() - grid.pattern_crosshatch(x, y, color="black", fill="blue", fill2="yellow", density = 0.5)) - - expect_doppelganger("fill", function() - grid.pattern_fill(x, y, fill = "blue", alpha = 0.5)) - - expect_doppelganger("none", function() - grid.pattern_none(x, y)) - - expect_error(assert_rp_shape(1), "Unknown shape 1") - expect_null(assert_rp_shape(c("square", "convex4"))) - expect_null(assert_rp_shape(c("star5", "circle", "null"))) - expect_doppelganger("regular_polygon", function() - grid.pattern_regular_polygon(x, y, color = "black", fill = "blue", density = 0.5)) - - expect_doppelganger("hexagon", function() - grid.pattern_regular_polygon(x, y, color = "transparent", fill = c("white", "grey", "black"), - density = 1.0, shape = "convex6", grid = "hex")) - - expect_doppelganger("square", function() - grid.pattern_regular_polygon(x, y, color = "black", fill = c("white", "grey"), - density = 1.0, shape = "square")) - - expect_doppelganger("eight_sided_star", function() - grid.pattern_regular_polygon(x, y, colour = "black", fill = c("blue", "yellow"), - density = 1.0, spacing = 0.1, shape = "star8")) - expect_doppelganger("stripe", function() - grid.pattern_stripe(x, y, color="black", fill=c("yellow", "blue"), density = 0.5)) - - expect_doppelganger("stripe_gpar", function() { - x <- c(0.1, 0.6, 0.8, 0.3) - y <- c(0.2, 0.3, 0.8, 0.5) - grid.pattern("stripe", x, y, gp = gpar(col="blue", fill="red", lwd=2)) - }) - - expect_doppelganger("wave_sine", function() - grid.pattern_wave(x, y, colour = "black", type = "sine", - fill = c("red", "blue"), density = 0.4, - spacing = 0.15, angle = 0, - amplitude = 0.05, frequency = 1 / 0.15)) - - expect_doppelganger("wave_triangle", function() - grid.pattern_wave(x, y, color="black", fill="yellow", - type = "triangle", density = 0.5, spacing = 0.15)) - - expect_doppelganger("weave", function() - grid.pattern_weave(x, y, color="black", fill="yellow", fill2="blue", - type = "twill", density = 0.5)) - - centroid_dot_pattern <- function(params, boundary_df, aspect_ratio, legend) { - boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df) - centroid <- sf::st_centroid(boundary_sf) - grid::pointsGrob(x = centroid[1], - y = centroid[2], - pch = params$pattern_shape, - size = unit(params$pattern_size, 'char'), - default.units = "npc", - gp = grid::gpar(col = update_alpha(params$pattern_fill, params$pattern_alpha)) - ) - } - options(ggpattern_geometry_funcs = list(centroid = centroid_dot_pattern)) - x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - expect_doppelganger("centroid", function() - grid.pattern("centroid", x, y, fill="blue", size = 5)) - - x <- c(0, 0, 0.5, 0.5, 0.5, 0.5, 1, 1) - y <- c(0, 0.5, 0.5, 0, 0.5, 1, 1, 0.5) - id <- rep(1:2, each = 4L) - expect_doppelganger("two_id", function() - grid.pattern(x = x, y = y, id = id)) + png_file <- tempfile(fileext = ".png") + png(png_file) + expect_error(grid.pattern_crosshatch(x, y, density = 1.1)) + expect_error(grid.pattern_stripe(x, y, density = 1.1)) + dev.off() + unlink(png_file) + + skip_if_not_installed("vdiffr") + skip_on_ci() + library("vdiffr") + + expect_doppelganger("default", grid.pattern) + + x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + expect_doppelganger("circle", function() { + grid.pattern_circle(x, y, color = "blue", fill = "yellow", size = 2, density = 0.5) + }) + + expect_doppelganger("crosshatch", function() { + grid.pattern_crosshatch( + x, + y, + color = "black", + fill = "blue", + fill2 = "yellow", + density = 0.5 + ) + }) + + expect_doppelganger("fill", function() { + grid.pattern_fill(x, y, fill = "blue", alpha = 0.5) + }) + + expect_doppelganger("none", function() { + grid.pattern_none(x, y) + }) + + expect_error(assert_rp_shape(1), "Unknown shape 1") + expect_null(assert_rp_shape(c("square", "convex4"))) + expect_null(assert_rp_shape(c("star5", "circle", "null"))) + expect_doppelganger("regular_polygon", function() { + grid.pattern_regular_polygon(x, y, color = "black", fill = "blue", density = 0.5) + }) + + expect_doppelganger("hexagon", function() { + grid.pattern_regular_polygon( + x, + y, + color = "transparent", + fill = c("white", "grey", "black"), + density = 1.0, + shape = "convex6", + grid = "hex" + ) + }) + + expect_doppelganger("square", function() { + grid.pattern_regular_polygon( + x, + y, + color = "black", + fill = c("white", "grey"), + density = 1.0, + shape = "square" + ) + }) + + expect_doppelganger("eight_sided_star", function() { + grid.pattern_regular_polygon( + x, + y, + colour = "black", + fill = c("blue", "yellow"), + density = 1.0, + spacing = 0.1, + shape = "star8" + ) + }) + expect_doppelganger("stripe", function() { + grid.pattern_stripe(x, y, color = "black", fill = c("yellow", "blue"), density = 0.5) + }) + + expect_doppelganger("stripe_gpar", function() { + x <- c(0.1, 0.6, 0.8, 0.3) + y <- c(0.2, 0.3, 0.8, 0.5) + grid.pattern("stripe", x, y, gp = gpar(col = "blue", fill = "red", lwd = 2)) + }) + + expect_doppelganger("wave_sine", function() { + grid.pattern_wave( + x, + y, + colour = "black", + type = "sine", + fill = c("red", "blue"), + density = 0.4, + spacing = 0.15, + angle = 0, + amplitude = 0.05, + frequency = 1 / 0.15 + ) + }) + + expect_doppelganger("wave_triangle", function() { + grid.pattern_wave( + x, + y, + color = "black", + fill = "yellow", + type = "triangle", + density = 0.5, + spacing = 0.15 + ) + }) + + expect_doppelganger("weave", function() { + grid.pattern_weave( + x, + y, + color = "black", + fill = "yellow", + fill2 = "blue", + type = "twill", + density = 0.5 + ) + }) + + centroid_dot_pattern <- function(params, boundary_df, aspect_ratio, legend) { + boundary_sf <- convert_polygon_df_to_polygon_sf(boundary_df) + centroid <- sf::st_centroid(boundary_sf) + grid::pointsGrob( + x = centroid[1], + y = centroid[2], + pch = params$pattern_shape, + size = unit(params$pattern_size, 'char'), + default.units = "npc", + gp = grid::gpar(col = update_alpha(params$pattern_fill, params$pattern_alpha)) + ) + } + options(ggpattern_geometry_funcs = list(centroid = centroid_dot_pattern)) + x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + expect_doppelganger("centroid", function() { + grid.pattern("centroid", x, y, fill = "blue", size = 5) + }) + + x <- c(0, 0, 0.5, 0.5, 0.5, 0.5, 1, 1) + y <- c(0, 0.5, 0.5, 0, 0.5, 1, 1, 0.5) + id <- rep(1:2, each = 4L) + expect_doppelganger("two_id", function() { + grid.pattern(x = x, y = y, id = id) + }) }) diff --git a/tests/testthat/test_hex.R b/tests/testthat/test_hex.R index 0caf352..02e314a 100644 --- a/tests/testthat/test_hex.R +++ b/tests/testthat/test_hex.R @@ -1,12 +1,12 @@ test_that("hex patterns work as expected", { - phh <- function(...) print.pattern_hex(pattern_hex(...)) + phh <- function(...) print.pattern_hex(pattern_hex(...)) - verify_output("../text_diagrams/hex.txt", phh("hex_skew", 3L, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/hex1_1.txt", phh("hex", 1L, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/hex1_2.txt", phh("hex", NULL, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/hex2_2.txt", phh("hex2", 2L, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/hex2_4.txt", phh("hex", 4L, nrow = 9, ncol = 9)) - verify_output("../text_diagrams/hex3_2.txt", phh("hex3", 2L, nrow = 9, ncol = 9)) - verify_output("../text_diagrams/hex3_7.txt", phh("hex", 7L, nrow = 9, ncol = 9)) - verify_output("../text_diagrams/hex_skew_5.txt", phh("hex", 5L, nrow = 9, ncol = 9)) + verify_output("../text_diagrams/hex.txt", phh("hex_skew", 3L, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/hex1_1.txt", phh("hex", 1L, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/hex1_2.txt", phh("hex", NULL, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/hex2_2.txt", phh("hex2", 2L, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/hex2_4.txt", phh("hex", 4L, nrow = 9, ncol = 9)) + verify_output("../text_diagrams/hex3_2.txt", phh("hex3", 2L, nrow = 9, ncol = 9)) + verify_output("../text_diagrams/hex3_7.txt", phh("hex", 7L, nrow = 9, ncol = 9)) + verify_output("../text_diagrams/hex_skew_5.txt", phh("hex", 5L, nrow = 9, ncol = 9)) }) diff --git a/tests/testthat/test_pch.R b/tests/testthat/test_pch.R index 3caf242..069f491 100644 --- a/tests/testthat/test_pch.R +++ b/tests/testthat/test_pch.R @@ -1,19 +1,18 @@ context("pch") test_that("pch patterns work as expected", { + skip_if_not_installed("vdiffr") + skip_on_ci() + library("vdiffr") - skip_if_not_installed("vdiffr") - skip_on_ci() - library("vdiffr") + x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + gp <- gpar(fill = "yellow", col = "black") + g.pp <- function(shape, ...) { + grid.pattern_pch(x, y, shape = shape, angle = 0, spacing = 0.15, gp = gp) + } - x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - gp <- gpar(fill = "yellow", col = "black") - g.pp <- function(shape, ...) { - grid.pattern_pch(x, y, shape = shape, angle = 0, spacing = 0.15, gp = gp) - } - - expect_doppelganger("simple", function() g.pp(0:6)) - expect_doppelganger("compound", function() g.pp(7:14)) - expect_doppelganger("col_fill", function() g.pp(15:20)) - expect_doppelganger("fill_fill", function() g.pp(21:25)) + expect_doppelganger("simple", function() g.pp(0:6)) + expect_doppelganger("compound", function() g.pp(7:14)) + expect_doppelganger("col_fill", function() g.pp(15:20)) + expect_doppelganger("fill_fill", function() g.pp(21:25)) }) diff --git a/tests/testthat/test_square.R b/tests/testthat/test_square.R index df3247d..d10d3e8 100644 --- a/tests/testthat/test_square.R +++ b/tests/testthat/test_square.R @@ -1,18 +1,23 @@ test_that("square patterns work as expected", { + pss <- function(...) print.pattern_square(pattern_square(...)) - pss <- function(...) print.pattern_square(pattern_square(...)) + expect_error(pattern_square("foobar"), "Don't recognize square pattern type foobar") - expect_error(pattern_square("foobar"), "Don't recognize square pattern type foobar") - - verify_output("../text_diagrams/diagonal.txt", pss("diagonal", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/diagonal_1.txt", pss("diagonal", 1L, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/diagonal_skew.txt", pss("diagonal_skew", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/horizontal.txt", pss("horizontal", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/square_twill.txt", pss("twill", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/vertical.txt", pss("vertical", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/square_1122.txt", pss("square_tiling", "1122", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/square_3.txt", pss("square", NULL, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/square_tiling_3.txt", pss("square_tiling", NULL, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/square_4.txt", pss("square", 4L, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/square_5.txt", pss("square", 5L, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/diagonal.txt", pss("diagonal", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/diagonal_1.txt", pss("diagonal", 1L, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/diagonal_skew.txt", pss("diagonal_skew", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/horizontal.txt", pss("horizontal", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/square_twill.txt", pss("twill", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/vertical.txt", pss("vertical", nrow = 7, ncol = 9)) + verify_output( + "../text_diagrams/square_1122.txt", + pss("square_tiling", "1122", nrow = 7, ncol = 9) + ) + verify_output("../text_diagrams/square_3.txt", pss("square", NULL, nrow = 7, ncol = 9)) + verify_output( + "../text_diagrams/square_tiling_3.txt", + pss("square_tiling", NULL, nrow = 7, ncol = 9) + ) + verify_output("../text_diagrams/square_4.txt", pss("square", 4L, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/square_5.txt", pss("square", 5L, nrow = 7, ncol = 9)) }) diff --git a/tests/testthat/test_tiling.R b/tests/testthat/test_tiling.R index b486034..f1cfd32 100644 --- a/tests/testthat/test_tiling.R +++ b/tests/testthat/test_tiling.R @@ -1,90 +1,124 @@ context("tiling") test_that("tiling patterns work as expected", { + skip_if_not_installed("vdiffr") + skip_on_ci() + library("vdiffr") - skip_if_not_installed("vdiffr") - skip_on_ci() - library("vdiffr") + x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) + g.ppt <- function(type, ...) { + grid.pattern_polygon_tiling(x, y, angle = 0, type = type, spacing = 0.15, ...) + } + gp1 <- gpar(fill = "yellow", col = "black") + gp2 <- gpar(fill = c("yellow", "red"), col = "black") + gp3 <- gpar(fill = c("yellow", "red", "blue"), col = "black") - x <- 0.5 + 0.5 * cos(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - y <- 0.5 + 0.5 * sin(seq(2 * pi / 4, by = 2 * pi / 6, length.out = 6)) - g.ppt <- function(type, ...) { - grid.pattern_polygon_tiling(x, y, angle = 0, type = type, - spacing = 0.15, ...) - } - gp1 <- gpar(fill = "yellow", col = "black") - gp2 <- gpar(fill = c("yellow", "red"), col = "black") - gp3 <- gpar(fill = c("yellow", "red", "blue"), col = "black") - - expect_doppelganger("elongated_triangular", function() - g.ppt("elongated_triangular", gp = gp2)) - expect_doppelganger("herringbone", function() - g.ppt("herringbone", gp = gp2)) - expect_doppelganger("hexagonal_tiling", function() - g.ppt("hexagonal", gp = gp2)) - expect_doppelganger("pythagorean", function() - g.ppt("pythagorean", gp = gp2)) - expect_doppelganger("rhombitrihexagonal_tiling", function() - g.ppt("rhombitrihexagonal", gp = gp3)) - expect_doppelganger("rhombille", function() - g.ppt("rhombille", gp = gp3)) - expect_doppelganger("snub_square_tiling", function() - g.ppt("snub_square", gp = gp3)) - expect_doppelganger("snub_trihex_tiling", function() - g.ppt("snub_trihexagonal", gp = gp3)) - expect_doppelganger("square_tiling", function() - g.ppt("square", gp = gp2)) - expect_doppelganger("tetrakis_square", function() - g.ppt("tetrakis_square", gp = gp3)) - expect_doppelganger("triangular_tiling", function() - g.ppt("triangular", gp = gp2)) - expect_doppelganger("trihexagonal_tiling", function() - g.ppt("trihexagonal", gp = gp2)) - expect_doppelganger("trunc_hex_tiling", function() - g.ppt("truncated_hexagonal", gp = gp3)) - expect_doppelganger("trunc_trihex_tiling", function() - g.ppt("truncated_trihexagonal", gp = gp2)) - expect_doppelganger("trunc_square_tiling", function() - g.ppt("truncated_square", gp = gp3)) - expect_doppelganger("2*.2**.2*.2**", function() - g.ppt("2*.2**.2*.2**", gp = gp3)) - expect_doppelganger("2**.3**.12*", function() - g.ppt("2**.3**.12*", gp = gp3)) - expect_doppelganger("3.3.3.3_alt", function() - g.ppt("3.3.3.3**", gp = gp2)) - expect_doppelganger("3.3*.3.3**", function() - g.ppt("3.3*.3.3**", gp = gp2)) - expect_doppelganger("3.3.3.12*.3.3.12*", function() - g.ppt("3.3.3.12*.3.3.12*", gp = gp3)) - expect_doppelganger("3.3.8*.3.4.3.8*", function() - g.ppt("3.3.8*.3.4.3.8*", gp = gp3)) - expect_doppelganger("3.3.8*.4**.8*", function() - g.ppt("3.3.8*.4**.8*", gp = gp3)) - expect_doppelganger("3.4.6.3.12*", function() - g.ppt("3.4.6.3.12*", gp = gp3)) - expect_doppelganger("3.4.8.3.8*", function() - g.ppt("3.4.8.3.8*", gp = gp3)) - expect_doppelganger("3.6*.6**", function() - g.ppt("3.6*.6**", gp = gp3)) - expect_doppelganger("4.2*.4.2**", function() - g.ppt("4.2*.4.2**", gp = gp3)) - expect_doppelganger("4.4*.4**", function() - g.ppt("4.4*.4**", gp = gp2)) - expect_doppelganger("4.6.4*.6", function() - g.ppt("4.6.4*.6", gp = gp3)) - expect_doppelganger("4.6*.4.6*.4.6*", function() - g.ppt("4.6*.4.6*.4.6*", gp = gp2)) - expect_doppelganger("4.8*.4**.8*", function() - g.ppt("4.8*.4**.8*", gp = gp2)) - expect_doppelganger("6.6*.6.6*", function() - g.ppt("6.6*.6.6*", gp = gp2)) - expect_doppelganger("8.4*.8.4*", function() - g.ppt("8.4*.8.4*", gp = gp2)) - expect_doppelganger("9.3.9.3*", function() - g.ppt("9.3.9.3*", gp = gp3)) - expect_doppelganger("12.3*.12.3*", function() - g.ppt("12.3*.12.3*", gp = gp2)) - expect_doppelganger("12.12.4*", function() - g.ppt("12.12.4*", gp = gp2)) - expect_doppelganger("18.18.3*", function() - g.ppt("18.18.3*", gp = gp2)) + expect_doppelganger("elongated_triangular", function() { + g.ppt("elongated_triangular", gp = gp2) + }) + expect_doppelganger("herringbone", function() { + g.ppt("herringbone", gp = gp2) + }) + expect_doppelganger("hexagonal_tiling", function() { + g.ppt("hexagonal", gp = gp2) + }) + expect_doppelganger("pythagorean", function() { + g.ppt("pythagorean", gp = gp2) + }) + expect_doppelganger("rhombitrihexagonal_tiling", function() { + g.ppt("rhombitrihexagonal", gp = gp3) + }) + expect_doppelganger("rhombille", function() { + g.ppt("rhombille", gp = gp3) + }) + expect_doppelganger("snub_square_tiling", function() { + g.ppt("snub_square", gp = gp3) + }) + expect_doppelganger("snub_trihex_tiling", function() { + g.ppt("snub_trihexagonal", gp = gp3) + }) + expect_doppelganger("square_tiling", function() { + g.ppt("square", gp = gp2) + }) + expect_doppelganger("tetrakis_square", function() { + g.ppt("tetrakis_square", gp = gp3) + }) + expect_doppelganger("triangular_tiling", function() { + g.ppt("triangular", gp = gp2) + }) + expect_doppelganger("trihexagonal_tiling", function() { + g.ppt("trihexagonal", gp = gp2) + }) + expect_doppelganger("trunc_hex_tiling", function() { + g.ppt("truncated_hexagonal", gp = gp3) + }) + expect_doppelganger("trunc_trihex_tiling", function() { + g.ppt("truncated_trihexagonal", gp = gp2) + }) + expect_doppelganger("trunc_square_tiling", function() { + g.ppt("truncated_square", gp = gp3) + }) + expect_doppelganger("2*.2**.2*.2**", function() { + g.ppt("2*.2**.2*.2**", gp = gp3) + }) + expect_doppelganger("2**.3**.12*", function() { + g.ppt("2**.3**.12*", gp = gp3) + }) + expect_doppelganger("3.3.3.3_alt", function() { + g.ppt("3.3.3.3**", gp = gp2) + }) + expect_doppelganger("3.3*.3.3**", function() { + g.ppt("3.3*.3.3**", gp = gp2) + }) + expect_doppelganger("3.3.3.12*.3.3.12*", function() { + g.ppt("3.3.3.12*.3.3.12*", gp = gp3) + }) + expect_doppelganger("3.3.8*.3.4.3.8*", function() { + g.ppt("3.3.8*.3.4.3.8*", gp = gp3) + }) + expect_doppelganger("3.3.8*.4**.8*", function() { + g.ppt("3.3.8*.4**.8*", gp = gp3) + }) + expect_doppelganger("3.4.6.3.12*", function() { + g.ppt("3.4.6.3.12*", gp = gp3) + }) + expect_doppelganger("3.4.8.3.8*", function() { + g.ppt("3.4.8.3.8*", gp = gp3) + }) + expect_doppelganger("3.6*.6**", function() { + g.ppt("3.6*.6**", gp = gp3) + }) + expect_doppelganger("4.2*.4.2**", function() { + g.ppt("4.2*.4.2**", gp = gp3) + }) + expect_doppelganger("4.4*.4**", function() { + g.ppt("4.4*.4**", gp = gp2) + }) + expect_doppelganger("4.6.4*.6", function() { + g.ppt("4.6.4*.6", gp = gp3) + }) + expect_doppelganger("4.6*.4.6*.4.6*", function() { + g.ppt("4.6*.4.6*.4.6*", gp = gp2) + }) + expect_doppelganger("4.8*.4**.8*", function() { + g.ppt("4.8*.4**.8*", gp = gp2) + }) + expect_doppelganger("6.6*.6.6*", function() { + g.ppt("6.6*.6.6*", gp = gp2) + }) + expect_doppelganger("8.4*.8.4*", function() { + g.ppt("8.4*.8.4*", gp = gp2) + }) + expect_doppelganger("9.3.9.3*", function() { + g.ppt("9.3.9.3*", gp = gp3) + }) + expect_doppelganger("12.3*.12.3*", function() { + g.ppt("12.3*.12.3*", gp = gp2) + }) + expect_doppelganger("12.12.4*", function() { + g.ppt("12.12.4*", gp = gp2) + }) + expect_doppelganger("18.18.3*", function() { + g.ppt("18.18.3*", gp = gp2) + }) }) diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index aaca00d..b1bfce8 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -1,73 +1,89 @@ test_that("`update_alpha()` works as expected", { - expect_equal(update_alpha("blue", 0.5), "#0000FF80") - expect_equal(update_alpha(list(c("blue", "red")), NA), c("#0000FFFF", "#FF0000FF")) - expect_equal(update_alpha("#00FF0080", NA), "#00FF0080") - expect_equal(update_alpha("#FF000080", 0.25), "#FF000040") + expect_equal(update_alpha("blue", 0.5), "#0000FF80") + expect_equal(update_alpha(list(c("blue", "red")), NA), c("#0000FFFF", "#FF0000FF")) + expect_equal(update_alpha("#00FF0080", NA), "#00FF0080") + expect_equal(update_alpha("#FF000080", 0.25), "#FF000040") - expect_error(update_alpha(list("blue", "red"), NA)) - skip_if_not(getRversion() >= "4.1.0") - expect_equal(update_pattern_alpha("red", 0.5, name = "nonrandom"), - pattern(rectGrob(name = "nonrandom"), gp = gpar(fill = "#FF000080"))) - expect_equal(update_pattern_alpha(linearGradient(c("black", "white")), 0.5), - linearGradient(c("#00000080", "#FFFFFF80"))) + expect_error(update_alpha(list("blue", "red"), NA)) + skip_if_not(getRversion() >= "4.1.0") + expect_equal( + update_pattern_alpha("red", 0.5, name = "nonrandom"), + pattern(rectGrob(name = "nonrandom"), gp = gpar(fill = "#FF000080")) + ) + expect_equal( + update_pattern_alpha(linearGradient(c("black", "white")), 0.5), + linearGradient(c("#00000080", "#FFFFFF80")) + ) }) test_that("`mean_col()` works as expected", { - expect_equal(mean_col("black", "white"), "#B4B4B4FF") - expect_equal(mean_col(c("black", "white")), "#B4B4B4FF") - expect_equal(mean_col("red", "blue"), "#B400B4FF") + expect_equal(mean_col("black", "white"), "#B4B4B4FF") + expect_equal(mean_col(c("black", "white")), "#B4B4B4FF") + expect_equal(mean_col("red", "blue"), "#B400B4FF") }) test_that("`get_params()` works as expected", { - params <- get_params() - expect_equal(params$pattern_colour, "grey20") - expect_equal(params$pattern_fill, "grey80") - expect_equal(params$pattern_angle, 30) - expect_equal(params$pattern_density, 0.2) - expect_equal(params$pattern_spacing, 0.05) - expect_equal(params$pattern_xoffset, 0) - expect_equal(params$pattern_yoffset, 0) - expect_equal(params$pattern_alpha, NA_real_) - expect_equal(params$pattern_linetype, 1) - expect_equal(params$pattern_linewidth, 1) + params <- get_params() + expect_equal(params$pattern_colour, "grey20") + expect_equal(params$pattern_fill, "grey80") + expect_equal(params$pattern_angle, 30) + expect_equal(params$pattern_density, 0.2) + expect_equal(params$pattern_spacing, 0.05) + expect_equal(params$pattern_xoffset, 0) + expect_equal(params$pattern_yoffset, 0) + expect_equal(params$pattern_alpha, NA_real_) + expect_equal(params$pattern_linetype, 1) + expect_equal(params$pattern_linewidth, 1) - params <- get_params(alpha = 0.5, spacing = 0.1) - expect_equal(params$pattern_alpha, 0.5) - expect_equal(params$pattern_spacing, 0.1) + params <- get_params(alpha = 0.5, spacing = 0.1) + expect_equal(params$pattern_alpha, 0.5) + expect_equal(params$pattern_spacing, 0.1) - gp <- gpar(col = "blue", lty = 2) - params <- get_params(gp = gp) - expect_equal(params$pattern_colour, "blue") - expect_equal(params$pattern_linetype, 2) + gp <- gpar(col = "blue", lty = 2) + params <- get_params(gp = gp) + expect_equal(params$pattern_colour, "blue") + expect_equal(params$pattern_linetype, 2) }) test_that("`star_scale()` works as expected", { - # |8/3| star has internal angle 45 degrees and external angle 90 degrees - scale <- star_scale(8, 45) - scale2 <- star_scale(8, 90, external = TRUE) - expect_equal(scale, scale2) - expect_equal(star_angle(8, scale), 45) - expect_equal(star_angle(8, scale, external = TRUE), 90) - expect_equal(star_angle(2, star_scale(2, 30)), 30) - expect_equal(star_angle(2, star_scale(2, 210, TRUE), TRUE), 210) + # |8/3| star has internal angle 45 degrees and external angle 90 degrees + scale <- star_scale(8, 45) + scale2 <- star_scale(8, 90, external = TRUE) + expect_equal(scale, scale2) + expect_equal(star_angle(8, scale), 45) + expect_equal(star_angle(8, scale, external = TRUE), 90) + expect_equal(star_angle(2, star_scale(2, 30)), 30) + expect_equal(star_angle(2, star_scale(2, 210, TRUE), TRUE), 210) }) test_that("`assert_patterns_unique()` works as expected", { - expect_null(assert_patterns_unique(list(), list())) - expect_null(assert_patterns_unique(list(custom1 = 2), list(custom2 = 2))) - expect_error(assert_patterns_unique(list(custom = 2, custom = 3), list()), - 'There are multiple custom "geometry" patterns named "custom"') - expect_error(assert_patterns_unique(list(), list(custom = 2, custom = 3)), - 'There are multiple custom "array" patterns named "custom"') - expect_error(assert_patterns_unique(list(custom = 2), list(custom = 2)), - 'There is a custom "geometry" pattern and custom "array" pattern both named "custom"') - expect_error(assert_patterns_unique(list(circle = 2), list()), - 'There is a custom "geometry" pattern and builtin \\{gridpattern\\} pattern both named "circle"') - expect_error(assert_patterns_unique(list(), list(image = 2)), - 'There is a custom "array" pattern and builtin \\{gridpattern\\} pattern both named "image"') + expect_null(assert_patterns_unique(list(), list())) + expect_null(assert_patterns_unique(list(custom1 = 2), list(custom2 = 2))) + expect_error( + assert_patterns_unique(list(custom = 2, custom = 3), list()), + 'There are multiple custom "geometry" patterns named "custom"' + ) + expect_error( + assert_patterns_unique(list(), list(custom = 2, custom = 3)), + 'There are multiple custom "array" patterns named "custom"' + ) + expect_error( + assert_patterns_unique(list(custom = 2), list(custom = 2)), + 'There is a custom "geometry" pattern and custom "array" pattern both named "custom"' + ) + expect_error( + assert_patterns_unique(list(circle = 2), list()), + 'There is a custom "geometry" pattern and builtin \\{gridpattern\\} pattern both named "circle"' + ) + expect_error( + assert_patterns_unique(list(), list(image = 2)), + 'There is a custom "array" pattern and builtin \\{gridpattern\\} pattern both named "image"' + ) }) test_that("`assert_suggested()` works as expected", { - expect_error(assert_suggested("doesnotexist", "blueberry"), - "The suggested package \\{doesnotexist\\} must be installed") + expect_error( + assert_suggested("doesnotexist", "blueberry"), + "The suggested package \\{doesnotexist\\} must be installed" + ) }) diff --git a/tests/testthat/test_weave.R b/tests/testthat/test_weave.R index 0bd80d5..f851826 100644 --- a/tests/testthat/test_weave.R +++ b/tests/testthat/test_weave.R @@ -1,30 +1,37 @@ test_that("weaves work as expected", { + pww <- function(...) print.pattern_weave(pattern_weave(...)) - pww <- function(...) print.pattern_weave(pattern_weave(...)) + expect_error(pattern_weave("foobar"), "Don't know weave type foobar") - expect_error(pattern_weave("foobar"), "Don't know weave type foobar") + # irregular mat + verify_output("../text_diagrams/plain.txt", pww("plain", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/basket.txt", pww("basket", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/matt.txt", pww("matt", 3, nrow = 7, ncol = 9)) + verify_output("../text_diagrams/matt_21.txt", pww("matt", "2/1", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/matt3221.txt", pww("matt", "3/2*2/1", nrow = 15, ncol = 9)) + verify_output( + "../text_diagrams/matt_irregular.txt", + pww("matt_irregular", "3/2(4+2)", nrow = 7, ncol = 9) + ) + verify_output("../text_diagrams/rib_warp", pww("rib_warp", "2/1", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/rib_warp.txt", pww("rib_warp", "2", nrow = 7, ncol = 9)) - # irregular mat - verify_output("../text_diagrams/plain.txt", pww("plain", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/basket.txt", pww("basket", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/matt.txt", pww("matt", 3, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/matt_21.txt", pww("matt", "2/1", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/matt3221.txt", pww("matt", "3/2*2/1", nrow = 15, ncol = 9)) - verify_output("../text_diagrams/matt_irregular.txt", - pww("matt_irregular", "3/2(4+2)", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/rib_warp", - pww("rib_warp", "2/1", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/rib_warp.txt", pww("rib_warp", "2", nrow = 7, ncol = 9)) - - # elongated twill - verify_output("../text_diagrams/satin_5.txt", pww("satin", "5", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/twill_3.txt", pww("twill", 3L, nrow = 7, ncol = 9)) - verify_output("../text_diagrams/twill_212.txt", pww("twill_elongated", "2/1(2)", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/twill_22.txt", pww("twill", "2/2", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/twill_13.txt", pww("twill", "1/3", nrow = 7, ncol = 9)) - verify_output("../text_diagrams/twill_22_zigzag.txt", - pww("twill_zigzag", "2/2", nrow = 15, ncol = 9)) - verify_output("../text_diagrams/twill_13_herringbone.txt", - pww("twill_herringbone", "1/3", nrow = 15, ncol = 9)) - verify_output("../text_diagrams/twill3221.txt", pww("twill", "3/2*2/1", nrow = 15, ncol = 9)) + # elongated twill + verify_output("../text_diagrams/satin_5.txt", pww("satin", "5", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/twill_3.txt", pww("twill", 3L, nrow = 7, ncol = 9)) + verify_output( + "../text_diagrams/twill_212.txt", + pww("twill_elongated", "2/1(2)", nrow = 7, ncol = 9) + ) + verify_output("../text_diagrams/twill_22.txt", pww("twill", "2/2", nrow = 7, ncol = 9)) + verify_output("../text_diagrams/twill_13.txt", pww("twill", "1/3", nrow = 7, ncol = 9)) + verify_output( + "../text_diagrams/twill_22_zigzag.txt", + pww("twill_zigzag", "2/2", nrow = 15, ncol = 9) + ) + verify_output( + "../text_diagrams/twill_13_herringbone.txt", + pww("twill_herringbone", "1/3", nrow = 15, ncol = 9) + ) + verify_output("../text_diagrams/twill3221.txt", pww("twill", "3/2*2/1", nrow = 15, ncol = 9)) })