Introduce check_dots_named()

DESCRIPTION

@@ -1,25 +1,38 @@
 Package: ellipsis
-Version: 0.3.1.9000
 Title: Tools for Working with ...
-Description: The ellipsis is a powerful tool for extending functions. Unfortunately 
-    this power comes at a cost: misspelled arguments will be silently ignored. 
-    The ellipsis package provides a collection of functions to catch problems
-    and alert the user.
-Authors@R: c(
-      person("Hadley", "Wickham", , "[email protected]", role = c("aut", "cre")),
-      person("RStudio", role = "cph")
-    )
+Version: 0.3.1.9001
+Authors@R: 
+    c(person(given = "Hadley",
+             family = "Wickham",
+             role = c("aut", "cre"),
+             email = "[email protected]"),
+      person(given = "Salim",
+             family = "Brüggemann",
+             role = c("aut"),
+             email = "[email protected]",
+             comment = c(ORCID = "0000-0002-5329-5987")),
+      person(given = "RStudio",
+             role = "cph"))
+Description: The ellipsis is a powerful tool for extending
+    functions. Unfortunately this power comes at a cost: misspelled
+    arguments will be silently ignored.  The ellipsis package provides a
+    collection of functions to catch problems and alert the user.
 License: GPL-3
-Encoding: UTF-8
-LazyData: true
-Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.0
-URL: https://ellipsis.r-lib.org, https://github.com/r-lib/ellipsis
+URL: https://ellipsis.r-lib.org,
+    https://github.com/r-lib/ellipsis
 BugReports: https://github.com/r-lib/ellipsis/issues
 Depends: 
     R (>= 3.2)
 Imports:
-    rlang (>= 0.3.0)
+    checkmate (>= 2.0.0),
+    methods (>= 3.6.0),
+    purrr (>= 0.3.4),
+    rlang (>= 0.3.0),
+    utils (>= 3.0.0)
 Suggests: 
     covr,
     testthat
+Encoding: UTF-8
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.1.0

NAMESPACE

@@ -2,6 +2,7 @@
 
 S3method(safe_median,numeric)
 export(check_dots_empty)
+export(check_dots_named)
 export(check_dots_unnamed)
 export(check_dots_used)
 export(safe_median)

R/check.R

@@ -129,3 +129,177 @@ action_dots <- function(action, message, dot_names, note = NULL, .subclass = NUL
   )
   action(message, .subclass = c(.subclass, "rlib_error_dots"), ...)
 }
+
+#' Check that all dot parameter names are a valid subset of a function's parameter names.
+#'
+#' This function ensures that [dots (...)][base::dots()] are either empty (if `.empty_ok = TRUE`), or all named dot parameter names are a valid subset of a
+#' function's parameter names. In case of an invalid or `.forbidden` argument, an informative message is shown and the defined `.action` is taken.
+#'
+#' `check_dots_named()` is intended to combat the second one of the two major downsides that using `...` usually brings. In chapter 6.6 of the book
+#' _Advanced R_ it is [phrased](https://adv-r.hadley.nz/functions.html#fun-dot-dot-dot) as follows:
+#'
+#' _Using `...` comes with two downsides:_
+#'
+#' - _When you use it to pass arguments to another function, you have to carefully explain to the user where those arguments go. This makes it hard to
+#'   understand what you can do with functions like `lapply()` and `plot()`._
+#'
+#' - **_A misspelled argument will not raise an error. This makes it easy for typos to go unnoticed._**
+#'
+#' @param ... The dots argument to check.
+#' @param .function The function the `...` will be passed on to.
+#' @param .forbidden Parameter names within `...` that should be treated as
+#'   invalid. A character vector.
+#' @param .empty_ok Set to `TRUE` if empty `...` should be allowed, or to `FALSE`
+#'   otherwise.
+#' @param .action The action to take when the check fails. One of [rlang::abort()],
+#'   [rlang::warn()], [rlang::inform()] or [rlang::signal()].
+#' @export
+#' @examples
+#' # We can use `check_dots_named()` to address this second downside:
+#' sum_safe <- function(...,
+#'                      na.rm = FALSE) {
+#'   check_dots_named(...,
+#'                    .function = sum)
+#'   sum(...,
+#'       na.rm = na.rm)
+#' }
+#'
+#' # note how the misspelled `na_rm` (instead of `na.rm`) silently gets ignored
+#' # in the original function
+#' sum(1, 2, NA, na_rm = TRUE)
+#'
+#' \dontrun{
+#' # whereas our safe version properly errors
+#' sum_safe(1, 2, NA, na_rm = TRUE)}
+#'
+#' # we can even build an `sapply()` function that fails "intelligently"
+#' sapply_safe <- function(X,
+#'                         FUN,
+#'                         ...,
+#'                         simplify = TRUE,
+#'                         USE.NAMES = TRUE) {
+#'   check_dots_named(...,
+#'                    .function = FUN)
+#'   sapply(X = X,
+#'          FUN = FUN,
+#'          ...,
+#'          simplify = TRUE,
+#'          USE.NAMES = TRUE)
+#' }
+#'
+#' # while the original `sapply()` silently ignores misspelled arguments,
+#' sapply(1:5, paste, "hour workdays", sep = "-", colaspe = " ")
+#'
+#' \dontrun{
+#' # `sapply_safe()` will throw an informative error message
+#' sapply_safe(1:5, paste, "hour workdays", sep = "-", colaspe = " ")}
+#'
+#' \dontrun{
+#' # but be aware that `check_dots_named()` might be a bit rash
+#' sum_safe(a = 1, b = 2)}
+#'
+#' # while the original function actually has nothing to complain about
+#' sum(a = 1, b = 2)
+#'
+#' \dontrun{
+#' # also, it doesn't play nicely with functions that don't expose all of
+#' # their arg names (`to` and `by` in the case of `seq()`)
+#' sapply_safe(X = c(0,50),
+#'             FUN = seq,
+#'             to = 100,
+#'             by = 5)}
+#'
+#' # but providing `to` and `by` *unnamed* is fine of course:
+#' sapply_safe(X = c(0,50),
+#'             FUN = seq,
+#'             100,
+#'             5)
+check_dots_named <- function(...,
+                             .function,
+                             .forbidden = NULL,
+                             .empty_ok = TRUE,
+                             .action = abort) {
+  if (...length()) {
+
+    # determine original function name the `...` will be passed on to
+    fun_arg_name <- deparse1(substitute(.function))
+    parent_call <- as.list(sys.call(-1L))
+    parent_param_names <- methods::formalArgs(sys.function(-1L))
+
+    if (fun_arg_name %in% parent_param_names) {
+      fun_name <- as.character(parent_call[which(parent_param_names == fun_arg_name) + 1][[1]])
+    } else {
+      fun_name <- fun_arg_name
+    }
+
+    # determine param names of the function the `...` will be passed on to
+    dots_param_names <- methods::formalArgs(checkmate::assert_function(.function))
+
+    # check named `...` args
+    purrr::walk(
+      .x = setdiff(names(c(...)), ""),
+      .f = check_dot_named,
+      values = dots_param_names,
+      allowed_values = setdiff(dots_param_names,
+                               checkmate::assert_character(.forbidden,
+                                                           any.missing = FALSE,
+                                                           null.ok = TRUE)),
+      fun_name = fun_name,
+      action = .action
+    )
+
+  } else if (!.empty_ok) {
+    .action("`...` must be provided (!= `NULL`).",
+            .subclass = c("rlib_error_dots_empty", "rlib_error_dots"))
+  }
+}
+
+# The following code is largely borrowed from `rlang::arg_match()`
+check_dot_named <- function(dot,
+                            values,
+                            allowed_values,
+                            fun_name,
+                            action) {
+  i <- match(dot, allowed_values)
+
+  if (is_na(i)) {
+
+    is_forbidden <- dot %in% values
+    is_restricted <- !setequal(values,
+                               allowed_values)
+
+    msg <- paste0(ifelse(is_forbidden, "Forbidden", "Invalid"),
+                  " argument provided in `...`: `", dot, "`\n")
+
+    if (length(allowed_values) > 0) {
+      msg <- paste0(msg, ifelse(is_restricted,
+                                "Arguments allowed to pass on to ",
+                                "Valid arguments for "),
+                    "`", fun_name, "()` include: ",
+                    prose_ls(allowed_values, wrap = "`"), "\n")
+    } else {
+      msg <- paste0(msg, "Only unnamed arguments are ",
+                    ifelse(is_restricted, "allowed", "valid"),
+                    " for `", fun_name, "()`.")
+    }
+
+    i_partial <- pmatch(dot, allowed_values)
+
+    if (!is_na(i_partial)) {
+      candidate <- allowed_values[[i_partial]]
+    }
+
+    i_close <- utils::adist(dot, allowed_values)/nchar(allowed_values)
+
+    if (any(i_close <= 0.5)) {
+      candidate <- allowed_values[[which.min(i_close)]]
+    }
+
+    if (exists("candidate")) {
+      candidate <- prose_ls(candidate, wrap = "`")
+      msg <- paste0(msg, "\n", "Did you mean ", candidate, "?")
+    }
+
+    action(msg, .subclass = c("rlib_error_dots_invalid_name", "rlib_error_dots"))
+  }
+}

R/utils.R

@@ -2,3 +2,33 @@
 paste_line <- function(...) {
   paste(c(...), collapse = "\n")
 }
+
+#' List items concatenated in prose-style (..., ... and ...)
+#'
+#' This function takes a vector or list and concatenates its elements to a single string separated in prose-style.
+#'
+#' @param x A vector or a list.
+#' @param wrap The string (usually a single character) in which `x` is to be wrapped.
+#' @param separator The separator to delimit the elements of `x`.
+#' @param last_separator The separator to delimit the second-last and last element of `x`.
+#'
+#' @return A character scalar.
+#' @keywords internal
+prose_ls <- function(x,
+                     wrap = "",
+                     separator = ", ",
+                     last_separator = " and ") {
+  if (length(x) < 2) {
+    paste0(checkmate::assert_string(wrap), x, wrap)
+
+  } else {
+    paste0(wrap,
+           paste0(x[-length(x)],
+                  collapse = paste0(checkmate::assert_string(wrap), separator, wrap)),
+           wrap,
+           checkmate::assert_string(last_separator),
+           wrap,
+           x[length(x)],
+           wrap)
+  }
+}