Merge branch 'dev' into djm/plotting

Author: dajmcdon

DESCRIPTION

@@ -31,14 +31,11 @@ Imports:
     cli,
     distributional,
     dplyr,
-    fs,
     generics,
     ggplot2,
     glue,
     hardhat (>= 1.3.0),
-    lifecycle,
     magrittr,
-    methods,
     quantreg,
     recipes (>= 1.0.4),
     rlang,
@@ -47,20 +44,22 @@ Imports:
     tibble,
     tidyr,
     tidyselect,
-    usethis,
+    tsibble,
     vctrs,
     workflows (>= 1.0.0)
 Suggests:
     covidcast,
     data.table,
     epidatr (>= 1.0.0),
+    fs,
     knitr,
     lubridate,
     poissonreg,
     ranger,
     RcppRoll,
     rmarkdown,
     testthat (>= 3.0.0),
+    usethis,
     xgboost
 VignetteBuilder:
     knitr

NAMESPACE

@@ -136,7 +136,6 @@ export(bake)
 export(cdc_baseline_args_list)
 export(cdc_baseline_forecaster)
 export(check_enough_train_data)
-export(create_layer)
 export(default_epi_recipe_blueprint)
 export(detect_layer)
 export(dist_quantiles)
@@ -223,9 +222,7 @@ importFrom(generics,fit)
 importFrom(ggplot2,autoplot)
 importFrom(hardhat,refresh_blueprint)
 importFrom(hardhat,run_mold)
-importFrom(lifecycle,deprecated)
 importFrom(magrittr,"%>%")
-importFrom(methods,is)
 importFrom(quantreg,rq)
 importFrom(recipes,bake)
 importFrom(recipes,prep)

NEWS.md

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

R/bake.epi_recipe.R

@@ -13,7 +13,6 @@
 #' original columns in `new_data`.
 #' @importFrom rlang is_empty quos
 #' @importFrom tibble is_tibble as_tibble
-#' @importFrom methods is
 #' @rdname bake
 #' @export
 bake.epi_recipe <- function(object, new_data, ...) {

R/create-layer.R

@@ -7,8 +7,8 @@
 #' @inheritParams usethis::use_test
 #'
 #' @importFrom rlang %||%
-#' @export
-#'
+#' @noRd
+#' @keywords internal
 #' @examples
 #' \dontrun{
 #'

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.",
-        i = "Do you need to call `fit()`?"
-      )
-    )
+    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/epipredict-package.R

@@ -1,9 +1,8 @@
 ## usethis namespace: start
 #' @importFrom tibble tibble
-#' @importFrom rlang := !!
+#' @importFrom rlang := !! %||%
 #' @importFrom stats poly predict lm residuals quantile
 #' @importFrom cli cli_abort
-#' @importFrom lifecycle deprecated
 #' @importFrom checkmate assert assert_character assert_int assert_scalar
 #'             assert_logical assert_numeric assert_number assert_integer
 #'             assert_integerish assert_date assert_function

R/flusight_hub_formatter.R

@@ -58,6 +58,10 @@ abbr_to_location <- function(abbr) {
 #' @examples
 #' if (require(dplyr)) {
 #'   weekly_deaths <- case_death_rate_subset %>%
+#'     filter(
+#'       time_value >= as.Date("2021-09-01"),
+#'       geo_value %in% c("ca", "ny", "dc", "ga", "vt")
+#'     ) %>%
 #'     select(geo_value, time_value, death_rate) %>%
 #'     left_join(state_census %>% select(pop, abbr), by = c("geo_value" = "abbr")) %>%
 #'     mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) %>%

R/layer_add_forecast_date.R

@@ -68,6 +68,9 @@
 #' p3
 layer_add_forecast_date <-
   function(frosting, forecast_date = NULL, id = rand_id("add_forecast_date")) {
+    arg_is_chr_scalar(id)
+    arg_is_scalar(forecast_date, allow_null = TRUE)
+    # can't validate the type of forecast_date until we know the time_type
     add_layer(
       frosting,
       layer_add_forecast_date_new(
@@ -78,8 +81,6 @@ 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)
   layer("add_forecast_date", forecast_date = forecast_date, id = id)
 }
 
@@ -91,26 +92,25 @@ slather.layer_add_forecast_date <- function(object, components, workflow, new_da
       workflow$fit$meta$max_time_value,
       max(new_data$time_value)
     )
-    object$forecast_date <- max_time_value
+    forecast_date <- max_time_value
+  } else {
+    forecast_date <- object$forecast_date
   }
-  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))
-
-  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}."
-      )
-    )
-  }
+  expected_time_type <- attr(
+    workflows::extract_preprocessor(workflow)$template, "metadata"
+  )$time_type
+  if (expected_time_type == "week") expected_time_type <- "day"
+  validate_date(forecast_date, expected_time_type,
+    call = expr(layer_add_forecast_date())
+  )
+  forecast_date <- coerce_time_type(forecast_date, expected_time_type)
+  object$forecast_date <- forecast_date
   components$predictions <- dplyr::bind_cols(
     components$predictions,
-    forecast_date = as.Date(object$forecast_date)
+    forecast_date = forecast_date
   )
+
   components
 }
 

R/layer_add_target_date.R

@@ -63,8 +63,9 @@
 #' 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)
     arg_is_chr_scalar(id)
+    arg_is_scalar(target_date, allow_null = TRUE)
+    # can't validate the type of target_date until we know the time_type
     add_layer(
       frosting,
       layer_add_target_date_new(
@@ -84,35 +85,39 @@ slather.layer_add_target_date <- function(object, components, workflow, new_data
   the_recipe <- workflows::extract_recipe(workflow)
   the_frosting <- extract_frosting(workflow)
 
+  expected_time_type <- attr(
+    workflows::extract_preprocessor(workflow)$template, "metadata"
+  )$time_type
+  if (expected_time_type == "week") expected_time_type <- "day"
+
   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"
+    target_date <- object$target_date
+    validate_date(target_date, expected_time_type,
+      call = expr(layer_add_target_date())
+    )
+    target_date <- coerce_time_type(target_date, expected_time_type)
+  } else if (
+    detect_layer(the_frosting, "layer_add_forecast_date") &&
+      !is.null(forecast_date <- extract_argument(
+        the_frosting, "layer_add_forecast_date", "forecast_date"
       ))) {
-      forecast_date <- extract_argument(
-        the_frosting,
-        "layer_add_forecast_date", "forecast_date"
-      )
-
-      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
-    }
+    validate_date(forecast_date, expected_time_type,
+      call = expr(layer_add_forecast_date())
+    )
+    forecast_date <- coerce_time_type(forecast_date, 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
   }
 
+  object$target_date <- target_date
   components$predictions <- dplyr::bind_cols(components$predictions,
     target_date = target_date
   )

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/pivot_quantiles.R

@@ -143,7 +143,11 @@ pivot_quantiles_wider <- function(.data, ...) {
 }
 
 pivot_quantiles <- function(.data, ...) {
-  lifecycle::deprecate_stop("0.0.6", "pivot_quantiles()", "pivot_quantiles_wider()")
+  msg <- c(
+    "{.fn pivot_quantiles} was deprecated in {.pkg epipredict} 0.0.6",
+    i = "Please use {.fn pivot_quantiles_wider} instead."
+  )
+  deprecate_stop(msg)
 }
 
 validate_pivot_quantiles <- function(.data, ...) {