Clean up orphan functions and tiny one-off helpers

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)
@@ -463,9 +459,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)

R/aes-evaluation.R

@@ -219,12 +219,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 +244,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))

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()
@@ -448,7 +457,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 @@
  }
 )
 
-#' 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

R/coord-cartesian-.R

@@ -163,7 +163,7 @@ view_scales_from_scale <- function(scale, coord_limits = NULL, expand = TRUE) {
 }
 
 panel_guides_grob <- function(guides, position, theme, labels = NULL) {
- if (!inherits(guides, "Guides")) {
+ if (!is.guides(guides)) {
  return(zeroGrob())
  }
  pair <- guides$get_position(position)

R/coord-map.R

@@ -157,7 +157,7 @@ CoordMap <- ggproto("CoordMap", Coord,
 
  transform = function(self, data, panel_params) {
  trans <- mproject(self, data$x, data$y, panel_params$orientation)
- out <- cunion(trans[c("x", "y")], data)
+ out <- data_frame0(!!!defaults(trans[c("x", "y")], data))
 
  out$x <- rescale(out$x, 0:1, panel_params$x.proj)
  out$y <- rescale(out$y, 0:1, panel_params$y.proj)

R/coord-sf.R

@@ -545,11 +545,7 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE,
  label_axes <- label_axes %|W|% ""
  }
 
- if (is.character(label_axes)) {
- label_axes <- parse_axes_labeling(label_axes)
- } else if (!is.list(label_axes)) {
- cli::cli_abort("Panel labeling format not recognized.")
- }
+ label_axes <- parse_axes_labeling(label_axes)
 
  if (is.character(label_graticule)) {
  label_graticule <- unlist(strsplit(label_graticule, ""))
@@ -582,9 +578,14 @@ coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE,
  )
 }
 
-parse_axes_labeling <- function(x) {
- labs <- unlist(strsplit(x, ""))
- list(top = labs[1], right = labs[2], bottom = labs[3], left = labs[4])
+parse_axes_labeling <- function(x, call = caller_env()) {
+ if (is.character(x)) {
+ x <- unlist(strsplit(x, ""))
+ x <- list(top = x[1], right = x[2], bottom = x[3], left = x[4])
+ } else if (!is.list(x)) {
+ cli::cli_abort("Panel labeling format not recognized.", call = call)
+ }
+ x
 }
 
 # This function does two things differently from standard breaks: