Stat for aligning lines before stacking

DESCRIPTION

@@ -230,6 +230,7 @@ Collate:
     'scale-view.r'
     'scale-viridis.r'
     'scales-.r'
+    'stat-align.R'
     'stat-bin.r'
     'stat-bin2d.r'
     'stat-bindot.r'

NAMESPACE

@@ -231,6 +231,7 @@ export(ScaleDiscrete)
 export(ScaleDiscreteIdentity)
 export(ScaleDiscretePosition)
 export(Stat)
+export(StatAlign)
 export(StatBin)
 export(StatBin2d)
 export(StatBindot)
@@ -609,6 +610,7 @@ export(should_stop)
 export(stage)
 export(standardise_aes_names)
 export(stat)
+export(stat_align)
 export(stat_bin)
 export(stat_bin2d)
 export(stat_bin_2d)

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* Added `stat_align()` to align data without common x-coordinates prior to
+  stacking. This is now the default stat for `geom_area()` (@thomasp85, #4850)
+
 * Fix a bug in `stat_contour_filled()` where break value differences below a 
   certain number of digits would cause the computations to fail (@thomasp85, 
   #4874)

R/geom-ribbon.r

@@ -130,11 +130,14 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
 
     data <- unclass(data) #for faster indexing
 
+    # In case the data comes from stat_align
+    upper_keep <- if (is.null(data$align_padding)) TRUE else !data$align_padding
+
     # The upper line and lower line need to processed separately (#4023)
     positions_upper <- new_data_frame(list(
-      x = data$x,
-      y = data$ymax,
-      id = ids
+      x = data$x[upper_keep],
+      y = data$ymax[upper_keep],
+      id = ids[upper_keep]
     ))
 
     positions_lower <- new_data_frame(list(
@@ -203,7 +206,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
 
 #' @rdname geom_ribbon
 #' @export
-geom_area <- function(mapping = NULL, data = NULL, stat = "identity",
+geom_area <- function(mapping = NULL, data = NULL, stat = "align",
                       position = "stack", na.rm = FALSE, orientation = NA,
                       show.legend = NA, inherit.aes = TRUE, ...,
                       outline.type = "upper") {

R/stat-align.R

@@ -0,0 +1,89 @@
+#' @inheritParams layer
+#' @inheritParams geom_point
+#' @export
+#' @rdname geom_ribbon
+stat_align <- function(mapping = NULL, data = NULL,
+                       geom = "area", position = "identity",
+                       ...,
+                       na.rm = FALSE,
+                       show.legend = NA,
+                       inherit.aes = TRUE) {
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = StatAlign,
+    geom = geom,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list2(
+      na.rm = na.rm,
+      ...
+    )
+  )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+StatAlign <- ggproto("StatAlign", Stat,
+  extra_params = c("na.rm", "orientation"),
+  required_aes = c("x", "y"),
+
+  setup_params = function(data, params) {
+    params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
+    x_name <- flipped_names(params$flipped_aes)$x
+    y_name <- flipped_names(params$flipped_aes)$y
+    x_cross <- dapply(data, "group", function(d) {
+      pivots <- cumsum(rle(d[[y_name]] < 0)$lengths)
+      pivots <- pivots[-length(pivots)]
+      cross <- vapply(pivots, function(i) {
+        y <- d[[y_name]][c(i, i+1)]
+        x <- d[[x_name]][c(i, i+1)]
+        -y[1]*diff(x)/diff(y) + x[1]
+      }, numeric(1))
+      data_frame(cross = cross)
+    })
+    unique_loc <- unique(sort(c(data[[x_name]], x_cross$cross)))
+    adjust <- diff(range(unique_loc, na.rm = TRUE)) * 0.001
+    adjust <- min(adjust, min(diff(unique_loc))/3)
+    unique_loc <- sort(c(unique_loc - adjust, unique_loc, unique_loc + adjust))
+    params$unique_loc <- unique_loc
+    params$adjust <- adjust
+    params
+  },
+
+  compute_group = function(data, scales, flipped_aes = NA, unique_loc = NULL, adjust = 0) {
+    data <- flip_data(data, flipped_aes)
+    if (length(unique(data$x)) == 1) {
+      # Not enough data to align
+      return(new_data_frame())
+    }
+    # Sort out multiple observations at the same x
+    if (anyDuplicated(data$x)) {
+      data <- dapply(data, "x", function(d) {
+        if (nrow(d) == 1) return(d)
+        d <- d[c(1, nrow(d)), ]
+        d$x[1] <- d$x[1] - adjust
+        d
+      })
+    }
+    y_val <- approxfun(data$x, data$y)(unique_loc)
+    keep <- !is.na(y_val)
+    x_val <- unique_loc[keep]
+    y_val <- y_val[keep]
+    x_val <- c(min(x_val) - adjust, x_val, max(x_val) + adjust)
+    y_val <- c(0, y_val, 0)
+
+    # TODO: Move to data_frame0 once merged
+    data_aligned <- cbind(
+      x = x_val,
+      y = y_val,
+      unrowname(data[1, setdiff(names(data), c("x", "y"))]),
+      align_padding = c(TRUE, rep(FALSE, length(x_val) - 2), TRUE),
+      flipped_aes = flipped_aes
+    )
+    flip_data(data_aligned, flipped_aes)
+  }
+)

tests/testthat/test-geom-ribbon.R

@@ -49,7 +49,7 @@ test_that("outline.type option works", {
   g_ribbon_upper   <- layer_grob(p + geom_ribbon(outline.type = "upper"))[[1]]
   g_ribbon_lower   <- layer_grob(p + geom_ribbon(outline.type = "lower"))[[1]]
   g_ribbon_full    <- layer_grob(p + geom_ribbon(outline.type = "full"))[[1]]
-  g_area_default   <- layer_grob(ggplot(df, aes(x, y)) + geom_area())[[1]]
+  g_area_default   <- layer_grob(ggplot(df, aes(x, y)) + geom_area(stat = "identity"))[[1]]
 
   # default
   expect_s3_class(g_ribbon_default$children[[1]]$children[[1]], "polygon")

tests/testthat/test-position-stack.R

@@ -5,7 +5,7 @@ test_that("data keeps its order after stacking", {
     y = round(runif(30, 1, 5))
   )
   p <- ggplot(df, aes(x = x, y = y, fill = var)) +
-    geom_area(position = "stack")
+    geom_area(stat = "identity", position = "stack")
   dat <- layer_data(p)
   expect_true(all(dat$group == rep(1:3, each = 10)))
   expect_true(all(dat$x == df$x))