Code sanitising: type checks (#5209)

* Add is_scalar_numeric

* Use type checks

* Import rlang types check

* Increment required rlang version

* Add utility for passing cli messages

* write additional checks

* Update checks

* Accept new snapshots

* ignore abort calls in standalone files

* retire `obj_desc()` in favour of `obj_type_friendly()`

* reimport standalone files

* Use `check_data_frame()`

* clean old checks

* Accept new messages

* Add NEWS bullet

* Cover remaining checks with snapshot tests

Author: teunbrand

DESCRIPTION

@@ -39,7 +39,7 @@ Imports:
     lifecycle (> 1.0.1),
     MASS,
     mgcv,
-    rlang (>= 1.0.0),
+    rlang (>= 1.1.0),
     scales (>= 1.2.0),
     stats,
     tibble,
@@ -93,6 +93,7 @@ Collate:
     'compat-plyr.R'
     'utilities.R'
     'aes.R'
+    'utilities-checks.R'
     'legend-draw.R'
     'geom-.R'
     'annotation-custom.R'
@@ -183,6 +184,8 @@ Collate:
     'guides-grid.R'
     'guides-none.R'
     'hexbin.R'
+    'import-standalone-obj-type.R'
+    'import-standalone-types-check.R'
     'labeller.R'
     'labels.R'
     'layer.R'

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* Various type checks and their messages have been standardised 
+  (@teunbrand, #4834).
 * The `layer_data()`, `layer_scales()` and `layer_grob()` now have the default
   `plot = last_plot()` (@teunbrand, #5166).
 * To prevent changing the plotting order, `stat_sf()` is now computed per panel 

R/aes.R

@@ -115,9 +115,7 @@ new_aesthetic <- function(x, env = globalenv()) {
   x
 }
 new_aes <- function(x, env = globalenv()) {
-  if (!is.list(x)) {
-    cli::cli_abort("{.arg x} must be a list")
-  }
+  check_object(x, is.list, "a {.cls list}")
   x <- lapply(x, new_aesthetic, env = env)
   structure(x, class = "uneval")
 }

R/annotation-map.R

@@ -58,9 +58,7 @@ NULL
 #' }}}
 annotation_map <- function(map, ...) {
   # Get map input into correct form
-  if (!is.data.frame(map)) {
-    cli::cli_abort("{.arg map} must be a {.cls data.frame}")
-  }
+  check_data_frame(map)
   if (!is.null(map$lat)) map$y <- map$lat
   if (!is.null(map$long)) map$x <- map$long
   if (!is.null(map$region)) map$id <- map$region

R/annotation.R

@@ -42,7 +42,7 @@ annotate <- function(geom, x = NULL, y = NULL, xmin = NULL, xmax = NULL,
                      ymin = NULL, ymax = NULL, xend = NULL, yend = NULL, ...,
                      na.rm = FALSE) {
 
-  if (is.character(geom) && geom %in% c("abline", "hline", "vline")) {
+  if (is_string(geom, c("abline", "hline", "vline"))) {
     cli::cli_warn(c(
       "{.arg geom} must not be {.val {geom}}.",
       "i" = "Please use {.fn {paste0('geom_', geom)}} directly instead."

R/bench.R

@@ -15,9 +15,7 @@
 benchplot <- function(x) {
   x <- enquo(x)
   construct <- system.time(x <- eval_tidy(x))
-  if (!inherits(x, "ggplot")) {
-    cli::cli_abort("{.arg x} must be a {.cls ggplot} object")
-  }
+  check_inherits(x, "ggplot")
 
   build <- system.time(data <- ggplot_build(x))
   render <- system.time(grob <- ggplot_gtable(data))

R/bin.R

@@ -1,8 +1,6 @@
 bins <- function(breaks, closed = "right",
                  fuzz = 1e-08 * stats::median(diff(breaks))) {
-  if (!is.numeric(breaks)) {
-    cli::cli_abort("{.arg breaks} must be a numeric vector")
-  }
+  check_numeric(breaks)
   closed <- arg_match0(closed, c("right", "left"))
 
   breaks <- sort(breaks)
@@ -56,12 +54,7 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
     cli::cli_abort("{.arg x_range} must have two elements")
   }
 
-  # if (length(x_range) == 0) {
-  #   return(bin_params(numeric()))
-  # }
-  if (!(is.numeric(width) && length(width) == 1)) {
-    cli::cli_abort("{.arg width} must be a number")
-  }
+  check_number_decimal(width)
   if (width <= 0) {
     cli::cli_abort("{.arg binwidth} must be positive")
   }
@@ -115,10 +108,8 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
     cli::cli_abort("{.arg x_range} must have two elements")
   }
 
-  bins <- as.integer(bins)
-  if (bins < 1) {
-    cli::cli_abort("{.arg bins} must be 1 or greater")
-  } else if (zero_range(x_range)) {
+  check_number_whole(bins, min = 1)
+  if (zero_range(x_range)) {
     # 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data
     width <- 0.1
   } else if (bins == 1) {
@@ -136,9 +127,7 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
 # Compute bins ------------------------------------------------------------
 
 bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
-  if (!is_bins(bins)) {
-    cli::cli_abort("{.arg bins} must be a {.cls ggplot2_bins} object")
-  }
+  check_object(bins, is_bins, "a {.cls ggplot2_bins} object")
 
   if (all(is.na(x))) {
     return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA))

R/compat-plyr.R

@@ -193,7 +193,7 @@ revalue <- function(x, replace) {
     lev[match(names(replace), lev)] <- replace
     levels(x) <- lev
   } else if (!is.null(x)) {
-    cli::cli_abort("{.arg x} must be a factor or character vector")
+    stop_input_type(x, "a factor or character vector")
   }
   x
 }
@@ -246,9 +246,7 @@ as.quoted <- function(x, env = parent.frame()) {
 }
 # round a number to a given precision
 round_any <- function(x, accuracy, f = round) {
-  if (!is.numeric(x)) {
-    cli::cli_abort("{.arg x} must be numeric")
-  }
+  check_numeric(x)
   f(x/accuracy) * accuracy
 }
 

R/facet-grid-.R

@@ -182,10 +182,7 @@ grid_as_facets_list <- function(rows, cols) {
     return(facets)
   }
 
-  is_cols_vars <- is.null(cols) || is_quosures(cols)
-  if (!is_cols_vars) {
-    cli::cli_abort("{.arg cols} must be {.val NULL} or a {.fn vars} specification")
-  }
+  check_object(cols, is_quosures, "a {.fn vars} specification", allow_null = TRUE)
 
   list(
     rows = compact_facets(as_facets_list(rows)),

R/facet-wrap.R

@@ -99,12 +99,10 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed",
     strip.position <- if (switch == "x") "bottom" else "left"
   }
   strip.position <- arg_match0(strip.position, c("top", "bottom", "left", "right"))
-  if (!(is.null(ncol) || (is_integerish(ncol, 1) && ncol > 0))) {
-    cli::cli_abort("{.arg ncol} must be a positive scalar integer or {.val NULL}")
-  }
-  if (!(is.null(nrow) || (is_integerish(nrow, 1) && nrow > 0))) {
-    cli::cli_abort("{.arg nrow} must be a positive scalar integer or {.val NULL}")
-  }
+
+  check_number_whole(ncol, allow_null = TRUE, min = 1)
+  check_number_whole(nrow, allow_null = TRUE, min = 1)
+
   if (identical(dir, "v")) {
     # swap
     tmp <- ncol

R/fortify.R

@@ -35,7 +35,10 @@ fortify.grouped_df <- function(model, data, ...) {
 }
 #' @export
 fortify.default <- function(model, data, ...) {
-  msg <- glue("{{.arg data}} must be a {{.cls data.frame}}, or an object coercible by `fortify()`, not {obj_desc(model)}.")
+  msg <- glue(
+    "{{.arg data}} must be a {{.cls data.frame}}, ",
+    "or an object coercible by `fortify()`, not {obj_type_friendly(model)}."
+  )
   if (inherits(model, "uneval")) {
     msg <- c(
       msg,

R/geom-.R

@@ -1,4 +1,5 @@
 #' @include legend-draw.R
+#' @include utilities-checks.R
 NULL
 
 #' @section Geoms:

R/geom-map.R

@@ -97,9 +97,7 @@ geom_map <- function(mapping = NULL, data = NULL,
                      show.legend = NA,
                      inherit.aes = TRUE) {
   # Get map input into correct form
-  if (!is.data.frame(map)) {
-    cli::cli_abort("{.arg map} must be a {.cls data.frame}")
-  }
+  check_data_frame(map)
   if (!is.null(map$lat)) map$y <- map$lat
   if (!is.null(map$long)) map$x <- map$long
   if (!is.null(map$region)) map$id <- map$region

R/geom-raster.R

@@ -18,12 +18,8 @@ geom_raster <- function(mapping = NULL, data = NULL,
                         show.legend = NA,
                         inherit.aes = TRUE)
 {
-  if (!is_scalar_double(hjust)) {
-    cli::cli_abort("{.arg hjust} must be a number")
-  }
-  if (!is_scalar_double(vjust)) {
-    cli::cli_abort("{.arg vjust} must be a number")
-  }
+  check_number_decimal(hjust)
+  check_number_decimal(vjust)
 
   layer(
     data = data,

R/geom-rug.R

@@ -91,9 +91,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))
-    if (!inherits(length, "unit")) {
-      cli::cli_abort("{.arg length} must be a {.cls unit} object.")
-    }
+    check_inherits(length, "unit")
     rugs <- list()
     data <- coord$transform(data, panel_params)
 

R/ggproto.R

@@ -78,9 +78,7 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) {
 
   super <- find_super()
   if (!is.null(super)) {
-    if (!is.ggproto(super)) {
-      cli::cli_abort("{.arg _inherit} must be a {.cls ggproto} object.")
-    }
+    check_object(super, is.ggproto, "a {.cls ggproto} object", arg = "_inherit")
     e$super <- find_super
     class(e) <- c(`_class`, class(super))
   } else {

R/guides-axis.R

@@ -386,9 +386,7 @@ axis_label_element_overrides <- function(axis_position, angle = NULL) {
   }
 
   # it is not worth the effort to align upside-down labels properly
-  if (angle > 90 || angle < -90) {
-    cli::cli_abort("{.arg angle} must be between 90 and -90")
-  }
+  check_number_decimal(angle, min = -90, max = 90)
 
   if (axis_position == "bottom") {
     element_text(