From 64a5dc69a8a254af0d5a8029c3592981ac7d4dc4 Mon Sep 17 00:00:00 2001
From: pratikunterwegs <pratikgupte16@gmail.com>
Date: Tue, 30 Jan 2024 15:59:42 +0000
Subject: [PATCH] Add functions to check fn req args

---
 R/function_checkers.R                   |  66 +++++++++++++++
 man/function_checkers.Rd                |  39 +++++++++
 tests/testthat/test-function_checkers.R | 107 ++++++++++++++++++++++++
 3 files changed, 212 insertions(+)
 create mode 100644 R/function_checkers.R
 create mode 100644 man/function_checkers.Rd
 create mode 100644 tests/testthat/test-function_checkers.R

diff --git a/R/function_checkers.R b/R/function_checkers.R
new file mode 100644
index 0000000..faec6e2
--- /dev/null
+++ b/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))
+}
diff --git a/man/function_checkers.Rd b/man/function_checkers.Rd
new file mode 100644
index 0000000..f499ca7
--- /dev/null
+++ b/man/function_checkers.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/function_checkers.R
+\name{function_checkers}
+\alias{function_checkers}
+\alias{test_fn_req_args}
+\alias{test_fn_num_out}
+\title{Check functions passed to exported functions}
+\usage{
+test_fn_req_args(fn, n_req_args = 1)
+
+test_fn_num_out(fn, n = 10)
+}
+\arguments{
+\item{fn}{A function. This is expected to be a function evaluating the
+density of a distribution at numeric values.}
+
+\item{n_req_args}{The number of required arguments, i.e., arguments without
+default values.}
+
+\item{n}{The number of elements over which to evaluate the function \code{fn}.
+Defaults to 10, and \code{fn} is evaluated over \code{seq(n)}.}
+}
+\value{
+A logical for whether the function \code{fn} fulfils conditions specified
+in the respective checks.
+}
+\description{
+Internal helper function that check whether a function passed as
+an argument meets the requirements of package methods.
+
+\code{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.
+
+\code{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.
+}
+\keyword{internal}
diff --git a/tests/testthat/test-function_checkers.R b/tests/testthat/test-function_checkers.R
new file mode 100644
index 0000000..aaa8641
--- /dev/null
+++ b/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)
+  )
+})