1#' @include utilities.r compat-plyr.R 2NULL 3 4#' Construct aesthetic mappings 5#' 6#' Aesthetic mappings describe how variables in the data are mapped to visual 7#' properties (aesthetics) of geoms. Aesthetic mappings can be set in 8#' [ggplot()] and in individual layers. 9#' 10#' This function also standardises aesthetic names by converting `color` to `colour` 11#' (also in substrings, e.g., `point_color` to `point_colour`) and translating old style 12#' R names to ggplot names (e.g., `pch` to `shape` and `cex` to `size`). 13#' 14#' @section Quasiquotation: 15#' 16#' `aes()` is a [quoting function][rlang::quotation]. This means that 17#' its inputs are quoted to be evaluated in the context of the 18#' data. This makes it easy to work with variables from the data frame 19#' because you can name those directly. The flip side is that you have 20#' to use [quasiquotation][rlang::quasiquotation] to program with 21#' `aes()`. See a tidy evaluation tutorial such as the [dplyr 22#' programming vignette](https://dplyr.tidyverse.org/articles/programming.html) 23#' to learn more about these techniques. 24#' 25#' @param x,y,... List of name-value pairs in the form `aesthetic = variable` 26#' describing which variables in the layer data should be mapped to which 27#' aesthetics used by the paired geom/stat. The expression `variable` is 28#' evaluated within the layer data, so there is no need to refer to 29#' the original dataset (i.e., use `ggplot(df, aes(variable))` 30#' instead of `ggplot(df, aes(df$variable))`). The names for x and y aesthetics 31#' are typically omitted because they are so common; all other aesthetics must be named. 32#' @seealso [vars()] for another quoting function designed for 33#' faceting specifications. 34#' @return A list with class `uneval`. Components of the list are either 35#' quosures or constants. 36#' @export 37#' @examples 38#' aes(x = mpg, y = wt) 39#' aes(mpg, wt) 40#' 41#' # You can also map aesthetics to functions of variables 42#' aes(x = mpg ^ 2, y = wt / cyl) 43#' 44#' # Or to constants 45#' aes(x = 1, colour = "smooth") 46#' 47#' # Aesthetic names are automatically standardised 48#' aes(col = x) 49#' aes(fg = x) 50#' aes(color = x) 51#' aes(colour = x) 52#' 53#' # aes() is passed to either ggplot() or specific layer. Aesthetics supplied 54#' # to ggplot() are used as defaults for every layer. 55#' ggplot(mpg, aes(displ, hwy)) + geom_point() 56#' ggplot(mpg) + geom_point(aes(displ, hwy)) 57#' 58#' # Tidy evaluation ---------------------------------------------------- 59#' # aes() automatically quotes all its arguments, so you need to use tidy 60#' # evaluation to create wrappers around ggplot2 pipelines. The 61#' # simplest case occurs when your wrapper takes dots: 62#' scatter_by <- function(data, ...) { 63#' ggplot(data) + geom_point(aes(...)) 64#' } 65#' scatter_by(mtcars, disp, drat) 66#' 67#' # If your wrapper has a more specific interface with named arguments, 68#' # you need "enquote and unquote": 69#' scatter_by <- function(data, x, y) { 70#' x <- enquo(x) 71#' y <- enquo(y) 72#' 73#' ggplot(data) + geom_point(aes(!!x, !!y)) 74#' } 75#' scatter_by(mtcars, disp, drat) 76#' 77#' # Note that users of your wrapper can use their own functions in the 78#' # quoted expressions and all will resolve as it should! 79#' cut3 <- function(x) cut_number(x, 3) 80#' scatter_by(mtcars, cut3(disp), drat) 81aes <- function(x, y, ...) { 82 exprs <- enquos(x = x, y = y, ..., .ignore_empty = "all") 83 aes <- new_aes(exprs, env = parent.frame()) 84 rename_aes(aes) 85} 86 87# Wrap symbolic objects in quosures but pull out constants out of 88# quosures for backward-compatibility 89new_aesthetic <- function(x, env = globalenv()) { 90 if (is_quosure(x)) { 91 if (!quo_is_symbolic(x)) { 92 x <- quo_get_expr(x) 93 } 94 return(x) 95 } 96 97 if (is_symbolic(x)) { 98 x <- new_quosure(x, env = env) 99 return(x) 100 } 101 102 x 103} 104new_aes <- function(x, env = globalenv()) { 105 if (!is.list(x)) { 106 abort("`x` must be a list") 107 } 108 x <- lapply(x, new_aesthetic, env = env) 109 structure(x, class = "uneval") 110} 111 112#' @export 113print.uneval <- function(x, ...) { 114 cat("Aesthetic mapping: \n") 115 116 if (length(x) == 0) { 117 cat("<empty>\n") 118 } else { 119 values <- vapply(x, quo_label, character(1)) 120 bullets <- paste0("* ", format(paste0("`", names(x), "`")), " -> ", values, "\n") 121 122 cat(bullets, sep = "") 123 } 124 125 invisible(x) 126} 127 128#' @export 129"[.uneval" <- function(x, i, ...) { 130 new_aes(NextMethod()) 131} 132 133# If necessary coerce replacements to quosures for compatibility 134#' @export 135"[[<-.uneval" <- function(x, i, value) { 136 new_aes(NextMethod()) 137} 138#' @export 139"$<-.uneval" <- function(x, i, value) { 140 # Can't use NextMethod() because of a bug in R 3.1 141 x <- unclass(x) 142 x[[i]] <- value 143 new_aes(x) 144} 145#' @export 146"[<-.uneval" <- function(x, i, value) { 147 new_aes(NextMethod()) 148} 149 150#' Standardise aesthetic names 151#' 152#' This function standardises aesthetic names by converting `color` to `colour` 153#' (also in substrings, e.g. `point_color` to `point_colour`) and translating old style 154#' R names to ggplot names (eg. `pch` to `shape`, `cex` to `size`). 155#' @param x Character vector of aesthetics names, such as `c("colour", "size", "shape")`. 156#' @return Character vector of standardised names. 157#' @keywords internal 158#' @export 159standardise_aes_names <- function(x) { 160 # convert US to UK spelling of colour 161 x <- sub("color", "colour", x, fixed = TRUE) 162 163 # convert old-style aesthetics names to ggplot version 164 revalue(x, ggplot_global$base_to_ggplot) 165} 166 167# x is a list of aesthetic mappings, as generated by aes() 168rename_aes <- function(x) { 169 names(x) <- standardise_aes_names(names(x)) 170 duplicated_names <- names(x)[duplicated(names(x))] 171 if (length(duplicated_names) > 0L) { 172 duplicated_message <- paste0(unique(duplicated_names), collapse = ", ") 173 warn(glue("Duplicated aesthetics after name standardisation: {duplicated_message}")) 174 } 175 x 176} 177substitute_aes <- function(x) { 178 x <- lapply(x, function(aesthetic) { 179 as_quosure(standardise_aes_symbols(quo_get_expr(aesthetic)), env = environment(aesthetic)) 180 }) 181 class(x) <- "uneval" 182 x 183} 184# x is a quoted expression from inside aes() 185standardise_aes_symbols <- function(x) { 186 if (is.symbol(x)) { 187 name <- standardise_aes_names(as_string(x)) 188 return(sym(name)) 189 } 190 if (!is.call(x)) { 191 return(x) 192 } 193 194 # Don't walk through function heads 195 x[-1] <- lapply(x[-1], standardise_aes_symbols) 196 197 x 198} 199 200# Look up the scale that should be used for a given aesthetic 201aes_to_scale <- function(var) { 202 var[var %in% c("x", "xmin", "xmax", "xend", "xintercept")] <- "x" 203 var[var %in% c("y", "ymin", "ymax", "yend", "yintercept")] <- "y" 204 205 var 206} 207 208# Figure out if an aesthetic is a position aesthetic or not 209is_position_aes <- function(vars) { 210 aes_to_scale(vars) %in% c("x", "y") 211} 212 213#' Define aesthetic mappings programmatically 214#' 215#' Aesthetic mappings describe how variables in the data are mapped to visual 216#' properties (aesthetics) of geoms. [aes()] uses non-standard 217#' evaluation to capture the variable names. `aes_()` and `aes_string()` 218#' require you to explicitly quote the inputs either with `""` for 219#' `aes_string()`, or with `quote` or `~` for `aes_()`. 220#' (`aes_q()` is an alias to `aes_()`). This makes `aes_()` and 221#' `aes_string()` easy to program with. 222#' 223#' `aes_string()` and `aes_()` are particularly useful when writing 224#' functions that create plots because you can use strings or quoted 225#' names/calls to define the aesthetic mappings, rather than having to use 226#' [substitute()] to generate a call to `aes()`. 227#' 228#' I recommend using `aes_()`, because creating the equivalents of 229#' `aes(colour = "my colour")` or \code{aes(x = `X$1`)} 230#' with `aes_string()` is quite clunky. 231#' 232#' 233#' @section Life cycle: 234#' 235#' All these functions are soft-deprecated. Please use tidy evaluation 236#' idioms instead (see the quasiquotation section in 237#' [aes()] documentation). 238#' 239#' @param x,y,... List of name value pairs. Elements must be either 240#' quoted calls, strings, one-sided formulas or constants. 241#' @seealso [aes()] 242#' @export 243#' @examples 244#' # Three ways of generating the same aesthetics 245#' aes(mpg, wt, col = cyl) 246#' aes_(quote(mpg), quote(wt), col = quote(cyl)) 247#' aes_(~mpg, ~wt, col = ~cyl) 248#' aes_string("mpg", "wt", col = "cyl") 249#' 250#' # You can't easily mimic these calls with aes_string 251#' aes(`$100`, colour = "smooth") 252#' aes_(~ `$100`, colour = "smooth") 253#' # Ok, you can, but it requires a _lot_ of quotes 254#' aes_string("`$100`", colour = '"smooth"') 255#' 256#' # Convert strings to names with as.name 257#' var <- "cyl" 258#' aes(col = x) 259#' aes_(col = as.name(var)) 260aes_ <- function(x, y, ...) { 261 mapping <- list(...) 262 if (!missing(x)) mapping["x"] <- list(x) 263 if (!missing(y)) mapping["y"] <- list(y) 264 265 caller_env <- parent.frame() 266 267 as_quosure_aes <- function(x) { 268 if (is.formula(x) && length(x) == 2) { 269 as_quosure(x) 270 } else if (is.call(x) || is.name(x) || is.atomic(x)) { 271 new_aesthetic(x, caller_env) 272 } else { 273 abort("Aesthetic must be a one-sided formula, call, name, or constant.") 274 } 275 } 276 mapping <- lapply(mapping, as_quosure_aes) 277 structure(rename_aes(mapping), class = "uneval") 278} 279 280#' @rdname aes_ 281#' @export 282aes_string <- function(x, y, ...) { 283 mapping <- list(...) 284 if (!missing(x)) mapping["x"] <- list(x) 285 if (!missing(y)) mapping["y"] <- list(y) 286 287 caller_env <- parent.frame() 288 mapping <- lapply(mapping, function(x) { 289 if (is.character(x)) { 290 x <- parse_expr(x) 291 } 292 new_aesthetic(x, env = caller_env) 293 }) 294 295 structure(rename_aes(mapping), class = "uneval") 296} 297 298#' @export 299#' @rdname aes_ 300aes_q <- aes_ 301 302#' Given a character vector, create a set of identity mappings 303#' 304#' @param vars vector of variable names 305#' @keywords internal 306#' @export 307#' @examples 308#' aes_all(names(mtcars)) 309#' aes_all(c("x", "y", "col", "pch")) 310aes_all <- function(vars) { 311 names(vars) <- vars 312 vars <- rename_aes(vars) 313 314 # Quosure the symbols in the empty environment because they can only 315 # refer to the data mask 316 structure( 317 lapply(vars, function(x) new_quosure(as.name(x), emptyenv())), 318 class = "uneval" 319 ) 320} 321 322#' Automatic aesthetic mapping 323#' 324#' @param data data.frame or names of variables 325#' @param ... aesthetics that need to be explicitly mapped. 326#' @keywords internal 327#' @export 328aes_auto <- function(data = NULL, ...) { 329 warn("aes_auto() is deprecated") 330 331 # detect names of data 332 if (is.null(data)) { 333 abort("aes_auto requires data.frame or names of data.frame.") 334 } else if (is.data.frame(data)) { 335 vars <- names(data) 336 } else { 337 vars <- data 338 } 339 340 # automatically detected aes 341 vars <- intersect(ggplot_global$all_aesthetics, vars) 342 names(vars) <- vars 343 aes <- lapply(vars, function(x) parse(text = x)[[1]]) 344 345 # explicitly defined aes 346 if (length(match.call()) > 2) { 347 args <- as.list(match.call()[-1]) 348 aes <- c(aes, args[names(args) != "data"]) 349 } 350 351 structure(rename_aes(aes), class = "uneval") 352} 353 354mapped_aesthetics <- function(x) { 355 if (is.null(x)) { 356 return(NULL) 357 } 358 359 is_null <- vapply(x, is.null, logical(1)) 360 names(x)[!is_null] 361} 362 363 364#' Check a mapping for discouraged usage 365#' 366#' Checks that `$` and `[[` are not used when the target *is* the data 367#' 368#' @param mapping A mapping created with [aes()] 369#' @param data The data to be mapped from 370#' 371#' @noRd 372warn_for_aes_extract_usage <- function(mapping, data) { 373 lapply(mapping, function(quosure) { 374 warn_for_aes_extract_usage_expr(get_expr(quosure), data, get_env(quosure)) 375 }) 376} 377 378warn_for_aes_extract_usage_expr <- function(x, data, env = emptyenv()) { 379 if (is_call(x, "[[") || is_call(x, "$")) { 380 if (extract_target_is_likely_data(x, data, env)) { 381 good_usage <- alternative_aes_extract_usage(x) 382 warn(glue("Use of `{format(x)}` is discouraged. Use `{good_usage}` instead.")) 383 } 384 } else if (is.call(x)) { 385 lapply(x, warn_for_aes_extract_usage_expr, data, env) 386 } 387} 388 389alternative_aes_extract_usage <- function(x) { 390 if (is_call(x, "[[")) { 391 good_call <- call2("[[", quote(.data), x[[3]]) 392 format(good_call) 393 } else if (is_call(x, "$")) { 394 as.character(x[[3]]) 395 } else { 396 abort(glue("Don't know how to get alternative usage for `{format(x)}`")) 397 } 398} 399 400extract_target_is_likely_data <- function(x, data, env) { 401 if (!is.name(x[[2]])) { 402 return(FALSE) 403 } 404 405 tryCatch({ 406 data_eval <- eval_tidy(x[[2]], data, env) 407 identical(data_eval, data) 408 }, error = function(err) FALSE) 409} 410