inst/doc/hatching.R

In gridpattern: 'grid' Pattern Grobs

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
    collapse = TRUE,
    comment = "#>"
)
can_render <- capabilities("png") || guess_has_R4.1_features("masks")
can_run_aqp <- requireNamespace("aqp", quietly = TRUE) &&
    (interactive() || identical(Sys.getenv("IN_PKGDOWN"), "true") || identical(Sys.getenv("NOT_CRAN"), "true"))

## ----setup--------------------------------------------------------------------
library("grid")
library("gridpattern")

## ----names--------------------------------------------------------------------
names_hatch()
names_hatch("fox-davies")
names_hatch("goodman")
names_hatch("unicode")

## ----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 && can_run_aqp, 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()

## ----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-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-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, 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()