From f60e953339f93637d7e5e00606855ef381681a24 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 5 Dec 2025 13:59:20 +0100 Subject: [PATCH 1/4] extract arg formatting logic in separate function --- R/utilities-checks.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/utilities-checks.R b/R/utilities-checks.R index d444e8c3d0..5390413b9e 100644 --- a/R/utilities-checks.R +++ b/R/utilities-checks.R @@ -83,7 +83,6 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, 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) { @@ -96,7 +95,7 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, } msg <- sprintf( "%s must be %s, not length %d.", - fmt(arg), type, n + fmt_arg(arg), type, n ) cli::cli_abort(msg, call = call, arg = arg) } @@ -122,7 +121,7 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, msg <- sprintf( "`%s` must be a %s with %s, not length %d.", - fmt(arg), type, what, n + fmt_arg(arg), type, what, n ) cli::cli_abort(msg, call = call, arg = arg) } @@ -419,3 +418,10 @@ check_device <- function(feature, action = "warn", op = NULL, maybe = FALSE, .blend_ops <- c("multiply", "screen", "overlay", "darken", "lighten", "color.dodge", "color.burn", "hard.light", "soft.light", "difference", "exclusion") + +fmt_arg <- function(x) { + if (inherits(x, "AsIs")) { + return(x) + } + sprintf("`%s`", x) +} From d6ebd4ca00b732d6ba4aaf6c9edba2a0852731dd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 5 Dec 2025 15:49:30 +0100 Subject: [PATCH 2/4] add check function --- R/utilities-checks.R | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/R/utilities-checks.R b/R/utilities-checks.R index 5390413b9e..ced8634193 100644 --- a/R/utilities-checks.R +++ b/R/utilities-checks.R @@ -126,6 +126,28 @@ check_length <- function(x, length = integer(), ..., min = 0, max = Inf, cli::cli_abort(msg, call = call, arg = arg) } +check_named <- function(x, arg = caller_arg(x), call = caller_env()) { + if (missing(x)) { + stop_input_type(x, "a vector", arg = arg, call = call) + } + if (length(x) < 1) { + return(invisible()) + } + msg <- character() + if (!is_named2(x)) { + msg <- sprintf("%s must have names.", fmt_arg(arg)) + } else if (anyDuplicated(names2(x))) { + dups <- names2(x) + dups <- sprintf('"%s"', unique(dups[duplicated(dups)])) + dups <- oxford_comma(dups, final = "and") + msg <- sprintf("%s cannot have duplicate names (%s).", fmt_arg(arg), dups) + } + if (length(msg) < 1) { + return(invisible()) + } + cli::cli_abort(msg, call = call, arg = arg) +} + #' Check graphics device capabilities #' #' This function makes an attempt to estimate whether the graphics device is From 7fd46b19977050ca2630a193abaa189d34bee2d7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 5 Dec 2025 15:50:48 +0100 Subject: [PATCH 3/4] Apply check in functions --- R/all-classes.R | 15 +-------------- R/limits.R | 5 +---- R/theme-elements.R | 5 +---- tests/testthat/_snaps/limits.md | 2 +- 4 files changed, 4 insertions(+), 23 deletions(-) diff --git a/R/all-classes.R b/R/all-classes.R index 42409e655a..898946f31e 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -253,21 +253,8 @@ class_labels <- S7::new_class( "labels", parent = class_S3_gg, constructor = function(labels = list(), ...) { warn_dots_empty() + check_named(labels, I("labels")) S7::new_object(labels) - }, - validator = function(self) { - if (!is.list(self)) { - return("labels must be a list.") - } - if (!is_named2(self)) { - return("every label must be named.") - } - dups <- unique(names(self)[duplicated(names(self))]) - if (length(dups) > 0) { - dups <- oxford_comma(dups, final = "and") - return(paste0("labels cannot contain duplicate names (", dups, ").")) - } - return(NULL) } ) diff --git a/R/limits.R b/R/limits.R index 976307a467..22aaf93f0d 100644 --- a/R/limits.R +++ b/R/limits.R @@ -81,10 +81,7 @@ #' lims <- function(...) { args <- list2(...) - - if (!is_named2(args)) { - cli::cli_abort("All arguments must be named.") - } + check_named(args, arg = I("Arguments")) env <- current_env() Map(limits, args, names(args), rep(list(env), length(args))) } diff --git a/R/theme-elements.R b/R/theme-elements.R index c8dab6c69f..e5411d326b 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -746,10 +746,7 @@ check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { if (length(x) < 1) { return(invisible(NULL)) } - - if (!is_named(x)) { - cli::cli_abort("{.arg {arg}} must have names.", call = call) - } + check_named(x, arg = arg, call = call) # All elements should be constructed with `el_def()` fields <- names(el_def()) diff --git a/tests/testthat/_snaps/limits.md b/tests/testthat/_snaps/limits.md index f52f2e94e5..b756f5a1f4 100644 --- a/tests/testthat/_snaps/limits.md +++ b/tests/testthat/_snaps/limits.md @@ -1,6 +1,6 @@ # limits() throw meaningful errors - All arguments must be named. + Arguments must have names. --- From 79a9d4efe86e2718f379a201efd331ca1e7554ba Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 5 Dec 2025 15:57:14 +0100 Subject: [PATCH 4/4] apply to `ggproto()` and deduplicate members --- R/ggproto.R | 4 +--- R/stat-bindot.R | 8 ++++---- tests/testthat/_snaps/ggproto.md | 8 ++++++-- tests/testthat/test-ggproto.R | 2 ++ 4 files changed, 13 insertions(+), 9 deletions(-) diff --git a/R/ggproto.R b/R/ggproto.R index 4e7ccc6e30..cdc2765e96 100644 --- a/R/ggproto.R +++ b/R/ggproto.R @@ -68,9 +68,7 @@ ggproto <- function(`_class` = NULL, `_inherit` = NULL, ...) { e <- new.env(parent = emptyenv()) members <- list2(...) - if (length(members) != sum(nzchar(names(members)))) { - cli::cli_abort("All members of a {.cls ggproto} object must be named.") - } + check_named(members, I("Members of a {.cls ggproto} object")) # R <3.1.2 will error when list2env() is given an empty list, so we need to # check length. https://github.com/tidyverse/ggplot2/issues/1444 diff --git a/R/stat-bindot.R b/R/stat-bindot.R index 5367a2d99a..189305af71 100644 --- a/R/stat-bindot.R +++ b/R/stat-bindot.R @@ -6,7 +6,9 @@ StatBindot <- ggproto("StatBindot", Stat, required_aes = "x", non_missing_aes = "weight", default_aes = aes(y = after_stat(count)), - dropped_aes = c("bin", "bincenter"), # these are temporary variables that are created and then removed by the stat + + # these are temporary variables that are created and then removed by the stat + dropped_aes = c("weight", "bin", "bincenter"), setup_params = function(data, params) { if (is.null(params$binwidth)) { @@ -122,9 +124,7 @@ StatBindot <- ggproto("StatBindot", Stat, data$x <- midline } return(data) - }, - - dropped_aes = c("weight", "bin", "bincenter") + } ) diff --git a/tests/testthat/_snaps/ggproto.md b/tests/testthat/_snaps/ggproto.md index 2fbd19d83f..a699f5d638 100644 --- a/tests/testthat/_snaps/ggproto.md +++ b/tests/testthat/_snaps/ggproto.md @@ -1,15 +1,19 @@ # construction checks input - All members of a object must be named. + Members of a object must have names. --- - All members of a object must be named. + Members of a object must have names. --- `_inherit` must be a object, not a object. +--- + + Members of a object cannot have duplicate names ("foo"). + # ggproto objects print well Code diff --git a/tests/testthat/test-ggproto.R b/tests/testthat/test-ggproto.R index 7ffe265735..b44b755577 100644 --- a/tests/testthat/test-ggproto.R +++ b/tests/testthat/test-ggproto.R @@ -9,6 +9,8 @@ test_that("construction checks input", { expect_snapshot_error(ggproto("Test", NULL, function(self, a) a)) expect_snapshot_error(ggproto("Test", NULL, a <- function(self, a) a)) expect_snapshot_error(ggproto("Test", mtcars, a = function(self, a) a)) + # Duplicate names + expect_snapshot_error(ggproto("Test", NULL, foo = 20, foo = "A")) }) test_that("all ggproto methods start with `{` (#6459)", {