Improve consistency of naming internal functions (#6072)

* rename `validate_facets()` to `check_facets()`

* write prevalidation/postvalidation as checks

* more responsibility for `check_nondata_cols()`

* `check_subclass()` is actually validator

* path checker is validator

* plot_dev is a validator

* `check_breaks_labels()` has no return value

* make `check_scale_type()` consistent

* `validate_theme/element()` is a check

* update labeller deprecation message

* `check_labeller()` performs an update

* `check_linewidth()` performs an update

* `check_polar_guide()` is validator

* `update_labeller()` -> `fix_labeller()`

* `update_linewidth()` -> `fix_linewidth()`

* `check_facet_class()` --> `check_vars()`

Author: teunbrand

R/coord-radial.R

@@ -191,7 +191,7 @@ CoordRadial <- ggproto("CoordRadial", Coord,
     # Validate appropriateness of guides
     drop_guides <- character(0)
     for (type in aesthetics) {
-      drop_guides <- check_polar_guide(drop_guides, guides, type)
+      drop_guides <- validate_polar_guide(drop_guides, guides, type)
     }
 
     guide_params <- guides$get_params(aesthetics)
@@ -603,7 +603,7 @@ theta_grid <- function(theta, element, inner_radius = c(0, 0.4),
   )
 }
 
-check_polar_guide <- function(drop_list, guides, type = "theta") {
+validate_polar_guide <- function(drop_list, guides, type = "theta") {
   guide <- guides$get_guide(type)
   primary <- gsub("\\.sec$", "", type)
   if (inherits(guide, "GuideNone") || primary %in% guide$available_aes) {

R/facet-.R

@@ -443,7 +443,7 @@ df.grid <- function(a, b) {
 # facetting variables.
 
 as_facets_list <- function(x) {
-  x <- validate_facets(x)
+  check_vars(x)
   if (is_quosures(x)) {
     x <- quos_auto_name(x)
     return(list(x))
@@ -487,7 +487,7 @@ as_facets_list <- function(x) {
   x
 }
 
-validate_facets <- function(x) {
+check_vars <- function(x) {
   if (is.mapping(x)) {
     cli::cli_abort("Please use {.fn vars} to supply facet variables.")
   }
@@ -499,7 +499,7 @@ validate_facets <- function(x) {
       "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?"
     ))
   }
-  x
+  invisible()
 }
 
 # Flatten a list of quosures objects to a quosures object, and compact it

R/facet-grid-.R

@@ -177,7 +177,7 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed",
   facets_list <- grid_as_facets_list(rows, cols)
 
   # Check for deprecated labellers
-  labeller <- check_labeller(labeller)
+  labeller <- fix_labeller(labeller)
 
   ggproto(NULL, FacetGrid,
     shrink = shrink,

R/facet-wrap.R

@@ -174,7 +174,7 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed",
   )
 
   # Check for deprecated labellers
-  labeller <- check_labeller(labeller)
+  labeller <- fix_labeller(labeller)
 
   # Flatten all facets dimensions into a single one
   facets <- compact_facets(facets)

R/fortify.R

@@ -44,34 +44,46 @@ fortify.grouped_df <- function(model, data, ...) {
 # There are a lot of ways that dim(), colnames(), or as.data.frame() could
 # do non-sensical things (they are not even guaranteed to work!) hence the
 # paranoid mode.
-.prevalidate_data_frame_like_object <- function(data) {
+check_data_frame_like <- function(data) {
   orig_dims <- dim(data)
-  if (!vec_is(orig_dims, integer(), size=2))
-    cli::cli_abort(paste0("{.code dim(data)} must return ",
-                          "an {.cls integer} of length 2."))
-  if (anyNA(orig_dims) || any(orig_dims < 0))  # extra-paranoid mode
-    cli::cli_abort(paste0("{.code dim(data)} can't have {.code NA}s ",
-                          "or negative values."))
+  if (!vec_is(orig_dims, integer(), size = 2)) {
+    cli::cli_abort(
+      "{.code dim(data)} must return an {.cls integer} of length 2."
+    )
+  }
+  if (anyNA(orig_dims) || any(orig_dims < 0)) { # extra-paranoid mode
+    cli::cli_abort(
+      "{.code dim(data)} can't have {.code NA}s or negative values."
+    )
+  }
   orig_colnames <- colnames(data)
-  if (!vec_is(orig_colnames, character(), size = ncol(data)))
-    cli::cli_abort(paste0("{.code colnames(data)} must return a ",
-                          "{.cls character} of length {.code ncol(data)}."))
+  if (!vec_is(orig_colnames, character(), size = ncol(data))) {
+    cli::cli_abort(
+      "{.code colnames(data)} must return a {.cls character} of length {.code ncol(data)}."
+    )
+  }
+  invisible()
 }
-.postvalidate_data_frame_like_object <- function(df, data) {
+check_data_frame_conversion <- function(new, old) {
   msg0 <- "{.code as.data.frame(data)} must "
-  if (!is.data.frame(df))
+  if (!is.data.frame(new)) {
     cli::cli_abort(paste0(msg0, "return a {.cls data.frame}."))
-  if (!identical(dim(df), dim(data)))
+  }
+  if (!identical(dim(new), dim(old))) {
     cli::cli_abort(paste0(msg0, "preserve dimensions."))
-  if (!identical(colnames(df), colnames(data)))
+  }
+  if (!identical(colnames(new), colnames(old))) {
     cli::cli_abort(paste0(msg0, "preserve column names."))
+  }
+  invisible()
 }
 validate_as_data_frame <- function(data) {
-  if (is.data.frame(data))
+  if (is.data.frame(data)) {
     return(data)
-  .prevalidate_data_frame_like_object(data)
+  }
+  check_data_frame_like(data)
   df <- as.data.frame(data)
-  .postvalidate_data_frame_like_object(df, data)
+  check_data_frame_conversion(df, data)
   df
 }
 

R/geom-.R

@@ -170,17 +170,11 @@ Geom <- ggproto("Geom",
       )
 
       # Check that all output are valid data
-      nondata_modified <- check_nondata_cols(modified_aes)
-      if (length(nondata_modified) > 0) {
-        issues <- paste0("{.code ", nondata_modified, " = ", as_label(modifiers[[nondata_modified]]), "}")
-        names(issues) <- rep("x", length(issues))
-        cli::cli_abort(c(
-          "Aesthetic modifiers returned invalid values",
-          "x" = "The following mappings are invalid",
-          issues,
-          "i" = "Did you map the modifier in the wrong layer?"
-        ))
-      }
+      check_nondata_cols(
+        modified_aes, modifiers,
+        problem = "Aesthetic modifiers returned invalid values.",
+        hint    = "Did you map the modifier in the wrong layer?"
+      )
 
       modified_aes <- cleanup_mismatched_data(modified_aes, nrow(data), "after_scale")
 
@@ -283,7 +277,7 @@ check_aesthetics <- function(x, n) {
   ))
 }
 
-check_linewidth <- function(data, name) {
+fix_linewidth <- function(data, name) {
   if (is.null(data$linewidth) && !is.null(data$size)) {
     deprecate_soft0("3.4.0", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic"))
     data$linewidth <- data$size

R/geom-boxplot.R

@@ -286,7 +286,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
                         whisker_gp = NULL, staple_gp = NULL, median_gp = NULL,
                         box_gp = NULL, notch = FALSE, notchwidth = 0.5,
                         staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
     # this may occur when using geom_boxplot(stat = "identity")
     if (nrow(data) != 1) {

R/geom-crossbar.R

@@ -84,8 +84,7 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom,
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "mitre", fatten = 2.5, width = NULL,
                         flipped_aes = FALSE, middle_gp = NULL, box_gp = NULL) {
-
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
 
     middle <- transform(data, x = xmin, xend = xmax, yend = y, linewidth = linewidth * fatten, alpha = NA)

R/geom-defaults.R

@@ -106,7 +106,7 @@ get_geom_defaults <- function(geom, theme = theme_get()) {
     return(data)
   }
   if (is.character(geom)) {
-    geom <- check_subclass(geom, "Geom")
+    geom <- validate_subclass(geom, "Geom")
   }
   if (is.geom(geom)) {
     out <- geom$use_defaults(data = NULL, theme = theme)
@@ -126,7 +126,7 @@ reset_stat_defaults <- function() reset_defaults("stat")
 cache_defaults <- new_environment()
 
 update_defaults <- function(name, subclass, new, env = parent.frame()) {
-  obj   <- check_subclass(name, subclass, env = env)
+  obj   <- validate_subclass(name, subclass, env = env)
   index <- snake_class(obj)
 
   if (is.null(new)) { # Reset from cache

R/geom-errorbar.R

@@ -93,7 +93,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom,
   # Note: `width` is vestigial
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         width = NULL, flipped_aes = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
     x <- vec_interleave(data$xmin, data$xmax, NA, data$x,    data$x,    NA, data$xmin, data$xmax)
     y <- vec_interleave(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin)

R/geom-hex.R

@@ -58,7 +58,7 @@ geom_hex <- function(mapping = NULL, data = NULL,
 GeomHex <- ggproto("GeomHex", Geom,
   draw_group = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "mitre", linemitre = 10) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     if (empty(data)) {
       return(zeroGrob())
     }

R/geom-path.R

@@ -165,7 +165,7 @@ GeomPath <- ggproto("GeomPath", Geom,
   draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL,
                         lineend = "butt", linejoin = "round", linemitre = 10,
                         na.rm = FALSE) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     if (!anyDuplicated(data$group)) {
       cli::cli_inform(c(
         "{.fn {snake_class(self)}}: Each group consists of only one observation.",

R/geom-polygon.R

@@ -109,7 +109,7 @@ geom_polygon <- function(mapping = NULL, data = NULL,
 GeomPolygon <- ggproto("GeomPolygon", Geom,
   draw_panel = function(self, data, panel_params, coord, rule = "evenodd",
                         lineend = "butt", linejoin = "round", linemitre = 10) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     n <- nrow(data)
     if (n == 1) return(zeroGrob())
 

R/geom-rect.R

@@ -69,7 +69,7 @@ GeomRect <- ggproto("GeomRect", Geom,
   },
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     if (!coord$is_linear()) {
       aesthetics <- setdiff(
         names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax")

R/geom-ribbon.R

@@ -157,7 +157,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom,
   draw_group = function(self, data, panel_params, coord, lineend = "butt",
                         linejoin = "round", linemitre = 10, na.rm = FALSE,
                         flipped_aes = FALSE, outline.type = "both") {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     data <- flip_data(data, flipped_aes)
     data <- data[order(data$group), ]
 

R/geom-rug.R

@@ -90,7 +90,7 @@ GeomRug <- ggproto("GeomRug", Geom,
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt",
                         sides = "bl", outside = FALSE, length = unit(0.03, "npc")) {
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     check_inherits(length, "unit")
     rugs <- list()
     data <- coord$transform(data, panel_params)

R/geom-segment.R

@@ -116,7 +116,7 @@ GeomSegment <- ggproto("GeomSegment", Geom,
                         lineend = "butt", linejoin = "round", na.rm = FALSE) {
     data$xend <- data$xend %||% data$x
     data$yend <- data$yend %||% data$y
-    data <- check_linewidth(data, snake_class(self))
+    data <- fix_linewidth(data, snake_class(self))
     data <- remove_missing(data, na.rm = na.rm,
       c("x", "y", "xend", "yend", "linetype", "linewidth"),
       name = "geom_segment"

R/guide-.R

@@ -19,7 +19,7 @@ NULL
 new_guide <- function(..., available_aes = "any", super) {
 
   pf <- parent.frame()
-  super <- check_subclass(super, "Guide", env = pf)
+  super <- validate_subclass(super, "Guide", env = pf)
 
   args <- list2(...)
 
@@ -51,7 +51,7 @@ new_guide <- function(..., available_aes = "any", super) {
   # Validate theme settings
   if (!is.null(params$theme)) {
     check_object(params$theme, is.theme, what = "a {.cls theme} object")
-    validate_theme(params$theme, call = caller_env())
+    check_theme(params$theme, call = caller_env())
     params$direction <- params$direction %||% params$theme$legend.direction
   }
 

R/labeller.R

@@ -577,21 +577,21 @@ assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) {
   })
 }
 
-# Check for old school labeller
-check_labeller <- function(labeller) {
+# Repair old school labeller
+fix_labeller <- function(labeller) {
   labeller <- match.fun(labeller)
   is_deprecated <- all(c("variable", "value") %in% names(formals(labeller)))
 
   if (is_deprecated) {
+    deprecate_warn0(
+      "2.0.0", what = "facet_(labeller)",
+      details =
+      "Modern labellers do not take `variable` and `value` arguments anymore."
+    )
     old_labeller <- labeller
     labeller <- function(labels) {
       Map(old_labeller, names(labels), labels)
     }
-    # TODO Update to lifecycle after next lifecycle release
-    cli::cli_warn(c(
-      "The {.arg labeller} API has been updated. Labellers taking {.arg variable} and {.arg value} arguments are now deprecated.",
-      "i" = "See labellers documentation."
-    ))
   }
 
   labeller