diff --git a/DESCRIPTION b/DESCRIPTION index dc40aa95f6..868061672f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -231,6 +231,7 @@ Collate: 'scale-view.r' 'scale-viridis.r' 'scales-.r' + 'stat-align.R' 'stat-bin.r' 'stat-bin2d.r' 'stat-bindot.r' diff --git a/NAMESPACE b/NAMESPACE index 5cedb05e5e..9cfee5593e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -252,6 +252,7 @@ export(ScaleDiscrete) export(ScaleDiscreteIdentity) export(ScaleDiscretePosition) export(Stat) +export(StatAlign) export(StatBin) export(StatBin2d) export(StatBindot) @@ -630,6 +631,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) diff --git a/NEWS.md b/NEWS.md index 4b416a20e1..9009c62262 100644 --- a/NEWS.md +++ b/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) diff --git a/R/geom-ribbon.r b/R/geom-ribbon.r index c92835f32d..2c8e1ba641 100644 --- a/R/geom-ribbon.r +++ b/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 <- data_frame0( - x = data$x, - y = data$ymax, - id = ids + x = data$x[upper_keep], + y = data$ymax[upper_keep], + id = ids[upper_keep] ) positions_lower <- data_frame0( @@ -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") { diff --git a/R/stat-align.R b/R/stat-align.R new file mode 100644 index 0000000000..f75423239b --- /dev/null +++ b/R/stat-align.R @@ -0,0 +1,88 @@ +#' @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) + + data_aligned <- data_frame0( + x = x_val, + y = y_val, + 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) + } +) diff --git a/man/geom_ribbon.Rd b/man/geom_ribbon.Rd index 21d0c9c21b..165f7ac3ca 100644 --- a/man/geom_ribbon.Rd +++ b/man/geom_ribbon.Rd @@ -1,8 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/geom-ribbon.r +% Please edit documentation in R/geom-ribbon.r, R/stat-align.R \name{geom_ribbon} \alias{geom_ribbon} \alias{geom_area} +\alias{stat_align} \title{Ribbons and area plots} \usage{ geom_ribbon( @@ -21,7 +22,7 @@ geom_ribbon( geom_area( mapping = NULL, data = NULL, - stat = "identity", + stat = "align", position = "stack", na.rm = FALSE, orientation = NA, @@ -30,6 +31,17 @@ geom_area( ..., outline.type = "upper" ) + +stat_align( + mapping = NULL, + data = NULL, + geom = "area", + position = "identity", + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE +) } \arguments{ \item{mapping}{Set of aesthetic mappings created by \code{\link[=aes]{aes()}} or @@ -89,6 +101,10 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \item{outline.type}{Type of the outline of the area; \code{"both"} draws both the upper and lower lines, \code{"upper"}/\code{"lower"} draws the respective lines only. \code{"full"} draws a closed polygon around the area.} + +\item{geom}{The geometric object to use to display the data, either as a +\code{ggproto} \code{Geom} subclass or as a string naming the geom stripped of the +\code{geom_} prefix (e.g. \code{"point"} rather than \code{"geom_point"})} } \description{ For each x value, \code{geom_ribbon()} displays a y interval defined diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index 7e9cf6e132..1fa686dc37 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -16,12 +16,12 @@ % R/position-dodge.r, R/position-dodge2.r, R/position-identity.r, % R/position-jitter.r, R/position-jitterdodge.R, R/position-nudge.R, % R/position-stack.r, R/scale-.r, R/scale-binned.R, R/scale-continuous.r, -% R/scale-date.r, R/scale-discrete-.r, R/scale-identity.r, R/stat-bin.r, -% R/stat-bin2d.r, R/stat-bindot.r, R/stat-binhex.r, R/stat-boxplot.r, -% R/stat-contour.r, R/stat-count.r, R/stat-density-2d.r, R/stat-density.r, -% R/stat-ecdf.r, R/stat-ellipse.R, R/stat-function.r, R/stat-identity.r, -% R/stat-qq-line.R, R/stat-qq.r, R/stat-quantile.r, R/stat-smooth.r, -% R/stat-sum.r, R/stat-summary-2d.r, R/stat-summary-bin.R, +% R/scale-date.r, R/scale-discrete-.r, R/scale-identity.r, R/stat-align.R, +% R/stat-bin.r, R/stat-bin2d.r, R/stat-bindot.r, R/stat-binhex.r, +% R/stat-boxplot.r, R/stat-contour.r, R/stat-count.r, R/stat-density-2d.r, +% R/stat-density.r, R/stat-ecdf.r, R/stat-ellipse.R, R/stat-function.r, +% R/stat-identity.r, R/stat-qq-line.R, R/stat-qq.r, R/stat-quantile.r, +% R/stat-smooth.r, R/stat-sum.r, R/stat-summary-2d.r, R/stat-summary-bin.R, % R/stat-summary-hex.r, R/stat-summary.r, R/stat-unique.r, R/stat-ydensity.r \docType{data} \name{ggplot2-ggproto} @@ -106,6 +106,7 @@ \alias{ScaleDiscretePosition} \alias{ScaleDiscreteIdentity} \alias{ScaleContinuousIdentity} +\alias{StatAlign} \alias{StatBin} \alias{StatBin2d} \alias{StatBindot} diff --git a/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg b/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg new file mode 100644 index 0000000000..abb667a819 --- /dev/null +++ b/tests/testthat/_snaps/stat-align/align-two-areas-with-cliff.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +2.5 +5.0 +7.5 + + + + + + + +2 +4 +6 +x +y + +g + + + + +a +b +align two areas with cliff + + diff --git a/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg b/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg new file mode 100644 index 0000000000..49be47a3ea --- /dev/null +++ b/tests/testthat/_snaps/stat-align/align-two-areas-with-pos-neg-y.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-5 +0 +5 + + + + + + + +2 +4 +6 +8 +x +y + +g + + + + +a +b +align two areas with pos/neg y + + diff --git a/tests/testthat/_snaps/stat-align/align-two-areas.svg b/tests/testthat/_snaps/stat-align/align-two-areas.svg new file mode 100644 index 0000000000..90186a513c --- /dev/null +++ b/tests/testthat/_snaps/stat-align/align-two-areas.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0 +2.5 +5.0 +7.5 + + + + + + + +2 +4 +6 +x +y + +g + + + + +a +b +align two areas + + diff --git a/tests/testthat/test-geom-ribbon.R b/tests/testthat/test-geom-ribbon.R index 1d454bdc21..bcc04bf6eb 100644 --- a/tests/testthat/test-geom-ribbon.R +++ b/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") diff --git a/tests/testthat/test-position-stack.R b/tests/testthat/test-position-stack.R index 0243f0edd9..6b404284de 100644 --- a/tests/testthat/test-position-stack.R +++ b/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)) diff --git a/tests/testthat/test-stat-align.R b/tests/testthat/test-stat-align.R new file mode 100644 index 0000000000..4037c9b916 --- /dev/null +++ b/tests/testthat/test-stat-align.R @@ -0,0 +1,44 @@ +test_that("standard alignment works", { + df <- tibble::tribble( + ~g, ~x, ~y, + "a", 1, 2, + "a", 3, 5, + "a", 5, 1, + "b", 2, 3, + "b", 4, 6, + "b", 6, 7 + ) + p <- ggplot(df, aes(x, y, fill = g)) + geom_area(color = "black") + expect_doppelganger("align two areas", p) +}) + +test_that("alignment with cliffs works", { + df <- tibble::tribble( + ~g, ~x, ~y, + "a", 1, 2, + "a", 3, 5, + "a", 5, 1, + "b", 2, 3, + "b", 4, 3, + "b", 4, 6, + "b", 6, 7 + ) + + p <- ggplot(df, aes(x, y, fill = g)) + geom_area(color = "black") + expect_doppelganger("align two areas with cliff", p) +}) + +test_that("alignment with negative and positive values works", { + df <- tibble::tribble( + ~g, ~x, ~y, + "a", 1, 1, + "a", 2, 4, + "a", 3, -4, + "a", 8, 0, + "b", 2, 4, + "b", 6, -4 + ) + + p <- ggplot(df, aes(x, y, fill = g)) + geom_area(color = "black") + expect_doppelganger("align two areas with pos/neg y", p) +})