Add check function for named-ness (#6766)

* extract arg formatting logic in separate function

* add check function

* Apply check in functions

* apply to `ggproto()` and deduplicate members

Author: teunbrand

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)
   }
 )
 

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

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)))
 }

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")
+  }
 )
 
 

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())

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,11 +121,33 @@ 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)
 }
 
+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
@@ -419,3 +440,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)
+}

tests/testthat/_snaps/ggproto.md

@@ -1,15 +1,19 @@
 # construction checks input
 
-    All members of a <ggproto> object must be named.
+    Members of a <ggproto> object must have names.
 
 ---
 
-    All members of a <ggproto> object must be named.
+    Members of a <ggproto> object must have names.
 
 ---
 
     `_inherit` must be a <ggproto> object, not a <data.frame> object.
 
+---
+
+    Members of a <ggproto> object cannot have duplicate names ("foo").
+
 # ggproto objects print well
 
     Code

tests/testthat/_snaps/limits.md

@@ -1,6 +1,6 @@
 # limits() throw meaningful errors
 
-    All arguments must be named.
+    Arguments must have names.
 
 ---
 

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)", {