Merge branch 'main' into geom_abline_clipping

Author: teunbrand

DESCRIPTION

@@ -276,7 +276,6 @@ Collate:
     'utilities-break.R'
     'utilities-grid.R'
     'utilities-help.R'
-    'utilities-matrix.R'
     'utilities-patterns.R'
     'utilities-resolution.R'
     'utilities-tidy-eval.R'

NAMESPACE

@@ -84,8 +84,6 @@ S3method(guide_train,default)
 S3method(guide_transform,default)
 S3method(heightDetails,titleGrob)
 S3method(heightDetails,zeroGrob)
-S3method(interleave,default)
-S3method(interleave,unit)
 S3method(limits,Date)
 S3method(limits,POSIXct)
 S3method(limits,POSIXlt)
@@ -126,8 +124,6 @@ S3method(scale_type,logical)
 S3method(scale_type,numeric)
 S3method(scale_type,ordered)
 S3method(scale_type,sfc)
-S3method(single_value,default)
-S3method(single_value,factor)
 S3method(summary,ggplot)
 S3method(vec_cast,character.mapped_discrete)
 S3method(vec_cast,double.mapped_discrete)
@@ -426,6 +422,7 @@ export(get_alt_text)
 export(get_element_tree)
 export(get_geom_defaults)
 export(get_guide_data)
+export(get_labs)
 export(get_last_plot)
 export(get_layer_data)
 export(get_layer_grob)
@@ -463,9 +460,20 @@ export(guide_transform)
 export(guides)
 export(has_flipped_aes)
 export(is.Coord)
+export(is.coord)
+export(is.element)
 export(is.facet)
+export(is.geom)
 export(is.ggplot)
 export(is.ggproto)
+export(is.guide)
+export(is.guides)
+export(is.layer)
+export(is.mapping)
+export(is.margin)
+export(is.position)
+export(is.scale)
+export(is.stat)
 export(is.theme)
 export(label_both)
 export(label_bquote)

NEWS.md

@@ -1,5 +1,9 @@
 # ggplot2 (development version)
 
+* Fixed bug where the `ggplot2::`-prefix did not work with `stage()` 
+  (@teunbrand, #6104).
+* New `get_labs()` function for retrieving completed plot labels 
+  (@teunbrand, #6008).
 * Built-in `theme_*()` functions now have `ink` and `paper` arguments to control
   foreground and background colours respectively (@teunbrand)
 * The `summary()` method for ggplots is now more terse about facets 

R/aes-evaluation.R

@@ -32,7 +32,7 @@
 #' Below follows an overview of the three stages of evaluation and how aesthetic
 #' evaluation can be controlled.
 #'
-#' ## Stage 1: direct input
+#' ## Stage 1: direct input at the start
 #' The default is to map at the beginning, using the layer data provided by
 #' the user. If you want to map directly from the layer data you should not do
 #' anything special. This is the only stage where the original layer data can
@@ -87,17 +87,19 @@
 #' ```
 #'
 #' ## Complex staging
-#' 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.
+#' Sometimes, you may want to map the same aesthetic multiple times, e.g. map
+#' `x` to a data column at the start for the layer stat, but remap it later to
+#' a variable from the stat transformation for the layer geom. The `stage()`
+#' function allows you to control multiple mappings for the same aesthetic
+#' across all three stages of evaluation.
 #'
 #' ```r
 #' # Use stage to modify the scaled fill
 #' ggplot(mpg, aes(class, hwy)) +
 #'   geom_boxplot(aes(fill = stage(class, after_scale = alpha(fill, 0.4))))
 #'
 #' # Using data for computing summary, but placing label elsewhere.
-#' # Also, we're making our own computed variable to use for the label.
+#' # Also, we're making our own computed variables to use for the label.
 #' ggplot(mpg, aes(class, displ)) +
 #'   geom_violin() +
 #'   stat_summary(
@@ -110,6 +112,11 @@
 #'   )
 #' ```
 #'
+#' Conceptually, `aes(x)` is equivalent to `aes(stage(start = x))`, and
+#' `aes(after_stat(count))` is equivalent to `aes(stage(after_stat = count))`,
+#' and so on. `stage()` is most useful when at least two of its arguments are
+#' specified.
+#'
 #' ## Theme access
 #' The `from_theme()` function can be used to acces the [`element_geom()`]
 #' fields of the `theme(geom)` argument. Using `aes(colour = from_theme(ink))`
@@ -219,12 +226,10 @@ stage_scaled <- function(start = NULL, after_stat = NULL, after_scale = NULL) {
 }
 
 # Regex to determine if an identifier refers to a calculated aesthetic
+# The pattern includes ye olde '...var...' syntax, which was
+# deprecated in 3.4.0 in favour of `after_stat()`
 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, warn = FALSE) {
   vapply(aesthetics, is_calculated, warn = warn, logical(1), USE.NAMES = FALSE)
@@ -246,7 +251,8 @@ is_calculated <- function(x, warn = FALSE) {
   if (is.null(x) || is.atomic(x)) {
     FALSE
   } else if (is.symbol(x)) {
-    res <- is_dotted_var(as.character(x))
+    # Test if x is a dotted variable
+    res <- grepl(match_calculated_aes, as.character(x))
     if (res && warn) {
       what <- I(paste0("The dot-dot notation (`", x, "`)"))
       var <- gsub(match_calculated_aes, "\\1", as.character(x))
@@ -333,7 +339,7 @@ strip_stage <- function(expr) {
   } else if (is_call(uq_expr, "stage")) {
     uq_expr <- call_match(uq_expr, stage)
     # Prefer stat mapping if present, otherwise original mapping (fallback to
-    # scale mapping) but there should always be two arguments to stage()
+    # scale mapping)
     uq_expr$after_stat %||% uq_expr$start %||% uq_expr$after_scale
   } else {
     expr
@@ -359,3 +365,39 @@ make_labels <- function(mapping) {
   }
   Map(default_label, names(mapping), mapping)
 }
+
+eval_aesthetics <- function(aesthetics, data, mask = NULL) {
+
+  env <- child_env(base_env())
+
+  # Here we mask functions, often to replace `stage()` with context appropriate
+  # functions `stage_calculated()`/`stage_scaled()`.
+  if (length(mask) > 0) {
+    aesthetics <- substitute_aes(aesthetics, mask_function, mask = mask)
+  }
+
+  evaled <- lapply(aesthetics, eval_tidy, data = data, env = env)
+  names(evaled) <- names(aesthetics)
+  compact(rename_aes(evaled))
+}
+
+# `mask` is a list of functions where `names(mask)` indicate names of functions
+# that need to be replaced, and `mask[[i]]` is the function to replace it
+# with.
+mask_function <- function(x, mask) {
+  if (!is.call(x)) {
+    return(x)
+  }
+  nms <- names(mask)
+  x[-1] <- lapply(x[-1], mask_function, mask = mask)
+  if (!is_call(x, nms)) {
+    return(x)
+  }
+  for (nm in nms) {
+    if (is_call(x, nm)) {
+      x[[1]] <- mask[[nm]]
+      return(x)
+    }
+  }
+}
+

R/aes.R

@@ -102,6 +102,10 @@ aes <- function(x, y, ...) {
   rename_aes(aes)
 }
 
+#' @export
+#' @rdname is_tests
+is.mapping <- function(x) inherits(x, "uneval")
+
 # Wrap symbolic objects in quosures but pull out constants out of
 # quosures for backward-compatibility
 new_aesthetic <- function(x, env = globalenv()) {
@@ -177,7 +181,12 @@ standardise_aes_names <- function(x) {
   x <- sub("color", "colour", x, fixed = TRUE)
 
   # convert old-style aesthetics names to ggplot version
-  revalue(x, ggplot_global$base_to_ggplot)
+  convert <- ggplot_global$base_to_ggplot
+  convert <- convert[names(convert) %in% x]
+  if (length(convert) > 0) {
+    x[match(names(convert), x)] <- convert
+  }
+  x
 }
 
 # x is a list of aesthetic mappings, as generated by aes()
@@ -189,9 +198,12 @@ rename_aes <- function(x) {
   }
   x
 }
-substitute_aes <- function(x) {
+
+# `x` is assumed to be a strict list of quosures;
+# it should have no non-quosure constants in it, even though `aes()` allows it.
+substitute_aes <- function(x, fun = standardise_aes_symbols, ...) {
   x <- lapply(x, function(aesthetic) {
-    as_quosure(standardise_aes_symbols(quo_get_expr(aesthetic)), env = environment(aesthetic))
+    as_quosure(fun(quo_get_expr(aesthetic), ...), env = environment(aesthetic))
   })
   class(x) <- "uneval"
   x
@@ -448,7 +460,9 @@ arg_enquos <- function(name, frame = caller_env()) {
   quo <- inject(enquo0(!!sym(name)), frame)
   expr <- quo_get_expr(quo)
 
-  if (!is_missing(expr) && is_triple_bang(expr)) {
+  is_triple_bang <- !is_missing(expr) &&
+    is_bang(expr) && is_bang(expr[[2]]) && is_bang(expr[[c(2, 2)]])
+  if (is_triple_bang) {
     # Evaluate `!!!` operand and create a list of quosures
     env <- quo_get_env(quo)
     xs <- eval_bare(expr[[2]][[2]][[2]], env)

R/compat-plyr.R

@@ -166,84 +166,7 @@ join_keys <- function(x, y, by) {
   list(x = keys[seq_len(n_x)], y = keys[n_x + seq_len(n_y)],
        n = attr(keys, "n"))
 }
-#' Replace specified values with new values, in a factor or character vector
-#'
-#' An easy to use substitution of elements in a string-like vector (character or
-#' factor). If `x` is a character vector the matching elements will be replaced
-#' directly and if `x` is a factor the matching levels will be replaced
-#'
-#' @param x A character or factor vector
-#' @param replace A named character vector with the names corresponding to the
-#' elements to replace and the values giving the replacement.
-#'
-#' @return A vector of the same class as `x` with the given values replaced
-#'
-#' @keywords internal
-#' @noRd
-#'
-revalue <- function(x, replace) {
-  if (is.character(x)) {
-    replace <- replace[names(replace) %in% x]
-    if (length(replace) == 0) return(x)
-    x[match(names(replace), x)] <- replace
-  } else if (is.factor(x)) {
-    lev <- levels(x)
-    replace <- replace[names(replace) %in% lev]
-    if (length(replace) == 0) return(x)
-    lev[match(names(replace), lev)] <- replace
-    levels(x) <- lev
-  } else if (!is.null(x)) {
-    stop_input_type(x, "a factor or character vector")
-  }
-  x
-}
-# Iterate through a formula and return a quoted version
-simplify_formula <- function(x) {
-  if (length(x) == 2 && x[[1]] == as.name("~")) {
-    return(simplify(x[[2]]))
-  }
-  if (length(x) < 3)
-    return(list(x))
-  op <- x[[1]]
-  a <- x[[2]]
-  b <- x[[3]]
-  if (op == as.name("+") || op == as.name("*") || op ==
-      as.name("~")) {
-    c(simplify(a), simplify(b))
-  }
-  else if (op == as.name("-")) {
-    c(simplify(a), bquote(-.(x), list(x = simplify(b))))
-  }
-  else {
-    list(x)
-  }
-}
-#' Create a quoted version of x
-#'
-#' This function captures the special meaning of formulas in the context of
-#' facets in ggplot2, where `+` have special meaning. It works as
-#' `plyr::as.quoted` but only for the special cases of `character`, `call`, and
-#' `formula` input as these are the only situations relevant for ggplot2.
-#'
-#' @param x A formula, string, or call to be quoted
-#' @param env The environment to a attach to the quoted expression.
-#'
-#' @keywords internal
-#' @noRd
-#'
-as.quoted <- function(x, env = parent.frame()) {
-  x <- if (is.character(x)) {
-    lapply(x, function(x) parse(text = x)[[1]])
-  } else if (is.formula(x)) {
-    simplify_formula(x)
-  } else if (is.call(x)) {
-    as.list(x)[-1]
-  } else {
-    cli::cli_abort("Must be a character vector, call, or formula.")
-  }
-  attributes(x) <- list(env = env, class = 'quoted')
-  x
-}
+
 # round a number to a given precision
 round_any <- function(x, accuracy, f = round) {
   check_numeric(x)
@@ -286,29 +209,20 @@ dapply <- function(df, by, fun, ..., drop = TRUE) {
   }
 
   # Shortcut when only one group
-  if (all(vapply(grouping_cols, single_value, logical(1)))) {
+  has_single_group <- all(vapply(
+    grouping_cols,
+    function(x) identical(as.character(levels(x) %||% attr(x, "n")), "1"),
+    logical(1)
+  ))
+  if (has_single_group) {
     return(apply_fun(df))
   }
 
   ids <- id(grouping_cols, drop = drop)
   group_rows <- split_with_index(seq_len(nrow(df)), ids)
   result <- lapply(seq_along(group_rows), function(i) {
-    cur_data <- df_rows(df, group_rows[[i]])
+    cur_data <- vec_slice(df, group_rows[[i]])
     apply_fun(cur_data)
   })
   vec_rbind0(!!!result)
 }
-
-single_value <- function(x, ...) {
-  UseMethod("single_value")
-}
-#' @export
-single_value.default <- function(x, ...) {
-  # This is set by id() used in creating the grouping var
-  identical(attr(x, "n"), 1L)
-}
-#' @export
-single_value.factor <- function(x, ...) {
-  # Panels are encoded as factor numbers and can never be missing (NA)
-  identical(levels(x), "1")
-}

R/coord-.R

@@ -226,11 +226,18 @@ Coord <- ggproto("Coord",
   }
 )
 
-#' Is this object a coordinate system?
-#'
-#' @export is.Coord
-#' @keywords internal
-is.Coord <- function(x) inherits(x, "Coord")
+
+#' @export
+#' @rdname is_tests
+is.coord <- function(x) inherits(x, "Coord")
+
+#' @export
+#' @rdname is_tests
+#' @usage is.Coord(x) # Deprecated
+is.Coord <- function(x) {
+  deprecate_soft0("3.5.2", "is.Coord()", "is.coord()")
+  is.coord(x)
+}
 
 # Renders an axis with the correct orientation or zeroGrob if no axis should be
 # generated
@@ -246,6 +253,9 @@ render_axis <- function(panel_params, axis, scale, position, theme) {
 
 # Elaborates an 'expand' argument for every side (top, right, bottom or left)
 parse_coord_expand <- function(expand) {
+  if (is.numeric(expand) && all(expand %in% c(0, 1))) {
+    expand <- as.logical(expand)
+  }
   check_logical(expand)
   if (anyNA(expand)) {
     cli::cli_abort("{.arg expand} cannot contain missing values.")