Clean up orphan functions and tiny one-off helpers (#6022)

* replace single use internal functions

* move helper to location where it is used

* remove orphan functions

* replace and remove redundant `adjust_breaks()` function

* replace `df_rows()` with `vec_slice()`

* inline `f_as_facets_list()`

* inline `find_origin()`

* inline `firstUpper()`

* replace `has_name()`

* replace `interleave()` with `vec_interleave()`

* remove `cunion()`

* inline `is_dotted_var()`

* inline `is_facets()`

* inline `is_labeller()`

* inline `is_missing_arg()`

* replace `is_npc()` (we partially backport `unitType()`)

* inline `is_scalar_numeric()`

* inline `is.margin()`

* inline `is.sec_axis()`

* inline `is.subclass()`

* inline `is_triple_bang()`

* remove `justify_grobs()`

* inline `label_variable()`

* more responsibility for `parse_axes_labeling()`, so that it is less distracting

* remove `resolve_guide()`

* inline revalue

* simplify `scale_flip_position()`

* remove `as.quoted()` (note there is still `as_quoted()`)

* replace `simplify_formula()` with `simplify()`

* inline `single_value()`

* inline `update_guides()`

* inline `is_column_vec()` and better name for `validate_column_vec()`

* remove/replace `wrap_as_facets_list()` (by `compact_facets()`

* finishing touches

* `parse_axes_labeling` uses parent call

* elaborate on regex pattern

* Revert "inline `is_labeller()`"

This reverts commit 9976913.

* Revert "inline `is.sec_axis()`"

This reverts commit 1bdc20d.

* Revert "replace single use internal functions"

This reverts commit 20fa50f.

* Collection of test functions for user-facing components

* apply tests when applicable

* redocument

* abolish `uniquecols()`'s rownames

* move `is.*()` functions to class definitions

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)
@@ -464,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)

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 @@ 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

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: