Add functions to check fn req args

R/function_checkers.R

@@ -0,0 +1,66 @@
+#' @title Check functions passed to exported functions
+#'
+#' @name function_checkers
+#' @rdname function_checkers
+#'
+#' @description Internal helper function that check whether a function passed as
+#' an argument meets the requirements of package methods.
+#'
+#' `test_fn_req_args()` checks whether the function has only the expected number
+#' of required arguments, i.e., arguments without default values. Defaults to
+#' checking for a single required argument.
+#'
+#' `test_fn_num_out()` checks whether a function accepting a numeric vector
+#' input returns a numeric vector output of the same length as the input, with
+#' finite non-missing values \eqn{\geq} 0.0.
+#'
+#' @param fn A function. This is expected to be a function evaluating the
+#' density of a distribution at numeric values.
+#' @param n_req_args The number of required arguments, i.e., arguments without
+#' default values.
+#' @param n The number of elements over which to evaluate the function `fn`.
+#' Defaults to 10, and `fn` is evaluated over `seq(n)`.
+#'
+#' @return A logical for whether the function `fn` fulfils conditions specified
+#' in the respective checks.
+#' @keywords internal
+test_fn_req_args <- function(fn, n_req_args = 1) {
+  # NOTE: replacing checkmate::assert_count()
+  stopifnot(
+    "`n_req_args` must be a single number" = (is.numeric(n_req_args)) &&
+      (length(n_req_args) == 1),
+    "`n_req_args` must be finite and non-missing" = (is.finite(n_req_args)) &&
+      (!is.na(n_req_args)),
+    "`n_req_args` must be a natural number > 0" = (n_req_args > 0) &&
+      (n_req_args %% 1 == 0)
+  )
+  # NOTE: using formals(args(fn)) to allow checking args of builtin primitives
+  # for which formals(fn) would return NULL and cause the check to error
+  # NOTE: errors non-informatively for specials such as `if`
+  is.function(fn) &&
+    Reduce(
+      x = Map(
+        function(x, y) {
+          is.name(x) && y != "..."
+        },
+        formals(args(fn)), names(formals(args(fn)))
+      ),
+      f = `+`
+    ) == n_req_args
+}
+
+#' @name function_checkers
+test_fn_num_out <- function(fn, n = 10) {
+  # NOTE: replacing checkmate::assert_count()
+  stopifnot(
+    "`n` must be a single number" = (is.numeric(n)) && (length(n) == 1),
+    "`n` must be finite and non-missing" = (is.finite(n)) && (!is.na(n)),
+    "`n` must be a natural number > 0" = (n > 0) && (n %% 1 == 0),
+    "`fn` must be a function" = is.function(fn)
+  )
+  out <- fn(seq(n))
+
+  # return logical output of conditions
+  is.numeric(out) && (length(out) == n) && (!anyNA(out)) &&
+    (all(is.finite(out))) && (all(out > 0.0))
+}

tests/testthat/test-function_checkers.R

@@ -0,0 +1,107 @@
+#### Checks on test_fn_req_args() ####
+test_that("Function to check N required arguments", {
+  # Test function to check number of required arguments
+  expect_true(
+    test_fn_req_args(
+      function(x) dgamma(x, 5, 1)
+    )
+  )
+  # `+` needs two arguments
+  expect_true(
+    test_fn_req_args(
+      `+`, 2L
+    )
+  )
+  expect_false(
+    test_fn_req_args(
+      `+`, 1L
+    )
+  )
+  expect_false(
+    test_fn_req_args(
+      function(x, y, ...) dgamma(x, 5, 1, ...) + y
+    )
+  )
+  expect_true(
+    test_fn_req_args(
+      dgamma, 2
+    )
+  )
+
+  # fails on poorly specified n
+  expect_error(
+    test_fn_req_args("dummy_fn", seq(10)),
+    regexp = "`n_req_args` must be a single number"
+  )
+  expect_error(
+    test_fn_req_args("dummy_fn", -1),
+    regexp = "`n_req_args` must be a natural number > 0"
+  )
+  expect_error(
+    test_fn_req_args("dummy_fn", NA_real_),
+    regexp = "`n_req_args` must be finite and non-missing"
+  )
+  expect_error(
+    test_fn_req_args("dummy_fn", Inf),
+    regexp = "`n_req_args` must be finite and non-missing"
+  )
+
+  # expect TRUE when an appropriate primitive is passed
+  # NOTE: Passes as this primitive has one arg
+  expect_true(
+    test_fn_req_args(is.list)
+  )
+
+  ## functions with ellipsis
+  expect_true(
+    test_fn_req_args(
+      function(x, ...) dgamma(x, 5, 1, ...)
+    )
+  )
+})
+
+#### Test function to check for numeric output ####
+test_that("Function to check numeric output", {
+  # well specified case
+  expect_true(
+    test_fn_num_out(
+      function(x) dgamma(x, 5, 1)
+    )
+  )
+  # false on wrong input type
+  expect_error(
+    test_fn_num_out("dummy_fn"),
+    regexp = "`fn` must be a function"
+  )
+  # fails on poorly specified n
+  expect_error(
+    test_fn_num_out("dummy_fn", seq(10)),
+    regexp = "`n` must be a single number"
+  )
+  expect_error(
+    test_fn_num_out("dummy_fn", -1),
+    regexp = "`n` must be a natural number > 0"
+  )
+  expect_error(
+    test_fn_num_out("dummy_fn", NA_real_),
+    regexp = "`n` must be finite and non-missing"
+  )
+  expect_error(
+    test_fn_num_out("dummy_fn", Inf),
+    regexp = "`n` must be finite and non-missing"
+  )
+  # false on wrong return type
+  expect_false(
+    test_fn_num_out(
+      function(x, ...) as.character(dgamma(x, 5, 1, ...))
+    )
+  )
+  # false on wrong return length
+  fn <- function(x) {
+    a <- x + 1
+    a[-1]
+  }
+  expect_false(
+    test_fn_num_out(fn)
+  )
+})