Stacked area

NEWS.md

@@ -62,12 +62,22 @@ enable finer control and customization of faceted plots:
   concatenating via the default `":"`. (#684 @grantmcdermott)
 
 Note that each of these `facet.args` arguments is paired with an equivalent
-`tpar(facet.<arg>)` parameter. For example, call `tpar(facet.axes = "outer")` 
+`tpar(facet.<arg>)` parameter. For example, call `tpar(facet.axes = "outer")`
 to set this behaviour globally. This also means that they can be set as part of
 a (custom) theme, e.g. `tinytheme("clean", facet.axes = "outer")`.
 
 #### Other new features
 
+- `type_area()` gains a `stack` argument for stacked area plots. A sister
+  `byord` argument enables convenient, on-the-fly (re-)ordering of stacking
+  layers through convenience keywords or custom functions (e.g.,
+  `byord = "end"` ranks groups according to their largest final value, while
+  `byord = "minvar"` puts the lowest variance group on the baseline, and
+  `byord = "rev"` simply reverses the existing level order). Custom
+  functions may additionally name an `x` argument to receive the group's `x`
+  values, as needed by any statistic that depends on their spacing.
+  Similarly, a new `FUN` argument permits stacking of multi-observation data by
+  collapsing repeated `y` values. (#688 @grantmcdermott)
 - `type_points()`, `type_lines()`, `type_errorbar()`, and `type_pointrange()`
   gain an `xlevels` argument for reordering a categorical `x` variable on the
   fly (matching existing functionality for `type_barplot()` and several other
@@ -107,6 +117,9 @@ a (custom) theme, e.g. `tinytheme("clean", facet.axes = "outer")`.
 
 ### Bug fixes
 
+- `type_area()` now labels a categorical `x` axis with its factor levels,
+  rather than falling back to the underlying integer positions.
+  (#688 @grantmcdermott)
 - Density-based plots no longer error out on singleton groups, i.e. `by` and
   `facet` combinations containing only one observation. Such groups are now
   dropped, together with a warning reporting how many were removed. The

R/assertions.R

@@ -323,7 +323,8 @@ known_type_hints = c(
   "has_rhs_axis",                  # secondary right-hand axis (reserve margin)
   "legend_border_fg",              # legend swatch border is always par("fg")
   "legend_fills_from_col",         # legend swatch fill comes from `col`
-  "legend_fills_from_seq_palette"  # ... or from the colour's sequential ramp
+  "legend_fills_from_seq_palette", # ... or from the colour's sequential ramp
+  "legend_reversed"                # list the key bottom-up, not top-down
 )
 
 ## Validate a type's declared hints.

R/legend.R

@@ -690,6 +690,13 @@ build_legend_args = function(
     legend_args[["inset"]] = 0
   }
 
+  # legend() lists its first entry at the top, so a type whose groups read
+  # bottom-up needs its key flipped or it runs backwards against the geometry it
+  # labels. Gradient legends already run bottom-up, so they are exempt. (#632)
+  if (isTRUE(legend_env[["type_hints"]][["legend_reversed"]]) && isFALSE(gradient)) {
+    legend_args = reverse_legend_keys(legend_args, n = length(lgnd_labs))
+  }
+
   # Additional tweaks for horizontal and/or multi-column legends
   mcol_flag = !is.null(legend_args[["ncol"]]) && legend_args[["ncol"]] > 1
   user_inset = !is.null(legend_args[["inset"]])
@@ -727,6 +734,30 @@ build_legend_args = function(
 }
 
 
+## Flip a discrete legend key end-for-end. Every element below is positionally
+## aligned with the labels, so they all have to move together or the swatches
+## detach from their text. An allowlist rather than "reverse anything of length
+## n", because some non-grouped args are legitimately length 2 -- `inset` above
+## all -- and would be corrupted on any two-group plot. Scalars are skipped (a
+## recycled `lty`, or a `col` that legend_border_fg collapsed to par("fg")), as
+## is a `legend` still held as an unevaluated expression.
+reverse_legend_keys = function(legend_args, n) {
+  if (n < 2L) return(legend_args)
+  keys = c(
+    "legend",                              # the labels themselves
+    "col", "pch", "lty", "lwd",            # line/point key
+    "pt.bg", "pt.cex", "pt.lwd",           # point key fill and sizing
+    "fill", "border", "density", "angle",  # box key, only ever user-supplied
+    "text.col"                             # label colour, ditto
+  )
+  for (key in keys) {
+    val = legend_args[[key]]
+    if (is.atomic(val) && length(val) == n) legend_args[[key]] = rev(val)
+  }
+  legend_args
+}
+
+
 #' Build legend environment
 #'
 #' @description Creates the legend environment by:

R/sanitize_ord.R

@@ -0,0 +1,122 @@
+## Derive a factor's level order from the data, per a type's `*ord` argument.
+## This is the computed counterpart to sanitize_xlevels(), which respecifies
+## levels literally. Accepts:
+##
+##   - NULL:       keep the existing factor levels (the default)
+##   - "asis":     the categories in the order they appear in the data
+##   - "rev":      the existing factor levels, reversed
+##   - "start":    rank by the group's y value at the smallest x
+##   - "end":      rank by the group's y value at the largest x
+##   - "total":    rank by the group's summed y across every x
+##   - "minvar":   rank by the group's variance, least variable first
+##
+## ... and, for anything else, a function that is handed each group's y values
+## (ordered by x) and returns a single number to sort *ascending* on. So
+## `function(y) -sum(y)` reproduces "total", and `function(y) sum(y)` reverses
+## it. This is the escape hatch for the reverse direction, and for statistics we
+## don't have a keyword for (`function(y) -median(y)`, etc.).
+##
+## A function that declares a formal named `x` also receives that group's x
+## values, which is what any statistic depending on the spacing between
+## observations needs -- a slope, say: `function(y, x) coef(lm(y ~ x))[2]`.
+## Keying on the *name* rather than the number of formals is deliberate: it
+## keeps a tuning parameter carrying a default, e.g. `function(y, p = 0.9)`,
+## from being silently handed x. x is passed by name, so the two arguments may
+## be declared in either order.
+##
+## "asis" and "rev" are the two keywords that consult no data at all -- they
+## just permute the levels -- so they work when y is absent or non-numeric.
+## "rev" is also the one thing a ranking function cannot express: a function is
+## handed only its own group's y values, never its group identity or level
+## index, so it has no way to say "put me where I already am, backwards". Note
+## that it reverses the *existing* level order only; to reverse what another
+## keyword computed, negate it with a function instead (`function(y) sum(y)` is
+## the reverse of "total").
+##
+## The three size keywords rank largest first, i.e. into the first level, which
+## is the bottom band of a stacked area. "minvar" ranks the *other* way --
+## smallest first -- because there the stable baseline is the calm group, not
+## the big one. Both directions serve the same end.
+##
+## Explicit level names or indexes are deliberately *not* accepted here -- that
+## is what sanitize_xlevels() is for, and letting both arguments take the same
+## inputs would collapse the distinction between them. Types that expose only
+## `*ord` point users at factor() instead; see the error below.
+##
+## Ranking pools over facets. `by` levels are global -- one legend, one colour
+## mapping -- so ordering each facet separately would desync the legend from the
+## groups it labels. Absent groups (and NA values) count as zero, matching how
+## stack_area() completes a ragged grid. Ties keep their existing relative
+## order. Only factors are touched, so the argument is inert for continuous
+## groupings.
+##
+## As with sanitize_xlevels()'s "asis", the keywords win over a same-named
+## category: in the degenerate case of a group literally called "end", set the
+## factor levels beforehand instead.
+
+ord_keywords = c("asis", "rev", "start", "end", "total", "minvar")
+
+sanitize_ord = function(v, y, x, ord, arg = "ord") {
+  if (is.null(ord) || !is.factor(v)) {
+    return(v)
+  }
+
+  keyword = is.character(ord) && length(ord) == 1L && ord %in% ord_keywords
+  if (!keyword && !is.function(ord)) {
+    stop(
+      sprintf(
+        "`%s` must be NULL, one of %s, or a function.\n  To set the level order explicitly, use factor(levels = ) on the variable beforehand.",
+        arg, paste(sprintf('"%s"', ord_keywords), collapse = ", ")
+      ),
+      call. = FALSE
+    )
+  }
+
+  # "asis" and "rev" need no y, and must work when y is absent or non-numeric.
+  # factor() defaults `ordered` to is.ordered(v), so an ordered grouping stays
+  # ordered (and keeps its sequential palette) through either.
+  if (identical(ord, "asis")) {
+    return(factor(v, levels = unique(v)))
+  }
+  if (identical(ord, "rev")) {
+    return(factor(v, levels = rev(levels(v))))
+  }
+
+  if (identical(ord, "minvar")) {
+    # Ascending, i.e. *not* negated like the size keywords below: a stacked
+    # baseline is steadiest when the least variable group sits on it, since
+    # every band above inherits its movement. Groups too short to have a
+    # variance give NA and sort last (to the top), which is the right place
+    # for them anyway.
+    stat = tapply(y, v, function(z) var(z, na.rm = TRUE), default = NA_real_)
+  } else if (keyword) {
+    if (identical(ord, "total")) {
+      keep = rep.int(TRUE, length(x))
+    } else {
+      edge = if (identical(ord, "start")) min(x, na.rm = TRUE) else max(x, na.rm = TRUE)
+      keep = !is.na(x) & x == edge
+    }
+    stat = tapply(y[keep], v[keep], function(z) sum(z, na.rm = TRUE), default = 0)
+    stat = -stat # largest group first, i.e. the bottom band
+  } else {
+    xord = order(x)
+    grps = split(y[xord], v[xord])
+    # Hand over x too, but only to functions that ask for it by name; see the
+    # note at the top of this file.
+    want_x = "x" %in% names(formals(ord))
+    xgrps = if (want_x) split(x[xord], v[xord]) else NULL
+    stat = vapply(
+      seq_along(grps),
+      function(i) {
+        z = grps[[i]]
+        if (length(z) == 0L) return(NA_real_)
+        as.numeric(if (want_x) ord(z, x = xgrps[[i]]) else ord(z))
+      },
+      numeric(1)
+    )
+  }
+
+  # seq_along() breaks ties on the existing level order; empty groups sort last
+  o = order(stat, seq_along(stat), na.last = TRUE)
+  factor(v, levels = levels(v)[o])
+}

R/type_area.R

@@ -1,22 +1,68 @@
 #' @rdname type_ribbon
 #' @export
-type_area = function(alpha = NULL) {
+type_area = function(alpha = NULL, stack = FALSE, byord = NULL, FUN = NULL) {
     out = list(
         draw = NULL,
-        data = data_area(alpha = alpha),
+        data = data_area(alpha = alpha, stack = stack, byord = byord, FUN = FUN),
         name = "area"
     )
     class(out) = "tinyplot_type"
     return(out)
 }
 
 
-data_area = function(alpha = alpha) {
-    ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha)
+data_area = function(alpha = NULL, stack = FALSE, byord = NULL, FUN = NULL) {
+    assert_flag(stack)
+    assert_function(FUN, null.ok = TRUE)
+    # Stacked bands don't overlap, so the usual semi-transparent ribbon fill
+    # only mutes them; default to opaque unless the user asks otherwise.
+    ribbon.alpha = if (is.null(alpha) && isTRUE(stack)) {
+        1
+    } else {
+        sanitize_ribbon_alpha(alpha)
+    }
+
     fun = function(settings, ...) {
-        env2env(settings, environment(), "datapoints")
-        datapoints$ymax = datapoints$y
-        datapoints$ymin = rep.int(0, nrow(datapoints))
+        env2env(settings, environment(), c("datapoints", "xlabs"))
+
+        # Categorical x -> integer positions plus axis labels (cf. data_ribbon)
+        if (is.character(datapoints$x)) datapoints$x = as.factor(datapoints$x)
+        if (is.factor(datapoints$x)) {
+            xlvls = levels(datapoints$x)
+            xlabs = seq_along(xlvls)
+            names(xlabs) = xlvls
+            datapoints$x = as.integer(datapoints$x)
+        }
+
+        # Collapse repeated cells *before* ranking below, so that `byord`
+        # sees the values that actually get drawn. Ranking first would sort on
+        # raw per-cell sums, which unequal cell counts can order differently
+        # from the aggregated bands.
+        if (isTRUE(stack)) {
+            datapoints = aggregate_cells(datapoints, FUN = FUN)
+        }
+
+        # The `by` level order sets the band order, and with it the legend
+        # order and the palette assignment, so this has to happen up front.
+        by = NULL
+        if (!is.null(byord)) {
+            datapoints$by = sanitize_ord(
+                datapoints$by, datapoints$y, datapoints$x, byord, arg = "byord"
+            )
+            by = datapoints$by
+        }
+
+        if (isTRUE(stack)) {
+            # bands read bottom-up, so the legend key should too
+            settings[["type_hints"]][["legend_reversed"]] = TRUE
+            datapoints = stack_area(datapoints)
+        } else {
+            datapoints$ymax = datapoints$y
+            datapoints$ymin = rep.int(0, nrow(datapoints))
+        }
+
+        x = datapoints$x
+        y = datapoints$y
         ymax = datapoints$ymax
         ymin = datapoints$ymin
         type = "ribbon"
@@ -32,13 +78,79 @@ data_area = function(alpha = alpha) {
         settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25
         settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25
 
-        env2env(environment(), settings, c(
+        vars_to_settings = c(
             "datapoints",
+            "x",
+            "y",
             "ymax",
             "ymin",
+            "xlabs",
             "type",
             "ribbon.alpha"
-        ))
+        )
+        # keep settings$by in step with datapoints$by if we releveled it
+        if (!is.null(by)) vars_to_settings = c(vars_to_settings, "by")
+
+        env2env(environment(), settings, vars_to_settings)
     }
     return(fun)
 }
+
+
+## Collapse repeated cells down to one `y` per group per `x`. Stacking needs
+## exactly one value per cell; repeats -- typically a variable that is in the
+## data but not in the plot -- would otherwise be cumsum'd against each other
+## into overlapping bands. Mirrors data_barplot(), default statistic included,
+## so that the same data stacks to the same heights whether it is drawn as bars
+## or as an area.
+aggregate_cells = function(datapoints, FUN = NULL) {
+    cellid = paste(datapoints$facet, datapoints$x, datapoints$by, sep = "\r")
+    if (!anyDuplicated(cellid)) {
+        return(datapoints)
+    }
+    if (is.null(FUN)) FUN = function(x, ...) mean(x, ..., na.rm = TRUE)
+    aggregate(
+        datapoints[, "y", drop = FALSE],
+        datapoints[, c("x", "by", "facet")],
+        FUN = FUN
+    )
+}
+
+
+## Cumulatively stack `y` across the `by` groups, separately within each facet
+## and x position. Groups accumulate in `by` level order, so the first level
+## forms the bottom band. Returns `datapoints` with `ymin`/`ymax` set to the
+## band edges and `y` set to the running total (the ribbon's line is drawn at
+## `y`, i.e. along the top of each band).
+stack_area = function(datapoints) {
+    # A gap in one group would otherwise drop every group stacked above it back
+    # down to zero, so complete the grid and treat missing (or NA) cells as
+    # contributing zero. Cross `by` against the (facet, x) pairs that were
+    # actually observed, not against every x in the data: a facet must not
+    # inherit x positions that only exist in some other facet, or it ramps to
+    # zero across a range it never spanned.
+    fx = unique(datapoints[, c("facet", "x")])
+    fx = fx[order(fx$facet, fx$x), , drop = FALSE]
+    cells = merge(fx, data.frame(by = unique(datapoints$by)), by = NULL)
+    if (nrow(cells) > nrow(datapoints)) {
+        datapoints = merge(
+            cells, datapoints,
+            by = c("x", "by", "facet"), all.x = TRUE, sort = FALSE
+        )
+    }
+    datapoints$y[is.na(datapoints$y)] = 0
+
+    # cumsum has to run across groups within each (facet, x) cell...
+    cellord = order(datapoints$facet, datapoints$x, datapoints$by)
+    datapoints = datapoints[cellord, , drop = FALSE]
+    cell = paste(datapoints$facet, datapoints$x, sep = "\r")
+    datapoints$ymax = ave(datapoints$y, cell, FUN = cumsum)
+    datapoints$ymin = datapoints$ymax - datapoints$y
+    datapoints$y = datapoints$ymax
+
+    # ... but the polygons are traced along x, so restore group-major ordering
+    xord = order(datapoints$facet, datapoints$by, datapoints$x)
+    datapoints = datapoints[xord, , drop = FALSE]
+
+    return(datapoints)
+}