Improve consistency of naming internal functions

R/coord-radial.R

@@ -180,7 +180,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)
@@ -648,7 +648,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

@@ -399,7 +399,7 @@ df.grid <- function(a, b) {
 # facetting variables.
 
 as_facets_list <- function(x) {
- x <- validate_facets(x)
+ check_facet_class(x)
  if (is_quosures(x)) {
  x <- quos_auto_name(x)
  return(list(x))
@@ -436,7 +436,7 @@ as_facets_list <- function(x) {
  x
 }
 
-validate_facets <- function(x) {
+check_facet_class <- function(x) {
  if (inherits(x, "uneval")) {
  cli::cli_abort("Please use {.fn vars} to supply facet variables.")
  }
@@ -448,7 +448,7 @@ validate_facets <- function(x) {
  "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?"
  ))
  }
- x
+ invisible()
 }
 
 

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 <- update_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 <- update_labeller(labeller)
 
  # Flatten all facets dimensions into a single one
  facets <- wrap_as_facets_list(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

@@ -165,17 +165,11 @@ Geom <- ggproto("Geom",
  modified_aes <- lapply(substitute_aes(modifiers), eval_tidy, mask, env)
 
  # 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?"
+ )
 
  names(modified_aes) <- names(rename_aes(modifiers))
 
@@ -277,7 +271,7 @@ check_aesthetics <- function(x, n) {
  ))
 }
 
-check_linewidth <- function(data, name) {
+update_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

@@ -227,7 +227,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom,
  outlier.size = NULL, outlier.stroke = 0.5,
  outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5,
  staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) {
- data <- check_linewidth(data, snake_class(self))
+ data <- update_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

@@ -55,7 +55,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) {
- data <- check_linewidth(data, snake_class(self))
+ data <- update_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

@@ -96,7 +96,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 (inherits(geom, "Geom")) {
  out <- geom$use_defaults(data = NULL, theme = theme)
@@ -116,7 +116,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

@@ -60,7 +60,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom,
 
  draw_panel = function(self, data, panel_params, coord, lineend = "butt",
  width = NULL, flipped_aes = FALSE) {
- data <- check_linewidth(data, snake_class(self))
+ data <- update_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-errorbarh.R

@@ -74,7 +74,7 @@ GeomErrorbarh <- ggproto("GeomErrorbarh", Geom,
  },
 
  draw_panel = function(self, data, panel_params, coord, height = NULL, lineend = "butt") {
- data <- check_linewidth(data, snake_class(self))
+ data <- update_linewidth(data, snake_class(self))
  GeomPath$draw_panel(data_frame0(
  x = vec_interleave(data$xmax, data$xmax, NA, data$xmax, data$xmin, NA, data$xmin, data$xmin),
  y = vec_interleave(data$ymin, data$ymax, NA, data$y, data$y, NA, data$ymin, data$ymax),

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 <- update_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 <- update_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 <- update_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 <- update_linewidth(data, snake_class(self))
  if (!coord$is_linear()) {
  aesthetics <- setdiff(
  names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax")

R/geom-ribbon.R

@@ -133,7 +133,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 <- update_linewidth(data, snake_class(self))
  data <- flip_data(data, flipped_aes)
  if (na.rm) data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ]
  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 <- update_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 <- update_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

@@ -590,20 +590,20 @@ assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) {
 }
 
 # Check for old school labeller
-check_labeller <- function(labeller) {
+update_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