first draft of extend_ahead

Author: dsweber2

R/step_epi_shift.R

@@ -20,6 +20,10 @@
 #' @param lag,ahead A vector of integers. Each specified column will
 #'  be the lag or lead for each value in the vector. Lag integers must be
 #'  nonnegative, while ahead integers must be positive.
+#' @param latency_adjustment a character. Determines the method by which the forecast handles data that doesn't extend to the day the forecast is made. The options are:
+#'   - `"extend_ahead"`: actually forecasts from the last date. E.g. if there are 3 days of latency for a 4 day ahead forecast, the ahead used in practice is actually 7.
+#'   - `"locf"`: carries forward the last observed value up to the forecast date.
+#'   - `"extend_lags"`: per `epi_key` and `predictor`, adjusts the lag so that the shortest lag at predict time is
 #' @param prefix A prefix to indicate what type of variable this is
 #' @param default Determines what fills empty rows
 #'   left by leading/lagging (defaults to NA).
@@ -60,6 +64,12 @@ step_epi_lag <-
            default = NA,
            columns = NULL,
            skip = FALSE,
+           latency_adjustment = c(
+             "None",
+             "extend_ahead",
+             "locf",
+             "extend_lags"
+           ),
            id = rand_id("epi_lag")) {
     if (!is_epi_recipe(recipe)) {
       rlang::abort("This recipe step can only operate on an `epi_recipe`.")
@@ -72,8 +82,9 @@ step_epi_lag <-
         )
       )
     }
+    latency_adjustment <- rlang::arg_match(latency_adjustment)
     arg_is_nonneg_int(lag)
-    arg_is_chr_scalar(prefix, id)
+    arg_is_chr_scalar(prefix, id, latency_adjustment)
     if (!is.null(columns)) {
       rlang::abort(c("The `columns` argument must be `NULL.",
         i = "Use `tidyselect` methods to choose columns to lag."
@@ -89,6 +100,7 @@ step_epi_lag <-
         prefix = prefix,
         default = default,
         keys = epi_keys(recipe),
+        latency_adjustment = latency_adjustment,
         columns = columns,
         skip = skip,
         id = id
@@ -109,6 +121,12 @@ step_epi_ahead <-
            ahead,
            prefix = "ahead_",
            default = NA,
+           latency_adjustment = c(
+             "None",
+             "extend_ahead",
+             "locf",
+             "extend_lags"
+           ),
            columns = NULL,
            skip = FALSE,
            id = rand_id("epi_ahead")) {
@@ -123,8 +141,9 @@ step_epi_ahead <-
         )
       )
     }
+    latency_adjustment <- rlang::arg_match(latency_adjustment)
     arg_is_nonneg_int(ahead)
-    arg_is_chr_scalar(prefix, id)
+    arg_is_chr_scalar(prefix, id, latency_adjustment)
     if (!is.null(columns)) {
       rlang::abort(c("The `columns` argument must be `NULL.",
         i = "Use `tidyselect` methods to choose columns to lead."
@@ -140,6 +159,7 @@ step_epi_ahead <-
         prefix = prefix,
         default = default,
         keys = epi_keys(recipe),
+        latency_adjustment = latency_adjustment,
         columns = columns,
         skip = skip,
         id = id
@@ -150,7 +170,7 @@ step_epi_ahead <-
 
 step_epi_lag_new <-
   function(terms, role, trained, lag, prefix, default, keys,
-           columns, skip, id) {
+           latency_adjustment, columns, skip, id) {
     step(
       subclass = "epi_lag",
       terms = terms,
@@ -160,14 +180,15 @@ step_epi_lag_new <-
       prefix = prefix,
       default = default,
       keys = keys,
+      latency_adjustment = latency_adjustment,
       columns = columns,
       skip = skip,
       id = id
     )
   }
 
 step_epi_ahead_new <-
-  function(terms, role, trained, ahead, prefix, default, keys,
+  function(terms, role, trained, ahead, prefix, default, keys, latency_adjustment,
            columns, skip, id) {
     step(
       subclass = "epi_ahead",
@@ -177,6 +198,7 @@ step_epi_ahead_new <-
       ahead = ahead,
       prefix = prefix,
       default = default,
+      latency_adjustment = latency_adjustment,
       keys = keys,
       columns = columns,
       skip = skip,
@@ -196,6 +218,7 @@ prep.step_epi_lag <- function(x, training, info = NULL, ...) {
     prefix = x$prefix,
     default = x$default,
     keys = x$keys,
+    latency_adjustment = x$latency_adjustment,
     columns = recipes_eval_select(x$terms, training, info),
     skip = x$skip,
     id = x$id
@@ -212,6 +235,7 @@ prep.step_epi_ahead <- function(x, training, info = NULL, ...) {
     prefix = x$prefix,
     default = x$default,
     keys = x$keys,
+    latency_adjustment = x$latency_adjustment,
     columns = recipes_eval_select(x$terms, training, info),
     skip = x$skip,
     id = x$id
@@ -257,7 +281,8 @@ bake.step_epi_lag <- function(object, new_data, ...) {
 
 #' @export
 bake.step_epi_ahead <- function(object, new_data, ...) {
-  grid <- tidyr::expand_grid(col = object$columns, ahead = object$ahead) %>%
+  ahead <- adjust_latency(object, new_data)
+  grid <- tidyr::expand_grid(col = object$columns, ahead = ahead) %>%
     dplyr::mutate(
       newname = glue::glue("{object$prefix}{ahead}_{col}"),
       shift_val = -ahead,

R/utils-shift.R

@@ -0,0 +1,69 @@
+#' various ways of handling differences between the `as_of` date and the maximum
+#' time value
+#' @description
+#' adjust the ahead so that we will be predicting `ahead` days after the `as_of`
+#'   date, rather than relative to the last day of data
+#' @keywords internal
+adjust_latency <- function(object, new_data) {
+  method <- object$latency_adjustment
+  ahead <- object$ahead
+  if (is.na(method) || is.null(method) || method == "None") {
+    return(object$ahead)
+  } else if (method == "extend_ahead") {
+    as_of <- attributes(new_data)$metadata$as_of
+    if (FALSE && (typeof(as_of) != typeof(new_data$time_value))) {
+      rlang::abort(glue::glue(
+        "the data matrix `as_of` value is {as_of}, ",
+        "and not a valid `time_type` with type ",
+        "matching `time_value`'s type of ",
+        "{typeof(new_data$time_value)}."
+      ))
+    }
+    # adjust the ahead so that we're predicting relative to the as_of date,
+    # rather
+    # than the last day of data
+    time_values <- new_data$time_value
+    if (length(time_values) > 0) {
+      max_time <- max(time_values)
+      shift_amount <- as.Date(as_of) - max_time
+      if (is.null(as_of) || is.na(as_of)) {
+        cli::cli_warn(glue::glue(
+          "epi_data's `as_of` was {as_of}, setting to ",
+          "the latest time value, {max_time}."
+        ))
+        as_of <- max_time
+      } else if (as_of < max_time) {
+        cli::cli_abort(glue::glue(
+          "`as_of` ({(as_of)}) is before the most ",
+          "recent data ({max_time}). Remove before ",
+          "predicting."
+        ))
+      }
+      effective_ahead <- as.integer(shift_amount + ahead)
+      time_type <- attributes(new_data)$metadata$time_type
+
+      if ((grepl("day", time_type) && (shift_amount >= 10)) ||
+            (grepl("week", time_type) && (shift_amount >= 4))||
+            ((time_type == "yearmonth") && (shift_amount >=2)) ||
+            ((time_type == "yearquarter") && (shift_amount >= 1)) ||
+            ((time_type == "year") && (shift_amount >= 1))) {
+        cli::cli_warn(c(
+          "!" = glue::glue("The ahead has been adjusted by {shift_amount}, ",
+                           "which is questionable for it's `time_type` of ",
+                           "{time_type}"),
+          "i" = "input ahead: {ahead}",
+          "i" = "shifted ahead: {effective_ahead}",
+          "i" = "max_time = {max_time} -> as_of = {as_of}"
+        ))
+      }
+      return(effective_ahead)
+    } else {
+      rlang::abort("the `time_value` column of `new_data` is empty")
+    }
+  } else {
+    rlang::abort(glue::glue(
+      "Latency adjustment method {method} has not yet ",
+      "been implemented for `step_epi_ahead`."
+    ))
+  }
+}

man/adjust_latency.Rd

@@ -0,0 +1,13 @@
+# extend_ahead warns in case of extreme adjustment
+
+    Code
+      adjust_latency(object, x_adjust_ahead)
+    Condition
+      Warning:
+      ! The ahead has been adjusted by 100, which is questionable for it's `time_type` of day
+      i input ahead: 7
+      i shifted ahead: 107
+      i max_time = 2021-07-19 -> as_of = 2021-10-27
+    Output
+      [1] 107
+

man/step_epi_shift.Rd

@@ -0,0 +1,30 @@
+time_range <- as.Date("2021-01-01") + 0:199
+x_adjust_ahead <- tibble(
+  geo_value = rep("place", 200),
+  time_value = time_range,
+  case_rate = sqrt(1:200) + atan(0.1 * 1:200) + sin(5 * 1:200) + 1,
+  death_rate = atan(0.1 * 1:200) + cos(5 * 1:200) + 1
+) %>%
+  as_epi_df(as_of = max(time_range) + 3)
+# confirm the delay is right
+
+test_that("adjust_latency extend_ahead works", {
+  # testing that POSIXct converts correctly (as well as basic types)
+  expect_equal(
+    attributes(x_adjust_ahead)$metadata$as_of - max(x_adjust_ahead$time_value),
+    as.difftime(3, units = "days")
+  )
+  object <- list(latency_adjustment = "extend_ahead", ahead = 7)
+  expect_no_error(adjusted_ahead <- adjust_latency(object, x_adjust_ahead))
+  expect_type(adjusted_ahead, "integer")
+  expect_equal(adjusted_ahead, 3 + 7)
+})
+
+test_that("extend_ahead warns in case of extreme adjustment", {
+  # warns if the ahead is relatively small
+  attributes(x_adjust_ahead)$metadata$as_of <-
+    max(x_adjust_ahead$time_value) + 100
+  object <- list(latency_adjustment = "extend_ahead", ahead = 7)
+  attributes(x_adjust_ahead)$metadata$time_type
+  expect_snapshot(adjust_latency(object, x_adjust_ahead))
+})