fix: output filter w/ before=Inf, wrong before/after types

Also change a map -> lapply so we can get srcref to internal error immediately,
add a missed .window_size-missingness check, delete some helper functions that
were sort of helpful but also tacked on significant run time when used in a
natural way.

Author: brookslogan

R/epi_slide_opt_archive.R

@@ -47,15 +47,16 @@
 epi_slide_opt_archive_one_epikey <- function(
     grp_updates,
     in_colnames,
-    f_dots_baked, f_from_package, before, after, time_type,
+    f_dots_baked, f_from_package,
+    before_steps, after_steps, time_type,
     out_colnames) {
   grp_updates_by_version <- grp_updates %>%
     nest(.by = version, .key = "subtbl") %>%
     arrange(version)
   unit_step <- unit_time_delta(time_type, format = "fast")
   prev_inp_snapshot <- NULL
   prev_out_snapshot <- NULL
-  result <- map(seq_len(nrow(grp_updates_by_version)), function(version_i) {
+  result <- lapply(seq_len(nrow(grp_updates_by_version)), function(version_i) {
     version <- grp_updates_by_version$version[[version_i]]
     inp_update <- grp_updates_by_version$subtbl[[version_i]]
     inp_snapshot <- tbl_patch(prev_inp_snapshot, inp_update, "time_value")
@@ -67,9 +68,13 @@ epi_slide_opt_archive_one_epikey <- function(
     # inp_update_min_t - after, or anything in between these two bounds. If
     # before == Inf, we need to update outputs all the way to the end of the
     # input *snapshot*.
-    out_update_min_t <- time_minus_slide_window_arg(inp_update_min_t, after, time_type)
-    out_update_max_t <- time_plus_slide_window_arg(inp_update_max_t, before, time_type, max(inp_snapshot$time_value))
-    out_update <- epi_slide_opt_one_epikey(inp_snapshot, f_dots_baked, f_from_package, before, after, unit_step, time_type, c(out_update_min_t, out_update_max_t), NULL, in_colnames, out_colnames)
+    out_update_min_t <- inp_update_min_t - after_steps * unit_step
+    if (before_steps == Inf) {
+      out_update_max_t <- max(inp_snapshot$time_value)
+    } else {
+      out_update_max_t <- inp_update_max_t + before_steps * unit_step
+    }
+    out_update <- epi_slide_opt_one_epikey(inp_snapshot, f_dots_baked, f_from_package, before_steps, after_steps, unit_step, time_type, c(out_update_min_t, out_update_max_t), NULL, in_colnames, out_colnames)
     out_diff <- tbl_diff2(prev_out_snapshot, out_update, "time_value", "update")
     prev_inp_snapshot <<- inp_snapshot
     prev_out_snapshot <<- tbl_patch(prev_out_snapshot, out_diff, "time_value")
@@ -118,11 +123,19 @@ epi_slide_opt.epi_archive <-
         purrr::partial(.f, ...)
       }
     col_names_quo <- enquo(.col_names)
+    if (is.null(.window_size)) {
+      cli_abort(
+        "epi_slide_opt: `.window_size` must be specified.",
+        class = "epiprocess__epi_slide_opt__window_size_missing"
+      )
+    }
     names_info <- across_ish_names_info(
       .x$DT, time_type, col_names_quo, .f_info$namer,
       .window_size, .align, .prefix, .suffix, .new_col_names
     )
     window_args <- get_before_after_from_window(.window_size, .align, time_type)
+    before_steps <- time_delta_to_n_steps(window_args$before, time_type)
+    after_steps <- time_delta_to_n_steps(window_args$after, time_type)
     if (!is.null(.ref_time_values)) {
       cli_abort("epi_slide.epi_archive does not support the `.ref_time_values` argument",
         class = "epiprocess__epi_slide_opt_archive__ref_time_values_unsupported"
@@ -154,7 +167,7 @@ epi_slide_opt.epi_archive <-
         res <- epi_slide_opt_archive_one_epikey(
           group_values,
           names_info$input_col_names,
-          .f_dots_baked, .f_info$from_package, window_args$before, window_args$after, time_type,
+          .f_dots_baked, .f_info$from_package, before_steps, after_steps, time_type,
           names_info$output_col_names
         )
         if (use_progress) cli::cli_progress_update(id = progress_bar_id)

R/epi_slide_opt_edf.R

@@ -168,9 +168,12 @@ across_ish_names_info <- function(.x, time_type, col_names_quo, .f_namer,
 }
 
 epi_slide_opt_one_epikey <- function(inp_tbl,
-                                     f_dots_baked, f_from_package, before, after, unit_step, time_type,
+                                     f_dots_baked, f_from_package,
+                                     before_steps, after_steps, unit_step, time_type,
                                      out_filter_time_range, out_filter_time_set,
                                      in_colnames, out_colnames) {
+  # TODO rename function, reorder args, roxygen2
+  #
   # TODO try converting time values to reals, do work on reals, convert back at very end?
   #
   # TODO loosen restrictions here.  each filter optional?
@@ -187,8 +190,14 @@ epi_slide_opt_one_epikey <- function(inp_tbl,
   } else {
     cli_abort("Exactly one of `out_filter_time_range` and `out_filter_time_set` must be non-`NULL`.")
   }
-  slide_t_min <- time_minus_slide_window_arg(out_t_min, before, time_type, min(inp_tbl$time_value))
-  slide_t_max <- time_plus_slide_window_arg(out_t_max, after, time_type)
+  if (before_steps == Inf) {
+    slide_t_min <- min(inp_tbl$time_value)
+    slide_start_padding_n <- time_minus_time_in_n_steps(out_t_min, slide_t_min, time_type)
+  } else {
+    slide_t_min <- out_t_min - before_steps * unit_step
+    slide_start_padding_n <- before_steps # perf: avoid time_minus_time_in_n_steps
+  }
+  slide_t_max <- out_t_max + after_steps * unit_step
   slide_nrow <- time_delta_to_n_steps(slide_t_max - slide_t_min, time_type) + 1L
   slide_time_values <- slide_t_min + 0L:(slide_nrow - 1L) * unit_step
   slide_inp_backrefs <- vec_match(slide_time_values, inp_tbl$time_value)
@@ -200,37 +209,41 @@ epi_slide_opt_one_epikey <- function(inp_tbl,
   # try removing time_value column before slice?
   slide$time_value <- slide_time_values
   if (f_from_package == "data.table") {
-    if (before == Inf) {
+    if (before_steps == Inf) {
       slide[, out_colnames] <-
         f_dots_baked(slide[, in_colnames], seq_len(slide_nrow), adaptive = TRUE)
     } else {
-      out_cols <- f_dots_baked(slide[, in_colnames], before + after + 1L)
-      if (after != 0L) {
+      out_cols <- f_dots_baked(slide[, in_colnames], before_steps + after_steps + 1L)
+      if (after_steps != 0L) {
         # Shift an appropriate amount of NA padding from the start to the end.
         # (This padding will later be cut off when we filter down to the
         # original time_values.)
         out_cols <- lapply(out_cols, function(out_col) {
-          c(out_col[(after + 1L):length(out_col)], rep(NA, after))
+          c(out_col[(after_steps + 1L):length(out_col)], rep(NA, after_steps))
         })
       }
       slide[, out_colnames] <- out_cols
     }
   } else if (f_from_package == "slider") {
     for (col_i in seq_along(in_colnames)) {
-      slide[[out_colnames[[col_i]]]] <- f_dots_baked(slide[[in_colnames[[col_i]]]], before = before, after = after)
+      slide[[out_colnames[[col_i]]]] <- f_dots_baked(slide[[in_colnames[[col_i]]]], before = before_steps, after = after_steps)
     }
   } else {
     cli_abort(
       "epiprocess internal error: `f_from_package` was {format_chr_deparse(f_from_package)}, which is unsupported",
       class = "epiprocess__epi_slide_opt_archive__f_from_package_invalid"
     )
   }
+  # We should filter down the slide time values to ones in the input time values
+  # when preparing the output:
   rows_should_keep1 <- !is.na(slide_inp_backrefs)
-  rows_should_keep2 <- switch(
-    out_filter_time_style,
+  # We also need to apply the out_filter.
+  #
+  # TODO comments + test vs. just using inequality
+  rows_should_keep2 <- switch(out_filter_time_style,
     range = vec_rep_each(
       c(FALSE, TRUE, FALSE),
-      c(before, slide_nrow - before - after, after),
+      c(slide_start_padding_n, slide_nrow - slide_start_padding_n - after_steps, after_steps),
     ),
     set = vec_in(slide_time_values, out_time_values)
   )
@@ -493,12 +506,15 @@ epi_slide_opt.epi_df <- function(.x, .col_names, .f, ...,
   .align <- rlang::arg_match(.align)
   time_type <- attr(.x, "metadata")$time_type
   if (is.null(.window_size)) {
-    cli_abort("epi_slide_opt: `.window_size` must be specified.")
+    cli_abort(
+      "epi_slide_opt: `.window_size` must be specified.",
+      class = "epiprocess__epi_slide_opt__window_size_missing"
+    )
   }
   validate_slide_window_arg(.window_size, time_type)
   window_args <- get_before_after_from_window(.window_size, .align, time_type)
-  before <- time_delta_to_n_steps(window_args$before, time_type)
-  after <- time_delta_to_n_steps(window_args$after, time_type)
+  before_steps <- time_delta_to_n_steps(window_args$before, time_type)
+  after_steps <- time_delta_to_n_steps(window_args$after, time_type)
   unit_step <- unit_time_delta(time_type, format = "fast")
 
   # Handle output naming:
@@ -520,7 +536,7 @@ epi_slide_opt.epi_df <- function(.x, .col_names, .f, ...,
 
   result <- .x %>%
     group_modify(function(grp_data, grp_key) {
-      epi_slide_opt_one_epikey(grp_data, f_dots_baked, f_from_package, before, after, unit_step, time_type, NULL, ref_time_values, names_info$input_col_names, names_info$output_col_names)
+      epi_slide_opt_one_epikey(grp_data, f_dots_baked, f_from_package, before_steps, after_steps, unit_step, time_type, NULL, ref_time_values, names_info$input_col_names, names_info$output_col_names)
     }) %>%
     arrange_col_canonical()
 

R/time-utils.R

@@ -373,32 +373,3 @@ time_plus_n_steps <- function(x, y, time_type) {
 time_minus_n_steps <- function(x, y, time_type) {
   x - y * unit_time_delta(time_type, "fast")
 }
-
-#' Advance/retreat time_value(s) by specified amount (slide window arg)
-#'
-#' @param x a time_value (vector) of time type `time_type`
-#' @param y a (scalar) slide window arg; should pass [`validate_slide_window_arg()`]
-#' @param time_type as in [`validate_slide_window_arg()`]
-#' @param max_time_value when `y == Inf`, what should be the result of adding `y`?
-#' @param min_time_value when `y == Inf`, what should be the result of subtracting `y`?
-#' @return a time_value (vector) of time type `time_type`
-#'
-#' @keywords internal
-#' @seealso [`time_plus_n_steps`], if you're working with an integerish vector
-#'   number of time steps `y` (output from other `*n_steps` functions) instead.
-time_plus_slide_window_arg <- function(x, y, time_type, max_time_value) {
-  if (y == Inf) {
-    rep(max_time_value, vec_size(x))
-  } else {
-    x + y
-  }
-}
-
-#' @rdname time_plus_slide_window_arg
-time_minus_slide_window_arg <- function(x, y, time_type, min_time_value) {
-  if (y == Inf) {
-    rep(min_time_value, vec_size(x))
-  } else {
-    x - y
-  }
-}