Merge branch 'cmu-delphi:main' into main

Author: kenmawer

.Rbuildignore

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

.gitignore

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

DESCRIPTION

@@ -1,47 +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
+    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,18 +1,41 @@
 # 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)
+export(knn_iteraive_ar_forecaster)
+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/arx_forecaster.R

@@ -37,7 +37,9 @@ arx_forecaster <- function(x, y, key_vars, time_value,
   if (intercept) dat$x0 <- 1
 
   obj <- stats::lm(
-    y1 ~ . + 0, data = dat %>% dplyr::select(starts_with(c("x","y"))))
+    y1 ~ . + 0,
+    data = dat %>% dplyr::select(starts_with(c("x", "y")))
+  )
 
   point <- make_predictions(obj, dat, time_value, keys)
 
@@ -50,8 +52,9 @@ arx_forecaster <- function(x, y, key_vars, time_value,
   # Harder case requires handling failures of 1 and or 2, neither implemented
   # 1. different quantiles by key, need to bind the keys, then group_modify
   # 2 fails. need to bind the keys, grab, y and yhat, subtract
-  if (nonneg)
+  if (nonneg) {
     q <- dplyr::mutate(q, dplyr::across(dplyr::everything(), ~ pmax(.x, 0)))
+  }
 
   return(
     dplyr::bind_cols(distinct_keys, q) %>%
@@ -80,12 +83,11 @@ arx_forecaster <- function(x, y, key_vars, time_value,
 #' arx_args_list()
 #' arx_args_list(symmetrize = FALSE)
 #' arx_args_list(levels = c(.1, .3, .7, .9), min_train_window = 120)
-arx_args_list <- function(
-  lags = c(0, 7, 14), ahead = 7, min_train_window = 20,
-  levels = c(0.05, 0.95), intercept = TRUE,
-  symmetrize = TRUE,
-  nonneg = TRUE,
-  quantile_by_key = FALSE) {
+arx_args_list <- function(lags = c(0, 7, 14), ahead = 7, min_train_window = 20,
+                          levels = c(0.05, 0.95), intercept = TRUE,
+                          symmetrize = TRUE,
+                          nonneg = TRUE,
+                          quantile_by_key = FALSE) {
 
   # error checking if lags is a list
   .lags <- lags
@@ -94,13 +96,15 @@ arx_args_list <- function(
   arg_is_scalar(ahead, min_train_window)
   arg_is_nonneg_int(ahead, min_train_window, lags)
   arg_is_lgl(intercept, symmetrize, nonneg)
-  arg_is_probabilities(levels, allow_null=TRUE)
+  arg_is_probabilities(levels, allow_null = TRUE)
 
   max_lags <- max(lags)
 
-  list(lags = .lags, ahead = as.integer(ahead),
-       min_train_window = min_train_window,
-       levels = levels, intercept = intercept,
-       symmetrize = symmetrize, nonneg = nonneg,
-       max_lags = max_lags)
-}
+  list(
+    lags = .lags, ahead = as.integer(ahead),
+    min_train_window = min_train_window,
+    levels = levels, intercept = intercept,
+    symmetrize = symmetrize, nonneg = nonneg,
+    max_lags = max_lags
+  )
+}

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))
+}