Merge branch 'dev' into lcb/make_epix_slide_more_like_reframe

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

@@ -86,13 +86,15 @@ importFrom(dplyr,ungroup)
 importFrom(lubridate,days)
 importFrom(lubridate,weeks)
 importFrom(magrittr,"%>%")
+importFrom(purrr,map_lgl)
 importFrom(rlang,"!!!")
 importFrom(rlang,"!!")
 importFrom(rlang,.data)
 importFrom(rlang,.env)
 importFrom(rlang,arg_match)
 importFrom(rlang,enquo)
 importFrom(rlang,enquos)
+importFrom(rlang,is_missing)
 importFrom(rlang,is_quosure)
 importFrom(rlang,quo_is_missing)
 importFrom(rlang,sym)
@@ -104,3 +106,4 @@ importFrom(tidyr,unnest)
 importFrom(tidyselect,eval_select)
 importFrom(tidyselect,starts_with)
 importFrom(tsibble,as_tsibble)
+importFrom(utils,tail)

R/data.R

@@ -65,7 +65,7 @@
 #'
 #' Modifications:
 #' * \href{https://cmu-delphi.github.io/delphi-epidata/api/covidcast-signals/doctor-visits.html}{From the COVIDcast Doctor Visits API}: The signal `percent_cli` is taken directly from the API without changes.
-#' * \href{https://cmu-delphi.github.io/delphi-epidata/api/covidcast-signals/jhu-csse.html}{From the COVIDcast Epidata API}: `case_rate_7d_av` is taken directly from the JHU CSSE \href{https://github.com/CSSEGISandData/COVID-19}{COVID-19 GitHub repository} without changes. The 7-day average signals are computed by Delphi by calculating moving averages of the preceding 7 days, so the signal for June 7 is the average of the underlying data for June 1 through 7, inclusive.
+#' * \href{https://cmu-delphi.github.io/delphi-epidata/api/covidcast-signals/jhu-csse.html}{From the COVIDcast Epidata API}: `case_rate_7d_av` signal was computed by Delphi from the original JHU-CSSE data by calculating moving averages of the preceding 7 days, so the signal for June 7 is the average of the underlying data for June 1 through 7, inclusive.
 #' * Furthermore, the data is a subset of the full dataset, the signal names slightly altered, and formatted into a tibble.
 #'
 #' @export

R/grouped_epi_archive.R

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

R/methods-epi_archive.R

@@ -800,6 +800,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),
@@ -811,39 +813,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, g) {
+#'      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, g) {
 #'       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

@@ -156,7 +156,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)) {
+    assert_sufficient_f_args(f, ...)
+  }
+
   # Arrange by increasing time_value
   x = arrange(x, time_value)
 

R/utils.R

@@ -100,6 +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: "), ...)
 
+#' 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`.
+#'
+#' @importFrom rlang is_missing
+#' @importFrom purrr map_lgl
+#' @importFrom utils tail
+#'
+#' @noRd
+assert_sufficient_f_args <- function(f, ...) {
+  mandatory_f_args_labels <- c("window data", "group key")
+  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 `...`
+    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 { # `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)
+  }
+}
+
 ##########
 
 in_range = function(x, rng) pmin(pmax(x, rng[1]), rng[2])

data-raw/archive_cases_dv_subset.R

@@ -12,7 +12,7 @@ dv_subset <- covidcast(
   geo_values = "ca,fl,ny,tx",
   issues = epirange(20200601, 20211201)
 ) %>%
-  fetch_tbl() %>%
+  fetch() %>%
   select(geo_value, time_value, version = issue, percent_cli = value) %>%
   # We're using compactify=FALSE here and below to avoid some testthat test
   # failures on tests that were based on a non-compactified version.
@@ -27,7 +27,7 @@ case_rate_subset <- covidcast(
   geo_values = "ca,fl,ny,tx",
   issues = epirange(20200601, 20211201)
 ) %>%
-  fetch_tbl() %>%
+  fetch() %>%
   select(geo_value, time_value, version = issue, case_rate_7d_av = value) %>%
   as_epi_archive(compactify=FALSE)
 

data-raw/incidence_num_outlier_example.R

@@ -12,7 +12,7 @@ incidence_num_outlier_example <- covidcast(
   geo_values = "fl,nj",
   as_of = 20211028
 ) %>%
-  fetch_tbl() %>%
+  fetch() %>%
   select(geo_value, time_value, cases = value) %>%
   as_epi_df()
 

data-raw/jhu_csse_county_level_subset.R

@@ -17,7 +17,7 @@ jhu_csse_county_level_subset <- covidcast(
   time_values = epirange(20200601, 20211231),
   geo_values = paste(y$geo_value, collapse = ",")
 ) %>%
-  fetch_tbl() %>%
+  fetch() %>%
   select(geo_value, time_value, cases = value) %>%
   full_join(y, by = "geo_value") %>%
   as_epi_df()