Merge branch 'frosting' of https://github.com/cmu-delphi/epipredict into km-kill-lags-good

Author: kenmawer

NAMESPACE

@@ -67,6 +67,7 @@ export(smooth_arx_args_list)
 export(smooth_arx_forecaster)
 export(step_epi_ahead)
 export(step_epi_lag)
+export(step_epi_naomit)
 export(validate_layer)
 import(recipes)
 importFrom(generics,augment)

R/epi_workflow.R

@@ -36,15 +36,13 @@
 #' wf <- epi_workflow(r, linear_reg())
 #'
 #' wf
-epi_workflow <- function(preprocessor = NULL, spec = NULL,
-                         postprocessor = NULL) {
+epi_workflow <- function(preprocessor = NULL, spec = NULL, postprocessor = NULL) {
   out <- workflows::workflow(spec = spec)
   class(out) <- c("epi_workflow", class(out))
 
   if (is_epi_recipe(preprocessor)) {
-    return(add_epi_recipe(out, preprocessor))
-  }
-  if (!is_null(preprocessor)) {
+    out <- add_epi_recipe(out, preprocessor)
+  }else if (!is_null(preprocessor)) {
     out <- workflows:::add_preprocessor(out, preprocessor)
   }
   if (!is_null(postprocessor)) {

R/step_epi_naomit.R

@@ -0,0 +1,20 @@
+#' Unified NA omission wrapper function for recipes
+#'
+#' @param recipe Recipe to be used for omission steps
+#'
+#' @return Omits NA's from both predictors and outcomes at training time
+#'   to fit the model. Also only omits associated predictors and not
+#'   outcomes at prediction time due to lack of response and avoidance
+#'   of data loss.
+#' @export
+#' @examples
+#' case_death_rate_subset %>%
+#'  epi_recipe() %>%
+#'  step_epi_naomit()
+
+step_epi_naomit <- function(recipe) {
+  stopifnot(inherits(recipe, "recipe"))
+  recipe %>%
+    recipes::step_naomit(all_predictors()) %>%
+    recipes::step_naomit(all_outcomes(), skip = TRUE)
+}

man/step_epi_naomit.Rd

@@ -0,0 +1,11 @@
+test_that("First argument must be a list",{
+  expect_error(assign_arg_list(c(1,2,3)))
+})
+test_that("All arguments should be named",{
+  expect_error(assign_arg_list(list(1,2)))
+})
+test_that("assign_arg_list works as intended",{
+  assign_arg_list(list(a="dog",b=2))
+  expect_identical(a,"dog")
+  expect_identical(b,2)
+})

tests/testthat/test-assign_arg_list.R

@@ -0,0 +1,41 @@
+df <- data.frame(matrix(1:100, ncol = 5))
+mat <- matrix(1:4, ncol = 2)
+
+test_that("First input must be a data frame and second
+          input must be a matrix", {
+  expect_error(df_mat_mul(df,20))
+  expect_error(df_mat_mul(30,mat))
+})
+
+test_that("Argument name is a character", {
+  expect_error(df_mat_mul(df, mat, 100))
+})
+
+test_that("The length of names does not differ from the length of the number
+          of outputs" ,{
+  expect_error(df_mat_mul(df, mat, c("a","b","c"), 2:3))
+})
+
+test_that("The number of columns of the first data frame cannot differ from the
+          number of rows of the second matrix, hence preventing incompatible
+          matrix multiplication", {
+            expect_error(df_mat_mul(df, mat, "z", 1:3))
+})
+
+X <- df[c(1,4,5)]
+Z <- as.data.frame(as.matrix(df[2:3]) %*% mat)
+colnames(Z) <- c("z1","z2")
+output <- cbind(X,Z)
+
+test_that("Names are being handled properly", {
+  expect_identical(df_mat_mul(df, mat, "z", 2:3),output)
+  expect_identical(df_mat_mul(df, mat, c("z1","z2"), 2:3),output)
+})
+
+test_that("Other tidyselect functionalities are working", {
+  mult <- df_mat_mul(df, mat, "z", dplyr::num_range("X", 2:3))
+  expect_identical(mult,output)
+  expect_identical(df_mat_mul(df, mat, "z", 2, 3),output)
+  # Mismatched names should not work:
+  expect_error(df_mat_mul(df, mat, "z", dplyr::num_range("Y", 2:3)))
+})

tests/testthat/test-df_mat_mul.R

@@ -0,0 +1,35 @@
+
+test_that("postprocesser was evaluated", {
+  r <- epi_recipe(case_death_rate_subset)
+  s <- parsnip::linear_reg()
+  f <- frosting()
+
+  ef <- epi_workflow(r, s, f)
+  ef2 <- epi_workflow(r, s) %>% add_frosting(f)
+
+  expect_true(epipredict:::has_postprocessor(ef))
+  expect_true(epipredict:::has_postprocessor(ef2))
+})
+
+
+test_that("outcome of the two methods are the same", {
+  jhu <- case_death_rate_subset
+
+  r <- epi_recipe(jhu) %>%
+    step_epi_lag(death_rate, lag = c(0, 7)) %>%
+    step_epi_ahead(death_rate, ahead = 7) %>%
+    step_epi_lag(case_rate, lag = c(7)) %>%
+    step_naomit(all_predictors()) %>%
+    step_naomit(all_outcomes())
+
+  s <- parsnip::linear_reg()
+  f <- frosting() %>%
+    layer_predict() %>%
+    layer_naomit(.pred) %>%
+    layer_residual_quantile()
+
+  ef <- epi_workflow(r, s, f)
+  ef2 <- epi_workflow(r, s) %>% add_frosting(f)
+
+  expect_equal(ef,ef2)
+})

tests/testthat/test-epi_workflow.R

@@ -0,0 +1,7 @@
+df <- data.frame(b=1,c=2,ca=3,cat=4)
+
+test_that("Names are grabbed properly", {
+  expect_identical(grab_names(df,dplyr::starts_with("ca")),
+                   subset(names(df),startsWith(names(df), "ca"))
+                   )
+})

tests/testthat/test-grab_names.R

@@ -0,0 +1,37 @@
+library(dplyr)
+library(parsnip)
+library(workflows)
+
+# Random generated dataset
+x <- tibble(geo_value = rep("nowhere",200),
+            time_value = as.Date("2021-01-01") + 0:199,
+            case_rate = 1:200,
+            death_rate = 1:200) %>%
+  epiprocess::as_epi_df()
+
+# Preparing the datasets to be used for comparison
+r <- epi_recipe(x) %>%
+  step_epi_ahead(death_rate, ahead = 7) %>%
+  step_epi_lag(death_rate, lag = c(0,7,14))
+
+test_that("Argument must be a recipe", {
+  expect_error(step_epi_naomit(x))
+})
+
+z1 <- step_epi_naomit(r)
+z2 <- r %>%
+  step_naomit(all_predictors()) %>%
+  step_naomit(all_outcomes(), skip = TRUE)
+
+# Checks the behaviour of a step function, omitting the quosure and id that
+# differ from one another, even with identical behaviour
+behav <- function(recipe,step_num) recipe$steps[[step_num]][-1][-5]
+# Checks the class type of an object
+step_class <- function(recipe,step_num) class(recipe$steps[step_num])
+
+test_that("Check that both functions behave the same way", {
+  expect_identical(behav(z1,3),behav(z2,3))
+  expect_identical(behav(z1,4),behav(z2,4))
+  expect_identical(step_class(z1,3),step_class(z2,3))
+  expect_identical(step_class(z1,4),step_class(z2,4))
+})