3232# ' Below follows an overview of the three stages of evaluation and how aesthetic
3333# ' evaluation can be controlled.
3434# '
35- # ' ## Stage 1: direct input
35+ # ' ## Stage 1: direct input at the start
3636# ' The default is to map at the beginning, using the layer data provided by
3737# ' the user. If you want to map directly from the layer data you should not do
3838# ' anything special. This is the only stage where the original layer data can
8787# ' ```
8888# '
8989# ' ## Complex staging
90- # ' If you want to map the same aesthetic multiple times, e.g. map `x` to a
91- # ' data column for the stat, but remap it for the geom, you can use the
92- # ' `stage()` function to collect multiple mappings.
90+ # ' Sometimes, you may want to map the same aesthetic multiple times, e.g. map
91+ # ' `x` to a data column at the start for the layer stat, but remap it later to
92+ # ' a variable from the stat transformation for the layer geom. The `stage()`
93+ # ' function allows you to control multiple mappings for the same aesthetic
94+ # ' across all three stages of evaluation.
9395# '
9496# ' ```r
9597# ' # Use stage to modify the scaled fill
9698# ' ggplot(mpg, aes(class, hwy)) +
9799# ' geom_boxplot(aes(fill = stage(class, after_scale = alpha(fill, 0.4))))
98100# '
99101# ' # Using data for computing summary, but placing label elsewhere.
100- # ' # Also, we're making our own computed variable to use for the label.
102+ # ' # Also, we're making our own computed variables to use for the label.
101103# ' ggplot(mpg, aes(class, displ)) +
102104# ' geom_violin() +
103105# ' stat_summary(
109111# ' fun.data = ~ round(data.frame(mean = mean(.x), sd = sd(.x)), 2)
110112# ' )
111113# ' ```
114+ # '
115+ # ' Conceptually, `aes(x)` is equivalent to `aes(stage(start = x))`, and
116+ # ' `aes(after_stat(count))` is equivalent to `aes(stage(after_stat = count))`,
117+ # ' and so on. `stage()` is most useful when at least two of its arguments are
118+ # ' specified.
119+ # '
120+ # ' ## Theme access
121+ # ' The `from_theme()` function can be used to acces the [`element_geom()`]
122+ # ' fields of the `theme(geom)` argument. Using `aes(colour = from_theme(ink))`
123+ # ' and `aes(colour = from_theme(accent))` allows swapping between foreground and
124+ # ' accent colours.
125+ # '
112126# ' @rdname aes_eval
113127# ' @name aes_eval
114128# '
@@ -192,6 +206,13 @@ stat <- function(x) {
192206after_scale <- function (x ) {
193207 x
194208}
209+
210+ # ' @rdname aes_eval
211+ # ' @export
212+ from_theme <- function (x ) {
213+ x
214+ }
215+
195216# ' @rdname aes_eval
196217# ' @export
197218stage <- function (start = NULL , after_stat = NULL , after_scale = NULL ) {
@@ -205,12 +226,10 @@ stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) {
205226}
206227
207228# Regex to determine if an identifier refers to a calculated aesthetic
229+ # The pattern includes ye olde '...var...' syntax, which was
230+ # deprecated in 3.4.0 in favour of `after_stat()`
208231match_calculated_aes <- " ^\\ .\\ .([a-zA-Z._]+)\\ .\\ .$"
209232
210- is_dotted_var <- function (x ) {
211- grepl(match_calculated_aes , x )
212- }
213-
214233# Determine if aesthetic is calculated
215234is_calculated_aes <- function (aesthetics , warn = FALSE ) {
216235 vapply(aesthetics , is_calculated , warn = warn , logical (1 ), USE.NAMES = FALSE )
@@ -221,6 +240,9 @@ is_scaled_aes <- function(aesthetics) {
221240is_staged_aes <- function (aesthetics ) {
222241 vapply(aesthetics , is_staged , logical (1 ), USE.NAMES = FALSE )
223242}
243+ is_themed_aes <- function (aesthetics ) {
244+ vapply(aesthetics , is_themed , logical (1 ), USE.NAMES = FALSE )
245+ }
224246is_calculated <- function (x , warn = FALSE ) {
225247 if (is_call(get_expr(x ), " after_stat"
226248 return (TRUE )
@@ -229,7 +251,8 @@ is_calculated <- function(x, warn = FALSE) {
229251 if (is.null(x ) || is.atomic(x )) {
230252 FALSE
231253 } else if (is.symbol(x )) {
232- res <- is_dotted_var(as.character(x ))
254+ # Test if x is a dotted variable
255+ res <- grepl(match_calculated_aes , as.character(x ))
233256 if (res && warn ) {
234257 what <- I(paste0(" The dot-dot notation (`" x , " `)"
235258 var <- gsub(match_calculated_aes , " \\ 1" x ))
@@ -263,6 +286,9 @@ is_scaled <- function(x) {
263286is_staged <- function (x ) {
264287 is_call(get_expr(x ), " stage"
265288}
289+ is_themed <- function (x ) {
290+ is_call(get_expr(x ), " from_theme"
291+ }
266292
267293# Strip dots from expressions
268294strip_dots <- function (expr , env , strip_pronoun = FALSE ) {
@@ -313,7 +339,7 @@ strip_stage <- function(expr) {
313339 } else if (is_call(uq_expr , " stage"
314340 uq_expr <- call_match(uq_expr , stage )
315341 # Prefer stat mapping if present, otherwise original mapping (fallback to
316- # scale mapping) but there should always be two arguments to stage()
342+ # scale mapping)
317343 uq_expr $ after_stat %|| % uq_expr $ start %|| % uq_expr $ after_scale
318344 } else {
319345 expr
@@ -339,3 +365,39 @@ make_labels <- function(mapping) {
339365 }
340366 Map(default_label , names(mapping ), mapping )
341367}
368+
369+ eval_aesthetics <- function (aesthetics , data , mask = NULL ) {
370+
371+ env <- child_env(base_env())
372+
373+ # Here we mask functions, often to replace `stage()` with context appropriate
374+ # functions `stage_calculated()`/`stage_scaled()`.
375+ if (length(mask ) > 0 ) {
376+ aesthetics <- substitute_aes(aesthetics , mask_function , mask = mask )
377+ }
378+
379+ evaled <- lapply(aesthetics , eval_tidy , data = data , env = env )
380+ names(evaled ) <- names(aesthetics )
381+ compact(rename_aes(evaled ))
382+ }
383+
384+ # `mask` is a list of functions where `names(mask)` indicate names of functions
385+ # that need to be replaced, and `mask[[i]]` is the function to replace it
386+ # with.
387+ mask_function <- function (x , mask ) {
388+ if (! is.call(x )) {
389+ return (x )
390+ }
391+ nms <- names(mask )
392+ x [- 1 ] <- lapply(x [- 1 ], mask_function , mask = mask )
393+ if (! is_call(x , nms )) {
394+ return (x )
395+ }
396+ for (nm in nms ) {
397+ if (is_call(x , nm )) {
398+ x [[1 ]] <- mask [[nm ]]
399+ return (x )
400+ }
401+ }
402+ }
403+
0 commit comments