diff --git a/.Rbuildignore b/.Rbuildignore index 68aeee9..9a55673 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -7,6 +7,7 @@ ^README.Rmd$ ^README.html$ ^Rakefile$ +^Rplots.pdf$ ^pkgdown$ ^_pkgdown.yml$ ^data-raw$ diff --git a/.gitignore b/.gitignore index aadc262..1313f1c 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ codecov.yml data-raw/*.png vignettes/*.R vignettes/*.html +Rplots.pdf diff --git a/DESCRIPTION b/DESCRIPTION index b1a7ae3..eeac94b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: gridpattern Type: Package Title: 'grid' Pattern Grobs -Version: 1.4.0-1 +Version: 1.4.0-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")), @@ -26,6 +26,7 @@ Imports: utils Suggests: ambient, + aqp, aRtsy, ggplot2 (>= 3.5.0), gtable, @@ -36,6 +37,7 @@ Suggests: scales, svglite (>= 2.1.0), testthat, + Unicode, vdiffr (>= 1.0.6) VignetteBuilder: knitr, rmarkdown Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 595f346..20f163e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ export(grid.pattern_circle) export(grid.pattern_crosshatch) export(grid.pattern_fill) export(grid.pattern_gradient) +export(grid.pattern_hatch) export(grid.pattern_image) export(grid.pattern_line) export(grid.pattern_magick) @@ -35,7 +36,9 @@ export(grid.pattern_wave) export(grid.pattern_weave) export(guess_has_R4.1_features) export(mean_col) +export(mix_col) export(names_aRtsy) +export(names_hatch) export(names_hex) export(names_magick) export(names_magick_intensity) diff --git a/NEWS.md b/NEWS.md index f234029..cccb174 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,12 +4,18 @@ gridpattern v1.4.0 (development) New Features ------------ +* New "hatch" pattern with corresponding `grid.pattern_hatch()` and `names_hatch()` (#97). + * New "line" pattern with corresponding `grid.pattern_line()`. Unlike the "stripe" pattern which fills bands with solid colour, "line" draws stroked lines using the device's native line rendering, enabling all of R's built-in `linetype` values (including `"dotdash"`, `"twodash"`, and custom line types specified as hex strings per `?par`). +* `mix_col()` is a new utility function that mixes colors via Munsell color + space using `aqp::mixMunsell()`. + Requires the suggested package `{aqp}`. + Bug fixes and minor improvements -------------------------------- diff --git a/R/grid-pattern.R b/R/grid-pattern.R index ae360f6..d65df02 100644 --- a/R/grid-pattern.R +++ b/R/grid-pattern.R @@ -17,6 +17,8 @@ #' See [grid.pattern_crosshatch()] for more information.} #' \item{gradient}{Gradient array/geometry patterns. #' See [grid.pattern_gradient()] for more information.} +#' \item{hatch}{Heraldic hatching patterns. +#' See [grid.pattern_hatch()] for more information.} #' \item{image}{Image array patterns. #' See [grid.pattern_image()] for more information.} #' \item{line}{Line geometry patterns. @@ -158,6 +160,7 @@ names_pattern <- c( "crosshatch", "fill", "gradient", + "hatch", "image", "line", "magick", @@ -251,6 +254,7 @@ get_pattern_fn <- function(pattern) { crosshatch = create_pattern_crosshatch_via_sf, fill = create_pattern_fill, gradient = create_pattern_gradient, + hatch = create_pattern_hatch, line = create_pattern_line, none = create_pattern_none, pch = create_pattern_pch, diff --git a/R/mean_col.R b/R/mean_col.R deleted file mode 100644 index b2a4e59..0000000 --- a/R/mean_col.R +++ /dev/null @@ -1,24 +0,0 @@ -#' Compute average color -#' -#' `mean_col()` computes an average color. -#' -#' We currently compute an average color -#' by using the quadratic mean of the colors' RGBA values. -#' -#' @param ... Colors to average -#' @return A color string of 9 characters: `"#"` followed by the -#' red, blue, green, and alpha values in hexadecimal. -#' @examples -#' mean_col("black", "white") -#' mean_col(c("black", "white")) -#' 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]) -} - -quadratic_mean <- function(x) sqrt(mean(x^2)) diff --git a/R/pattern-both-hatch.R b/R/pattern-both-hatch.R new file mode 100644 index 0000000..bd86556 --- /dev/null +++ b/R/pattern-both-hatch.R @@ -0,0 +1,639 @@ +#' Heraldic color hatching patterned grobs +#' +#' `grid.pattern_hatch()` draws a heraldic color hatching patterns onto the graphic device. +#' `names_hatch()` returns a character vector of supported `type` values. +#' +#' @inheritParams grid.pattern_line +#' @param type A tincture or color name. `names_hatch()` lists supported values. +#' Both traditional tincture names (e.g. `"gules"`) and modern color equivalents +#' (e.g. `"red"`) are accepted. Matching is case-insensitive and ignores hyphens +#' and spaces. +#' @param subtype A string with one of +#' +#' * `"combinatorial"` (default): an extension of the seven standard Petra Sancta hatchings with systematically derived mixed-color hatchings. +#' * `"fox-davies"`: the hatchings in Fox-Davies' *A Complete Guide to Heraldry*. +#' * `"goodman"`: the hatchings in David Goodman's *Heraldic Tincture* reference. +#' * `"unicode"`: the hatchings used in Unicode character charts. +#' +#' The string is case-insensitive and hyphens and spaces are ignored. +#' @return A grid grob object invisibly. If `draw` is `TRUE` then also draws to the graphic device as a side effect. +#' @examples +#' 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)) +#' if (capabilities("png") || guess_has_R4.1_features("masks")) { +#' grid::grid.newpage() +#' grid.pattern_hatch(x_hex, y_hex, type = "azure", colour = "blue") +#' } +#' if (capabilities("png") || guess_has_R4.1_features("masks")) { +#' grid::grid.newpage() +#' grid.pattern_hatch(x_hex, y_hex, type = "cendree", colour = "grey", spacing = 0.1) +#' } +#' print(names_hatch()) +#' print(names_hatch("fox-davies")) +#' print(names_hatch("goodman")) +#' print(names_hatch("unicode")) +#' @seealso [grid.pattern_line()] for single-direction lines, +#' [grid.pattern_crosshatch()] for perpendicular lines. +#' `vignette("hatching", package = "gridpattern")` for a visual overview of all subtypes. +#' for Fox-Davies' +#' _A Complete Guide to Heraldry_. +#' for +#' David Goodman's Heraldic Tincture reference. +#' @export +grid.pattern_hatch <- function( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + type = "gules", + subtype = "combinatorial", + colour = gp$col %||% "grey20", + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + alpha = gp$alpha %||% NA_real_, + lineend = gp$lineend %||% "round", + 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( + "hatch", + x, + y, + id, + colour = colour, + type = type, + subtype = subtype, + spacing = spacing, + xoffset = xoffset, + yoffset = yoffset, + units = units, + alpha = alpha, + lineend = lineend, + linewidth = linewidth, + 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 + ) +} + +#' @rdname grid.pattern_hatch +#' @param accent If `TRUE`, return tincture names using their traditional +#' accented spellings where applicable (e.g. `"tenn\u00e9"`, `"brun\u00e2tre"`). +#' Defaults to `FALSE`. +#' @export +names_hatch <- function( + subtype = c("combinatorial", "fox-davies", "goodman", "unicode"), + accent = FALSE +) { + subtype <- tolower(subtype) + subtype <- match.arg(subtype) + nms <- if (subtype == "fox-davies") { + sort(names(HATCH_FOX_DAVIES)) + } else if (subtype == "unicode") { + sort(unname(HATCH_COLORS[names(HATCH_UNICODE)])) + } else if (subtype == "goodman") { + sort(names(HATCH_GOODMAN)) + } else { + sort(unname(HATCH_COLORS[names(HATCH_COMBINATORIAL)])) + } + if (accent) { + accented <- HATCH_ACCENTS[nms] + nms[!is.na(accented)] <- accented[!is.na(accented)] + } + nms +} + +# Accented spellings for tincture names that have them. +HATCH_ACCENTS <- c( + `bleu celeste` = "bleu c\u00e9leste", + cendree = "cendr\u00e9e", + tenne = "tenn\u00e9", + brunatre = "brun\u00e2tre" +) + +# Internal: hatching specs per subtype. +# Each entry is one of: +# list(special = "plain") -- no pattern (argent) +# list(special = "solid") -- solid colour fill (unicode sable) +# list(angles, linetypes) -- one or two sets of stroked lines + +# Combinatorial Petra Sancta: systematically extends the seven standard tinctures. +# Three derivation rules: +# white + color → dashed lines at that color's angle (lightened tints) +# yellow + color → dotdash lines at that color's angle (Munsell YR and GY secondaries) +# color + color → crossing solid lines at both angles (Munsell BG, PB, RP secondaries + others) +HATCH_COMBINATORIAL <- list( + # === Base seven tinctures (standard Petra Sancta) === + argent = list(special = "plain"), + or = list(special = "circle"), + azure = list(angles = 0, linetypes = "solid"), + gules = list(angles = 90, linetypes = "solid"), + sable = list(angles = c(0, 90), linetypes = c("solid", "solid")), + vert = list(angles = 135, linetypes = "solid"), + purpure = list(angles = 45, linetypes = "solid"), + # === White + color: dashed lines === + `bleu celeste` = list(angles = 0, linetypes = "dashed"), # argent + azure + carnation = list(angles = 90, linetypes = "dashed"), # argent + gules + cendree = list(special = "cendree"), # argent + sable + mint = list(angles = 135, linetypes = "dashed"), # argent + vert (new) + lavender = list(angles = 45, linetypes = "dashed"), # argent + purpure (new) + # === Yellow + color: dotdash lines === + orange = list(angles = 90, linetypes = "dotdash"), # or + gules (YR) + lime = list(angles = 135, linetypes = "dotdash"), # or + vert (GY) + olive = list(special = "olive"), # or + sable: alternating circles and plus signs + rose = list(angles = 45, linetypes = "dotdash"), # or + purpure (YP) + # === Color × color: crossing lines === + brunatre = list( + angles = c(90, 0, 135), + linetypes = c("solid", "solid", "solid"), + spacings = c(1, 1, 1 / sqrt(2)) + ), # gules × azure × vert + eisenfarbe = list(angles = c(45, 135), linetypes = c("solid", "solid")), # purpure × vert + sanguine = list(angles = c(90, 45), linetypes = c("solid", "solid")), # gules × purpure (RP) + tenne = list(angles = c(90, 135), linetypes = c("solid", "solid")), # gules × vert + teal = list(angles = c(0, 135), linetypes = c("solid", "solid")), # azure × vert (BG, new) + violet = list(angles = c(0, 45), linetypes = c("solid", "solid")) # azure × purpure (PB, new) +) + +# Fox-Davies is the standard Petra Sancta tinctures plus the German heraldry extensions, +# all of which are defined in HATCH_COMBINATORIAL. +HATCH_FOX_DAVIES <- c( + HATCH_COMBINATORIAL[c( + "argent", + "or", + "azure", + "gules", + "sable", + "vert", + "purpure", + "eisenfarbe", + "sanguine", + "tenne", + "brunatre", + "carnation", + "cendree", + "orange", + "bleu celeste" + )], + list(proper = list(special = "proper")) +) + +# Goodman system (david.goodman.graphics v2.0 2024-02-14). +# Shares most specs with fox-davies; key differences: +# murrey = eisenfarbe spec (45° + 135°) — not fox-davies sanguine +# sanguine = teal spec (0° + 135°) — different from fox-davies sanguine (90° + 45°) +# rose = carnation spec (90° dashed) — rose and carnation share one hatching +# Rare metals (steel, copper, bronze, lead) are unique to this system. +HATCH_GOODMAN <- c( + HATCH_COMBINATORIAL[c( + "argent", + "or", + "azure", + "gules", + "sable", + "vert", + "purpure", + "cendree", + "brunatre", + "bleu celeste", + "carnation", + "orange", + "tenne" + )], + list( + murrey = HATCH_COMBINATORIAL[["eisenfarbe"]], # 45° + 135° (dark red-purple) + sanguine = HATCH_COMBINATORIAL[["teal"]], # 0° + 135° (blood red) + rose = HATCH_COMBINATORIAL[["carnation"]], # 90° dashed (rose/carnation share hatching) + steel = list(special = "steel"), # + signs in square grid + copper = list(special = "c_hex"), # c in hex grid + bronze = list(special = "c_hex"), # c in hex grid + lead = list(special = "c_hex") # c in hex grid + ) +) + +HATCH_UNICODE <- c( + HATCH_COMBINATORIAL[c("argent", "or", "azure", "gules", "vert", "purpure", "tenne")], + list( + `bleu celeste` = list(angles = 0, linetypes = "dotdash"), + carnation = HATCH_COMBINATORIAL[["rose"]], # unicode "pink" heart uses 45° dotdash + cendree = list(special = "checker"), + orange = list(angles = c(0, 45), linetypes = c("solid", "solid")), + sable = list(special = "solid") + ) +) + +# Modern color equivalents for tincture names. +# For the unicode subtype, values match the canonical Unicode emoji color names. +HATCH_COLORS <- c( + `bleu celeste` = "light blue", + argent = "white", + azure = "blue", + bronze = "bronze", + brunatre = "umbre", + carnation = "pink", + cendree = "grey", + copper = "copper", + eisenfarbe = "slate", + gules = "red", + lavender = "lavender", + lead = "lead grey", + lime = "lime green", + mint = "mint green", + murrey = "mulberry", + olive = "olive", + or = "yellow", + orange = "orange", + proper = "color of nature", + purpure = "purple", + rose = "rose", + sable = "black", + sanguine = "magenta", + steel = "steel grey", + teal = "teal", + tenne = "brown", + vert = "green", + violet = "violet" +) + + +# Map from normalized user input to canonical tincture name. +# Normalization: tolower() + remove hyphens and spaces. +HATCH_NAME_MAP <- c( + argent = "argent", + white = "argent", + silver = "argent", + azure = "azure", + blue = "azure", + cobalt = "azure", + bleuceleste = "bleu celeste", + "bleuc\u00e9leste" = "bleu celeste", + skyblue = "bleu celeste", + lightblue = "bleu celeste", + celeste = "bleu celeste", + "c\u00e9leste" = "bleu celeste", + ciel = "bleu celeste", + bronze = "bronze", + brunatre = "brunatre", + "brun\u00e2tre" = "brunatre", + darkbrown = "brunatre", + umbre = "brunatre", + umber = "brunatre", + carnation = "carnation", + flesh = "carnation", + pink = "carnation", + cendree = "cendree", + "cendr\u00e9e" = "cendree", + grey = "cendree", + gray = "cendree", + ash = "cendree", + ashgray = "cendree", + ashgrey = "cendree", + copper = "copper", + slate = "eisenfarbe", + irongrey = "eisenfarbe", + irongray = "eisenfarbe", + iron = "eisenfarbe", + eisenfarbe = "eisenfarbe", + gules = "gules", + red = "gules", + crimson = "gules", + lavender = "lavender", + lilac = "lavender", + lead = "lead", + leadgrey = "lead", + leadgray = "lead", + lime = "lime", + chartreuse = "lime", + limegreen = "lime", + yellowgreen = "lime", + mint = "mint", + mintgreen = "mint", + seafoam = "mint", + murrey = "murrey", + mulberry = "murrey", + olive = "olive", + or = "or", + yellow = "or", + gold = "or", + orange = "orange", + colorofnature = "proper", + proper = "proper", + natural = "proper", + purpure = "purpure", + purple = "purpure", + rose = "rose", + sable = "sable", + black = "sable", + sanguine = "sanguine", + bloodred = "sanguine", + magenta = "sanguine", + steel = "steel", + steelgrey = "steel", + steelgray = "steel", + teal = "teal", + cyan = "teal", + aqua = "teal", + aquamarine = "teal", + turquoise = "teal", + bluegreen = "teal", + tenne = "tenne", + "tenn\u00e9" = "tenne", + tawny = "tenne", + brown = "tenne", + vert = "vert", + green = "vert", + violet = "violet", + bluepurple = "violet", + violetblue = "violet" +) + +create_pattern_hatch <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + type_norm <- gsub("[- ]", "", tolower(params$pattern_type)) + subtype_norm <- gsub("[- ]", "", tolower(params$pattern_subtype %||% "combinatorial")) + is_unicode <- subtype_norm == "unicode" + is_fox_davies <- subtype_norm == "foxdavies" + is_goodman <- subtype_norm == "goodman" + canonical <- HATCH_NAME_MAP[type_norm] + if (is.na(canonical)) { + stop("Unknown hatching type '", params$pattern_type, "'.") + } + + spec <- if (is_unicode) { + HATCH_UNICODE[[canonical]] + } else if (is_fox_davies) { + HATCH_FOX_DAVIES[[canonical]] + } else if (is_goodman) { + HATCH_GOODMAN[[canonical]] + } else { + HATCH_COMBINATORIAL[[canonical]] + } + + if (is.null(spec)) { + stop( + "Hatching type '", + params$pattern_type, + "' is not supported ", + "by the '", + params$pattern_subtype %||% "combinatorial", + "' subtype." + ) + } + + if (!is.null(spec$special)) { + if (spec$special == "plain") { + return(grid::nullGrob()) + } + if (spec$special == "solid") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + default.units <- "bigpts" + bd <- convert_polygon_df_units(boundary_df, default.units) + return(convert_polygon_df_to_polygon_grob( + bd, + default.units = default.units, + gp = gpar(fill = col, col = NA) + )) + } + if (spec$special == "circle") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + spacing_bigpts <- convertX( + unit(params$pattern_spacing, params$pattern_units), + "bigpts", + valueOnly = TRUE + ) + density <- params$pattern_linewidth * .pt / spacing_bigpts + return(patternGrob( + "circle", + x = boundary_df$x, + y = boundary_df$y, + id = boundary_df$id, + colour = NA, + fill = col, + spacing = params$pattern_spacing, + density = density, + grid = "hex_circle" + )) + } + if (spec$special == "olive") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + spacing_bigpts <- convertX( + unit(params$pattern_spacing, params$pattern_units), + "bigpts", + valueOnly = TRUE + ) + lwd_bigpts <- params$pattern_linewidth * .pt + density_dot <- lwd_bigpts / spacing_bigpts * 0.6 + density_plus <- min(lwd_bigpts / spacing_bigpts * 2, 0.9) + return(patternGrob( + "pch", + x = boundary_df$x, + y = boundary_df$y, + id = boundary_df$id, + colour = col, + fill = col, + shape = c(16, 3), + spacing = params$pattern_spacing, + density = c(density_dot, density_plus), + angle = 0, + type = "diagonal", + subtype = 2L, + grid = "square" + )) + } + if (spec$special == "steel") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + spacing_bigpts <- convertX( + unit(params$pattern_spacing, params$pattern_units), + "bigpts", + valueOnly = TRUE + ) + lwd_bigpts <- params$pattern_linewidth * .pt + density <- min(lwd_bigpts / spacing_bigpts * 2.5, 0.9) + return(patternGrob( + "pch", + x = boundary_df$x, + y = boundary_df$y, + id = boundary_df$id, + colour = col, + fill = col, + shape = 3, + spacing = params$pattern_spacing, + density = density, + angle = 0, + grid = "square" + )) + } + if (spec$special == "c_hex") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + return(patternGrob( + "text", + x = boundary_df$x, + y = boundary_df$y, + id = boundary_df$id, + colour = col, + shape = "c", + spacing = params$pattern_spacing, + angle = 0, + grid = "hex_circle" + )) + } + if (spec$special == "checker") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + return(patternGrob( + "polygon_tiling", + x = boundary_df$x, + y = boundary_df$y, + id = boundary_df$id, + type = "square", + spacing = params$pattern_spacing, + angle = 0, + colour = NA, + fill = c(col, "transparent") + )) + } + if (spec$special == "cendree") { + # Build segments directly at exact grid intersections (no lty approximation). + # At each (m, j) grid point, draw an H dash if (m+j) is even, V dash if odd. + # Dashes have length exactly S so centers are precisely at grid positions. + default.units <- "bigpts" + boundary_df_pts <- convert_polygon_df_units(boundary_df, default.units) + params_pts <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) + col <- update_alpha(params_pts$pattern_colour, params_pts$pattern_alpha) + lwd <- params_pts$pattern_linewidth * .pt + gp_seg <- gpar( + col = col, + lwd = lwd, + lty = "solid", + lineend = params_pts$pattern_lineend + ) + S <- params_pts$pattern_spacing + xo <- params_pts$pattern_xoffset + yo <- params_pts$pattern_yoffset + half <- S / 2 + # Grid indices covering viewport + margin (same extent as get_xy_grid) + idx_seq <- seq_robust(from = 0, to = vpm$length, by = S) + idx <- round(c(rev(-idx_seq[-1L]), idx_seq) / S) # ..., -2, -1, 0, 1, 2, ... + x_grid <- xo + vpm$x + idx * S + y_grid <- yo + vpm$y + idx * S + ng <- length(idx) + m_mat <- matrix(idx, nrow = ng, ncol = ng, byrow = FALSE) + j_mat <- matrix(idx, nrow = ng, ncol = ng, byrow = TRUE) + x_mat <- matrix(x_grid, nrow = ng, ncol = ng, byrow = FALSE) + y_mat <- matrix(y_grid, nrow = ng, ncol = ng, byrow = TRUE) + is_H <- (m_mat + j_mat) %% 2L == 0L + x_H <- as.vector(x_mat[is_H]) + y_H <- as.vector(y_mat[is_H]) + x_V <- as.vector(x_mat[!is_H]) + y_V <- as.vector(y_mat[!is_H]) + maskee <- grid::grobTree( + segmentsGrob( + x_H - half, + y_H, + x_H + half, + y_H, + default.units = default.units, + gp = gp_seg + ), + segmentsGrob( + x_V, + y_V - half, + x_V, + y_V + half, + default.units = default.units, + gp = gp_seg + ) + ) + masker <- convert_polygon_df_to_polygon_grob( + boundary_df_pts, + default.units = default.units, + gp = gpar(fill = "white", col = NA, lwd = 0) + ) + return(alphaMaskGrob( + maskee, + masker, + use_R4.1_masks = params$pattern_use_R4.1_masks, + png_device = params$pattern_png_device, + res = params$pattern_res + )) + } + if (spec$special == "proper") { + col <- update_alpha(params$pattern_colour, params$pattern_alpha) + spacing_bigpts <- convertX( + unit(params$pattern_spacing, params$pattern_units), + "bigpts", + valueOnly = TRUE + ) + density <- params$pattern_linewidth * .pt / spacing_bigpts + return(patternGrob( + "wave", + x = boundary_df$x, + y = boundary_df$y, + id = boundary_df$id, + colour = NA, + fill = c(col, "transparent"), + angle = 135, + spacing = params$pattern_spacing, + density = density, + type = "triangle" + )) + } + } + + # Build all line-segment grobs and apply a single mask. Using separate + # alphaMaskGrobs in a grobTree breaks compositing (full-viewport rasters + # overwrite each other), so we combine the maskees first. + default.units <- "bigpts" + boundary_df_pts <- convert_polygon_df_units(boundary_df, default.units) + params_pts <- convert_params_units(params, default.units) + vpm <- get_vp_measurements(default.units) + + spacings <- spec$spacings %||% rep(1, length(spec$angles)) + maskees <- mapply( + function(angle, lty, spacing_mult) { + p <- params_pts + p$pattern_angle <- angle + p$pattern_linetype <- lty + p$pattern_stagger <- (lty != "solid") + p$pattern_spacing <- p$pattern_spacing * spacing_mult + create_line_maskee(p, vpm, default.units) + }, + spec$angles, + spec$linetypes, + spacings, + SIMPLIFY = FALSE + ) + maskee <- if (length(maskees) == 1L) maskees[[1L]] else do.call(grid::grobTree, maskees) + masker <- convert_polygon_df_to_polygon_grob( + boundary_df_pts, + default.units = default.units, + 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 + ) +} diff --git a/R/pattern-both-line.R b/R/pattern-both-line.R index ee57f65..5a5054a 100644 --- a/R/pattern-both-line.R +++ b/R/pattern-both-line.R @@ -9,19 +9,17 @@ #' @inheritParams grid.pattern_circle #' @inheritParams alphaMaskGrob #' @param lineend Line end style, one of `"round"` (default), `"butt"`, or `"square"`. +#' @param stagger If `TRUE`, alternate lines are shifted by half the dash period so that +#' dashes of adjacent lines interleave. +#' Computed from `linetype` and `linewidth` per `?par`. Default `FALSE`. #' @return A grid grob object invisibly. If `draw` is `TRUE` then also draws to the graphic device as a side effect. #' @examples #' 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)) #' if (capabilities("png") || guess_has_R4.1_features("masks")) { #' grid::grid.newpage() -#' grid.pattern_line(x_hex, y_hex, colour = "black", angle = 0, spacing = 0.1) -#' } -#' -#' if (capabilities("png") || guess_has_R4.1_features("masks")) { -#' grid::grid.newpage() #' grid.pattern_line(x_hex, y_hex, colour = "black", linetype = "dotdash", -#' angle = 45, spacing = 0.1) +#' angle = 45, spacing = 0.1, stagger = TRUE) #' } #' #' # more intricate dashed lines are possible with hex strings @@ -47,6 +45,7 @@ grid.pattern_line <- function( linetype = gp$lty %||% 1, linewidth = size %||% gp$lwd %||% 1, size = NULL, + stagger = FALSE, use_R4.1_masks = getOption( "ggpattern_use_R4.1_masks", getOption("ggpattern_use_R4.1_features") @@ -77,6 +76,7 @@ grid.pattern_line <- function( linetype = linetype, linewidth = linewidth, lineend = lineend, + stagger = stagger, use_R4.1_masks = use_R4.1_masks, png_device = png_device, res = res, @@ -88,11 +88,80 @@ grid.pattern_line <- function( ) } -create_pattern_line <- function(params, boundary_df, aspect_ratio, legend = FALSE) { - 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) +# blank or solid lines return NULL +lty_pattern_str <- function(lty) { + if (is.numeric(lty)) { + lty <- c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash")[lty + 1L] + } + switch( + lty, + blank = , + solid = NULL, + dashed = "44", + dotted = "13", + dotdash = "1343", + longdash = "73", + twodash = "2262", + lty + ) +} + +# blank or solid lines return 0L +lty_period_sum <- function(lty) { + pat <- lty_pattern_str(lty) + if (is.null(pat)) { + return(0L) + } + sum(strtoi(strsplit(pat, "")[[1L]], base = 16L)) +} + +# Expand one row of a staggered pattern into explicit solid on-segments. +# phase_offset_lwd: phase in lwd units (may be fractional, e.g. 5.5 for dotdash half-period). +# Returns list(x0, x1, y) — equal-length vectors. +expand_lty_row <- function(lty, lwd, x_min, x_max, y_row, phase_offset_lwd) { + pat <- lty_pattern_str(lty) + if (is.null(pat)) { + if (lty_period_sum(lty) == 0L) { + return(list(x0 = x_min, x1 = x_max, y = y_row)) + } + return(list(x0 = numeric(0L), x1 = numeric(0L), y = numeric(0L))) + } + units_lwd <- strtoi(strsplit(pat, "")[[1L]], base = 16L) + n <- length(units_lwd) + period_lwd <- sum(units_lwd) + phase <- phase_offset_lwd %% period_lwd + cumul_lwd <- c(0, cumsum(units_lwd)) + seg_idx <- findInterval(phase, cumul_lwd[-length(cumul_lwd)]) + offset_in_seg <- phase - cumul_lwd[seg_idx] + x0s <- numeric(0L) + x1s <- numeric(0L) + x_cur <- x_min + first <- TRUE + i <- seg_idx + while (x_cur < x_max) { + rem_lwd <- if (first) { + first <- FALSE + units_lwd[i] - offset_in_seg + } else { + units_lwd[i] + } + if (rem_lwd > 0) { + x_end <- min(x_cur + rem_lwd * lwd, x_max) + if (i %% 2L == 1L) { + x0s <- c(x0s, x_cur) + x1s <- c(x1s, x_end) + } + x_cur <- x_end + } + i <- i %% n + 1L + } + list(x0 = x0s, x1 = x1s, y = rep(y_row, length(x0s))) +} + +# Build the segments grob for one set of lines (angle/lty/stagger already set in params). +# params must already be unit-converted (via convert_params_units). +# vpm must be from get_vp_measurements(default.units). +create_line_maskee <- function(params, vpm, default.units = "bigpts") { grid_xy <- get_xy_grid(params, vpm) col <- update_alpha(params$pattern_colour, params$pattern_alpha) @@ -103,17 +172,50 @@ create_pattern_line <- function(params, boundary_df, aspect_ratio, legend = FALS x0 <- rep(grid_xy$x_min, length(grid_xy$y)) x1 <- rep(grid_xy$x_max, length(grid_xy$y)) - xy0 <- rotate_xy(x0, grid_xy$y, params$pattern_angle, vpm$x, vpm$y) - xy1 <- rotate_xy(x1, grid_xy$y, params$pattern_angle, vpm$x, vpm$y) + seg_y <- grid_xy$y - maskee <- segmentsGrob( - xy0$x, - xy0$y, - xy1$x, - xy1$y, - default.units = default.units, - gp = gp - ) + # Stagger alternating lines by half the dash period so that marks of + # adjacent lines interleave (heraldic convention). Explicit solid + # sub-segments are used so the phase is device-independent (relying on a + # segment start outside the viewport breaks dash phase on some devices). + if (isTRUE(params$pattern_stagger)) { + half_period_lwd <- lty_period_sum(lty) / 2 + if (half_period_lwd > 0) { + segs <- lapply(seq_along(grid_xy$y), function(i) { + phase <- if (i %% 2L == 0L) half_period_lwd else 0 + expand_lty_row(lty, lwd, grid_xy$x_min, grid_xy$x_max, grid_xy$y[i], phase) + }) + x0_list <- lapply(segs, `[[`, "x0") + x0 <- unlist(x0_list, use.names = FALSE) + x1 <- unlist(lapply(segs, `[[`, "x1"), use.names = FALSE) + seg_y <- unlist(lapply(segs, `[[`, "y"), use.names = FALSE) + # Expand per-line gp values to per-sub-segment so recycling + # matches the non-stagger path (one gp value per line, not per dash). + n_sub <- lengths(x0_list) + line_idx <- rep(seq_along(grid_xy$y), n_sub) + recycle_to_lines <- function(v) v[(line_idx - 1L) %% length(v) + 1L] + gp <- gpar( + col = recycle_to_lines(col), + lwd = recycle_to_lines(lwd), + lineend = recycle_to_lines(lineend), + lty = "solid" + ) + } + } + + xy0 <- rotate_xy(x0, seg_y, params$pattern_angle, vpm$x, vpm$y) + xy1 <- rotate_xy(x1, seg_y, params$pattern_angle, vpm$x, vpm$y) + + segmentsGrob(xy0$x, xy0$y, xy1$x, xy1$y, default.units = default.units, gp = gp) +} + +create_pattern_line <- function(params, boundary_df, aspect_ratio, legend = FALSE) { + 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) + + maskee <- create_line_maskee(params, vpm, default.units) masker <- convert_polygon_df_to_polygon_grob( boundary_df, default.units = default.units, diff --git a/R/utils-color.R b/R/utils-color.R new file mode 100644 index 0000000..cd57486 --- /dev/null +++ b/R/utils-color.R @@ -0,0 +1,58 @@ +#' Compute average color +#' +#' `mean_col()` computes an average color. +#' +#' We currently compute an average color +#' by using the quadratic mean of the colors' RGBA values. +#' +#' @param ... Colors to average +#' @return A color string of 9 characters: `"#"` followed by the +#' red, blue, green, and alpha values in hexadecimal. +#' @examples +#' mean_col("black", "white") +#' mean_col(c("black", "white")) +#' mean_col("red", "blue") +#' @seealso [mix_col()] for subtractive (pigment) mixing via Munsell color space. +#' @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]) +} + +quadratic_mean <- function(x) sqrt(mean(x^2)) + +#' Mix colors via Munsell color space +#' +#' `mix_col()` simulates subtractive (pigment) color mixing by converting +#' input colors to Munsell notation via [aqp::col2Munsell()], mixing them with +#' [aqp::mixMunsell()], and converting the result back to an R color string +#' via [aqp::parseMunsell()]. +#' +#' @param ... Colors to mix. Can be individual color strings or character vectors; +#' all are combined into a single vector. +#' @param w A numeric vector of weights or proportions the same length as the combined color vector. +#' Defaults to equal weights. +#' @param mixingMethod Mixing method passed to [aqp::mixMunsell()]. +#' @return A single R color string in hex notation. +#' @examples +#' if (requireNamespace("aqp", quietly = TRUE)) { +#' mix_col("red", "blue") +#' mix_col(c("red", "blue")) +#' } +#' if (requireNamespace("aqp", quietly = TRUE)) { +#' mix_col("red", "yellow", "blue", w = c(2, 1, 1)) +#' } +#' @seealso [mean_col()] for a simpler quadratic-mean RGB approach (no extra packages required). +#' @export +mix_col <- function(..., w = NULL, mixingMethod = "adaptive") { + assert_suggested("aqp", fn = "mix_col") + cols <- unlist(list(...)) + w <- w %||% rep.int(1, length(cols)) + df <- aqp::col2Munsell(cols) + s <- aqp::formatMunsell(df$hue, df$value, df$chroma) + mixed <- suppressMessages(aqp::mixMunsell(s, w = w, mixingMethod = mixingMethod)) + aqp::parseMunsell(mixed$munsell[1L]) +} diff --git a/R/utils-misc.R b/R/utils-misc.R index a66ae88..c0a9d54 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -1,10 +1,12 @@ -assert_suggested <- function(package, pattern) { +assert_suggested <- function(package, pattern = NULL, fn = NULL) { if (!requireNamespace(package, quietly = TRUE)) { + context <- if (!is.null(pattern)) { + glue('in order to use the "{pattern}" pattern.') + } else { + glue("in order to use `{fn}()`.") + } abort(c( - glue( - "The suggested package {{{package}}} must be installed ", - 'in order to use the "{pattern}" pattern.' - ), + glue("The suggested package {{{package}}} must be installed {context}"), i = glue('Install with the command `install.packages("{package}")`') )) } diff --git a/R/utils-params.R b/R/utils-params.R index 4d00459..e2ad82f 100644 --- a/R/utils-params.R +++ b/R/utils-params.R @@ -45,6 +45,7 @@ get_params <- function(..., pattern = "none", prefix = "pattern_", gp = gpar()) l$pattern_type <- default_pattern_type(pattern) } l$pattern_units <- l$pattern_units %||% "snpc" + l$pattern_stagger <- l$pattern_stagger %||% FALSE l$pattern_xoffset <- l$pattern_xoffset %||% 0 l$pattern_yoffset <- l$pattern_yoffset %||% 0 @@ -131,6 +132,7 @@ default_pattern_type <- function(pattern) { pattern, ambient = "simplex", aRtsy = "strokes", + hatch = "gules", image = "fit", placeholder = "bear", polygon_tiling = "square", diff --git a/README.Rmd b/README.Rmd index 61c8eb7..271a818 100644 --- a/README.Rmd +++ b/README.Rmd @@ -34,6 +34,7 @@ as well as original "pch", "polygon_tiling", "regular_polygon", "rose", "text", 1. [crosshatch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_crosshatch.html): crosshatch geometry patterns 1. [fill](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_fill.html): simple fill patterns 1. [gradient](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_gradient.html): gradient array/geometry patterns +1. [hatch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_hatch.html): heraldic hatching patterns 1. [image](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_image.html): image array patterns 1. [line](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_line.html): line geometry patterns 1. [magick](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_magick.html): imagemagick array patterns diff --git a/README.md b/README.md index 5653878..9ab4c55 100644 --- a/README.md +++ b/README.md @@ -34,6 +34,7 @@ as well as original "pch", "polygon_tiling", "regular_polygon", "rose", "text", 1. [crosshatch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_crosshatch.html): crosshatch geometry patterns 1. [fill](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_fill.html): simple fill patterns 1. [gradient](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_gradient.html): gradient array/geometry patterns +1. [hatch](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_hatch.html): heraldic hatching patterns 1. [image](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_image.html): image array patterns 1. [line](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_line.html): line geometry patterns 1. [magick](https://trevorldavis.com/R/gridpattern/dev/reference/grid.pattern_magick.html): imagemagick array patterns diff --git a/_pkgdown.yml b/_pkgdown.yml index a9f3936..3ec5eae 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -25,6 +25,7 @@ reference: - clippingPathGrob - guess_has_R4.1_features - mean_col + - mix_col - reset_image_cache - star_scale - update_alpha diff --git a/man/figures/README-piecepackr-1.png b/man/figures/README-piecepackr-1.png index c4d1b09..5a8cf92 100644 Binary files a/man/figures/README-piecepackr-1.png and b/man/figures/README-piecepackr-1.png differ diff --git a/man/grid.pattern.Rd b/man/grid.pattern.Rd index 0656469..37e87c4 100644 --- a/man/grid.pattern.Rd +++ b/man/grid.pattern.Rd @@ -92,6 +92,8 @@ See \code{\link[=grid.pattern_circle]{grid.pattern_circle()}} for more informati See \code{\link[=grid.pattern_crosshatch]{grid.pattern_crosshatch()}} for more information.} \item{gradient}{Gradient array/geometry patterns. See \code{\link[=grid.pattern_gradient]{grid.pattern_gradient()}} for more information.} +\item{hatch}{Heraldic hatching patterns. +See \code{\link[=grid.pattern_hatch]{grid.pattern_hatch()}} for more information.} \item{image}{Image array patterns. See \code{\link[=grid.pattern_image]{grid.pattern_image()}} for more information.} \item{line}{Line geometry patterns. diff --git a/man/grid.pattern_hatch.Rd b/man/grid.pattern_hatch.Rd new file mode 100644 index 0000000..03f1700 --- /dev/null +++ b/man/grid.pattern_hatch.Rd @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pattern-both-hatch.R +\name{grid.pattern_hatch} +\alias{grid.pattern_hatch} +\alias{names_hatch} +\title{Heraldic color hatching patterned grobs} +\usage{ +grid.pattern_hatch( + x = c(0, 0, 1, 1), + y = c(1, 0, 0, 1), + id = 1L, + ..., + type = "gules", + subtype = "combinatorial", + colour = gp$col \%||\% "grey20", + spacing = 0.05, + xoffset = 0, + yoffset = 0, + units = "snpc", + alpha = gp$alpha \%||\% NA_real_, + lineend = gp$lineend \%||\% "round", + 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 +) + +names_hatch( + subtype = c("combinatorial", "fox-davies", "goodman", "unicode"), + accent = FALSE +) +} +\arguments{ +\item{x}{A numeric vector or unit object specifying x-locations of the pattern boundary.} + +\item{y}{A numeric vector or unit object specifying y-locations of the pattern boundary.} + +\item{id}{A numeric vector used to separate locations in x, y into multiple boundaries. +All locations within the same \code{id} belong to the same boundary.} + +\item{...}{Currently ignored.} + +\item{type}{A tincture or color name. \code{names_hatch()} lists supported values. +Both traditional tincture names (e.g. \code{"gules"}) and modern color equivalents +(e.g. \code{"red"}) are accepted. Matching is case-insensitive and ignores hyphens +and spaces.} + +\item{subtype}{A string with one of +\itemize{ +\item \code{"combinatorial"} (default): an extension of the seven standard Petra Sancta hatchings with systematically derived mixed-color hatchings. +\item \code{"fox-davies"}: the hatchings in Fox-Davies' \emph{A Complete Guide to Heraldry}. +\item \code{"goodman"}: the hatchings in David Goodman's \emph{Heraldic Tincture} reference. +\item \code{"unicode"}: the hatchings used in Unicode character charts. +} + +The string is case-insensitive and hyphens and spaces are ignored.} + +\item{colour}{Stroke colour(s).} + +\item{spacing}{Spacing between repetitions of pattern (in \code{units} units).} + +\item{xoffset}{Shift pattern along x axis (in \code{units} units).} + +\item{yoffset}{Shift pattern along y axis (in \code{units} units).} + +\item{units}{\code{\link[grid:unit]{grid::unit()}} units for \code{spacing}, \code{xoffset}, and \code{yoffset} parameters.} + +\item{alpha}{Alpha (between 0 and 1) or \code{NA} (default, preserves colors' alpha value).} + +\item{lineend}{Line end style, one of \code{"round"} (default), \code{"butt"}, or \code{"square"}.} + +\item{linewidth}{Stroke linewidth.} + +\item{size}{For backwards compatibility can be used to set \code{linewidth}.} + +\item{use_R4.1_masks}{If \code{TRUE} use the grid mask feature introduced in R v4.1.0. +If \code{FALSE} do a \code{rasterGrob} approximation. +If \code{NULL} try to guess an appropriate choice. +Note not all graphic devices support the grid mask feature.} + +\item{png_device}{\dQuote{png} graphics device to save intermediate raster data with if \code{use_R4.1_masks} is \code{FALSE}. +If \code{NULL} and suggested package \code{ragg} is available +and versions are high enough we directly capture masked raster via \code{\link[ragg:agg_capture]{ragg::agg_capture()}}. +Otherwise we will use \code{png_device} +(default \code{\link[ragg:agg_png]{ragg::agg_png()}} if available else \code{\link[grDevices:png]{grDevices::png()}}) and \code{\link[png:readPNG]{png::readPNG()}} +to manually compute a masked raster.} + +\item{res}{Resolution of desired \code{rasterGrob} in pixels per inch if \code{use_R4.1_masks} is \code{FALSE}.} + +\item{default.units}{A string indicating the default units to use if \code{x} or \code{y} +are only given as numeric vectors.} + +\item{name}{ A character identifier. } + +\item{gp}{An object of class \code{"gpar"}, typically the output + from a call to the function \code{\link[grid]{gpar}}. This is basically + a list of graphical parameter settings.} + +\item{draw}{A logical value indicating whether graphics output + should be produced.} + +\item{vp}{A Grid viewport object (or NULL).} + +\item{accent}{If \code{TRUE}, return tincture names using their traditional +accented spellings where applicable (e.g. \code{"tenn\\u00e9"}, \code{"brun\\u00e2tre"}). +Defaults to \code{FALSE}.} +} +\value{ +A grid grob object invisibly. If \code{draw} is \code{TRUE} then also draws to the graphic device as a side effect. +} +\description{ +\code{grid.pattern_hatch()} draws a heraldic color hatching patterns onto the graphic device. +\code{names_hatch()} returns a character vector of supported \code{type} values. +} +\examples{ +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)) +if (capabilities("png") || guess_has_R4.1_features("masks")) { + grid::grid.newpage() + grid.pattern_hatch(x_hex, y_hex, type = "azure", colour = "blue") +} +if (capabilities("png") || guess_has_R4.1_features("masks")) { + grid::grid.newpage() + grid.pattern_hatch(x_hex, y_hex, type = "cendree", colour = "grey", spacing = 0.1) +} +print(names_hatch()) +print(names_hatch("fox-davies")) +print(names_hatch("goodman")) +print(names_hatch("unicode")) +} +\seealso{ +\code{\link[=grid.pattern_line]{grid.pattern_line()}} for single-direction lines, +\code{\link[=grid.pattern_crosshatch]{grid.pattern_crosshatch()}} for perpendicular lines. +\code{vignette("hatching", package = "gridpattern")} for a visual overview of all subtypes. +\url{https://en.wikisource.org/wiki/A_Complete_Guide_to_Heraldry/Chapter_7#74} for Fox-Davies' +\emph{A Complete Guide to Heraldry}. +\url{https://david.goodman.graphics/portfolio/item/crests-heraldry-and-coats-of-arms/} for +David Goodman's Heraldic Tincture reference. +} diff --git a/man/grid.pattern_line.Rd b/man/grid.pattern_line.Rd index dac39b0..07d395b 100644 --- a/man/grid.pattern_line.Rd +++ b/man/grid.pattern_line.Rd @@ -20,6 +20,7 @@ grid.pattern_line( linetype = gp$lty \%||\% 1, linewidth = size \%||\% gp$lwd \%||\% 1, size = NULL, + stagger = FALSE, use_R4.1_masks = getOption("ggpattern_use_R4.1_masks", getOption("ggpattern_use_R4.1_features")), png_device = NULL, @@ -63,6 +64,10 @@ All locations within the same \code{id} belong to the same boundary.} \item{size}{For backwards compatibility can be used to set \code{linewidth}.} +\item{stagger}{If \code{TRUE}, alternate lines are shifted by half the dash period so that +dashes of adjacent lines interleave. +Computed from \code{linetype} and \code{linewidth} per \code{?par}. Default \code{FALSE}.} + \item{use_R4.1_masks}{If \code{TRUE} use the grid mask feature introduced in R v4.1.0. If \code{FALSE} do a \code{rasterGrob} approximation. If \code{NULL} try to guess an appropriate choice. @@ -104,15 +109,10 @@ enabling all of R's built-in \code{linetype} values (including \code{"dotdash"}, \examples{ 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)) -if (capabilities("png") || guess_has_R4.1_features("masks")) { - grid::grid.newpage() - grid.pattern_line(x_hex, y_hex, colour = "black", angle = 0, spacing = 0.1) -} - if (capabilities("png") || guess_has_R4.1_features("masks")) { grid::grid.newpage() grid.pattern_line(x_hex, y_hex, colour = "black", linetype = "dotdash", - angle = 45, spacing = 0.1) + angle = 45, spacing = 0.1, stagger = TRUE) } # more intricate dashed lines are possible with hex strings diff --git a/man/mean_col.Rd b/man/mean_col.Rd index 6d00e8b..23644bb 100644 --- a/man/mean_col.Rd +++ b/man/mean_col.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mean_col.R +% Please edit documentation in R/utils-color.R \name{mean_col} \alias{mean_col} \title{Compute average color} @@ -25,3 +25,6 @@ by using the quadratic mean of the colors' RGBA values. mean_col(c("black", "white")) mean_col("red", "blue") } +\seealso{ +\code{\link[=mix_col]{mix_col()}} for subtractive (pigment) mixing via Munsell color space. +} diff --git a/man/mix_col.Rd b/man/mix_col.Rd new file mode 100644 index 0000000..7a6ab1b --- /dev/null +++ b/man/mix_col.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-color.R +\name{mix_col} +\alias{mix_col} +\title{Mix colors via Munsell color space} +\usage{ +mix_col(..., w = NULL, mixingMethod = "adaptive") +} +\arguments{ +\item{...}{Colors to mix. Can be individual color strings or character vectors; +all are combined into a single vector.} + +\item{w}{A numeric vector of weights or proportions the same length as the combined color vector. +Defaults to equal weights.} + +\item{mixingMethod}{Mixing method passed to \code{\link[aqp:mixMunsell]{aqp::mixMunsell()}}.} +} +\value{ +A single R color string in hex notation. +} +\description{ +\code{mix_col()} simulates subtractive (pigment) color mixing by converting +input colors to Munsell notation via \code{\link[aqp:col2Munsell]{aqp::col2Munsell()}}, mixing them with +\code{\link[aqp:mixMunsell]{aqp::mixMunsell()}}, and converting the result back to an R color string +via \code{\link[aqp:parseMunsell]{aqp::parseMunsell()}}. +} +\examples{ +if (requireNamespace("aqp", quietly = TRUE)) { + mix_col("red", "blue") + mix_col(c("red", "blue")) +} +if (requireNamespace("aqp", quietly = TRUE)) { + mix_col("red", "yellow", "blue", w = c(2, 1, 1)) +} +} +\seealso{ +\code{\link[=mean_col]{mean_col()}} for a simpler quadratic-mean RGB approach (no extra packages required). +} diff --git a/tests/figs/array/hatch_azure.png b/tests/figs/array/hatch_azure.png new file mode 100644 index 0000000..541444a Binary files /dev/null and b/tests/figs/array/hatch_azure.png differ diff --git a/tests/figs/array/hatch_cendree.png b/tests/figs/array/hatch_cendree.png new file mode 100644 index 0000000..26478dc Binary files /dev/null and b/tests/figs/array/hatch_cendree.png differ diff --git a/tests/figs/array/hatch_copper.png b/tests/figs/array/hatch_copper.png new file mode 100644 index 0000000..8602837 Binary files /dev/null and b/tests/figs/array/hatch_copper.png differ diff --git a/tests/figs/array/hatch_gules.png b/tests/figs/array/hatch_gules.png new file mode 100644 index 0000000..b114236 Binary files /dev/null and b/tests/figs/array/hatch_gules.png differ diff --git a/tests/figs/array/hatch_olive.png b/tests/figs/array/hatch_olive.png new file mode 100644 index 0000000..d7f0981 Binary files /dev/null and b/tests/figs/array/hatch_olive.png differ diff --git a/tests/figs/array/hatch_or.png b/tests/figs/array/hatch_or.png new file mode 100644 index 0000000..687b706 Binary files /dev/null and b/tests/figs/array/hatch_or.png differ diff --git a/tests/figs/array/hatch_proper.png b/tests/figs/array/hatch_proper.png new file mode 100644 index 0000000..5a6cacd Binary files /dev/null and b/tests/figs/array/hatch_proper.png differ diff --git a/tests/figs/array/hatch_sable.png b/tests/figs/array/hatch_sable.png new file mode 100644 index 0000000..e579f6e Binary files /dev/null and b/tests/figs/array/hatch_sable.png differ diff --git a/tests/figs/array/hatch_sanguine.png b/tests/figs/array/hatch_sanguine.png new file mode 100644 index 0000000..45b4c5f Binary files /dev/null and b/tests/figs/array/hatch_sanguine.png differ diff --git a/tests/figs/array/hatch_steel.png b/tests/figs/array/hatch_steel.png new file mode 100644 index 0000000..afba2f7 Binary files /dev/null and b/tests/figs/array/hatch_steel.png differ diff --git a/tests/figs/array/hatch_unicode_grey.png b/tests/figs/array/hatch_unicode_grey.png new file mode 100644 index 0000000..7e9d24d Binary files /dev/null and b/tests/figs/array/hatch_unicode_grey.png differ diff --git a/tests/figs/array/hatch_unicode_orange.png b/tests/figs/array/hatch_unicode_orange.png new file mode 100644 index 0000000..c3212ae Binary files /dev/null and b/tests/figs/array/hatch_unicode_orange.png differ diff --git a/tests/figs/array/line_stagger.png b/tests/figs/array/line_stagger.png new file mode 100644 index 0000000..242973a Binary files /dev/null and b/tests/figs/array/line_stagger.png differ diff --git a/tests/testthat/test_array.R b/tests/testthat/test_array.R index 865d996..88e9862 100644 --- a/tests/testthat/test_array.R +++ b/tests/testthat/test_array.R @@ -14,10 +14,13 @@ test_raster <- function(ref_png, fn, update = FALSE) { bool <- attr(diff, "distortion") < 0.01 if (!bool) { grDevices::dev.new() + grid::grid.text(ref_png, y = 0.95) grid::pushViewport(grid::viewport(x = 0.25, width = 0.5)) + grid::grid.text("ref", y = 0.9) grid::grid.raster(ref) grid::popViewport() grid::pushViewport(grid::viewport(x = 0.75, width = 0.5)) + grid::grid.text("new", y = 0.9) grid::grid.raster(image) grid::popViewport() } @@ -79,9 +82,91 @@ test_that("array patterns works as expected", { test_raster("image_squish.png", function() { grid.pattern_image(x, y, filename = logo_filename, type = "squish") }) + test_raster("hatch_azure.png", function() { + grid.pattern_hatch(x, y, type = "azure", colour = "black", spacing = 0.1) + }) + test_raster("hatch_gules.png", function() { + grid.pattern_hatch(x, y, type = "gules", colour = "black", spacing = 0.1) + }) + test_raster("hatch_sable.png", function() { + grid.pattern_hatch(x, y, type = "sable", colour = "black", spacing = 0.1) + }) + test_raster("hatch_sanguine.png", function() { + grid.pattern_hatch(x, y, type = "sanguine", colour = "black", spacing = 0.1) + }) + test_raster("hatch_or.png", function() { + grid.pattern_hatch(x, y, type = "or", colour = "black", spacing = 0.1) + }) + test_raster("hatch_cendree.png", function() { + grid.pattern_hatch(x, y, type = "cendree", colour = "black", spacing = 0.1) + }) + test_raster("hatch_olive.png", function() { + grid.pattern_hatch(x, y, type = "olive", colour = "black", spacing = 0.1) + }) + test_raster("hatch_proper.png", function() { + grid.pattern_hatch( + x, + y, + type = "proper", + subtype = "fox-davies", + colour = "black", + spacing = 0.1 + ) + }) + test_raster("hatch_steel.png", function() { + grid.pattern_hatch( + x, + y, + type = "steel", + subtype = "goodman", + colour = "black", + spacing = 0.1 + ) + }) + test_raster("hatch_copper.png", function() { + grid.pattern_hatch( + x, + y, + type = "copper", + subtype = "goodman", + colour = "black", + spacing = 0.1 + ) + }) + test_raster("hatch_unicode_orange.png", function() { + grid.pattern_hatch( + x, + y, + type = "orange", + subtype = "unicode", + colour = "black", + spacing = 0.1 + ) + }) + test_raster("hatch_unicode_grey.png", function() { + grid.pattern_hatch( + x, + y, + type = "grey", + subtype = "unicode", + colour = "black", + spacing = 0.1 + ) + }) test_raster("line.png", function() { grid.pattern_line(x, y, colour = "black", angle = 0, spacing = 0.1) }) + test_raster("line_stagger.png", function() { + grid.pattern_line( + x, + y, + colour = "black", + angle = 0, + spacing = 0.1, + linetype = "dashed", + stagger = TRUE + ) + }) test_raster("magick.png", function() { grid.pattern_magick(x, y, type = "octagons", fill = "blue", scale = 2) }) diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index b1bfce8..d487ef4 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -81,9 +81,123 @@ test_that("`assert_patterns_unique()` works as expected", { ) }) +test_that("`mix_col()` works as expected", { + skip_if_not_installed("aqp") + expect_equal(mix_col(c("red", "blue")), "#C2008FFF") + expect_equal(mix_col(c("yellow", "green")), "#ACFF00FF") + expect_equal(mix_col(c("red", "yellow", "blue"), w = c(2, 1, 1)), "#F46666FF") +}) + +test_that("`names_hatch()` works as expected", { + # default is combinatorial, returns color equivalents + nms <- names_hatch() + expect_type(nms, "character") + expect_true(all(!duplicated(nms))) + expect_true(all(c("red", "blue", "green", "purple", "yellow", "black", "white") %in% nms)) + expect_true(all(c("magenta", "teal", "violet", "orange", "lime green") %in% nms)) + expect_true(all(c("pink", "grey", "mint green", "light blue", "lavender") %in% nms)) + + # fox-davies returns heraldic names + fd <- names_hatch("fox-davies") + expect_true(all(!duplicated(fd))) + expect_true(all(c("gules", "azure", "vert", "purpure", "sable", "argent", "or") %in% fd)) + expect_true(all( + c( + "eisenfarbe", + "brunatre", + "sanguine", + "tenne", + "carnation", + "cendree", + "orange", + "bleu celeste", + "proper" + ) %in% + fd + )) + + # goodman: has new tinctures, lacks eisenfarbe and proper + gd <- names_hatch("goodman") + expect_true(all(!duplicated(gd))) + expect_true(all(c("murrey", "steel", "copper", "bronze", "lead") %in% gd)) + expect_false("eisenfarbe" %in% gd) + expect_false("proper" %in% gd) + + # unicode returns color equivalents matching emoji heart colors + un <- names_hatch("unicode") + expect_true(all(!duplicated(un))) + expect_true(all( + c( + "red", + "blue", + "green", + "yellow", + "purple", + "black", + "white", + "brown", + "orange", + "light blue", + "grey", + "pink" + ) %in% + un + )) + + # accent substitutes accented spellings + fd_acc <- names_hatch("fox-davies", accent = TRUE) + expect_true("tenné" %in% fd_acc) + expect_true("brunâtre" %in% fd_acc) + expect_true("cendrée" %in% fd_acc) + expect_true("bleu céleste" %in% fd_acc) + expect_false("tenne" %in% fd_acc) + + # subtype matching is case-insensitive and ignores hyphens + expect_equal(names_hatch("Fox-Davies"), names_hatch("fox-davies")) + expect_equal(names_hatch("UNICODE"), names_hatch("unicode")) + expect_equal(names_hatch("Goodman"), names_hatch("goodman")) +}) + +test_that("`grid.pattern_hatch()` warns on unsupported type/subtype combinations", { + x <- c(0, 0, 1, 1) + y <- c(1, 0, 0, 1) + render <- function(expr) { + f <- tempfile(fileext = ".pdf") + on.exit(unlink(f)) + prev_dev <- dev.cur() + pdf(f) + on.exit( + { + suppressWarnings(dev.off()) + if (prev_dev > 1L) dev.set(prev_dev) + }, + add = TRUE + ) + force(expr) + } + # unknown type errors + expect_error( + render(grid.pattern_hatch(x, y, type = "notacolor")), + "Unknown hatching type" + ) + # type valid globally but not in this subtype errors + expect_error( + render(grid.pattern_hatch(x, y, type = "violet", subtype = "fox-davies")), + "not supported by the 'fox-davies' subtype" + ) + expect_error( + render(grid.pattern_hatch(x, y, type = "proper", subtype = "goodman")), + "not supported by the 'goodman' subtype" + ) +}) + test_that("`assert_suggested()` works as expected", { expect_error( - assert_suggested("doesnotexist", "blueberry"), - "The suggested package \\{doesnotexist\\} must be installed" + assert_suggested("doesnotexist", pattern = "blueberry"), + "The suggested package \\{doesnotexist\\} must be installed in order to use the \"blueberry\" pattern" + ) + expect_error( + assert_suggested("doesnotexist", fn = "blueberry"), + "The suggested package \\{doesnotexist\\} must be installed in order to use `blueberry\\(\\)`" ) }) diff --git a/vignettes/hatching.Rmd b/vignettes/hatching.Rmd new file mode 100644 index 0000000..c3a6066 --- /dev/null +++ b/vignettes/hatching.Rmd @@ -0,0 +1,553 @@ +--- +title: "Heraldic Color Hatching" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Heraldic Color Hatching} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +can_render <- capabilities("png") || guess_has_R4.1_features("masks") +``` + +The `gridpattern` package supports heraldic color hatching via `grid.pattern_hatch()`. +Hatching encodes color information using patterns of lines and dots, allowing +images to be reproduced in black and white while retaining color identity. + +Four systems are supported via the `subtype` argument: + +- `"combinatorial"` (default): extends the seven standard Petra Sancta tinctures with systematically derived mixed-color combinations following three rules: + + 1. white combined with a color is represented by dashed lines + 2. yellow combined with a color is represented by dotdash lines + 3. color combined with a color is represented by crossing solid lines + +- `"fox-davies"`: contains the sixteen hatchings from Fox-Davies' [*A Complete Guide to Heraldry*](https://en.wikisource.org/wiki/A_Complete_Guide_to_Heraldry/Chapter_7#74) covering the seven standard Petra Sancta tinctures plus nine extensions from German heraldry. +- `"goodman"`: contains all the hatchings from David Goodman's [Heraldic Tincture](https://david.goodman.graphics/portfolio/item/crests-heraldry-and-coats-of-arms/) reference (v2.0, 2024). +- `"unicode"`: the system used in the official Unicode character chart pdfs to render "colored" (emoji) glyphs in black-and-white. + +Use `names_hatch()` to query supported tincture names for a given subtype. The "hatch" pattern will also coerce some of the more common color names to the right tincture e.g. "gold" and "yellow" will be both coerced to "or" and vice versa. + +```{r setup} +library("grid") +library("gridpattern") +``` + +```{r names} +names_hatch() +names_hatch("fox-davies") +names_hatch("goodman") +names_hatch("unicode") +``` + +## Combinatorial color hatching + +The default `"combinatorial"` subtype starts from the set of five [Munsell primary colors](https://en.wikipedia.org/wiki/Munsell_color_system) of red, yellow, green, blue, and purple plus black and white and the standard Petra Sancta color hatching system and then systematically derives additional color hatchings via three rules: + +1. **white + color** → dashed lines +2. **yellow + color** → dotdash lines +3. **color + color** → crossing solid lines + +```{r combinatorial-table, fig.alt = "Color table showing the Combinatorial Petra Sancta tinctures arranged by achromatic, primaries, secondaries, and notable combinations", fig.width = 7, fig.height = 8.5, eval = can_render && requireNamespace("aqp", quietly = TRUE), echo = FALSE} +# Munsell primary colors +p_col <- c( + argent = "#FFFFFF", + sable = "#000000", + gules = "#C83030", # 5R 4/14 + # or = "#E8C840", # 5Y 8/12 + or = "#D4B828", # 5Y 7/12 + azure = "#0072B0", # 5B 4/10 + vert = "#008060", # 5G 5/10 + # purpure = "#7B4090" # 5P 4/10 + purpure = "#9050C0" # 5P 6/12 +) +# p_col <- c( +# argent = aqp::parseMunsell("N 9.5/"), +# azure = aqp::parseMunsell("5B 4/10"), +# gules = aqp::parseMunsell("5R 4/14"), +# or = aqp::parseMunsell("5Y 7/12"), +# sable = aqp::parseMunsell("N 1/"), +# purpure = aqp::parseMunsell("5P 6/12"), +# vert = aqp::parseMunsell("5G 5/10") +# ) + +# Five Munsell secondary hues via subtractive mixing +s_col <- c( + orange = mix_col(c(p_col["gules"], p_col["or"])), # YR: red + yellow + lime = mix_col(c(p_col["or"], p_col["vert"])), # GY: yellow + green + teal = mix_col(c(p_col["azure"], p_col["vert"])), # BG: blue + green + violet = mix_col(c(p_col["azure"], p_col["purpure"])), # PB: blue + purple + sanguine = mix_col(c(p_col["gules"], p_col["purpure"])) # RP: red + purple +) + +# Notable combination colors +w_col <- c( + carnation = mix_col(c(p_col["argent"], p_col["gules"])), + cendree = mix_col(c(p_col["argent"], p_col["sable"])), + mint = mix_col(c(p_col["argent"], p_col["vert"])), + `bleu celeste` = mix_col(c(p_col["argent"], p_col["azure"])), + lavender = mix_col(c(p_col["argent"], p_col["purpure"])) +) +o_col <- c( + tenne = mix_col(c(p_col["gules"], p_col["vert"])), + slate = mix_col(c(p_col["purpure"], p_col["vert"])), + olive = mix_col(c(p_col["or"], p_col["sable"])), + rose = mix_col(c(p_col["or"], p_col["purpure"])), + brunatre = mix_col(c(p_col["azure"], p_col["gules"], p_col["vert"])) +) + +groups <- list( + list( + label = "Achromatic", + tinctures = c("argent", "sable"), + cols = p_col[c("argent", "sable")], + names = c("white (W)", "black (K)") + ), + list( + label = "Munsell Primary Hues", + tinctures = c("gules", "or", "vert", "azure", "purpure"), + cols = p_col[c("gules", "or", "vert", "azure", "purpure")], + names = c("red (R)", "yellow (Y)", "green (G)", "blue (B)", "purple (P)") + ), + list( + label = "Munsell Secondary Hues", + tinctures = c("orange", "lime", "teal", "violet", "sanguine"), + cols = s_col, + names = c("orange (R+Y)", "lime (Y+G)", "teal (G+B)", "violet (B+P)", "magenta (P+R)") + ), + list( + label = "Combinations with White", + tinctures = c("carnation", "cendree", "mint", "bleu celeste", "lavender"), + cols = w_col, + names = c("pink (R+W)", "grey (K+W)", "mint (G+W)", "light blue (B+W)", "lavender (P+W)") + ), + list( + label = "Other Combinations*", + tinctures = c("tenne", "olive", "slate", "brunatre", "rose"), + cols = o_col[c("tenne", "olive", "slate", "brunatre", "rose")], + names = c("brown (R+G)", "olive (Y+K)", "slate (G+P)", "umbre (B+R+G)", "rose (Y+P)") + ) +) + +rx <- c(0, 0, 1, 1) +ry <- c(1, 0, 0, 1) +ncols_fig <- 5L + +row_heights <- unlist(lapply(groups, function(g) { + n_sr <- ceiling(length(g$tinctures) / ncols_fig) + c(0.28, rep(1, n_sr)) +})) + +grid.newpage() +grid.rect(gp = gpar(fill = "white", col = NA)) +pushViewport(viewport(width = 0.97, height = 0.97)) +grid.text( + "Combinatorial Petra Sancta", + y = unit(1, "npc") - unit(0.25, "cm"), + just = "top", + gp = gpar(fontsize = 31, fontface = "bold") +) + +# Upper-right rules legend +pushViewport(viewport( + x = unit(1, "npc") - unit(0.2, "cm"), + y = unit(1, "npc") - unit(1.3, "cm"), + just = c("right", "top"), + width = unit(10.0, "cm"), height = unit(3.1, "cm") +)) +grid.rect(gp = gpar(fill = "grey98", col = "grey60", lwd = 0.8)) +grid.text("Combination rules:", x = 0.01, y = 0.91, just = c("left", "top"), + gp = gpar(fontsize = 14, fontface = "bold")) +legend_rules <- c( + "1. Dashed lines — combined with white", + "2. Dot-dash lines — combined with yellow", + "3. Crossed solid lines — mixed colors (if not black)" +) +for (i in seq_along(legend_rules)) { + grid.text(legend_rules[i], x = 0.01, y = 0.66 - (i - 1L) * 0.25, + just = c("left", "top"), gp = gpar(fontsize = 11)) +} +popViewport() + +pushViewport(viewport( + y = 0.49, height = 0.90, + layout = grid.layout(length(row_heights), ncols_fig, heights = unit(row_heights, "null")) +)) + +layout_row <- 1L +for (g in groups) { + pushViewport(viewport(layout.pos.row = layout_row, layout.pos.col = 1:ncols_fig)) + grid.text(g$label, x = 0.01, just = "left", + gp = gpar(fontsize = 18, fontface = "bold", col = "black")) + popViewport() + layout_row <- layout_row + 1L + + n_sr <- ceiling(length(g$tinctures) / ncols_fig) + for (sr in seq_len(n_sr)) { + idx_from <- (sr - 1L) * ncols_fig + 1L + idx_to <- min(sr * ncols_fig, length(g$tinctures)) + for (ci in idx_from:idx_to) { + t <- g$tinctures[ci] + col_i <- (ci - 1L) %% ncols_fig + 1L + if (is.na(t)) next + col <- unname(g$cols[ci]) + nm <- g$names[ci] + display_col <- if (t == "argent") "grey55" else col + + pushViewport(viewport(layout.pos.row = layout_row, layout.pos.col = col_i)) + pushViewport(viewport(y = 0.58, width = 0.90, height = 0.72, + layout = grid.layout(1, 2))) + pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) + grid.rect(gp = gpar(fill = col, col = display_col, lwd = 1.5)) + popViewport() + pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) + grid.pattern_hatch(rx, ry, type = t, color = display_col, + spacing = 0.18, linewidth = 0.8) + grid.rect(gp = gpar(fill = NA, col = display_col, lwd = 1.5)) + popViewport() + popViewport() + grid.text(nm, y = unit(0.105, "npc"), gp = gpar(fontsize = 9, col = "black")) + popViewport() + } + layout_row <- layout_row + 1L + } +} + +popViewport() + +# Footnote +grid.text( + "* Display colors are sensitive to the exact primary pigments chosen;\n results are roughly consistent for saturated heraldic primaries with Munsell pigment mixing.", + x = 0.01, y = 0.004, just = c("left", "bottom"), + gp = gpar(fontsize = 10, col = "black", fontface = "italic") +) + +popViewport() +``` + +**Note:** The mixed display colors shown above can be sensitive to the exact hex values chosen for the primaries. +The results are fairly consistent when the primaries are the saturated, high-chroma colors typical of heraldry combined with Munsell pigment mixing +but softer or more neutral primaries can shift some secondaries noticeably +(for example, mixing yellow and blue can yield anything from olive-grey to muted purple depending on the blue's hue angle). + +## Heraldic tincture hatching + +### Fox-Davies + +The `"fox-davies"` hatching subtype includes the seven standard tinctures plus nine extensions from German heraldry whose hatchings were included in Fox-Davies' [*A Complete Guide to Heraldry*](https://en.wikisource.org/wiki/A_Complete_Guide_to_Heraldry/Chapter_7#74). + +```{r fox-davies-shields, fig.alt = "Heraldic shields showing the Fox-Davies hatching tinctures", fig.width = 7, fig.height = 6.0, eval = can_render, echo = FALSE} +# Approximate display color for each tincture +tincture_col <- c( + argent = "grey40", + azure = "#003399", + `bleu celeste` = "#4499CC", + brunatre = "#7B3A10", + carnation = "#CC6688", + cendree = "#708090", + gules = "#CC0000", + eisenfarbe = "#708090", + proper = "#228B22", + or = "#DAA520", + orange = "#EE7700", + purpure = "#660099", + sable = "#111111", + sanguine = "#880000", + tenne = "#BB6600", + vert = "#006400" +) +color_equiv <- c( + argent = "white/silver", + azure = "blue", + `bleu celeste` = "light blue", + brunatre = "(earth) brown", + carnation = "carnation", + cendree = "ash grey", + gules = "red", + eisenfarbe = "iron grey", + proper = "color of nature", + or = "yellow/gold", + orange = "orange", + purpure = "purple", + sable = "black", + sanguine = "blood red", + tenne = "(tawny) brown", + vert = "green" +) + +# Heater shield polygon (normalised to [0,1] x [0,1]) +sx <- c(0.0, 0.0, 0.5, 1.0, 1.0) +sy <- c(1.0, 0.35, 0.0, 0.35, 1.0) + +tinctures <- names_hatch("fox-davies") +tincture_labels <- names_hatch("fox-davies", accent = TRUE) +n <- length(tinctures) +ncols <- 4L +nrows <- ceiling(n / ncols) + +grid.newpage() +grid.rect(gp = gpar(fill = "white", col = NA)) +pushViewport(viewport(width = 0.97, height = 0.97)) +grid.text( + "Heraldic Hatching (Petra Sancta + German Heraldry Extensions)", + y = unit(1, "npc") - unit(0.25, "cm"), + just = "top", + gp = gpar(fontsize = 13, fontface = "bold") +) +pushViewport(viewport(y = 0.47, height = 0.90, layout = grid.layout(nrows, ncols))) + +for (i in seq_len(n)) { + t <- tinctures[i] + col <- tincture_col[t] + row_i <- ((i - 1L) %/% ncols) + 1L + col_i <- ((i - 1L) %% ncols) + 1L + + pushViewport(viewport(layout.pos.row = row_i, layout.pos.col = col_i)) + pushViewport(viewport(y = 0.60, width = 0.78, height = 0.70)) + + grid.polygon(sx, sy, gp = gpar(fill = "white", col = NA)) + grid.pattern_hatch(sx, sy, type = t, subtype = "fox-davies", color = col, spacing = 0.12, linewidth = 1.0) + grid.polygon(sx, sy, gp = gpar(fill = NA, col = col, lwd = 1.5)) + + popViewport() + + grid.text(tincture_labels[i], y = unit(0.20, "npc"), gp = gpar(fontsize = 8.5, col = "grey20")) + grid.text(color_equiv[t], y = unit(0.06, "npc"), gp = gpar(fontsize = 7.5, col = col)) + + popViewport() +} + +popViewport() +popViewport() +``` + +### Goodman + +The `"goodman"` hatching subtype includes all the hatchings in David Goodman's [Heraldic Tincture](https://david.goodman.graphics/portfolio/item/crests-heraldry-and-coats-of-arms/) reference (v2.0, 2024). This shares most hatchings with Fox-Davies but differs in few ways: + +- Goodman's **sanguine** hatching instead uses horizontal plus diagonal `\` crossing lines. +- Goodman also has a distinct **murrey** hatching which uses crossing diagonal lines (Fox-Davies' instead uses this hatching for the eisenfarbe (iron grey) hatching). +- New **rose** with the same hatching as carnation (which Goodman also lists). +- New **steel** metal rendered as plus signs in a square grid. +- New **copper**, **bronze**, and **lead** metals which are each rendered as the letter "c" in a hex grid. +- Goodman omits the **proper** hatching that Fox-Davies included. + +```{r goodman-shields, fig.alt = "Heraldic shields showing Goodman tinctures that differ from Fox-Davies", fig.width = 7, fig.height = 4.0, eval = can_render, echo = FALSE} +tincture_col <- c( + sanguine = "#880000", + murrey = "#990055", + steel = "#708090", + copper = "#B87333" +) + +sx <- c(0.0, 0.0, 0.5, 1.0, 1.0) +sy <- c(1.0, 0.35, 0.0, 0.35, 1.0) + +tinctures <- names(tincture_col) +n <- length(tinctures) +ncols <- 4L +nrows <- ceiling(n / ncols) + +grid.newpage() +grid.rect(gp = gpar(fill = "white", col = NA)) +pushViewport(viewport(width = 0.97, height = 0.97)) +grid.text( + "Goodman — New and Different Tinctures", + y = unit(1, "npc") - unit(0.25, "cm"), + just = "top", + gp = gpar(fontsize = 13, fontface = "bold") +) +pushViewport(viewport(y = 0.44, height = 0.85, layout = grid.layout(nrows, ncols))) + +for (i in seq_len(n)) { + t <- tinctures[i] + col <- tincture_col[t] + row_i <- ((i - 1L) %/% ncols) + 1L + col_i <- ((i - 1L) %% ncols) + 1L + + pushViewport(viewport(layout.pos.row = row_i, layout.pos.col = col_i)) + pushViewport(viewport(y = 0.60, width = 0.78, height = 0.70)) + + grid.polygon(sx, sy, gp = gpar(fill = "white", col = NA)) + grid.pattern_hatch(sx, sy, type = t, subtype = "goodman", color = col, spacing = 0.12, linewidth = 0.8) + grid.polygon(sx, sy, gp = gpar(fill = NA, col = col, lwd = 1.5)) + + popViewport() + + grid.text(t, y = unit(0.20, "npc"), gp = gpar(fontsize = 18, col = "black")) + popViewport() +} + +popViewport() +popViewport() +``` + +## Unicode color hatching + +The `"unicode"` hatching subtype provides each of the hatching used in the official Unicode character chart pdfs to assign a distinct pattern to each color to render "colored" (emoji) glyphs in black-and-white. +Notably Unicode has twelve different [colored heart emoji](https://unicode.org/emoji/charts/full-emoji-list.html#heart) (red, blue, green, yellow, purple, black, white, brown, orange, light blue, grey, pink) that each needed a separate hatching. + +```{r unicode-hearts, fig.alt = "Twelve Unicode colored hearts rendered with hatching patterns", fig.width = 7, fig.height = 6, eval = requireNamespace("Unicode", quietly = TRUE) && can_render, echo = FALSE} +library("Unicode") + +# The 12 Unicode colored hearts in codepoint order +heart_codepoints <- c( + red = 0x2764L, # HEAVY BLACK HEART (displays as red via emoji VS) + blue = 0x1F499L, + green = 0x1F49AL, + yellow = 0x1F49BL, + purple = 0x1F49CL, + black = 0x1F5A4L, + white = 0x1F90DL, + brown = 0x1F90EL, + orange = 0x1F9E1L, + `light blue` = 0x1FA75L, + grey = 0x1FA76L, + pink = 0x1FA77L +) + +# Approximate display colors +heart_col <- c( + red = "#CC0000", + blue = "#0055CC", + green = "#006400", + yellow = "#CCAA00", + purple = "#6600AA", + black = "#111111", + white = "#999999", # grey stroke so argent pattern is visible + brown = "#7B3A10", + orange = "#FF8000", + `light blue` = "#4499CC", + grey = "#666666", + pink = "#DD4488" +) + +uchars <- as.u_char(as.integer(heart_codepoints)) +labels <- u_char_name(uchars) +heart_shape <- "♥" # U+2665 BLACK HEART SUIT — uniform shape template + +n <- length(heart_codepoints) +ncols <- 4L +nrows <- ceiling(n / ncols) + +grid.newpage() +grid.rect(gp = gpar(fill = "white", col = NA)) +pushViewport(viewport(width = 0.95, height = 0.95)) +grid.text( + "Unicode Colored Hearts with Hatching", + y = unit(1, "npc") - unit(0.25, "cm"), + just = "top", + gp = gpar(fontsize = 22, fontface = "bold") +) +pushViewport(viewport(y = 0.48, height = 0.90, layout = grid.layout(nrows, ncols))) + +for (i in seq_len(n)) { + col_i <- ((i - 1L) %% ncols) + 1L + row_i <- ((i - 1L) %/% ncols) + 1L + col <- heart_col[i] + + pushViewport(viewport(layout.pos.row = row_i, layout.pos.col = col_i)) + pushViewport(viewport(width = 0.85, height = 0.85)) + + pfill <- patternFill( + "hatch", + type = names(heart_codepoints)[i], + subtype = "unicode", + color = col, + spacing = 0.14, + linewidth = 0.8 + ) + grid.draw( + fillStrokeGrob( + textGrob(heart_shape, gp = gpar(fontsize = 84)), + gp = gpar(fill = pfill, col = col) + ) + ) + + grid.text(labels[i], y = unit(0.12, "npc"), + gp = gpar(fontsize = 12, col = "black")) + grid.text(sprintf("U+%04X", heart_codepoints[i]), y = unit(0.00, "npc"), + gp = gpar(fontsize = 10, col = "black")) + + popViewport() + popViewport() +} + +popViewport() +popViewport() +``` + +## Okabe-Ito hatching + +One of the techniques to meet Web Content Accessibility Guidelines (WCAG) is to [use color and pattern](https://www.w3.org/WAI/WCAG21/Techniques/general/G111) to ensure things are accessible to the color-blind. + +The [Okabe-Ito palette](https://jfly.uni-koeln.de/color/) is a widely used colorblind-friendly palette. Here is an example of adding a simple hatching scheme to go with this palette to provide visual redundancy: + + * "yellow", "blue", and "white" are given their standard Petra Sancta hatchings + + "reddish purple" is given a "purple" Petra Sancta hatching + * "bluish green" is given a "green" Petra Sancta hatching + * "vermillion" (red orange) is given a "red" Petra Sancta hatching + + we use a simple black fill for "black" instead of a "sable" crosshatch + * "orange" and "sky blue" are given the hatchings from German heraldry (see Fox-Davies' section above) + +```{r okabe-ito, fig.alt = "Table of Okabe-Ito palette colors paired with heraldic hatching patterns", fig.width = 6, fig.height = 6, eval = can_render} +oi_names <- c( + "black", "orange", "sky blue", "bluish green", + "yellow", "blue", "vermilion", "reddish purple", "white" +) +oi_hex <- c( + "#000000", "#E69F00", "#56B4E9", "#009E73", + "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#FFFFFF" +) +oi_hatch <- c( + NA, "orange", "bleu celeste", "vert", + "or", "azure", "gules", "purpure", NA +) +sx <- c(0, 0, 1, 1) +sy <- c(1, 0, 0, 1) +n <- length(oi_names) + +grid.newpage() +grid.rect(gp = gpar(fill = "white", col = NA)) +pushViewport(viewport(width = 0.90, height = 0.94)) +grid.text( + "Okabe-Ito Palette with Heraldic Hatching", + y = unit(1, "npc") - unit(0.25, "cm"), + just = "top", + gp = gpar(fontsize = 13, fontface = "bold") +) +pushViewport(viewport( + y = 0.46, height = 0.88, + layout = grid.layout( + n, 3, + widths = unit(c(3, 2.5, 4), "null"), + heights = unit(rep(1, n), "null") + ) +)) + +for (i in seq_len(n)) { + grid.text(oi_names[i], x = 0.90, just = "right", + gp = gpar(fontsize = 12, col = "black"), + vp = viewport(layout.pos.row = i, layout.pos.col = 1)) + + grid.text(oi_hex[i], + gp = gpar(fontsize = 12, fontfamily = "mono", col = "black"), + vp = viewport(layout.pos.row = i, layout.pos.col = 2)) + + pushViewport(viewport(layout.pos.row = i, layout.pos.col = 3)) + grid.rect(gp = gpar(fill = oi_hex[i], col = "black", lwd = 3.0)) + if (!is.na(oi_hatch[i])) { + grid.pattern_hatch(sx, sy, type = oi_hatch[i], + colour = "black", spacing = 0.18, linewidth = 0.8) + } + popViewport() +} + +popViewport() +popViewport() +```