feat(epi[x]_slide): hint on forgotten syntax specifying comp

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: epiprocess
 Title: Tools for basic signal processing in epidemiology
-Version: 0.9.1
+Version: 0.9.3
 Authors@R: c(
     person("Jacob", "Bien", role = "ctb"),
     person("Logan", "Brooks", , "[email protected]", role = c("aut", "cre")),

NEWS.md

@@ -2,6 +2,21 @@
 
 Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.x.y will indicate PR's.
 
+# epiprocess 0.10
+
+## Breaking changes
+
+- Removed `.window_size = 1` default from `epi_slide_{mean,sum,opt}`; this
+  argument is now mandatory, and should nearly always be greater than 1 except
+  for testing purposes.
+
+## Improvements
+
+- `epi_slide` and `epix_slide` now provide some hints if you forget a `~` when
+  using a formula to specify the slide computation, and other bits of forgotten
+  syntax.
+- Improved validation of `.window_size` arguments.
+
 # epiprocess 0.9
 
 ## Breaking changes

R/grouped_epi_archive.R

@@ -312,14 +312,15 @@ epix_slide.grouped_epi_archive <- function(
       cli_abort("If `f` is missing then a computation must be specified via `...`.")
     }
 
-    .slide_comp <- as_diagonal_slide_computation(quosures)
+    .f_arg <- ".f" # dummy val, shouldn't be used since we're not using `.f`
+    .slide_comp <- as_diagonal_slide_computation(quosures, .f_arg = .f_arg)
     # Magic value that passes zero args as dots in calls below. Equivalent to
     # `... <- missing_arg()`, but use `assign` to avoid warning about
     # improper use of dots.
     assign("...", missing_arg())
   } else {
     used_data_masking <- FALSE
-    .slide_comp <- as_diagonal_slide_computation(.f, ...)
+    .slide_comp <- as_diagonal_slide_computation(.f, ..., .f_arg = caller_arg(.f))
   }
 
   # Computation for one group, one time value

R/slide.R

@@ -147,14 +147,16 @@ epi_slide <- function(
     }
 
     .f <- quosures
+    .f_arg <- ".f" # dummy val, shouldn't be used since we're not using `.f`
     # Magic value that passes zero args as dots in calls below. Equivalent to
     # `... <- missing_arg()`, but `assign` avoids warning about improper use of
     # dots.
     assign("...", missing_arg())
   } else {
     used_data_masking <- FALSE
+    .f_arg <- caller_arg(.f)
   }
-  .slide_comp <- as_time_slide_computation(.f, ...)
+  .slide_comp <- as_time_slide_computation(.f, ..., .f_arg = .f_arg)
 
   .align <- rlang::arg_match(.align)
   time_type <- attr(.x, "metadata")$time_type
@@ -576,7 +578,7 @@ get_before_after_from_window <- function(window_size, align, time_type) {
 #'   ungroup()
 epi_slide_opt <- function(
     .x, .col_names, .f, ...,
-    .window_size = 1, .align = c("right", "center", "left"),
+    .window_size = NULL, .align = c("right", "center", "left"),
     .ref_time_values = NULL, .all_rows = FALSE) {
   assert_class(.x, "epi_df")
 
@@ -678,46 +680,16 @@ epi_slide_opt <- function(
   ref_time_values <- sort(.ref_time_values)
 
   # Handle window arguments
-  align <- rlang::arg_match(.align)
+  .align <- rlang::arg_match(.align)
   time_type <- attr(.x, "metadata")$time_type
-  validate_slide_window_arg(.window_size, time_type)
-  if (identical(.window_size, Inf)) {
-    if (align == "right") {
-      before <- Inf
-      if (time_type %in% c("day", "week")) {
-        after <- as.difftime(0, units = glue::glue("{time_type}s"))
-      } else {
-        after <- 0
-      }
-    } else {
-      cli_abort(
-        "`epi_slide`: center and left alignment are not supported with an infinite window size."
-      )
-    }
-  } else {
-    if (align == "right") {
-      before <- .window_size - 1
-      if (time_type %in% c("day", "week")) {
-        after <- as.difftime(0, units = glue::glue("{time_type}s"))
-      } else {
-        after <- 0
-      }
-    } else if (align == "center") {
-      # For .window_size = 5, before = 2, after = 2. For .window_size = 4, before = 2, after = 1.
-      before <- floor(.window_size / 2)
-      after <- .window_size - before - 1
-    } else if (align == "left") {
-      if (time_type %in% c("day", "week")) {
-        before <- as.difftime(0, units = glue::glue("{time_type}s"))
-      } else {
-        before <- 0
-      }
-      after <- .window_size - 1
-    }
+  if (is.null(.window_size)) {
+    cli_abort("epi_slide_opt: `.window_size` must be specified.")
   }
+  validate_slide_window_arg(.window_size, time_type)
+  window_args <- get_before_after_from_window(.window_size, .align, time_type)
 
   # Make a complete date sequence between min(.x$time_value) and max(.x$time_value).
-  date_seq_list <- full_date_seq(.x, before, after, time_type)
+  date_seq_list <- full_date_seq(.x, window_args$before, window_args$after, time_type)
   all_dates <- date_seq_list$all_dates
   pad_early_dates <- date_seq_list$pad_early_dates
   pad_late_dates <- date_seq_list$pad_late_dates
@@ -786,16 +758,16 @@ epi_slide_opt <- function(
       # `before` and `after` params. Right-aligned `frollmean` results'
       # `ref_time_value`s will be `after` timesteps ahead of where they should
       # be; shift results to the left by `after` timesteps.
-      if (before != Inf) {
-        window_size <- before + after + 1L
+      if (window_args$before != Inf) {
+        window_size <- window_args$before + window_args$after + 1L
         roll_output <- .f(x = .data_group[, col_names_chr], n = window_size, ...)
       } else {
         window_size <- list(seq_along(.data_group$time_value))
         roll_output <- .f(x = .data_group[, col_names_chr], n = window_size, adaptive = TRUE, ...)
       }
-      if (after >= 1) {
+      if (window_args$after >= 1) {
         .data_group[, result_col_names] <- purrr::map(roll_output, function(.x) {
-          c(.x[(after + 1L):length(.x)], rep(NA, after))
+          c(.x[(window_args$after + 1L):length(.x)], rep(NA, window_args$after))
         })
       } else {
         .data_group[, result_col_names] <- roll_output
@@ -805,8 +777,8 @@ epi_slide_opt <- function(
       for (i in seq_along(col_names_chr)) {
         .data_group[, result_col_names[i]] <- .f(
           x = .data_group[[col_names_chr[i]]],
-          before = as.numeric(before),
-          after = as.numeric(after),
+          before = as.numeric(window_args$before),
+          after = as.numeric(window_args$after),
           ...
         )
       }
@@ -902,7 +874,7 @@ epi_slide_opt <- function(
 #'   ungroup()
 epi_slide_mean <- function(
     .x, .col_names, ...,
-    .window_size = 1, .align = c("right", "center", "left"),
+    .window_size = NULL, .align = c("right", "center", "left"),
     .ref_time_values = NULL, .all_rows = FALSE) {
   # Deprecated argument handling
   provided_args <- rlang::call_args_names(rlang::call_match())
@@ -979,7 +951,7 @@ epi_slide_mean <- function(
 #'   ungroup()
 epi_slide_sum <- function(
     .x, .col_names, ...,
-    .window_size = 1, .align = c("right", "center", "left"),
+    .window_size = NULL, .align = c("right", "center", "left"),
     .ref_time_values = NULL, .all_rows = FALSE) {
   # Deprecated argument handling
   provided_args <- rlang::call_args_names(rlang::call_match())

R/utils.R

@@ -358,9 +358,48 @@ assert_sufficient_f_args <- function(.f, ..., .ref_time_value_label) {
 #' @importFrom rlang is_function new_function f_env is_environment missing_arg
 #'  f_rhs is_formula caller_arg caller_env
 #' @keywords internal
-as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_time_value_label) {
-  arg <- caller_arg(.f)
-  call <- caller_env()
+as_slide_computation <- function(.f, ...,
+                                 .f_arg = caller_arg(.f), .call = caller_env(),
+                                 .ref_time_value_long_varnames, .ref_time_value_label) {
+  if (".col_names" %in% rlang::call_args_names(rlang::call_match())) {
+    cli_abort(
+      c("{.code epi_slide} and {.code epix_slide} do not support `.col_names`;
+         consider:",
+        "*" = "using {.code epi_slide_mean}, {.code epi_slide_sum}, or
+               {.code epi_slide_opt}, if applicable",
+        "*" = "using {.code .f = ~ .x %>%
+               dplyr::reframe(across(your_col_names, list(your_func_name = your_func)))}"
+      ),
+      call = .call,
+      class = "epiprocess__as_slide_computation__given_.col_names"
+    )
+  }
+
+  f_arg <- .f_arg # for cli interpolation, avoid dot prefix; # nolint: object_usage_linter
+  withCallingHandlers(
+    {
+      force(.f)
+    },
+    error = function(e) {
+      cli_abort(
+        c("Failed to convert {.code {f_arg}} to a slide computation.",
+          "*" = "If you were trying to use the formula interface,
+                 maybe you forgot a tilde at the beginning.",
+          "*" = "If you were trying to use the tidyeval interface,
+                 maybe you forgot to specify the name,
+                 e.g.: `my_output_col_name =`.  Note that `.col_names`
+                 is not supported.",
+          "*" = "If you were trying to use advanced features of the
+                 tidyeval interface such as `!! name_variable :=`,
+                 maybe you forgot the required leading comma.",
+          "*" = "Something else could have gone wrong; see below."
+        ),
+        parent = e,
+        call = .call,
+        class = "epiprocess__as_slide_computation__error_forcing_.f"
+      )
+    }
+  )
 
   if (rlang::is_quosures(.f)) {
     quosures <- rlang::quos_auto_name(.f) # resolves := among other things
@@ -463,10 +502,10 @@ as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_ti
     }
 
     if (length(.f) > 2) {
-      cli_abort("{.code {arg}} must be a one-sided formula",
+      cli_abort("{.code {f_arg}} must be a one-sided formula",
         class = "epiprocess__as_slide_computation__formula_is_twosided",
         epiprocess__f = .f,
-        call = call
+        .call = .call
       )
     }
     if (rlang::dots_n(...) > 0L) {
@@ -486,7 +525,7 @@ as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_ti
         class = "epiprocess__as_slide_computation__formula_has_no_env",
         epiprocess__f = .f,
         epiprocess__f_env = env,
-        arg = arg, call = call
+        .f_arg = .f_arg, .call = .call
       )
     }
 
@@ -513,26 +552,32 @@ as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_ti
     class = "epiprocess__as_slide_computation__cant_convert_catchall",
     epiprocess__f = .f,
     epiprocess__f_class = class(.f),
-    arg = arg,
-    call = call
+    .f_arg = .f_arg,
+    .call = .call
   )
 }
 
 #' @rdname as_slide_computation
+#' @importFrom rlang caller_arg caller_env
 #' @keywords internal
-as_time_slide_computation <- function(.f, ...) {
+as_time_slide_computation <- function(.f, ..., .f_arg = caller_arg(.f), .call = caller_env()) {
   as_slide_computation(
     .f, ...,
+    .f_arg = .f_arg,
+    .call = .call,
     .ref_time_value_long_varnames = ".ref_time_value",
     .ref_time_value_label = "reference time value"
   )
 }
 
 #' @rdname as_slide_computation
+#' @importFrom rlang caller_arg caller_env
 #' @keywords internal
-as_diagonal_slide_computation <- function(.f, ...) {
+as_diagonal_slide_computation <- function(.f, ..., .f_arg = caller_arg(.f), .call = caller_env()) {
   as_slide_computation(
     .f, ...,
+    .f_arg = .f_arg,
+    .call = .call,
     .ref_time_value_long_varnames = c(".version", ".ref_time_value"),
     .ref_time_value_label = "version"
   )
@@ -982,14 +1027,28 @@ guess_period.POSIXt <- function(time_values, time_values_arg = rlang::caller_arg
   as.numeric(NextMethod(), units = "secs")
 }
 
-validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRUE, arg_name = rlang::caller_arg(arg)) {
-  if (!checkmate::test_scalar(arg) || arg < lower) {
-    cli_abort(
-      "Slide function expected `{arg_name}` to be a non-null, scalar integer >= {lower}.",
-      class = "epiprocess__validate_slide_window_arg"
-    )
+#' Is `x` an "int" with a sensible class? TRUE/FALSE
+#'
+#' Like [`checkmate::test_int`] but disallowing some non-sensible classes that
+#' `test_int` accepts, such as `difftime`s. We rely on [`is.numeric`] to
+#' determine class appropriateness; note that `is.numeric` is NOT simply
+#' checking for the class to be "numeric" (or else we'd fail on integer class).
+#'
+#' @param x object
+#' @return Boolean
+#'
+#' @importFrom checkmate test_int
+#' @keywords internal
+test_sensible_int <- function(x, na.ok = FALSE, lower = -Inf, upper = Inf, # nolint: object_name_linter
+                              tol = sqrt(.Machine$double.eps), null.ok = FALSE) { # nolint: object_name_linter
+  if (null.ok && is.null(x)) {
+    TRUE
+  } else {
+    is.numeric(x) && test_int(x, na.ok = na.ok, lower = lower, upper = upper, tol = tol)
   }
+}
 
+validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRUE, arg_name = rlang::caller_arg(arg)) {
   if (time_type == "custom") {
     cli_abort(
       "Unsure how to interpret slide units with a custom time type. Consider converting your time
@@ -999,31 +1058,45 @@ validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRU
   }
 
   msg <- ""
-  if (!identical(arg, Inf)) {
-    if (time_type == "day") {
-      if (!test_int(arg, lower = 0L) && !(inherits(arg, "difftime") && units(arg) == "days")) {
-        msg <- glue::glue_collapse(c("difftime with units in days", "non-negative integer", "Inf"), " or ")
-      }
-    } else if (time_type == "week") {
-      if (!(inherits(arg, "difftime") && units(arg) == "weeks")) {
-        msg <- glue::glue_collapse(c("difftime with units in weeks", "Inf"), " or ")
-      }
-    } else if (time_type == "yearmonth") {
-      if (!test_int(arg, lower = 0L) || inherits(arg, "difftime")) {
-        msg <- glue::glue_collapse(c("non-negative integer", "Inf"), " or ")
-      }
-    } else if (time_type == "integer") {
-      if (!test_int(arg, lower = 0L) || inherits(arg, "difftime")) {
-        msg <- glue::glue_collapse(c("non-negative integer", "Inf"), " or ")
-      }
-    } else {
-      msg <- glue::glue_collapse(c("difftime", "non-negative integer", "Inf"), " or ")
-    }
+  inf_if_okay <- if (allow_inf) {
+    "Inf"
   } else {
-    if (!allow_inf) {
-      msg <- glue::glue_collapse(c("a difftime", "a non-negative integer"), " or ")
+    character(0L)
+  }
+
+  # nolint start: indentation_linter.
+  if (time_type == "day") {
+    if (!(test_sensible_int(arg, lower = lower) ||
+      inherits(arg, "difftime") && length(arg) == 1L && units(arg) == "days" ||
+      allow_inf && identical(arg, Inf)
+    )) {
+      msg <- glue::glue_collapse(c("length-1 difftime with units in days", "non-negative integer", inf_if_okay), " or ")
+    }
+  } else if (time_type == "week") {
+    if (!(inherits(arg, "difftime") && length(arg) == 1L && units(arg) == "weeks" ||
+      allow_inf && identical(arg, Inf)
+    )) {
+      msg <- glue::glue_collapse(c("length-1 difftime with units in weeks", inf_if_okay), " or ")
+    }
+  } else if (time_type == "yearmonth") {
+    if (!(test_sensible_int(arg, lower = lower) ||
+      allow_inf && identical(arg, Inf)
+    )) {
+      msg <- glue::glue_collapse(c("non-negative integer", inf_if_okay), " or ")
     }
+  } else if (time_type == "integer") {
+    if (!(test_sensible_int(arg, lower = lower) ||
+      allow_inf && identical(arg, Inf)
+    )) {
+      msg <- glue::glue_collapse(c("non-negative integer", inf_if_okay), " or ")
+    }
+  } else {
+    cli_abort('`epiprocess` internal error: unrecognized time_type: "{time_type}"',
+      class = "epiprocess__unrecognized_time_type"
+    )
   }
+  # nolint end
+
   if (msg != "") {
     cli_abort(
       "Slide function expected `{arg_name}` to be a {msg}.",