Check that the f passed to epi[x]_slide takes enough args

R/grouped_epi_archive.R

@@ -220,6 +220,11 @@ grouped_epi_archive =
               ref_time_values = sort(ref_time_values)
             }
 
+            # Check that `f` takes enough args
+            if (!missing(f) && is.function(f)) {
+              check_sufficient_f_args(f)
+            }
+
             # Validate and pre-process `before`:
             if (missing(before)) {
               Abort("`before` is required (and must be passed by name);

R/slide.R

@@ -155,7 +155,12 @@ epi_slide = function(x, f, ..., before, after, ref_time_values,
 
   # Check we have an `epi_df` object
   if (!inherits(x, "epi_df")) Abort("`x` must be of class `epi_df`.")
-
+
+  # Check that `f` takes enough args
+  if (!missing(f) && is.function(f)) {
+    check_sufficient_f_args(f)
+  }
+
   # Arrange by increasing time_value
   x = arrange(x, time_value)
 

R/utils.R

@@ -100,6 +100,36 @@ paste_lines = function(lines) {
 Abort = function(msg, ...) rlang::abort(break_str(msg, init = "Error: "), ...)
 Warn = function(msg, ...) rlang::warn(break_str(msg, init = "Warning: "), ...)
 
+#' Check that a sliding computation function takes enough args
+#'
+#' @param f Function; specifies a computation to slide over an `epi_df` or
+#'  `epi_archive` in `epi_slide` or `epix_slide`.
+#'
+#' @noRd
+check_sufficient_f_args <- function(f) {
+  n_mandatory_f_args <- 2
+  arg_names = names(formals(args(f)))
+  if ("..." %in% arg_names) {
+    # Keep all arg names before `...`
+    dots_i <- which(arg_names == "...")
+    arg_names <- arg_names[seq_len(dots_i - 1)]
+
+    if (length(arg_names) < n_mandatory_f_args) {
+      Warn(sprintf("`f` only takes %s positional arguments before the `...` args, but %s were expected; this can lead to obtuse errors downstream", length(arg_names), n_mandatory_f_args),
+          class="check_sufficient_f_args__f_needs_min_args_before_dots",
+          epiprocess__f = f,
+          epiprocess__arg_names = arg_names)
+    }
+  } else {
+    if (length(arg_names) < n_mandatory_f_args) {
+      Abort(sprintf("`f` must take at least %s arguments", n_mandatory_f_args),
+          class="check_sufficient_f_args__f_needs_min_args",
+          epiprocess__f = f,
+          epiprocess__arg_names = arg_names)
+    }
+  }
+}
+
 ##########
 
 in_range = function(x, rng) pmin(pmax(x, rng[1]), rng[2])

tests/testthat/test-epi_slide.R

@@ -86,3 +86,15 @@ test_that("these doesn't produce an error; the error appears only if the ref tim
                      dplyr::select("geo_value","slide_value_value"), 
                    dplyr::tibble(geo_value = c("ak", "al"), slide_value_value = c(2, -2))) # not out of range for either group
 })
+
+test_that("epi_slide alerts if the provided f doesn't take enough args", {
+  f_xg = function(x, g) dplyr::tibble(value=mean(x$value), count=length(x$value))
+  # If `regexp` is NA, asserts that there should be no errors/messages.
+  expect_error(epi_slide(grouped, f_xg, before = 1L, ref_time_values = d+1), regexp = NA)
+  expect_warning(epi_slide(grouped, f_xg, before = 1L, ref_time_values = d+1), regexp = NA)
+
+  f_x_dots = function(x, ...) dplyr::tibble(value=mean(x$value), count=length(x$value))
+  expect_warning(epi_slide(grouped, f_x_dots, before = 1L, ref_time_values = d+1),
+    regexp = "positional arguments before the `...` args",
+    class = "check_sufficient_f_args__f_needs_min_args_before_dots")
+})

tests/testthat/test-epix_slide.R

@@ -348,3 +348,15 @@ test_that("epix_slide with all_versions option works as intended",{
 
   expect_identical(xx1,xx3) # This and * Imply xx2 and xx3 are identical
 })
+
+test_that("epix_slide alerts if the provided f doesn't take enough args", {
+  f_xg = function(x, g) dplyr::tibble(value=mean(x$binary), count=length(x$binary))
+  # If `regexp` is NA, asserts that there should be no errors/messages.
+  expect_error(epix_slide(xx, f = f_xg, before = 2L), regexp = NA)
+  expect_warning(epix_slide(xx, f = f_xg, before = 2L), regexp = NA)
+
+  f_x_dots = function(x, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary))
+  expect_warning(epix_slide(xx, f_x_dots, before = 2L),
+    regexp = "positional arguments before the `...` args",
+    class = "check_sufficient_f_args__f_needs_min_args_before_dots")
+})

tests/testthat/test-utils.R

@@ -107,4 +107,33 @@ test_that("enlist works",{
   my_list <- enlist(x=1,y=2,z=3)
   expect_equal(my_list$x,1)
   expect_true(inherits(my_list,"list"))
-})
+})
+
+test_that("check_sufficient_f_args alerts if the provided f doesn't take enough args", {
+  f_xg = function(x, g) dplyr::tibble(value=mean(x$binary), count=length(x$binary))
+  f_xg_dots = function(x, g, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary))
+
+  # If `regexp` is NA, asserts that there should be no errors/messages.
+  expect_error(check_sufficient_f_args(f_xg), regexp = NA)
+  expect_warning(check_sufficient_f_args(f_xg), regexp = NA)
+  expect_error(check_sufficient_f_args(f_xg_dots), regexp = NA)
+  expect_warning(check_sufficient_f_args(f_xg_dots), regexp = NA)
+
+  f_x_dots = function(x, ...) dplyr::tibble(value=mean(x$binary), count=length(x$binary))
+  f_dots = function(...) dplyr::tibble(value=c(5), count=c(2))
+  f_x = function(x) dplyr::tibble(value=mean(x$binary), count=length(x$binary))
+  f = function() dplyr::tibble(value=c(5), count=c(2))
+
+  expect_warning(check_sufficient_f_args(f_x_dots),
+    regexp = "positional arguments before the `...` args",
+    class = "check_sufficient_f_args__f_needs_min_args_before_dots")
+  expect_warning(check_sufficient_f_args(f_dots),
+    regexp = "positional arguments before the `...` args",
+    class = "check_sufficient_f_args__f_needs_min_args_before_dots")
+  expect_error(check_sufficient_f_args(f_x),
+    regexp = "`f` must take at least",
+    class = "check_sufficient_f_args__f_needs_min_args")
+  expect_error(check_sufficient_f_args(f),
+    regexp = "`f` must take at least",
+    class = "check_sufficient_f_args__f_needs_min_args")
+})