From aa2ddbe95b521359cebc19cf1e7463ad08ed7ebe Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 8 May 2023 20:37:41 +0200 Subject: [PATCH] coord_munch can convert closed shapes to closed form (#5081) * `coord_munch()` can close polygons * Polygon-like Geoms use the `make_closed` argument * Speed up rectangles to polygons * Accept invisible visual changes * Add NEWS bullet * Document `make_closed` argument * Fix order issue * make_closed -> is_closed * improve `close_poly()` * Remove closing point after munching * Accept snapshots * Add munching test --- NEWS.md | 2 + R/annotation-map.R | 2 +- R/coord-munch.R | 34 ++++++++++++++- R/geom-map.R | 2 +- R/geom-polygon.R | 2 +- R/geom-rect.R | 30 ++++--------- man/coord_munch.Rd | 4 +- ...etrack-plot-closed-and-has-center-hole.svg | 6 +-- ...cetrack-plot-closed-and-no-center-hole.svg | 6 +-- .../rose-plot-with-has-equal-spacing.svg | 6 +-- .../polar-lines-intersect-mid-bars.svg | 10 ++--- .../open-and-closed-munched-polygons.svg | 43 +++++++++++++++++++ tests/testthat/test-geom-polygon.R | 30 +++++++++++++ 13 files changed, 136 insertions(+), 41 deletions(-) create mode 100644 tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg diff --git a/NEWS.md b/NEWS.md index dc43b0f7e0..9e8d26f28b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* `coord_munch()` can now close polygon shapes (@teunbrand, #3271) + * You can now omit either `xend` or `yend` from `geom_segment()` as only one of these is now required. If one is missing, it will be filled from the `x` and `y` aesthetics respectively. This makes drawing horizontal or vertical diff --git a/R/annotation-map.R b/R/annotation-map.R index 5f11edb69e..d92195170c 100644 --- a/R/annotation-map.R +++ b/R/annotation-map.R @@ -89,7 +89,7 @@ GeomAnnotationMap <- ggproto("GeomAnnotationMap", GeomMap, draw_panel = function(data, panel_params, coord, map) { # Munch, then set up id variable for polygonGrob - # must be sequential integers - coords <- coord_munch(coord, map, panel_params) + coords <- coord_munch(coord, map, panel_params, is_closed = TRUE) coords$group <- coords$group %||% coords$id grob_id <- match(coords$group, unique0(coords$group)) diff --git a/R/coord-munch.R b/R/coord-munch.R index 5ba5951da0..6f2bbb2afb 100644 --- a/R/coord-munch.R +++ b/R/coord-munch.R @@ -9,11 +9,16 @@ #' All other variables are duplicated as needed. #' @param range Panel range specification. #' @param segment_length Target segment length +#' @param is_closed Whether data should be considered as a closed polygon. #' @keywords internal #' @export -coord_munch <- function(coord, data, range, segment_length = 0.01) { +coord_munch <- function(coord, data, range, segment_length = 0.01, is_closed = FALSE) { if (coord$is_linear()) return(coord$transform(data, range)) + if (is_closed) { + data <- close_poly(data) + } + # range has theta and r values; get corresponding x and y values ranges <- coord$backtransform_range(range) @@ -34,6 +39,11 @@ coord_munch <- function(coord, data, range, segment_length = 0.01) { # Munch and then transform result munched <- munch_data(data, dist, segment_length) + if (is_closed) { + group_cols <- intersect(c("group", "subgroup"), names(munched)) + runs <- vec_run_sizes(munched[, group_cols, drop = FALSE]) + munched <- vec_slice(munched, -(cumsum(runs))) + } coord$transform(munched, range) } @@ -204,3 +214,25 @@ spiral_arc_length <- function(a, theta1, theta2) { (theta1 * sqrt(1 + theta1 * theta1) + asinh(theta1)) - (theta2 * sqrt(1 + theta2 * theta2) + asinh(theta2))) } + +# Closes a polygon type data structure by repeating the first-in-group after +# the last-in-group +close_poly <- function(data) { + # Sort by group + groups <- data[, intersect(c("group", "subgroup"), names(data)), drop = FALSE] + ord <- vec_order(groups) + + # Run length encoding stats + runs <- vec_run_sizes(vec_slice(groups, ord)) + ends <- cumsum(runs) + starts <- ends - runs + 1 + + # Repeat 1st row of group after every group + index <- seq_len(nrow(data)) + insert <- ends + seq_along(ends) + new_index <- integer(length(index) + length(runs)) + new_index[-insert] <- index + new_index[insert] <- starts + + vec_slice(data, ord[new_index]) +} diff --git a/R/geom-map.R b/R/geom-map.R index a1085fd75d..987ee864b4 100644 --- a/R/geom-map.R +++ b/R/geom-map.R @@ -135,7 +135,7 @@ GeomMap <- ggproto("GeomMap", GeomPolygon, # Munch, then set up id variable for polygonGrob - # must be sequential integers - coords <- coord_munch(coord, map, panel_params) + coords <- coord_munch(coord, map, panel_params, is_closed = TRUE) coords$group <- coords$group %||% coords$id grob_id <- match(coords$group, unique0(coords$group)) diff --git a/R/geom-polygon.R b/R/geom-polygon.R index 0558a64efe..cfeefa1d12 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -113,7 +113,7 @@ GeomPolygon <- ggproto("GeomPolygon", Geom, n <- nrow(data) if (n == 1) return(zeroGrob()) - munched <- coord_munch(coord, data, panel_params) + munched <- coord_munch(coord, data, panel_params, is_closed = TRUE) if (is.null(munched$subgroup)) { # Sort by group to make sure that colors, fill, etc. come in same order diff --git a/R/geom-rect.R b/R/geom-rect.R index 00eee5fb48..1d4108345d 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -39,15 +39,16 @@ GeomRect <- ggproto("GeomRect", Geom, aesthetics <- setdiff( names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax") ) + index <- rep(seq_len(nrow(data)), each = 4) - polys <- lapply(split(data, seq_len(nrow(data))), function(row) { - poly <- rect_to_poly(row$xmin, row$xmax, row$ymin, row$ymax) - aes <- row[rep(1,5), aesthetics] + new <- data[index, aesthetics, drop = FALSE] + new$x <- vec_interleave(data$xmin, data$xmax, data$xmax, data$xmin) + new$y <- vec_interleave(data$ymax, data$ymax, data$ymin, data$ymin) + new$group <- index - GeomPolygon$draw_panel(vec_cbind(poly, aes), panel_params, coord, lineend = lineend, linejoin = linejoin) - }) - - ggname("geom_rect", inject(grobTree(!!!polys))) + ggname("geom_rect", GeomPolygon$draw_panel( + new, panel_params, coord, lineend = lineend, linejoin = linejoin + )) } else { coords <- coord$transform(data, panel_params) ggname("geom_rect", rectGrob( @@ -72,18 +73,3 @@ GeomRect <- ggproto("GeomRect", Geom, rename_size = TRUE ) - - -# Convert rectangle to polygon -# Useful for non-Cartesian coordinate systems where it's easy to work purely in -# terms of locations, rather than locations and dimensions. Note that, though -# `polygonGrob()` expects an open form, closed form is needed for correct -# munching (c.f. https://github.com/tidyverse/ggplot2/issues/3037#issuecomment-458406857). -# -# @keyword internal -rect_to_poly <- function(xmin, xmax, ymin, ymax) { - data_frame0( - y = c(ymax, ymax, ymin, ymin, ymax), - x = c(xmin, xmax, xmax, xmin, xmin) - ) -} diff --git a/man/coord_munch.Rd b/man/coord_munch.Rd index c09cd1658d..9be68514d3 100644 --- a/man/coord_munch.Rd +++ b/man/coord_munch.Rd @@ -4,7 +4,7 @@ \alias{coord_munch} \title{Munch coordinates data} \usage{ -coord_munch(coord, data, range, segment_length = 0.01) +coord_munch(coord, data, range, segment_length = 0.01, is_closed = FALSE) } \arguments{ \item{coord}{Coordinate system definition.} @@ -16,6 +16,8 @@ All other variables are duplicated as needed.} \item{range}{Panel range specification.} \item{segment_length}{Target segment length} + +\item{is_closed}{Whether data should be considered as a closed polygon.} } \description{ This function "munches" lines, dividing each line into many small pieces diff --git a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg index d5a1760e83..8bf3cc6ec2 100644 --- a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg +++ b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg @@ -44,9 +44,9 @@ - - - + + + 1 2 0/3 diff --git a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg index 56a632f253..d145a1e446 100644 --- a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg +++ b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg @@ -44,9 +44,9 @@ - - - + + + 1 2 0/3 diff --git a/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg b/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg index c9b4539265..b9d09b1835 100644 --- a/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg +++ b/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg @@ -44,9 +44,9 @@ - - - + + + A B C diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg index 66a7e87a17..c6f3b60763 100644 --- a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg +++ b/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg @@ -36,11 +36,11 @@ - - - - - + + + + + diff --git a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg new file mode 100644 index 0000000000..74816059df --- /dev/null +++ b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +colour + + + + +closed +open +open and closed munched polygons + + diff --git a/tests/testthat/test-geom-polygon.R b/tests/testthat/test-geom-polygon.R index 334e62043f..3cf3636655 100644 --- a/tests/testthat/test-geom-polygon.R +++ b/tests/testthat/test-geom-polygon.R @@ -24,3 +24,33 @@ test_that("geom_polygon draws correctly", { expect_doppelganger("basic polygon plot", p) }) + +test_that("geom_polygon is closed before munching", { + + df <- data_frame0( + x = c(1, 1, 4, 4, 2, 2, 3, 3), + y = c(1, 4, 4, 1, 2, 3, 3, 2), + sub = c(1, 1, 1, 1, 2, 2, 2, 2) + ) + + p <- ggplot(df, aes(x, y, subgroup = sub)) + + geom_polygon() + + xlim(c(0.5, 4.5)) + + ylim(c(0, 5)) + + coord_polar() + + built <- ggplot_build(p) + coord <- built$plot$coordinates + data <- built$data[[1]] + param <- built$layout$panel_params[[1]] + + closed <- coord_munch(coord, data, param, is_closed = TRUE) + open <- coord_munch(coord, data, param, is_closed = FALSE) + + p <- ggplot(mapping = aes(x = x, y = y, group = subgroup)) + + geom_polygon(aes(colour = "closed"), data = closed, fill = NA) + + geom_polygon(aes(colour = "open"), data = open, fill = NA) + + theme_void() + + expect_doppelganger("open and closed munched polygons", p) +})