Reign in overly ambitious arrow() in geom_path() (#5078)

* Repair arrows in `!constant` branch

* Add arrow repair tests

* Add NEWS bullet

* Move NEWS bullet

Author: teunbrand

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* When `geom_path()` has aesthetics varying within groups, the `arrow()` is
+  applied to groups instead of individual segments (@teunbrand, #4935).
 * The default width of `geom_bar()` is now based on panel-wise resolution of
   the data, rather than global resolution (@teunbrand, #4336).
 * To apply dodging more consistently in violin plots, `stat_ydensity()` now

R/geom-path.R

@@ -188,6 +188,9 @@ GeomPath <- ggproto("GeomPath", Geom,
     end <-   c(group_diff, TRUE)
 
     if (!constant) {
+
+      arrow <- repair_segment_arrow(arrow, munched$group)
+
       segmentsGrob(
         munched$x[!end], munched$y[!end], munched$x[!start], munched$y[!start],
         default.units = "native", arrow = arrow,
@@ -363,3 +366,40 @@ stairstep <- function(data, direction = "hv") {
 
   data_frame0(x = x, y = y, data_attr)
 }
+
+repair_segment_arrow <- function(arrow, group) {
+  # Early exit if there is no arrow
+  if (is.null(arrow)) {
+    return(arrow)
+  }
+
+  # Get group parameters
+  rle       <- vec_group_rle(group) # handles NAs better than base::rle()
+  n_groups  <- length(rle)
+  rle_len   <- field(rle, "length") - 1 # segments have 1 member less than lines
+  rle_end   <- cumsum(rle_len)
+  rle_start <- rle_end - rle_len + 1
+
+  # Recycle ends and lengths
+  ends <- rep(rep(arrow$ends,   length.out = n_groups), rle_len)
+  len  <- rep(rep(arrow$length, length.out = n_groups), rle_len)
+
+  # Repair ends
+  # Convert 'both' ends to first/last in multi-member groups
+  is_both <- which(ends == 3)
+  ends[setdiff(intersect(rle_start, is_both), rle_end)] <- 1L
+  ends[setdiff(intersect(rle_end, is_both), rle_start)] <- 2L
+  arrow$ends <- ends
+
+  # Repair lengths
+  zero <- unit(0, "mm")
+  # Set length of first segment to zero when ends is 'last'
+  len[intersect(setdiff(rle_start, rle_end), which(ends == 2))] <- zero
+  # Set length of last segment to zero when ends is 'first'
+  len[intersect(setdiff(rle_end, rle_start), which(ends == 1))] <- zero
+  # Set length of middle pieces to zero
+  len[setdiff(seq_along(len), c(rle_start, rle_end))] <- zero
+  arrow$length <- len
+
+  return(arrow)
+}

tests/testthat/test-geom-path.R

@@ -10,6 +10,22 @@ test_that("geom_path() throws meaningful error on bad combination of varying aes
   expect_snapshot_error(ggplotGrob(p))
 })
 
+test_that("repair_segment_arrow() repairs sensibly", {
+  group <- c(1,1,1,1,2,2)
+
+  ans <- repair_segment_arrow(arrow(ends = "last"), group)
+  expect_equal(ans$ends, rep(2L, 4))
+  expect_equal(as.numeric(ans$length), c(0, 0, 0.25, 0.25))
+
+  ans <- repair_segment_arrow(arrow(ends = "first"), group)
+  expect_equal(ans$ends, rep(1L, 4))
+  expect_equal(as.numeric(ans$length), c(0.25, 0, 0, 0.25))
+
+  ans <- repair_segment_arrow(arrow(ends = "both"), group)
+  expect_equal(ans$ends, c(1L, 3L, 2L, 3L))
+  expect_equal(as.numeric(ans$length), c(0.25, 0, 0.25, 0.25))
+})
+
 # Tests on stairstep() ------------------------------------------------------------
 
 test_that("stairstep() does not error with too few observations", {