Merge branch 'main' into main

Author: dajmcdon

.Rbuildignore

@@ -8,3 +8,4 @@
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$
+^musings$

.gitignore

@@ -4,3 +4,4 @@
 .Ruserdata
 docs
 inst/doc
+.DS_Store

DESCRIPTION

@@ -1,48 +1,44 @@
 Package: epipredict
 Title: Basic epidemiology forecasting methods
 Version: 0.0.0.9000
-Authors@R: 
-  c(
-  person(given = "Jacob",
-         family = "Bien",
-         role = "aut"),
-  person(given = "Daniel",
-         family = "McDonald",
-         role = "aut"),
-  person(given = "Ryan",
-         family = "Tibshirani",
-         role = c("aut", "cre"),
-         email = "[email protected]"))
+Authors@R: c(
+    person("Jacob", "Bien", role = "aut"),
+    person("Daniel", "McDonald", role = "aut"),
+    person("Ryan", "Tibshirani", , "[email protected]", role = c("aut", "cre"))
+  )
 Description: What the package does (one paragraph).
 License: MIT + file LICENSE
-Encoding: UTF-8
-Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.2
-Remotes:
-    cmu-delphi/epiprocess#58
+URL: https://github.com/cmu-delphi/epipredict/,
+    https://cmu-delphi.github.io/epiprocess
 Imports: 
+    assertthat,
+    cli,
     dplyr,
+    glue,
     magrittr,
-    tibble,
-    rlang,
     purrr,
-    cli,
+    recipes,
+    rlang,
     stats,
+    tibble,
     tidyr,
-    assertthat,
     tidyselect,
     tensr
 Suggests: 
-    epiprocess,
-    data.table,
     covidcast,
+    data.table,
+    epiprocess,
     ggplot2,
     knitr,
     lubridate,
     RcppRoll,
     rmarkdown,
     testthat (>= 3.0.0)
+VignetteBuilder: 
+    knitr
+Remotes:
+    dajmcdon/epiprocess
 Config/testthat/edition: 3
-URL: https://github.com/cmu-delphi/epipredict/,
-     https://cmu-delphi.github.io/epiprocess
-VignetteBuilder: knitr
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.2.0

NAMESPACE

@@ -1,10 +1,24 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(bake,step_epi_ahead)
+S3method(bake,step_epi_lag)
+S3method(epi_keys,default)
+S3method(epi_keys,epi_df)
+S3method(epi_keys,recipe)
+S3method(epi_recipe,default)
+S3method(epi_recipe,epi_df)
+S3method(epi_recipe,formula)
+S3method(prep,step_epi_ahead)
+S3method(prep,step_epi_lag)
+S3method(print,step_epi_ahead)
+S3method(print,step_epi_lag)
 export("%>%")
 export(arx_args_list)
 export(arx_forecaster)
 export(create_lags_and_leads)
 export(df_mat_mul)
+export(epi_keys)
+export(epi_recipe)
 export(get_precision)
 export(grab_names)
 export(knn_iteraive_ar_args_list)
@@ -13,10 +27,15 @@ export(knnarx_args_list)
 export(knnarx_forecaster)
 export(smooth_arx_args_list)
 export(smooth_arx_forecaster)
+export(step_epi_ahead)
+export(step_epi_lag)
+import(recipes)
 importFrom(magrittr,"%>%")
 importFrom(rlang,"!!")
 importFrom(rlang,":=")
+importFrom(stats,as.formula)
 importFrom(stats,lm)
+importFrom(stats,model.frame)
 importFrom(stats,poly)
 importFrom(stats,predict)
 importFrom(stats,quantile)

R/compat-recipes.R

@@ -0,0 +1,96 @@
+# These are copied from `recipes` where they are unexported
+
+fun_calls <- function (f) {
+  if (is.function(f)) fun_calls(body(f))
+  else if (rlang::is_quosure(f)) fun_calls(rlang::quo_get_expr(f))
+  else if (is.call(f)) {
+    fname <- as.character(f[[1]])
+    if (identical(fname, ".Internal"))
+      return(fname)
+    unique(c(fname, unlist(lapply(f[-1], fun_calls), use.names = FALSE)))
+  }
+}
+
+inline_check <- function(x) {
+  funs <- fun_calls(x)
+  funs <- funs[!(funs %in% c("~", "+", "-"))]
+  if (length(funs) > 0) {
+    rlang::abort(paste0(
+      "No in-line functions should be used here; ",
+      "use steps to define baking actions."
+    ))
+  }
+  invisible(x)
+}
+
+#' @importFrom stats as.formula
+get_lhs_vars <- function(formula, data) {
+  if (!rlang::is_formula(formula)) {
+    formula <- as.formula(formula)
+  }
+  ## Want to make sure that multiple outcomes can be expressed as
+  ## additions with no cbind business and that `.` works too (maybe)
+  new_formula <- rlang::new_formula(lhs = NULL, rhs = rlang::f_lhs(formula))
+  get_rhs_vars(new_formula, data)
+}
+
+#' @importFrom stats model.frame
+get_rhs_vars <- function(formula, data, no_lhs = FALSE) {
+  if (!rlang::is_formula(formula)) {
+    formula <- as.formula(formula)
+  }
+  if (no_lhs) {
+    formula <- rlang::new_formula(lhs = NULL, rhs = rlang::f_rhs(formula))
+  }
+
+  ## This will need a lot of work to account for cases with `.`
+  ## or embedded functions like `Sepal.Length + poly(Sepal.Width)`.
+  ## or should it? what about Y ~ log(x)?
+  ## Answer: when called from `form2args`, the function
+  ## `inline_check` stops when in-line functions are used.
+  data_info <- attr(model.frame(formula, data[1, ]), "terms")
+  response_info <- attr(data_info, "response")
+  predictor_names <- names(attr(data_info, "dataClasses"))
+  if (length(response_info) > 0 && all(response_info > 0)) {
+    predictor_names <- predictor_names[-response_info]
+  }
+  predictor_names
+}
+
+## Buckets variables into discrete, mutally exclusive types
+get_types <- function(x) {
+  var_types <-
+    c(
+      character = "nominal",
+      factor = "nominal",
+      ordered = "nominal",
+      integer = "numeric",
+      numeric = "numeric",
+      double = "numeric",
+      Surv = "censored",
+      logical = "logical",
+      Date = "date",
+      POSIXct = "date",
+      list = "list",
+      textrecipes_tokenlist = "tokenlist"
+    )
+
+  classes <- lapply(x, class)
+  res <- lapply(
+    classes,
+    function(x, types) {
+      in_types <- x %in% names(types)
+      if (sum(in_types) > 0) {
+        # not sure what to do with multiple matches; right now
+        ## pick the first match which favors "factor" over "ordered"
+        out <- unname(types[min(which(names(types) %in% x))])
+      } else {
+        out <- "other"
+      }
+      out
+    },
+    types = var_types
+  )
+  res <- unlist(res)
+  tibble(variable = names(res), type = unname(res))
+}

R/epi_ahead.R

@@ -0,0 +1,163 @@
+#' Create a leading outcome
+#'
+#' `step_epi_ahead` creates a *specification* of a recipe step that
+#'   will add new columns of leading data. Leading data will
+#'   by default include NA values where the lag was induced.
+#'   These can be removed with [step_naomit()], or you may
+#'   specify an alternative filler value with the `default`
+#'   argument.
+#'
+#' @param recipe A recipe object. The step will be added to the
+#'  sequence of operations for this recipe.
+#' @param ... One or more selector functions to choose variables
+#'  for this step. See [selections()] for more details.
+#' @param role For model terms created by this step, what analysis role should
+#'  they be assigned?
+#' @param trained A logical to indicate if the quantities for
+#'  preprocessing have been estimated.
+#' @param ahead A vector of positive integers. Each specified column will be
+#'  lead for each value in the vector.
+#' @param prefix A prefix for generated column names, default to "ahead_".
+#' @param default Determines what fills empty rows
+#'   left by leading/lagging (defaults to NA).
+#' @param keys A character vector of the keys in an epi_df
+#' @param columns A character string of variable names that will
+#'  be populated (eventually) by the `terms` argument.
+#' @param skip A logical. Should the step be skipped when the
+#'  recipe is baked by [bake()]? While all operations are baked
+#'  when [prep()] is run, some operations may not be able to be
+#'  conducted on new data (e.g. processing the outcome variable(s)).
+#'  Care should be taken when using `skip = TRUE` as it may affect
+#'  the computations for subsequent operations.
+#' @param id A character string that is unique to this step to identify it.
+#' @template step-return
+#'
+#' @details The step assumes that the data are already _in the proper sequential
+#'  order_ for leading.
+#'
+#' @family row operation steps
+#' @export
+#'
+#' @examples
+#' tib <- tibble::tibble(
+#'   x = 1:5, y = 1:5,
+#'   time_value = seq(as.Date("2020-01-01"), by = 1, length.out = 5),
+#'   geo_value = "ca"
+#'   ) %>% epiprocess::as_epi_df()
+#'
+#' library(recipes)
+#' epi_recipe(y ~ x, data = tib) %>%
+#'   step_epi_lag(x, lag = 2:3) %>%
+#'   step_epi_ahead(y, ahead = 1) %>%
+#'   prep(tib) %>%
+#'   bake(tib)
+step_epi_ahead <-
+  function(recipe,
+           ...,
+           role = "outcome",
+           trained = FALSE,
+           ahead = 1,
+           prefix = "ahead_",
+           default = NA,
+           keys = epi_keys(recipe),
+           columns = NULL,
+           skip = FALSE,
+           id = rand_id("epi_ahead")) {
+    add_step(
+      recipe,
+      step_epi_ahead_new(
+        terms = dplyr::enquos(...),
+        role = role,
+        trained = trained,
+        ahead = ahead,
+        prefix = prefix,
+        default = default,
+        keys = keys,
+        columns = columns,
+        skip = skip,
+        id = id
+      )
+    )
+  }
+
+step_epi_ahead_new <-
+  function(terms, role, trained, ahead, prefix, default, keys,
+           columns, skip, id) {
+    step(
+      subclass = "epi_ahead",
+      terms = terms,
+      role = role,
+      trained = trained,
+      ahead = ahead,
+      prefix = prefix,
+      default = default,
+      keys = keys,
+      columns = columns,
+      skip = skip,
+      id = id
+    )
+  }
+
+#' @export
+prep.step_epi_ahead <- function(x, training, info = NULL, ...) {
+  step_epi_ahead_new(
+    terms = x$terms,
+    role = x$role,
+    trained = TRUE,
+    ahead = x$ahead,
+    prefix = x$prefix,
+    default = x$default,
+    keys = x$keys,
+    columns = recipes_eval_select(x$terms, training, info),
+    skip = x$skip,
+    id = x$id
+  )
+}
+
+#' @export
+bake.step_epi_ahead <- function(object, new_data, ...) {
+  if (!all(object$ahead == as.integer(object$ahead))) {
+    rlang::abort("step_epi_ahead requires 'ahead' argument to be integer valued.")
+  }
+
+  grid <- tidyr::expand_grid(
+    col = object$columns, lag_val = -object$ahead) %>%
+    dplyr::mutate(
+      ahead_val = -lag_val,
+      newname = glue::glue("{object$prefix}{ahead_val}_{col}")
+    ) %>%
+    dplyr::select(-ahead_val)
+
+  ## ensure no name clashes
+  new_data_names <- colnames(new_data)
+  intersection <- new_data_names %in% grid$newname
+  if (any(intersection)) {
+    rlang::abort(
+      paste0("Name collision occured in `", class(object)[1],
+             "`. The following variable names already exists: ",
+             paste0(new_data_names[intersection], collapse = ", "),
+             "."))
+  }
+
+  ok <- object$keys
+  lagged <- purrr::reduce(
+    purrr::pmap(grid, epi_shift_single, x = new_data, key_cols = ok),
+    dplyr::full_join,
+    by = ok
+  )
+
+  dplyr::full_join(new_data, lagged, by = ok) %>%
+    dplyr::group_by(dplyr::across(dplyr::all_of(ok[-1]))) %>%
+    dplyr::arrange(time_value) %>%
+    dplyr::ungroup()
+
+}
+
+#' @export
+print.step_epi_ahead <-
+  function(x, width = max(20, options()$width - 30), ...) {
+    ## TODO add printing of the lags
+    title <- "Leading "
+    recipes::print_step(x$columns, x$terms, x$trained, title, width)
+    invisible(x)
+  }