Add argument args to check_function()

R/standalone-types-check.R

@@ -9,6 +9,10 @@
 #
 # ## Changelog
 #
+# 2023-08-31:
+# - `check_functions()` gains the argument `args` to specify which arguments the
+#   function should have (@mgirlich).
+#
 # 2023-03-13:
 # - Improved error messages of number checkers (@teunbrand)
 # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich).
@@ -381,11 +385,19 @@ check_environment <- function(x,
 
 check_function <- function(x,
                            ...,
+                           args = NULL,
                            allow_null = FALSE,
                            arg = caller_arg(x),
                            call = caller_env()) {
   if (!missing(x)) {
     if (is_function(x)) {
+      .check_function_args(
+        f = x,
+        expected_args = args,
+        arg = arg,
+        call = call
+      )
+
       return(invisible(NULL))
     }
     if (allow_null && is_null(x)) {
@@ -404,6 +416,48 @@ check_function <- function(x,
   )
 }
 
+.check_function_args <- function(f,
+                                 expected_args,
+                                 arg,
+                                 call) {
+  if (is_null(expected_args)) {
+    return(invisible(NULL))
+  }
+
+  actual_args <- fn_fmls_names(f) %||% character()
+  if (identical(actual_args, expected_args)) {
+    return(invisible(NULL))
+  }
+
+  n_expected_args <- length(expected_args)
+  n_actual_args <- length(actual_args)
+
+  if (n_expected_args == 0) {
+    message <- sprintf(
+      "%s must have no arguments, not %i %s.",
+      format_arg(arg),
+      length(actual_args),
+      pluralise(n_actual_args, "argument", "arguments")
+    )
+    abort(message, call = call, arg = arg)
+  }
+
+  if (n_actual_args == 0) {
+    arg_info <- "instead of no arguments"
+  } else {
+    arg_info <- paste0("not ", format_arg(actual_args))
+  }
+
+  message <- sprintf(
+    "%s must have the %s %s, %s.",
+    format_arg(arg),
+    pluralise(n_expected_args, "argument", "arguments"),
+    format_arg(expected_args),
+    arg_info
+  )
+  abort(message, call = call, arg = arg)
+}
+
 check_closure <- function(x,
                           ...,
                           allow_null = FALSE,

tests/testthat/_snaps/standalone-types-check.md

@@ -391,6 +391,72 @@
       Error in `checker()`:
       ! `foo` must be a defused call, not a symbol.
 
+# `check_function()` checks
+
+    Code
+      err(checker(, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not absent.
+    Code
+      err(checker(NULL, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not `NULL`.
+    Code
+      err(checker(TRUE, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not `TRUE`.
+    Code
+      err(checker(alist(foo(), bar()), check_function, allow_null = TRUE))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function or `NULL`, not a list.
+    Code
+      err(checker(quote(foo), check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not a symbol.
+
+---
+
+    Code
+      err(checker(function(x) x, args = character(), check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have no arguments, not 1 argument.
+    Code
+      err(checker(function(x, y) x, args = character(), check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have no arguments, not 2 arguments.
+    Code
+      err(checker(function() x, args = "x", check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have the argument `x`, instead of no arguments.
+    Code
+      err(checker(function(y) x, args = "x", check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have the argument `x`, not `y`.
+    Code
+      err(checker(function(y, x) x, args = c("x", "y"), check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have the arguments `x` and `y`, not `y` and `x`.
+
 # `check_environment()` checks
 
     Code

tests/testthat/test-standalone-types-check.R

@@ -138,6 +138,34 @@ test_that("`check_call()` checks", {
   })
 })
 
+test_that("`check_function()` checks", {
+  expect_null(check_function(function(x) x))
+  expect_null(check_function(NULL, allow_null = TRUE))
+
+  expect_snapshot({
+    err(checker(, check_function))
+    err(checker(NULL, check_function))
+    err(checker(TRUE, check_function))
+    err(checker(alist(foo(), bar()), check_function, allow_null = TRUE))
+    err(checker(quote(foo), check_function))
+  })
+
+  expect_null(check_function(function() x, args = character()))
+  expect_null(check_function(function(x) x, args = "x"))
+  expect_null(check_function(function(x, y) x, args = c("x", "y")))
+
+  expect_snapshot({
+    # should have no arguments
+    err(checker(function(x) x, args = character(), check_function))
+    err(checker(function(x, y) x, args = character(), check_function))
+
+    # should have arguments
+    err(checker(function() x, args = "x", check_function))
+    err(checker(function(y) x, args = "x", check_function))
+    err(checker(function(y, x) x, args = c("x", "y"), check_function))
+  })
+})
+
 test_that("`check_environment()` checks", {
   expect_null(check_environment(env()))
   expect_null(check_environment(NULL, allow_null = TRUE))