non-shift a noop, NA robust max_time

Author: dsweber2

R/epi_shift.R

@@ -42,6 +42,10 @@ get_sign <- function(object) {
 add_shifted_columns <- function(new_data, object) {
   grid <- object$shift_grid
 
+  if (nrow(object$shift_grid) == 0) {
+    # we're not shifting any rows, so this is a no-op
+    return(new_data)
+  }
   ## ensure no name clashes
   new_data_names <- colnames(new_data)
   intersection <- new_data_names %in% grid$newname

R/step_adjust_latency.R

@@ -317,8 +317,6 @@ bake.step_adjust_latency <- function(object, new_data, ...) {
   if (!inherits(new_data, "epi_df") || is.null(attributes(new_data)$metadata$as_of)) {
     new_data <- as_epi_df(new_data, as_of = object$forecast_date, other_keys = object$metadata$other_keys %||% character())
     attributes(new_data)$metadata <- object$metadata
-    attributes(new_data)$metadata$as_of <- object$forecast_date
-  } else {
     compare_bake_prep_latencies(object, new_data)
   }
   if (object$method == "locf") {

R/step_epi_shift.R

@@ -192,15 +192,6 @@ prep.step_epi_lag <- function(x, training, info = NULL, ...) {
   } else {
     shift_grid <- x$shift_grid
   }
-  if (nrow(shift_grid) == 0) {
-    cli_warn(
-      c(
-        "prepping no columns!",
-        "{x$terms} returns no columns for this dataset."
-      ),
-      class = "epipredict__step_epi_lag__no_columns_shifted"
-    )
-  }
 
   step_epi_lag_new(
     terms = x$terms,
@@ -235,15 +226,6 @@ prep.step_epi_ahead <- function(x, training, info = NULL, ...) {
   } else {
     shift_grid <- x$shift_grid
   }
-  if (nrow(shift_grid) == 0) {
-    cli_warn(
-      c(
-        "prepping no columns!",
-        "{x$terms} returns no columns for this dataset."
-      ),
-      class = "epipredict__step_epi_ahead__no_columns_shifted"
-    )
-  }
 
   step_epi_ahead_new(
     terms = x$terms,

R/utils-latency.R

@@ -50,27 +50,18 @@ get_forecast_date <- function(new_data, info, epi_keys_checked, latency, columns
       )
     }
   }
+  max_time <- get_max_time(new_data, epi_keys_checked, columns)
   # the source data determines the actual time_values
-  # these are the non-na time_values;
-  # get the minimum value across the checked epi_keys' maximum time values
-  max_time <- new_data %>%
-    select(all_of(columns)) %>%
-    drop_na()
-  # null and "" don't work in `group_by`
-  if (!is.null(epi_keys_checked) && all(epi_keys_checked != "")) {
-    max_time <- max_time %>% group_by(across(all_of(epi_keys_checked)))
-  }
-  max_time <- max_time %>%
-    summarise(time_value = max(time_value)) %>%
-    pull(time_value) %>%
-    min()
   if (is.null(latency)) {
     forecast_date <- attributes(new_data)$metadata$as_of
   } else {
+    if (is.null(max_time)) {
+      cli_abort("max_time is null. This likely means there is one of {columns} that is all `NA`")
+    }
     forecast_date <- max_time + latency
   }
   # make sure the as_of is sane
-  if (!inherits(forecast_date, class(max_time)) & !inherits(forecast_date, "POSIXt")) {
+  if (!inherits(forecast_date, class(new_data$time_value)) & !inherits(forecast_date, "POSIXt")) {
     cli_abort(
       paste(
         "the data matrix `forecast_date` value is {forecast_date}, ",
@@ -84,13 +75,13 @@ get_forecast_date <- function(new_data, info, epi_keys_checked, latency, columns
   if (is.null(forecast_date) || is.na(forecast_date)) {
     cli_warn(
       paste(
-        "epi_data's `forecast_date` was {forecast_date}, setting to ",
-        "the latest time value, {max_time}."
+        "epi_data's `forecast_date` was `NA`, setting to ",
+        "the latest non-`NA` time value for these columns, {max_time}."
       ),
       class = "epipredict__get_forecast_date__max_time_warning"
     )
     forecast_date <- max_time
-  } else if (forecast_date < max_time) {
+  } else if (!is.null(max_time) && (forecast_date < max_time)) {
     cli_abort(
       paste(
         "`forecast_date` ({(forecast_date)}) is before the most ",
@@ -101,19 +92,46 @@ get_forecast_date <- function(new_data, info, epi_keys_checked, latency, columns
     )
   }
   # TODO cover the rest of the possible types for as_of and max_time...
-  if (inherits(max_time, "Date")) {
+  if (inherits(new_data$time_value, "Date")) {
     forecast_date <- as.Date(forecast_date)
   }
   return(forecast_date)
 }
 
+get_max_time <- function(new_data, epi_keys_checked, columns) {
+  # these are the non-na time_values;
+  # get the minimum value across the checked epi_keys' maximum time values
+  max_time <- new_data %>%
+    select(all_of(columns)) %>%
+    drop_na()
+  if (nrow(max_time) == 0) {
+    return(NULL)
+  }
+  # null and "" don't work in `group_by`
+  if (!is.null(epi_keys_checked) && all(epi_keys_checked != "")) {
+    max_time <- max_time %>% group_by(across(all_of(epi_keys_checked)))
+  }
+  max_time <- max_time %>%
+    summarise(time_value = max(time_value)) %>%
+    pull(time_value) %>%
+    min()
+  return(max_time)
+}
+
+
+
 #' the latency is also the amount the shift is off by
 #' @param sign_shift integer. 1 if lag and -1 if ahead. These represent how you
 #'   need to shift the data to bring the 3 day lagged value to today.
 #' @keywords internal
 get_latency <- function(new_data, forecast_date, column, sign_shift, epi_keys_checked) {
   shift_max_date <- new_data %>%
     drop_na(all_of(column))
+  if (nrow(shift_max_date) == 0) {
+    # if everything is an NA, there's infinite latency, but shifting by that is
+    # untenable. May as well not shift at all
+    return(0)
+  }
   # null and "" don't work in `group_by`
   if (!is.null(epi_keys_checked) && all(epi_keys_checked != "")) {
     shift_max_date <- shift_max_date %>% group_by(across(all_of(epi_keys_checked)))

man/step_adjust_latency.Rd

@@ -398,10 +398,6 @@ test_that("epi_adjust_latency correctly extends the lags when there are differen
     names(fit5$pre$mold$outcomes),
     glue::glue("ahead_{ahead}_death_rate")
   )
-  latest <- get_test_data(r5, x)
-  pred <- predict(fit5, latest)
-  actual_solutions <- pred %>% filter(!is.na(.pred))
-  expect_equal(actual_solutions$time_value, testing_as_of + 1)
 
   # should have four predictors, including the intercept
   expect_equal(length(fit5$fit$fit$fit$coefficients), 6)

tests/testthat/test-step_adjust_latency.R

@@ -66,3 +66,8 @@ test_that("Check that epi_lag shifts applies the shift", {
   # Should have four predictors, including the intercept
   expect_equal(length(fit5$fit$fit$fit$coefficients), 4)
 })
+
+test_that("Shifting nothing is a no-op", {
+  expect_no_error(noop <- epi_recipe(x) %>% step_epi_ahead(ahead = 3) %>% prep(x) %>% bake(x))
+  expect_equal(noop, x)
+})