From 0c464efe5bd6e5e312d269fec57ec7aa7e18ed7d Mon Sep 17 00:00:00 2001 From: David Schoch Date: Sat, 1 Aug 2026 17:55:45 +0200 Subject: [PATCH] feat: mark_sf(merge = TRUE) dissolves adjacent same-fill regions A choropleth built from many small features (counties grouped into regions) draws a border between every feature, meshing each colour block with internal seams. `merge = TRUE` dissolves each same-fill style group into one region: each feature's rings are unioned with vellum::vl_path_op() (interpreted even-odd, so holes and multipart features stay correct), producing a single winding path whose shared interior borders are gone -- one crisp outline per region, exact in PDF, no double-stroked seams. Raw coordinates are unioned and the result mapped once (the same map-once discipline as the batched emit). With fewer than two features in a group there is nothing to union, so it falls back to the ordinary emit; and it is skipped on an interactive layer, where the per-feature keys must survive. Docs: NEWS, a spatial-and-networks section, inst/examples/33-merged-regions.R, tests in test-sf-merge.R. Co-Authored-By: Claude Opus 4.8 (1M context) --- NEWS.md | 7 ++ R/compile-marks.R | 72 +++++++++++++++++-- R/marks.R | 8 ++- inst/examples/33-merged-regions.R | 38 ++++++++++ man/mark_sf.Rd | 7 ++ tests/testthat/test-sf-merge.R | 80 +++++++++++++++++++++ vignettes/articles/spatial-and-networks.qmd | 23 ++++++ 7 files changed, 229 insertions(+), 6 deletions(-) create mode 100644 inst/examples/33-merged-regions.R create mode 100644 tests/testthat/test-sf-merge.R diff --git a/NEWS.md b/NEWS.md index 92f9bb58..8f37eba6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # vellumplot (development version) +* **Merged choropleth regions.** `mark_sf(merge = TRUE)` dissolves adjacent + features that share a fill into one region, so the internal borders between + same-valued features disappear and each region is a single crisp path — no + double-stroked seams, and exact in PDF. The union is real boolean geometry + (`vellum::vl_path_op()`), holes and multipart features preserved. It is ignored + on an interactive layer, where per-feature keys must survive. + * **Rotated and wrapping axis tick labels.** `axis.text.x` / `axis.text.y` now honour an `angle` — `theme(axis.text.x = element_text(angle = 45))` slants the labels and the gutter reserves the rotated height (an explicit `hjust`/`vjust` diff --git a/R/compile-marks.R b/R/compile-marks.R index cf0b22bd..6a9071c6 100644 --- a/R/compile-marks.R +++ b/R/compile-marks.R @@ -3671,6 +3671,47 @@ gp_alpha <- function(a) if (is.na(a)) NULL else a list(x = unlist(px, use.names = FALSE), y = unlist(py, use.names = FALSE)) } + # Dissolve a style group's polygon features into ONE region: union each + # feature's rings (interpreted even-odd, so holes and multipart features stay + # correct) with `vl_path_op`, so the shared borders between same-valued + # features vanish and the fill is a single crisp path (exact in PDF). Raw + # coordinates are unioned, then the result is mapped once -- the same map-once + # discipline as `gather_poly`. Returns a mapped `path_grob`, or NULL when there + # is nothing to merge (< 2 non-empty features) so the caller falls back to the + # ordinary batched emit. + merge_poly <- function(idx, gpp) { + operand <- function(i) { + fp <- gather_poly(i) + if (is.null(fp)) { + return(NULL) + } + list(x = fp$x, y = fp$y, nper = rle(fp$id)$lengths) + } + ops <- Filter(Negate(is.null), lapply(idx, operand)) + if (length(ops) < 2L) { + return(NULL) + } + acc <- ops[[1L]] + for (j in seq_along(ops)[-1L]) { + acc <- vellum::vl_path_op(acc, ops[[j]], op = "union", rule = "evenodd") + } + rx <- as.numeric(vctrs::field(acc@x, "value")) + ry <- as.numeric(vctrs::field(acc@y, "value")) + if (!length(rx)) { + return(NULL) + } + nper <- acc@nper %||% length(rx) + xy <- .xy_units(scales, scales$x$map(rx), scales$y$map(ry)) + vellum::path_grob( + xy$x, + xy$y, + id = rep(seq_along(nper), nper), + rule = "winding", + sketch = sk, + gp = gpp + ) + } + # Iterate style groups of the features that carry kind `k`, calling `draw`. by_style <- function(scene, k, colvec, draw) { sub <- which(has_kind(k)) @@ -3690,7 +3731,10 @@ gp_alpha <- function(a) if (is.na(a)) NULL else a # polygons: batched into one path_grob per style group (its features' rings are # `evenodd` sub-paths) -- unless the layer is interactive, when each feature is # its own grob so `.draw()` can key it (`rows = i`) with the feature's data_id / - # tooltip. See the EXCEPTION / CAVEAT notes on `.emit_sf`. + # tooltip. See the EXCEPTION / CAVEAT notes on `.emit_sf`. With `merge = TRUE` + # (and non-interactive) the group's features are instead dissolved into one + # unioned region so their shared borders disappear. + do_merge <- isTRUE(L$stat_params$merge) && !interactive scene <- by_style( scene, "poly", @@ -3702,6 +3746,10 @@ gp_alpha <- function(a) if (is.na(a)) NULL else a lwd = lwd, alpha = gp_alpha(a) ) + merged <- if (do_merge) merge_poly(idx, gpp) else NULL + if (!is.null(merged)) { + return(.draw(scene, merged, rows = NULL)) + } emit <- function(scene, g, rows) { if (is.null(g)) { return(scene) @@ -4207,8 +4255,18 @@ gp_alpha <- function(a) if (is.na(a)) NULL else a # radius (mm); the engine blurs the whole group once (cheaper, smoother, and it # works on text, unlike stroking N glyph copies). `widen` optionally fattens the # stroke/point first so the halo has body before the blur spreads it. -.emit_soft <- function(scene, L, scales, blur, alpha, colour, blend = "normal", - xoff = 0, yoff = 0, widen = 0) { +.emit_soft <- function( + scene, + L, + scales, + blur, + alpha, + colour, + blend = "normal", + xoff = 0, + yoff = 0, + widen = 0 +) { is_point <- L$mark %in% c("point", "nodes") base <- .glow_base(L) rng <- .panel_scale_range(scales) @@ -4252,7 +4310,9 @@ gp_alpha <- function(a) if (is.na(a)) NULL else a # opacity so brightness is comparable; `blend` (screen by default) keeps the # additive neon look over a dark backdrop. .emit_soft( - scene, L, scales, + scene, + L, + scales, blur = g@size * 0.6, alpha = min(1, g@alpha * g@layers), colour = g@color, @@ -4271,7 +4331,9 @@ gp_alpha <- function(a) if (is.na(a)) NULL else a # A real drop shadow: one blurred, offset copy in the shadow colour, instead of # the old stack of widened copies. .emit_soft( - scene, L, scales, + scene, + L, + scales, blur = s@spread, alpha = min(1, s@alpha * s@layers), colour = s@color, diff --git a/R/marks.R b/R/marks.R index bd4f15c4..9b4bfd17 100644 --- a/R/marks.R +++ b/R/marks.R @@ -547,6 +547,11 @@ mark_line <- function( #' constant or a mapped expression. #' @param na_value Fill colour for features whose mapped `fill`/`color` value is #' `NA` (drawn as a distinct legend swatch). Default `"grey80"`. +#' @param merge Dissolve adjacent features that share a fill into one region, so +#' the internal borders between same-valued features disappear and each region +#' is a single crisp path (no seam artefacts, and exact in PDF). The union is +#' real boolean geometry via [vellum::vl_path_op()]. Default `FALSE`. Ignored +#' when the layer is interactive (merging would drop the per-feature keys). #' @param blend Optional blend mode (see [mark_point()]). #' @param data Optional layer data (an `sf` object); overrides the plot data. #' @return The modified [PlotSpec]. @@ -568,6 +573,7 @@ mark_sf <- function( linewidth = NULL, size = NULL, na_value = "grey80", + merge = FALSE, blend = NULL, sketch = NULL, data = NULL @@ -585,7 +591,7 @@ mark_sf <- function( linewidth = linewidth, size = size ), - stat_params = list(na_value = na_value), + stat_params = list(na_value = na_value, merge = isTRUE(merge)), blend = blend, sketch = sketch, data = data diff --git a/inst/examples/33-merged-regions.R b/inst/examples/33-merged-regions.R new file mode 100644 index 00000000..52a0d737 --- /dev/null +++ b/inst/examples/33-merged-regions.R @@ -0,0 +1,38 @@ +# Merged choropleth regions: mark_sf(merge = TRUE) dissolves adjacent features +# that share a fill into one crisp region (no internal seams, exact in PDF). + +library(vellumplot) +if (!requireNamespace("sf", quietly = TRUE)) { + stop("this example needs the 'sf' package") +} +outdir <- "figures" +dir.create(outdir, showWarnings = FALSE) + +nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE) +# group the counties into four east-west regions, so adjacent counties share a +# fill value +nc$region <- cut( + sf::st_coordinates(sf::st_centroid(sf::st_geometry(nc)))[, 1], + 4, + labels = c("west", "midwest", "mideast", "east") +) + +# Plain: every county border is drawn, subdividing each colour block. +render_plot( + vplot(nc) |> + mark_sf(fill = region) |> + coord_sf() |> + labs(title = "Counties (internal borders)"), + file.path(outdir, "33-plain.png") +) + +# Merged: each region dissolves to one outline. +render_plot( + vplot(nc) |> + mark_sf(fill = region, merge = TRUE, color = "white") |> + coord_sf() |> + labs(title = "Merged regions"), + file.path(outdir, "33-merged.png") +) + +message("33-merged-regions: wrote plain + merged choropleths to ", outdir) diff --git a/man/mark_sf.Rd b/man/mark_sf.Rd index 034b3726..bb6f1b47 100644 --- a/man/mark_sf.Rd +++ b/man/mark_sf.Rd @@ -13,6 +13,7 @@ mark_sf( linewidth = NULL, size = NULL, na_value = "grey80", + merge = FALSE, blend = NULL, sketch = NULL, data = NULL @@ -31,6 +32,12 @@ constant or a mapped expression.} \item{na_value}{Fill colour for features whose mapped \code{fill}/\code{color} value is \code{NA} (drawn as a distinct legend swatch). Default \code{"grey80"}.} +\item{merge}{Dissolve adjacent features that share a fill into one region, so +the internal borders between same-valued features disappear and each region +is a single crisp path (no seam artefacts, and exact in PDF). The union is +real boolean geometry via \code{\link[vellum:vl_path_op]{vellum::vl_path_op()}}. Default \code{FALSE}. Ignored +when the layer is interactive (merging would drop the per-feature keys).} + \item{blend}{Optional blend mode (see \code{\link[=mark_point]{mark_point()}}).} \item{sketch}{A \code{\link[=sketch]{sketch()}} spec giving the layer a hand-drawn look, or \code{NULL} diff --git a/tests/testthat/test-sf-merge.R b/tests/testthat/test-sf-merge.R new file mode 100644 index 00000000..7a3a7932 --- /dev/null +++ b/tests/testthat/test-sf-merge.R @@ -0,0 +1,80 @@ +# mark_sf(merge = TRUE): dissolve adjacent same-fill features into one region. + +# Two unit squares sharing the edge x = 1, light grey fill and the default border. +# Plain: the shared edge is stroked (drawn once per square). Merged: the two +# squares union into one 2x1 rectangle, so that interior edge is gone. +two_squares <- function() { + skip_if_not_installed("sf") + sq <- function(x0) { + sf::st_polygon(list(rbind( + c(x0, 0), + c(x0 + 1, 0), + c(x0 + 1, 1), + c(x0, 1), + c(x0, 0) + ))) + } + sf::st_sf(id = c("a", "b"), geometry = sf::st_sfc(sq(0), sq(1))) +} + +# Count the mid-grey border pixels (the polygon stroke) across the image. The +# fills are either light grey (excluded, too pale) or saturated palette colours +# (excluded, not grey), so this isolates the borders. A dissolved region strokes +# only its outer perimeter, so it has fewer. +border_px <- function(p) { + img <- render_px(p) + g <- img[,, 1] + sum( + g > 0.25 & + g < 0.55 & + abs(img[,, 1] - img[,, 2]) < 0.04 & + abs(img[,, 2] - img[,, 3]) < 0.04 + ) +} + +sfmap <- function(d, m, ...) { + vplot(d, width = 4, height = 3) |> + mark_sf(merge = m, linewidth = 1, ...) |> + coord_sf() |> + theme_void() +} + +test_that("merge dissolves the shared border between same-fill features", { + d <- two_squares() + plain <- border_px(sfmap(d, FALSE, fill = "grey90")) + merged <- border_px(sfmap(d, TRUE, fill = "grey90")) + expect_gt(plain, 0) + expect_lt(merged, 0.75 * plain) # the interior edge is gone +}) + +test_that("merge leaves features of different fill untouched", { + d <- two_squares() + # distinct fills => two style groups => nothing to union either way + kept <- border_px(sfmap(d, TRUE, fill = id)) + same <- border_px(sfmap(d, FALSE, fill = id)) + expect_equal(kept, same) +}) + +test_that("merge is a no-op on a single feature (nothing to union)", { + skip_if_not_installed("sf") + d <- two_squares()[1, ] + # one feature => merge_poly() returns NULL => identical batched emit + expect_identical( + vellum::scene_raster(sfmap(d, TRUE, fill = "grey90")), + vellum::scene_raster(sfmap(d, FALSE, fill = "grey90")) + ) +}) + +test_that("a merged choropleth renders to PNG, PDF, and a scene", { + skip_if_not_installed("sf") + nc <- sf::st_read( + system.file("shape/nc.shp", package = "sf"), + quiet = TRUE + ) + nc$region <- factor(nc$CNTY_ID %% 3L) + p <- vplot(nc) |> mark_sf(fill = region, merge = TRUE) |> coord_sf() + expect_no_error(vellum::as_vellum_scene(p)) + f <- withr::local_tempfile(fileext = ".pdf") + expect_no_error(render_plot(p, f)) + expect_identical(rawToChar(readBin(f, "raw", 5L)), "%PDF-") +}) diff --git a/vignettes/articles/spatial-and-networks.qmd b/vignettes/articles/spatial-and-networks.qmd index 54fd4e7c..5e7ee24f 100644 --- a/vignettes/articles/spatial-and-networks.qmd +++ b/vignettes/articles/spatial-and-networks.qmd @@ -49,6 +49,29 @@ Because `mark_sf()` is an ordinary layer, you can stack it: draw a base layer of boundaries, then a second `mark_sf()` for highlighted features or point locations on top, and every layer reprojects together. +### Merging regions + +When several small features share a value — counties grouped into a region, or +tracts into a district — the borders *between* them are usually noise: you want +one clean outline per group, not a mesh of internal seams. `merge = TRUE` +dissolves each same-fill group into a single region with real boolean geometry +(`vellum::vl_path_op()`), so the shared edges vanish and each region is one crisp +path that stays exact in PDF (no double-stroked seams, no hairline gaps). + +```{r} +#| eval: !expr have_sf +nc$region <- cut(sf::st_coordinates(sf::st_centroid(sf::st_geometry(nc)))[, 1], + 4, + labels = c("west", "midwest", "mideast", "east") +) +vplot(nc) |> + mark_sf(fill = region, merge = TRUE, color = "white") |> + coord_sf() +``` + +Merging is for static choropleths; on an interactive layer it is ignored, since +dissolving the features would drop the per-feature keys a tooltip needs. + ### Cartographic furniture A map usually wants more than the polygons: a graticule to place it on the