Merge branch 'dev' into ndefries/epix-slide-pass-reftimevalue-without-env

Author: nmdefries

DESCRIPTION

@@ -21,7 +21,8 @@ Description: This package introduces a common data structure for epidemiological
     work with revisions to these data sets over time, and offers associated
     utilities to perform basic signal processing tasks.
 License: MIT + file LICENSE
-Imports: 
+Imports:
+    cli,
     data.table,
     dplyr (>= 1.0.0),
     fabletools,
@@ -48,7 +49,7 @@ Suggests:
     knitr,
     outbreaks,
     rmarkdown,
-    testthat (>= 3.0.0),
+    testthat (>= 3.1.5),
     waldo (>= 0.3.1),
     withr
 VignetteBuilder: 

NAMESPACE

@@ -85,6 +85,7 @@ importFrom(dplyr,ungroup)
 importFrom(lubridate,days)
 importFrom(lubridate,weeks)
 importFrom(magrittr,"%>%")
+importFrom(purrr,map_lgl)
 importFrom(rlang,"!!!")
 importFrom(rlang,"!!")
 importFrom(rlang,.data)
@@ -102,6 +103,7 @@ importFrom(rlang,f_rhs)
 importFrom(rlang,is_environment)
 importFrom(rlang,is_formula)
 importFrom(rlang,is_function)
+importFrom(rlang,is_missing)
 importFrom(rlang,is_quosure)
 importFrom(rlang,is_string)
 importFrom(rlang,missing_arg)
@@ -118,3 +120,4 @@ importFrom(tidyr,unnest)
 importFrom(tidyselect,eval_select)
 importFrom(tidyselect,starts_with)
 importFrom(tsibble,as_tsibble)
+importFrom(utils,tail)

R/grouped_epi_archive.R

@@ -222,7 +222,7 @@ grouped_epi_archive =
 
             # Check that `f` takes enough args
             if (!missing(f) && is.function(f)) {
-              check_sufficient_f_args(f, 3L)
+              assert_sufficient_f_args(f, ..., n_mandatory_f_args = 3L)
             }
 
             # Validate and pre-process `before`:

R/methods-epi_archive.R

@@ -793,6 +793,8 @@ group_by.epi_archive = function(.data, ..., .add=FALSE, .drop=dplyr::group_by_dr
 #'                        as.Date("2020-06-15"),
 #'                        by = "1 day")
 #'
+#' # A simple (but not very useful) example (see the archive vignette for a more
+#' # realistic one):
 #' archive_cases_dv_subset %>%
 #'   group_by(geo_value) %>%
 #'   epix_slide(f = ~ mean(.x$case_rate_7d_av),
@@ -804,39 +806,71 @@ group_by.epi_archive = function(.data, ..., .add=FALSE, .drop=dplyr::group_by_dr
 #' # values. The actual number of `time_value`s in each computation depends on
 #' # the reporting latency of the signal and `time_value` range covered by the
 #' # archive (2020-06-01 -- 2021-11-30 in this example).  In this case, we have
-#' # 0 `time_value`s, for ref time 2020-06-01 --> the result is automatically discarded
-#' # 1 `time_value`, for ref time 2020-06-02
-#' # 2 `time_value`s, for the rest of the results
-#' # never 3 `time_value`s, due to data latency
-#'
-#'
+#' # * 0 `time_value`s, for ref time 2020-06-01 --> the result is automatically
+#' #                                                discarded
+#' # * 1 `time_value`, for ref time 2020-06-02
+#' # * 2 `time_value`s, for the rest of the results
+#' # * never the 3 `time_value`s we would get from `epi_slide`, since, because
+#' #   of data latency, we'll never have an observation
+#' #   `time_value == ref_time_value` as of `ref_time_value`.
+#' # The example below shows this type of behavior in more detail.
+#'
+#' # Examining characteristics of the data passed to each computation with
+#' # `all_versions=FALSE`.
+#' archive_cases_dv_subset %>%
+#'  group_by(geo_value) %>%
+#'  epix_slide(
+#'    function(x, gk, rtv) {
+#'      tibble(
+#'        time_range = if(nrow(x) == 0L) {
+#'          "0 `time_value`s"
+#'        } else {
+#'          sprintf("%s -- %s", min(x$time_value), max(x$time_value))
+#'        },
+#'        n = nrow(x),
+#'        class1 = class(x)[[1L]]
+#'      )
+#'    },
+#'    before = 5, all_versions = FALSE,
+#'    ref_time_values = ref_time_values, names_sep=NULL) %>%
+#'  ungroup() %>%
+#'  arrange(geo_value, time_value)
 #'
 #' # --- Advanced: ---
 #'
 #' # `epix_slide` with `all_versions=FALSE` (the default) applies a
 #' # version-unaware computation to several versions of the data. We can also
 #' # use `all_versions=TRUE` to apply a version-*aware* computation to several
-#' # versions of the data. In this case, each computation should expect an
+#' # versions of the data, again looking at characteristics of the data passed
+#' # to each computation. In this case, each computation should expect an
 #' # `epi_archive` containing the relevant version data:
 #'
 #' archive_cases_dv_subset %>%
 #'   group_by(geo_value) %>%
 #'   epix_slide(
 #'     function(x, gk, rtv) {
 #'       tibble(
-#'         versions_end = max(x$versions_end),
+#'         versions_start = if (nrow(x$DT) == 0L) {
+#'           "NA (0 rows)"
+#'         } else {
+#'           toString(min(x$DT$version))
+#'         },
+#'         versions_end = x$versions_end,
 #'         time_range = if(nrow(x$DT) == 0L) {
 #'           "0 `time_value`s"
 #'         } else {
 #'           sprintf("%s -- %s", min(x$DT$time_value), max(x$DT$time_value))
 #'         },
+#'         n = nrow(x$DT),
 #'         class1 = class(x)[[1L]]
 #'       )
 #'     },
-#'     before = 2, all_versions = TRUE,
+#'     before = 5, all_versions = TRUE,
 #'     ref_time_values = ref_time_values, names_sep=NULL) %>%
 #'   ungroup() %>%
-#'   arrange(geo_value, time_value)
+#'   # Focus on one geo_value so we can better see the columns above:
+#'   filter(geo_value == "ca") %>%
+#'   select(-geo_value)
 #'
 #' @importFrom rlang enquo !!!
 #' @export

R/slide.R

@@ -158,7 +158,7 @@ epi_slide = function(x, f, ..., before, after, ref_time_values,
 
   # Check that `f` takes enough args
   if (!missing(f) && is.function(f)) {
-    check_sufficient_f_args(f)
+    assert_sufficient_f_args(f, ...)
   }
 
   # Arrange by increasing time_value

R/utils.R

@@ -100,35 +100,87 @@ 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
+#' Assert 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`.
+#' @param ... Dots that will be forwarded to `f` from the dots of `epi_slide` or
+#'   `epix_slide`.
 #' @param n_mandatory_f_args Integer; specifies the number of arguments `f`
 #'  is required to take before any `...` arg. Defaults to 2.
 #'
+#' @importFrom rlang is_missing
+#' @importFrom purrr map_lgl
+#' @importFrom utils tail
+#'
 #' @noRd
-check_sufficient_f_args <- function(f, n_mandatory_f_args = 2L) {
-  arg_names = names(formals(args(f)))
-  if ("..." %in% arg_names) {
+assert_sufficient_f_args <- function(f, ..., n_mandatory_f_args = 2L) {
+  mandatory_f_args_labels <- c("window data", "group key", "reference time value")[seq(n_mandatory_f_args)]
+  n_mandatory_f_args <- length(mandatory_f_args_labels)
+  args = formals(args(f))
+  args_names = names(args)
+  # Remove named arguments forwarded from `epi[x]_slide`'s `...`:
+  forwarded_dots_names = names(rlang::call_match(dots_expand = FALSE)[["..."]])
+  args_matched_in_dots =
+    # positional calling args will skip over args matched by named calling args
+    args_names %in% forwarded_dots_names &
+    # extreme edge case: `epi[x]_slide(<stuff>, dot = 1, `...` = 2)`
+    args_names != "..."
+  remaining_args = args[!args_matched_in_dots]
+  remaining_args_names = names(remaining_args)
+  # note that this doesn't include unnamed args forwarded through `...`.
+  dots_i <- which(remaining_args_names == "...") # integer(0) if no match
+  n_f_args_before_dots <- dots_i - 1L
+  if (length(dots_i) != 0L) { # `f` has a dots "arg"
     # 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)
+    mandatory_args_mapped_names <- remaining_args_names[seq_len(n_f_args_before_dots)]
+
+    if (n_f_args_before_dots < n_mandatory_f_args) {
+      mandatory_f_args_in_f_dots =
+        tail(mandatory_f_args_labels, n_mandatory_f_args - n_f_args_before_dots)
+      cli::cli_warn(
+        "`f` might not have enough positional arguments before its `...`; in the current `epi[x]_slide` call, the {mandatory_f_args_in_f_dots} will be included in `f`'s `...`; if `f` doesn't expect those arguments, it may produce confusing error messages",
+        class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots",
+        epiprocess__f = f,
+        epiprocess__mandatory_f_args_in_f_dots = mandatory_f_args_in_f_dots
+      )
     }
-  } 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)
+  } else { # `f` doesn't have a dots "arg"
+    if (length(args_names) < n_mandatory_f_args + rlang::dots_n(...)) {
+      # `f` doesn't take enough args.
+      if (rlang::dots_n(...) == 0L) {
+        # common case; try for friendlier error message
+        Abort(sprintf("`f` must take at least %s arguments", n_mandatory_f_args),
+              class = "epiprocess__assert_sufficient_f_args__f_needs_min_args",
+              epiprocess__f = f)
+      } else {
+        # less common; highlight that they are (accidentally?) using dots forwarding
+        Abort(sprintf("`f` must take at least %s arguments plus the %s arguments forwarded through `epi[x]_slide`'s `...`, or a named argument to `epi[x]_slide` was misspelled", n_mandatory_f_args, rlang::dots_n(...)),
+              class = "epiprocess__assert_sufficient_f_args__f_needs_min_args_plus_forwarded",
+              epiprocess__f = f)
+      }
     }
   }
+  # Check for args with defaults that are filled with mandatory positional
+  # calling args. If `f` has fewer than n_mandatory_f_args before `...`, then we
+  # only need to check those args for defaults. Note that `n_f_args_before_dots` is
+  # length 0 if `f` doesn't accept `...`.
+  n_remaining_args_for_default_check = min(c(n_f_args_before_dots, n_mandatory_f_args))
+  default_check_args = remaining_args[seq_len(n_remaining_args_for_default_check)]
+  default_check_args_names = names(default_check_args)
+  has_default_replaced_by_mandatory = map_lgl(default_check_args, ~!is_missing(.x))
+  if (any(has_default_replaced_by_mandatory)) {
+    default_check_mandatory_args_labels =
+      mandatory_f_args_labels[seq_len(n_remaining_args_for_default_check)]
+    # ^ excludes any mandatory args absorbed by f's `...`'s:
+    mandatory_args_replacing_defaults =
+      default_check_mandatory_args_labels[has_default_replaced_by_mandatory]
+    args_with_default_replaced_by_mandatory =
+      rlang::syms(default_check_args_names[has_default_replaced_by_mandatory])
+    cli::cli_abort("`epi[x]_slide` would pass the {mandatory_args_replacing_defaults} to `f`'s {args_with_default_replaced_by_mandatory} argument{?s}, which {?has a/have} default value{?s}; we suspect that `f` doesn't expect {?this arg/these args} at all and may produce confusing error messages.  Please add additional arguments to `f` or remove defaults as appropriate.",
+                   class = "epiprocess__assert_sufficient_f_args__required_args_contain_defaults",
+                   epiprocess__f = f)
+  }
 }
 
 #' Convert to function

man/epix_slide.Rd

@@ -95,6 +95,5 @@ test_that("epi_slide alerts if the provided f doesn't take enough args", {
 
   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")
+    class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots")
 })

tests/testthat/test-epi_slide.R

@@ -357,8 +357,7 @@ test_that("epix_slide alerts if the provided f doesn't take enough args", {
 
   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")
+    class = "epiprocess__assert_sufficient_f_args__mandatory_f_args_passed_to_f_dots")
 })
 
 test_that("epix_slide computation can use ref_time_value", {