Check continuous scale limits (#6114)

* re-import standalone rlang files

* add length checker

* add `allow_na` option to `check_object()`

* simplify coord limit check

* use `check_length()` more often

* add `check_continuous_limits()`

* add test

* fix snapshots

* relax coord requirements

* TIL: is.vector(<Date>) is FALSE, whereas is_vector(<Date>) is TRUE

* restore previous error

* update snapshots

Author: teunbrand

R/bin.R

@@ -54,9 +54,7 @@ bin_breaks <- function(breaks, closed = c("right", "left")) {
 
 bin_breaks_width <- function(x_range, width = NULL, center = NULL,
                              boundary = NULL, closed = c("right", "left")) {
-  if (length(x_range) != 2) {
-    cli::cli_abort("{.arg x_range} must have two elements.")
-  }
+  check_length(x_range, 2L)
 
   # binwidth seems to be the argument name supplied to width. (stat-bin and stat-bindot)
   check_number_decimal(width, min = 0, allow_infinite = FALSE, arg = "binwidth")
@@ -106,9 +104,7 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL,
 
 bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
                             boundary = NULL, closed = c("right", "left")) {
-  if (length(x_range) != 2) {
-    cli::cli_abort("{.arg x_range} must have two elements.")
-  }
+  check_length(x_range, 2L)
 
   check_number_whole(bins, min = 1)
   if (zero_range(x_range)) {

R/coord-.R

@@ -281,14 +281,6 @@ check_coord_limits <- function(
   if (is.null(limits)) {
     return(invisible(NULL))
   }
-  if (!obj_is_vector(limits) || length(limits) != 2) {
-    what <- "{.obj_type_friendly {limits}}"
-    if (is.vector(limits)) {
-      what <- paste0(what, " of length {length(limits)}")
-    }
-    cli::cli_abort(
-      paste0("{.arg {arg}} must be a vector of length 2, not ", what, "."),
-      call = call
-    )
-  }
+  check_object(limits, is_vector, "a vector", arg = arg, call = call)
+  check_length(limits, 2L, arg = arg, call = call)
 }

R/import-standalone-obj-type.R

@@ -1,17 +1,27 @@
 # Standalone file: do not edit by hand
-# Source: <https://github.com/r-lib/rlang/blob/main/R/standalone-obj-type.R>
+# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R
+# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type")
 # ----------------------------------------------------------------------
 #
 # ---
 # repo: r-lib/rlang
 # file: standalone-obj-type.R
-# last-updated: 2022-10-04
+# last-updated: 2024-02-14
 # license: https://unlicense.org
 # imports: rlang (>= 1.1.0)
 # ---
 #
 # ## Changelog
 #
+# 2024-02-14:
+# - `obj_type_friendly()` now works for S7 objects.
+#
+# 2023-05-01:
+# - `obj_type_friendly()` now only displays the first class of S3 objects.
+#
+# 2023-03-30:
+# - `stop_input_type()` now handles `I()` input literally in `arg`.
+#
 # 2022-10-04:
 # - `obj_type_friendly(value = TRUE)` now shows numeric scalars
 #   literally.
@@ -65,7 +75,7 @@ obj_type_friendly <- function(x, value = TRUE) {
     if (inherits(x, "quosure")) {
       type <- "quosure"
     } else {
-      type <- paste(class(x), collapse = "/")
+      type <- class(x)[[1L]]
     }
     return(sprintf("a <%s> object", type))
   }
@@ -261,19 +271,19 @@ vec_type_friendly <- function(x, length = FALSE) {
 #' Return OO type
 #' @param x Any R object.
 #' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`,
-#'   `"R6"`, or `"R7"`.
+#'   `"R6"`, or `"S7"`.
 #' @noRd
 obj_type_oo <- function(x) {
   if (!is.object(x)) {
     return("bare")
   }
 
-  class <- inherits(x, c("R6", "R7_object"), which = TRUE)
+  class <- inherits(x, c("R6", "S7_object"), which = TRUE)
 
   if (class[[1]]) {
     "R6"
   } else if (class[[2]]) {
-    "R7"
+    "S7"
   } else if (isS4(x)) {
     "S4"
   } else {
@@ -315,10 +325,15 @@ stop_input_type <- function(x,
   if (length(what)) {
     what <- oxford_comma(what)
   }
+  if (inherits(arg, "AsIs")) {
+    format_arg <- identity
+  } else {
+    format_arg <- cli$format_arg
+  }
 
   message <- sprintf(
     "%s must be %s, not %s.",
-    cli$format_arg(arg),
+    format_arg(arg),
     what,
     obj_type_friendly(x, value = show_value)
   )

R/import-standalone-types-check.R

@@ -1,5 +1,6 @@
 # Standalone file: do not edit by hand
-# Source: <https://github.com/r-lib/rlang/blob/main/R/standalone-types-check.R>
+# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R
+# Generated by: usethis::use_standalone("r-lib/rlang", "types-check")
 # ----------------------------------------------------------------------
 #
 # ---
@@ -13,6 +14,9 @@
 #
 # ## Changelog
 #
+# 2024-08-15:
+# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724)
+#
 # 2023-03-13:
 # - Improved error messages of number checkers (@teunbrand)
 # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich).
@@ -461,15 +465,28 @@ check_formula <- function(x,
 
 # Vectors -----------------------------------------------------------------
 
+# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE`
+
 check_character <- function(x,
                             ...,
+                            allow_na = TRUE,
                             allow_null = FALSE,
                             arg = caller_arg(x),
                             call = caller_env()) {
+
   if (!missing(x)) {
     if (is_character(x)) {
+      if (!allow_na && any(is.na(x))) {
+        abort(
+          sprintf("`%s` can't contain NA values.", arg),
+          arg = arg,
+          call = call
+        )
+      }
+
       return(invisible(NULL))
     }
+
     if (allow_null && is_null(x)) {
       return(invisible(NULL))
     }
@@ -479,7 +496,6 @@ check_character <- function(x,
     x,
     "a character vector",
     ...,
-    allow_na = FALSE,
     allow_null = allow_null,
     arg = arg,
     call = call

R/limits.R

@@ -113,9 +113,7 @@ ylim <- function(...) {
 limits <- function(lims, var, call = caller_env()) UseMethod("limits")
 #' @export
 limits.numeric <- function(lims, var, call = caller_env()) {
-  if (length(lims) != 2) {
-    cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call)
-  }
+  check_length(lims, 2L, arg = var, call = call)
   if (!anyNA(lims) && lims[1] > lims[2]) {
     trans <- "reverse"
   } else {
@@ -143,23 +141,17 @@ limits.factor <- function(lims, var, call = caller_env()) {
 }
 #' @export
 limits.Date <- function(lims, var, call = caller_env()) {
-  if (length(lims) != 2) {
-    cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call)
-  }
+  check_length(lims, 2L, arg = var, call = call)
   make_scale("date", var, limits = lims, call = call)
 }
 #' @export
 limits.POSIXct <- function(lims, var, call = caller_env()) {
-  if (length(lims) != 2) {
-    cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call)
-  }
+  check_length(lims, 2L, arg = var, call = call)
   make_scale("datetime", var, limits = lims, call = call)
 }
 #' @export
 limits.POSIXlt <- function(lims, var, call = caller_env()) {
-  if (length(lims) != 2) {
-    cli::cli_abort("{.arg {var}} must be a two-element vector.", call = call)
-  }
+  check_length(lims, 2L, arg = var, call = call)
   make_scale("datetime", var, limits = as.POSIXct(lims), call = call)
 }
 

R/plot-build.R

@@ -358,13 +358,10 @@ table_add_tag <- function(table, label, theme) {
       ),
       call = expr(theme()))
     }
-    if (length(position) != 2) {
-      cli::cli_abort(paste0(
-        "A {.cls numeric} {.arg plot.tag.position} ",
-        "theme setting must have length 2."
-      ),
-      call = expr(theme()))
-    }
+    check_length(
+      position, 2L, call = expr(theme()),
+      arg = I("A {.cls numeric} {.arg plot.tag.position}")
+    )
     top <- left <- right <- bottom <- FALSE
   } else {
     # Break position into top/left/right/bottom

R/scale-.R

@@ -128,12 +128,14 @@ continuous_scale <- function(aesthetics, scale_name = deprecated(), palette, nam
   }
 
   transform <- as.transform(transform)
+  limits   <- allow_lambda(limits)
+
   if (!is.null(limits) && !is.function(limits)) {
     limits <- transform$transform(limits)
   }
+  check_continuous_limits(limits, call = call)
 
   # Convert formula to function if appropriate
-  limits   <- allow_lambda(limits)
   breaks   <- allow_lambda(breaks)
   labels   <- allow_lambda(labels)
   rescaler <- allow_lambda(rescaler)
@@ -1400,6 +1402,16 @@ check_transformation <- function(x, transformed, name, arg = NULL, call = NULL)
   cli::cli_warn(msg, call = call)
 }
 
+check_continuous_limits <- function(limits, ...,
+                                    arg = caller_arg(limits),
+                                    call = caller_env()) {
+  if (is.null(limits) || is.function(limits)) {
+    return(invisible())
+  }
+  check_numeric(limits, arg = arg, call = call, allow_na = TRUE)
+  check_length(limits, 2L, arg = arg, call = call)
+}
+
 trans_support_nbreaks <- function(trans) {
   "n" %in% names(formals(trans$breaks))
 }

R/utilities-checks.R

@@ -7,6 +7,7 @@ check_object <- function(x,
                          check_fun,
                          what,
                          ...,
+                         allow_na = FALSE,
                          allow_null = FALSE,
                          arg = caller_arg(x),
                          call = caller_env()) {
@@ -18,6 +19,9 @@ check_object <- function(x,
     if (allow_null && is_null(x)) {
       return(invisible(NULL))
     }
+    if (allow_na && all(is.na(x))) {
+      return(invisible(NULL))
+    }
   }
 
   stop_input_type(
@@ -69,6 +73,60 @@ check_inherits <- function(x,
   )
 }
 
+check_length <- function(x, length = integer(), ..., min = 0, max = Inf,
+                         arg = caller_arg(x), call = caller_env()) {
+  if (missing(x)) {
+    stop_input_type(x, "a vector", arg = arg, call = call)
+  }
+
+  n <- length(x)
+  if (n %in% length) {
+    return(invisible(NULL))
+  }
+  fmt <- if (inherits(arg, "AsIs")) identity else function(x) sprintf("`%s`", x)
+  if (length(length) > 0) {
+    type <- paste0("a vector of length ", oxford_comma(length))
+    if (length(length) == 1) {
+      type <- switch(
+        sprintf("%d", length),
+        "0" = "an empty vector",
+        "1" = "a scalar of length 1",
+        type
+      )
+    }
+    msg <- sprintf(
+      "%s must be %s, not length %d.",
+      fmt(arg), type, n
+    )
+    cli::cli_abort(msg, call = call, arg = arg)
+  }
+
+  range <- pmax(range(min, max, na.rm = TRUE), 0)
+  if (n >= min & n <= max) {
+    return(invisible(NULL))
+  }
+  if (identical(range[1], range[2])) {
+    check_length(x, range[1], arg = arg, call = call)
+    return(invisible(NULL))
+  }
+
+  type <- if (range[2] == 1) "scalar" else "vector"
+
+  what <- paste0("a length between ", range[1], " and ", range[2])
+  if (identical(range[2], Inf)) {
+    what <- paste0("at least length ", range[1])
+  }
+  if (identical(range[1], 0)) {
+    what <- paste0("at most length ", range[2])
+  }
+
+  msg <- sprintf(
+    "`%s` must be a %s with %s, not length %d.",
+    fmt(arg), type, what, n
+  )
+  cli::cli_abort(msg, call = call, arg = arg)
+}
+
 #' Check graphics device capabilities
 #'
 #' This function makes an attempt to estimate whether the graphics device is

tests/testthat/_snaps/coord-.md

@@ -24,13 +24,13 @@
       check_coord_limits(xlim(1, 2))
     Condition
       Error:
-      ! `xlim(1, 2)` must be a vector of length 2, not a <ScaleContinuousPosition> object.
+      ! `xlim(1, 2)` must be a vector, not a <ScaleContinuousPosition> object.
 
 ---
 
     Code
       check_coord_limits(1:3)
     Condition
       Error:
-      ! `1:3` must be a vector of length 2, not an integer vector of length 3.
+      ! `1:3` must be a vector of length 2, not length 3.
 

tests/testthat/_snaps/coord-cartesian.md

@@ -1,8 +1,8 @@
 # cartesian coords throws error when limits are badly specified
 
-    `xlim` must be a vector of length 2, not a <ScaleContinuousPosition> object.
+    `xlim` must be a vector, not a <ScaleContinuousPosition> object.
 
 ---
 
-    `ylim` must be a vector of length 2, not an integer vector of length 3.
+    `ylim` must be a vector of length 2, not length 3.