Enable geom_ribbon() to draw separate lines for upper and lower intervals

NEWS.md

@@ -122,6 +122,11 @@
 * `stat_summary()` and related functions now support rlang-style lambda functions
   (#3568, @dkahle).
 
+* `geom_ribbon()` now draws separate lines for the upper and lower intervals if
+  `colour` is mapped by default. Similarly, `geom_area()` now draws lines for
+  the upper in the same case by default. If you want old-style full stroking, use
+  `outlier.type = "legacy"` (#3503, @yutannihilation).
+
 
 # ggplot2 3.2.1
 

R/geom-ribbon.r

@@ -21,6 +21,9 @@
 #'   [geom_polygon()] for general polygons
 #' @inheritParams layer
 #' @inheritParams geom_bar
+#' @param outline.type Type of the outline of the area; `"both"` draws both the
+#'   upper and lower lines, `"upper"` draws the upper lines only. `"legacy"`
+#'   draws a closed polygon around the area.
 #' @export
 #' @examples
 #' # Generate data
@@ -44,7 +47,10 @@ geom_ribbon <- function(mapping = NULL, data = NULL,
                         na.rm = FALSE,
                         orientation = NA,
                         show.legend = NA,
-                        inherit.aes = TRUE) {
+                        inherit.aes = TRUE,
+                        outline.type = "both") {
+  outline.type <- match.arg(outline.type, c("both", "upper", "legacy"))
+
   layer(
     data = data,
     mapping = mapping,
@@ -56,6 +62,7 @@ geom_ribbon <- function(mapping = NULL, data = NULL,
     params = list(
       na.rm = na.rm,
       orientation = orientation,
+      outline.type = outline.type,
       ...
     )
   )
@@ -97,7 +104,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
     data
   },
 
-  draw_group = function(data, panel_params, coord, na.rm = FALSE, flipped_aes = FALSE) {
+  draw_group = function(data, panel_params, coord, na.rm = FALSE, flipped_aes = FALSE, outline.type = "both") {
     data <- flip_data(data, flipped_aes)
     if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ]
     data <- data[order(data$group), ]
@@ -131,23 +138,50 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
 
     munched <- coord_munch(coord, positions, panel_params)
 
-    ggname("geom_ribbon", polygonGrob(
+    g_poly <- polygonGrob(
       munched$x, munched$y, id = munched$id,
       default.units = "native",
       gp = gpar(
         fill = alpha(aes$fill, aes$alpha),
+        col = if (identical(outline.type, "legacy")) aes$colour else NA
+      )
+    )
+
+    if (identical(outline.type, "legacy")) {
+      warn(glue('outline.type = "legacy" is only for backward-compatibility ',
+                'and might be removed eventually'))
+      return(ggname("geom_ribbon", g_poly))
+    }
+
+    munched_lines <- munched
+    # increment the IDs of the lower line
+    munched_lines$id <- switch(outline.type,
+      both = munched_lines$id + rep(c(0, max(ids, na.rm = TRUE)), each = length(ids)),
+      upper = munched_lines$id + rep(c(0, NA), each = length(ids)),
+      abort(glue("invalid outline.type: {outline.type}"))
+    )
+    g_lines <- polylineGrob(
+      munched_lines$x, munched_lines$y, id = munched_lines$id,
+      default.units = "native",
+      gp = gpar(
         col = aes$colour,
         lwd = aes$size * .pt,
         lty = aes$linetype)
-    ))
+    )
+
+    ggname("geom_ribbon", grobTree(g_poly, g_lines))
   }
+
 )
 
 #' @rdname geom_ribbon
 #' @export
 geom_area <- function(mapping = NULL, data = NULL, stat = "identity",
                       position = "stack", na.rm = FALSE, orientation = NA,
-                      show.legend = NA, inherit.aes = TRUE, ...) {
+                      show.legend = NA, inherit.aes = TRUE, ...,
+                      outline.type = "upper") {
+  outline.type <- match.arg(outline.type, c("both", "upper", "legacy"))
+
   layer(
     data = data,
     mapping = mapping,
@@ -159,6 +193,7 @@ geom_area <- function(mapping = NULL, data = NULL, stat = "identity",
     params = list(
       na.rm = na.rm,
       orientation = orientation,
+      outline.type = outline.type,
       ...
     )
   )

tests/testthat/test-aes-setting.r

@@ -32,14 +32,15 @@ test_that("alpha affects only fill colour of solid geoms", {
     geom_polygon(fill = "red", colour = "red", alpha = 0.5)
   rect <- ggplot(df, aes(xmin = x, xmax = x + 1, ymin = 1, ymax = y + 1)) +
     geom_rect(fill = "red", colour = "red", alpha = 0.5)
+  # geom_ribbon() consists of polygonGrob and polylineGrob
   ribb <- ggplot(df, aes(x = x, ymin = 1, ymax = y + 1)) +
     geom_ribbon(fill = "red", colour = "red", alpha = 0.5)
 
   expect_equal(layer_grob(poly)[[1]]$gp$col[[1]], "red")
   expect_equal(layer_grob(rect)[[1]]$gp$col[[1]], "red")
-  expect_equal(layer_grob(ribb)[[1]]$children[[1]]$gp$col[[1]], "red")
+  expect_equal(layer_grob(ribb)[[1]]$children[[1]]$children[[2]]$gp$col[[1]], "red")
 
   expect_equal(layer_grob(poly)[[1]]$gp$fill[[1]], "#FF000080")
   expect_equal(layer_grob(rect)[[1]]$gp$fill[[1]], "#FF000080")
-  expect_equal(layer_grob(ribb)[[1]]$children[[1]]$gp$fill[[1]], "#FF000080")
+  expect_equal(layer_grob(ribb)[[1]]$children[[1]]$children[[1]]$gp$fill[[1]], "#FF000080")
 })

tests/testthat/test-function-args.r

@@ -13,7 +13,8 @@ test_that("geom_xxx and GeomXxx$draw arg defaults match", {
   # These aren't actually geoms, or need special parameters and can't be tested this way.
   geom_fun_names <- setdiff(
     geom_fun_names,
-    c("geom_map", "geom_sf", "geom_smooth", "geom_column", "annotation_custom", "annotation_map",
+    c("geom_map", "geom_sf", "geom_smooth", "geom_column", "geom_area",
+      "annotation_custom", "annotation_map",
       "annotation_raster", "annotation_id")
   )
 

tests/testthat/test-geom-ribbon.R

@@ -26,3 +26,36 @@ test_that("geom_ribbon works in both directions", {
   y$flipped_aes <- NULL
   expect_identical(x, flip_data(y, TRUE)[,names(x)])
 })
+
+test_that("outline.type option works", {
+  df <- data_frame(x = 1:4, y = c(1, 1, 1, 1))
+
+  p <- ggplot(df, aes(x, ymin = -y, ymax = y))
+
+  g_ribbon_default <- layer_grob(p + geom_ribbon())[[1]]
+  g_ribbon_upper   <- layer_grob(p + geom_ribbon(outline.type = "upper"))[[1]]
+  g_ribbon_legacy  <- expect_warning(
+    layer_grob(p + geom_ribbon(outline.type = "legacy"))[[1]],
+    'outline.type = "legacy" is only for backward-compatibility and might be removed eventually',
+    fixed = TRUE
+  )
+  g_area_default   <- layer_grob(ggplot(df, aes(x, y)) + geom_area())[[1]]
+
+  # default
+  expect_s3_class(g_ribbon_default$children[[1]]$children[[1]], "polygon")
+  expect_s3_class(g_ribbon_default$children[[1]]$children[[2]], "polyline")
+  expect_equal(g_ribbon_default$children[[1]]$children[[2]]$id, rep(c(1L, 2L), each = 4))
+
+  # upper
+  expect_s3_class(g_ribbon_upper$children[[1]]$children[[1]], "polygon")
+  expect_s3_class(g_ribbon_upper$children[[1]]$children[[2]], "polyline")
+  expect_equal(g_ribbon_upper$children[[1]]$children[[2]]$id, rep(c(1L, NA), each = 4))
+
+  # legacy
+  expect_s3_class(g_ribbon_legacy$children[[1]], "polygon")
+
+  # geom_area()'s default is upper
+  expect_s3_class(g_area_default$children[[1]]$children[[1]], "polygon")
+  expect_s3_class(g_area_default$children[[1]]$children[[2]], "polyline")
+  expect_equal(g_area_default$children[[1]]$children[[2]]$id, rep(c(1L, NA), each = 4))
+})