Finer control over aesthetic evaluation (#3534)

Author: thomasp85

DESCRIPTION

@@ -64,8 +64,8 @@ Collate:
     'ggproto.r'
     'ggplot-global.R'
     'aaa-.r'
-    'aes-calculated.r'
     'aes-colour-fill-alpha.r'
+    'aes-evaluation.r'
     'aes-group-order.r'
     'aes-linetype-size-shape.r'
     'aes-position.r'

NAMESPACE

@@ -252,6 +252,8 @@ export(aes_all)
 export(aes_auto)
 export(aes_q)
 export(aes_string)
+export(after_scale)
+export(after_stat)
 export(alpha)
 export(annotate)
 export(annotation_custom)
@@ -570,6 +572,7 @@ export(scale_y_time)
 export(sec_axis)
 export(set_last_plot)
 export(should_stop)
+export(stage)
 export(standardise_aes_names)
 export(stat)
 export(stat_bin)

NEWS.md

@@ -1,5 +1,12 @@
 # ggplot2 (development version)
 
+* The evaluation time of aesthetics can now be controlled to a finer degree. 
+  `after_stat()` superseeds the use of `stat()` and `..var..`-notation, ad is
+  joined by `after_scale()` to allow for mapping to scaled aesthetic values. 
+  Remapping of the same aesthetic is now supported with `stage()`, so you can 
+  map a data variable to a stat aesthetic, and remap the same aesthetic to 
+  something else after statistical transformation (@thomasp85, #3534)
+
 * ggplot2 no longer depends on reshape2, which means that it no longer 
   (recursively) needs plyr, stringr, or stringi packages.
 

R/aes-calculated.r

@@ -0,0 +1,200 @@
+#' Control aesthetic evaluation
+#'
+#' Most aesthetics are mapped from variables found in the data. Sometimes,
+#' however, you want to delay the mapping until later in the rendering process.
+#' ggplot2 has three stages of the data that you can map aesthetics from. The
+#' default is to map at the beginning, using the layer data provided by the
+#' user. The second stage is after the data has been transformed by the layer
+#' stat. The third and last stage is after the data has been transformed and
+#' mapped by the plot scales. The most common example of mapping from stat
+#' transformed data is the height of bars in [geom_histogram()]:
+#' the height does not come from a variable in the underlying data, but
+#' is instead mapped to the `count` computed by [stat_bin()]. An example of
+#' mapping from scaled data could be to use a desaturated version of the stroke
+#' colour for fill. If you want to map directly from the layer data you should
+#' not do anything special. In order to map from stat transformed data you
+#' should use the `after_stat()` function to flag that evaluation of the
+#' aesthetic mapping should be postponed until after stat transformation.
+#' Similarly, you should use `after_scale()` to flag evaluation of mapping for
+#' after data has been scaled. If you want to map the same aesthetic multiple
+#' times, e.g. map `x` to a data column for the stat, but remap it for the geom,
+#' you can use the `stage()` function to collect multiple mappings.
+#'
+#' `after_stat()` replaces the old approaches of using either `stat()` or
+#' surrounding the variable names with `..`.
+#'
+#' @note Evaluation after stat transformation will only have access to the
+#' variables calculated by the stat. Evaluation after scaling will only have
+#' access to the final aesthetics of the layer (including non-mapped, default
+#' aesthetics). The original layer data can only be accessed at the first stage.
+#'
+#' @param x An aesthetic expression using variables calculated by the stat
+#'   (`after_stat()`) or layer aesthetics (`after_scale()`).
+#' @param start An aesthetic expression using variables from the layer data.
+#' @param after_stat An aesthetic expression using variables calculated by the
+#'   stat.
+#' @param after_scale An aesthetic expression using layer aesthetics.
+#'
+#' @rdname aes_eval
+#' @name aes_eval
+#'
+#' @examples
+#' # Default histogram display
+#' ggplot(mpg, aes(displ)) +
+#'   geom_histogram(aes(y = after_stat(count)))
+#'
+#' # Scale tallest bin to 1
+#' ggplot(mpg, aes(displ)) +
+#'   geom_histogram(aes(y = after_stat(count / max(count))))
+#'
+#' # Use a transparent version of colour for fill
+#' ggplot(mpg, aes(class, hwy)) +
+#'   geom_boxplot(aes(colour = class, fill = after_scale(alpha(colour, 0.4))))
+#'
+#' # Use stage to modify the scaled fill
+#' ggplot(mpg, aes(class, hwy)) +
+#'   geom_boxplot(aes(fill = stage(class, after_scale = alpha(fill, 0.4))))
+NULL
+
+#' @rdname aes_eval
+#' @export
+after_stat <- function(x) {
+  x
+}
+#' @rdname aes_eval
+#' @usage NULL
+#' @export
+stat <- function(x) {
+  x
+}
+#' @rdname aes_eval
+#' @export
+after_scale <- function(x) {
+  x
+}
+#' @rdname aes_eval
+#' @export
+stage <- function(start = NULL, after_stat = NULL, after_scale = NULL) {
+  start
+}
+stage_calculated <- function(start = NULL, after_stat = NULL, after_scale = NULL) {
+  after_stat
+}
+stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) {
+  after_scale
+}
+
+# Regex to determine if an identifier refers to a calculated aesthetic
+match_calculated_aes <- "^\\.\\.([a-zA-Z._]+)\\.\\.$"
+
+is_dotted_var <- function(x) {
+  grepl(match_calculated_aes, x)
+}
+
+# Determine if aesthetic is calculated
+is_calculated_aes <- function(aesthetics) {
+  vapply(aesthetics, is_calculated, logical(1), USE.NAMES = FALSE)
+}
+is_scaled_aes <- function(aesthetics) {
+  vapply(aesthetics, is_scaled, logical(1), USE.NAMES = FALSE)
+}
+is_staged_aes <- function(aesthetics) {
+  vapply(aesthetics, is_staged, logical(1), USE.NAMES = FALSE)
+}
+is_calculated <- function(x) {
+  if (is_call(get_expr(x), "after_stat")) {
+    return(TRUE)
+  }
+  # Support of old recursive behaviour
+  if (is.atomic(x)) {
+    FALSE
+  } else if (is.symbol(x)) {
+    is_dotted_var(as.character(x))
+  } else if (is_quosure(x)) {
+    is_calculated(quo_get_expr(x))
+  } else if (is.call(x)) {
+    if (identical(x[[1]], quote(stat))) {
+      TRUE
+    } else {
+      any(vapply(x, is_calculated, logical(1)))
+    }
+  } else if (is.pairlist(x)) {
+    FALSE
+  } else {
+    stop("Unknown input:", class(x)[1])
+  }
+}
+is_scaled <- function(x) {
+  is_call(get_expr(x), "after_scale")
+}
+is_staged <- function(x) {
+  is_call(get_expr(x), "stage")
+}
+
+# Strip dots from expressions
+strip_dots <- function(expr) {
+  if (is.atomic(expr)) {
+    expr
+  } else if (is.name(expr)) {
+    expr_ch <- as.character(expr)
+    if (nchar(expr_ch) > 0) {
+      as.name(gsub(match_calculated_aes, "\\1", expr_ch))
+    } else {
+      expr
+    }
+  } else if (is_quosure(expr)) {
+    # strip dots from quosure and reconstruct the quosure
+    expr <- new_quosure(
+      strip_dots(quo_get_expr(expr)),
+      quo_get_env(expr)
+    )
+  } else if (is.call(expr)) {
+    if (identical(expr[[1]], quote(stat))) {
+      strip_dots(expr[[2]])
+    } else {
+      expr[-1] <- lapply(expr[-1], strip_dots)
+      expr
+    }
+  } else if (is.pairlist(expr)) {
+    # In the unlikely event of an anonymous function
+    as.pairlist(lapply(expr, strip_dots))
+  } else if (is.list(expr)) {
+    # For list of aesthetics
+    lapply(expr, strip_dots)
+  } else {
+    stop("Unknown input:", class(expr)[1])
+  }
+}
+
+strip_stage <- function(expr) {
+  uq_expr <- get_expr(expr)
+  if (is_call(uq_expr, c("after_stat", "after_scale"))) {
+    uq_expr[[2]]
+  } else if (is_call(uq_expr, "stage")) {
+    # Prefer stat mapping if present, otherwise original mapping (fallback to
+    # scale mapping) but there should always be two arguments to stage()
+    uq_expr$after_stat %||% uq_expr$start %||% (if (is.null(uq_expr$after_scale)) uq_expr[[3]]) %||% uq_expr[[2]]
+  } else {
+    expr
+  }
+}
+
+# Convert aesthetic mapping into text labels
+make_labels <- function(mapping) {
+  default_label <- function(aesthetic, mapping) {
+    # e.g., geom_smooth(aes(colour = "loess")) or aes(y = NULL)
+    if (is.atomic(mapping)) {
+      return(aesthetic)
+    }
+    mapping <- strip_stage(mapping)
+    mapping <- strip_dots(mapping)
+    if (is_quosure(mapping) && quo_is_symbol(mapping)) {
+      name <- as_string(quo_get_expr(mapping))
+    } else {
+      name <- quo_text(mapping)
+      name <- gsub("\n.*$", "...", name)
+    }
+    name
+  }
+  Map(default_label, names(mapping), mapping)
+}

R/aes-evaluation.r

@@ -34,7 +34,8 @@
 #' f + geom_line(aes(linetype = variable))
 #'
 #' # Using facets
-#' k <- ggplot(diamonds, aes(carat, stat(density))) + geom_histogram(binwidth = 0.2)
+#' k <- ggplot(diamonds, aes(carat, after_stat(density))) +
+#'   geom_histogram(binwidth = 0.2)
 #' k + facet_grid(. ~ cut)
 #'
 #' # There are three common cases where the default is not enough, and we

R/aes-group-order.r

@@ -174,6 +174,28 @@ rename_aes <- function(x) {
   }
   x
 }
+substitute_aes <- function(x) {
+  x <- lapply(x, function(aesthetic) {
+    as_quosure(standardise_aes_symbols(quo_get_expr(aesthetic)), env = environment(aesthetic))
+  })
+  class(x) <- "uneval"
+  x
+}
+# x is a quoted expression from inside aes()
+standardise_aes_symbols <- function(x) {
+  if (is.symbol(x)) {
+    name <- standardise_aes_names(as_string(x))
+    return(sym(name))
+  }
+  if (!is.call(x)) {
+    return(x)
+  }
+
+  # Don't walk through function heads
+  x[-1] <- lapply(x[-1], standardise_aes_symbols)
+
+  x
+}
 
 # Look up the scale that should be used for a given aesthetic
 aes_to_scale <- function(var) {