291 date period

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: epipredict
 Title: Basic epidemiology forecasting methods
-Version: 0.0.10
+Version: 0.0.11
 Authors@R: c(
     person("Daniel", "McDonald", , "[email protected]", role = c("aut", "cre")),
     person("Ryan", "Tibshirani", , "[email protected]", role = "aut"),
@@ -46,6 +46,7 @@ Imports:
     tibble,
     tidyr,
     tidyselect,
+    tsibble,
     usethis,
     vctrs,
     workflows (>= 1.0.0)

NEWS.md

@@ -33,3 +33,5 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.0.x will indicat
 -   Working vignette
 -   use `checkmate` for input validation
 -   refactor quantile extrapolation (possibly creates different results)
+-   force `target_date` + `forecast_date` handling to match the time_type of 
+    the epi_df. allows for annual and weekly data

R/dist_quantiles.R

@@ -233,10 +233,10 @@ quantile_extrapolate <- function(x, tau_out, middle) {
       dplyr::arrange(q)
   }
   if (any(indl)) {
-    qvals_out[indl] <- tail_extrapolate(tau_out[indl], head(qv, 2))
+    qvals_out[indl] <- tail_extrapolate(tau_out[indl], utils::head(qv, 2))
   }
   if (any(indr)) {
-    qvals_out[indr] <- tail_extrapolate(tau_out[indr], tail(qv, 2))
+    qvals_out[indr] <- tail_extrapolate(tau_out[indr], utils::tail(qv, 2))
   }
   qvals_out
 }

R/epi_workflow.R

@@ -251,11 +251,10 @@ fit.epi_workflow <- function(object, data, ..., control = workflows::control_wor
 #' preds
 predict.epi_workflow <- function(object, new_data, ...) {
   if (!workflows::is_trained_workflow(object)) {
-    rlang::abort(
-      c("Can't predict on an untrained epi_workflow.",
+    cli::cli_abort(c(
+      "Can't predict on an untrained epi_workflow.",
         i = "Do you need to call `fit()`?"
-      )
-    )
+    ))
   }
   components <- list()
   components$mold <- workflows::extract_mold(object)

R/layer_add_forecast_date.R

@@ -78,8 +78,8 @@ layer_add_forecast_date <-
   }
 
 layer_add_forecast_date_new <- function(forecast_date, id) {
-  forecast_date <- arg_to_date(forecast_date, allow_null = TRUE)
   arg_is_chr_scalar(id)
+  # can't validate forecast_date until we know the time_type
   layer("add_forecast_date", forecast_date = forecast_date, id = id)
 }
 
@@ -93,23 +93,24 @@ slather.layer_add_forecast_date <- function(object, components, workflow, new_da
     )
     object$forecast_date <- max_time_value
   }
-  as_of_pre <- attributes(workflows::extract_preprocessor(workflow)$template)$metadata$as_of
-  as_of_fit <- workflow$fit$meta$as_of
-  as_of_post <- attributes(new_data)$metadata$as_of
 
-  as_of_date <- as.Date(max(as_of_pre, as_of_fit, as_of_post))
+  expected_time_type <- attr(
+    workflows::extract_preprocessor(workflow)$template, "metadata"
+  )$time_type
+  if (expected_time_type == "week") expected_time_type = "day"
+  check <- validate_date(object$forecast_date, expected_time_type)
 
-  if (object$forecast_date < as_of_date) {
-    cli_warn(
-      c("The forecast_date is less than the most ",
-        "recent update date of the data: ",
-        i = "forecast_date = {object$forecast_date} while data is from {as_of_date}."
-      )
-    )
+  if (!check$ok) {
+    cli::cli_abort(c(
+      "The `forecast_date` was given as a {.val {check$x}} while the",
+      `!` = "`time_type` of the training data was {.val {check$expected}}.",
+      i = "See {.topic epiprocess::epi_df} for how these are determined."
+    ))
   }
+
   components$predictions <- dplyr::bind_cols(
     components$predictions,
-    forecast_date = as.Date(object$forecast_date)
+    forecast_date = coerce_time_type(object$forecast_date, expected_time_type)
   )
   components
 }

R/layer_add_target_date.R

@@ -63,7 +63,7 @@
 #' p3
 layer_add_target_date <-
   function(frosting, target_date = NULL, id = rand_id("add_target_date")) {
-    target_date <- arg_to_date(target_date, allow_null = TRUE)
+    # can't validate target_date until we know the time_type
     arg_is_chr_scalar(id)
     add_layer(
       frosting,
@@ -84,33 +84,46 @@ slather.layer_add_target_date <- function(object, components, workflow, new_data
   the_recipe <- workflows::extract_recipe(workflow)
   the_frosting <- extract_frosting(workflow)
 
-  if (!is.null(object$target_date)) {
-    target_date <- as.Date(object$target_date)
-  } else { # null target date case
-    if (detect_layer(the_frosting, "layer_add_forecast_date") &&
-      !is.null(extract_argument(
-        the_frosting,
-        "layer_add_forecast_date", "forecast_date"
-      ))) {
-      forecast_date <- extract_argument(
-        the_frosting,
-        "layer_add_forecast_date", "forecast_date"
-      )
+  expected_time_type <- attr(
+    workflows::extract_preprocessor(workflow)$template, "metadata"
+  )$time_type
+  if (expected_time_type == "week") expected_time_type = "day"
 
-      ahead <- extract_argument(the_recipe, "step_epi_ahead", "ahead")
+  if (!is.null(object$target_date)) {
+    check <- validate_date(object$target_date, expected_time_type)
+    if (!check$ok) {
+      cli::cli_abort(c(
+        "The `target_date` was given as a {.val {check$x}} while the",
+        `!` = "`time_type` of the training data was {.val {check$expected}}.",
+        i = "See {.topic epiprocess::epi_df} for descriptions of these are determined."
+      ))
+    }
+    target_date <- coerce_time_type(object$target_date, expected_time_type)
+  } else if (
+    detect_layer(the_frosting, "layer_add_forecast_date") &&
+    !is.null(possible_fd <- extract_argument(
+      the_frosting, "layer_add_forecast_date", "forecast_date"
+    ))) {
 
-      target_date <- forecast_date + ahead
-    } else {
+    check <- validate_date(possible_fd, expected_time_type)
+    if (!check$ok) {
+      cli::cli_abort(c(
+        "The `forecast_date` was given as a {.val {check$x}} while the",
+        `!` = "`time_type` of the training data was {.val {check$expected}}.",
+        i = "See {.topic epiprocess::epi_df} for how these are determined."
+      ))
+    }
+    forecast_date <- coerce_time_type(possible_fd, expected_time_type)
+    ahead <- extract_argument(the_recipe, "step_epi_ahead", "ahead")
+    target_date <- forecast_date + ahead
+  } else {
       max_time_value <- max(
         workflows::extract_preprocessor(workflow)$max_time_value,
         workflow$fit$meta$max_time_value,
         max(new_data$time_value)
       )
-
       ahead <- extract_argument(the_recipe, "step_epi_ahead", "ahead")
-
       target_date <- max_time_value + ahead
-    }
   }
 
   components$predictions <- dplyr::bind_cols(components$predictions,

R/layer_population_scaling.R

@@ -144,6 +144,12 @@ slather.layer_population_scaling <-
         length(object$df_pop_col) == 1
     )
 
+    if (is.null(object$by)) {
+      object$by <- intersect(
+        kill_time_value(epi_keys(components$predictions)),
+        colnames(dplyr::select(object$df, !object$df_pop_col))
+      )
+    }
     try_join <- try(
       dplyr::left_join(components$predictions, object$df,
         by = object$by
@@ -157,8 +163,8 @@ slather.layer_population_scaling <-
       ))
     }
 
-    object$df <- object$df %>%
-      dplyr::mutate(dplyr::across(tidyselect::where(is.character), tolower))
+    # object$df <- object$df %>%
+    #  dplyr::mutate(dplyr::across(tidyselect::where(is.character), tolower))
     pop_col <- rlang::sym(object$df_pop_col)
     exprs <- rlang::expr(c(!!!object$terms))
     pos <- tidyselect::eval_select(exprs, components$predictions)

R/step_epi_shift.R

@@ -53,20 +53,20 @@
 step_epi_lag <-
   function(recipe,
            ...,
+           lag,
            role = "predictor",
            trained = FALSE,
-           lag,
            prefix = "lag_",
            default = NA,
            columns = NULL,
            skip = FALSE,
            id = rand_id("epi_lag")) {
     if (!is_epi_recipe(recipe)) {
-      rlang::abort("This recipe step can only operate on an `epi_recipe`.")
+      cli::cli_abort("This step can only operate on an `epi_recipe`.")
     }
 
     if (missing(lag)) {
-      rlang::abort(
+      cli::cli_abort(
         c("The `lag` argument must not be empty.",
           i = "Did you perhaps pass an integer in `...` accidentally?"
         )
@@ -75,7 +75,8 @@ step_epi_lag <-
     arg_is_nonneg_int(lag)
     arg_is_chr_scalar(prefix, id)
     if (!is.null(columns)) {
-      rlang::abort(c("The `columns` argument must be `NULL.",
+      cli::cli_abort(c(
+        "The `columns` argument must be `NULL.",
         i = "Use `tidyselect` methods to choose columns to lag."
       ))
     }
@@ -85,7 +86,7 @@ step_epi_lag <-
         terms = dplyr::enquos(...),
         role = role,
         trained = trained,
-        lag = lag,
+        lag = as.integer(lag),
         prefix = prefix,
         default = default,
         keys = epi_keys(recipe),
@@ -104,21 +105,21 @@ step_epi_lag <-
 step_epi_ahead <-
   function(recipe,
            ...,
+           ahead,
            role = "outcome",
            trained = FALSE,
-           ahead,
            prefix = "ahead_",
            default = NA,
            columns = NULL,
            skip = FALSE,
            id = rand_id("epi_ahead")) {
     if (!is_epi_recipe(recipe)) {
-      rlang::abort("This recipe step can only operate on an `epi_recipe`.")
+      cli::cli_abort("This step can only operate on an `epi_recipe`.")
     }
 
     if (missing(ahead)) {
-      rlang::abort(
-        c("The `ahead` argument must not be empty.",
+      cli::cli_abort(c(
+        "The `ahead` argument must not be empty.",
           i = "Did you perhaps pass an integer in `...` accidentally?"
         )
       )
@@ -136,7 +137,7 @@ step_epi_ahead <-
         terms = dplyr::enquos(...),
         role = role,
         trained = trained,
-        ahead = ahead,
+        ahead = as.integer(ahead),
         prefix = prefix,
         default = default,
         keys = epi_keys(recipe),

R/time_types.R

@@ -0,0 +1,48 @@
+guess_time_type <- function(time_value) {
+  # similar to epiprocess:::guess_time_type() but w/o the gap handling
+  arg_is_scalar(time_value)
+  if (is.character(time_value)) {
+    if (nchar(time_value) <= "10") {
+      new_time_value <- tryCatch({
+        as.Date(time_value)
+      }, error = function(e) NULL)
+    } else {
+      new_time_value <- tryCatch({
+        as.POSIXct(time_value)
+      }, error = function(e) NULL)
+    }
+    if (!is.null(new_time_value)) time_value <- new_time_value
+  }
+  if (inherits(time_value, "POSIXct")) return("day-time")
+  if (inherits(time_value, "Date")) return("day")
+  if (inherits(time_value, "yearweek")) return("yearweek")
+  if (inherits(time_value, "yearmonth")) return("yearmonth")
+  if (inherits(time_value, "yearquarter")) return("yearquarter")
+  if (is.numeric(time_value) && all(time_value == as.integer(time_value)) &&
+      all(time_value >= 1582)) {
+    return("year")
+  }
+  return("custom")
+}
+
+coerce_time_type <- function(x, target_type) {
+  if (target_type == "year") {
+    if (is.numeric(x)) return(as.integer(x))
+    else return(as.POSIXlt(x)$year + 1900L)
+  }
+  switch(
+    target_type,
+    "day-time" = as.POSIXct(x),
+    "day" = as.Date(x),
+    "week" = as.Date(x),
+    "yearweek" = tsibble::yearweek(x),
+    "yearmonth" = tsibble::yearmonth(x),
+    "yearquarter" = tsibble::yearquarter(x)
+  )
+}
+
+validate_date <- function(x, expected) {
+  x <- guess_time_type(x)
+  ok <- x == expected
+  enlist(ok, x, expected)
+}

tests/testthat/test-extract_argument.R

@@ -43,19 +43,19 @@ test_that("recipe argument extractor works", {
 
   expect_error(extract_argument(r$steps[[1]], "uhoh", "bubble"))
   expect_error(extract_argument(r$steps[[1]], "step_epi_lag", "bubble"))
-  expect_identical(extract_argument(r$steps[[2]], "step_epi_ahead", "ahead"), 7)
+  expect_identical(extract_argument(r$steps[[2]], "step_epi_ahead", "ahead"), 7L)
 
 
   expect_error(extract_argument(r, "step_lightly", "quantile_levels"))
   expect_identical(
     extract_argument(r, "step_epi_lag", "lag"),
-    list(c(0, 7, 14), c(0, 7, 14))
+    list(c(0L, 7L, 14L), c(0L, 7L, 14L))
   )
 
   wf <- epi_workflow(preprocessor = r)
   expect_error(extract_argument(epi_workflow(), "step_epi_lag", "lag"))
   expect_identical(
     extract_argument(wf, "step_epi_lag", "lag"),
-    list(c(0, 7, 14), c(0, 7, 14))
+    list(c(0L, 7L, 14L), c(0L, 7L, 14L))
   )
 })