Merge pull request #151 from cmu-delphi/remove-flag

Remove flag

Author: dajmcdon

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: epipredict
 Title: Basic epidemiology forecasting methods
-Version: 0.0.3
+Version: 0.0.3.9999
 Authors@R: c(
     person("Daniel", "McDonald", , "[email protected]", role = c("aut", "cre")),
     person("Ryan", "Tibshirani", , "[email protected]", role = "aut"),

R/create-layer.R

@@ -25,10 +25,12 @@ create_layer <- function(name = NULL, open = rlang::is_interactive()) {
   name <- usethis:::slug(name, "R")
   usethis:::check_file_name(name)
   path <- fs::path("R", name)
-  if (! fs::file_exists(path)) {
-    usethis::use_template("layer.R", save_as = path,
-                          data = list(name = layer_name), open = FALSE,
-                          package = "epipredict")
+  if (!fs::file_exists(path)) {
+    usethis::use_template(
+      "layer.R", save_as = path,
+      data = list(name = layer_name), open = FALSE,
+      package = "epipredict"
+    )
   }
   usethis::edit_file(usethis::proj_path(path), open = open)
 }

R/layer_add_forecast_date.R

@@ -69,13 +69,8 @@ layer_add_forecast_date <-
   }
 
 layer_add_forecast_date_new <- function(forecast_date, id) {
-  arg_is_scalar(forecast_date, allow_null = TRUE)
-  if (!is.null(forecast_date)) {
-    forecast_date <- tryCatch(as.Date(forecast_date), error = function(e) NA)
-  }
-  arg_is_date(forecast_date, allow_null = TRUE)
+  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)
 }
 

R/layer_add_target_date.R

@@ -45,6 +45,8 @@
 #' p2
 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)
     add_layer(
       frosting,
       layer_add_target_date_new(

R/layer_naomit.R

@@ -6,8 +6,6 @@
 #'   were positions in the data frame, so expressions like `x:y` can
 #'   be used to select a range of variables. Typical usage is `.pred` to remove
 #'   any rows with `NA` predictions.
-#' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
 #' @param id a random id string
 #'
 #' @return an updated `frosting` postprocessor
@@ -35,14 +33,14 @@
 #'
 #' p <- predict(wf1, latest)
 #' p
-layer_naomit <- function(frosting, ..., .flag = TRUE, id = rand_id("naomit")) {
+layer_naomit <- function(frosting, ..., id = rand_id("naomit")) {
+  arg_is_chr_scalar(id)
   add_layer(
     frosting,
     layer_naomit_new(
       terms = dplyr::enquos(...),
       id = id
-    ),
-    flag = .flag
+    )
   )
 }
 

R/layer_point_from_distn.R

@@ -64,8 +64,7 @@ layer_point_from_distn <- function(frosting,
       type = type,
       name = name,
       id = id
-    ),
-    flag = TRUE
+    )
   )
 }
 

R/layer_population_scaling.R

@@ -42,8 +42,6 @@
 #' in the `epi_df`.
 #' @param suffix a character. The suffix added to the column name if
 #' `create_new = TRUE`. Default to "_original".
-#' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
 #' @param id a random id string
 #'
 #' @return an updated `frosting` postprocessor
@@ -94,11 +92,10 @@ layer_population_scaling <- function(frosting,
                            rate_rescaling = 1,
                            create_new = TRUE,
                            suffix = "_scaled",
-                           .flag = TRUE,
                            id = rand_id("population_scaling")) {
 
-  arg_is_scalar(df_pop_col, rate_rescaling, create_new, suffix, .flag, id)
-  arg_is_lgl(create_new, .flag)
+  arg_is_scalar(df_pop_col, rate_rescaling, create_new, suffix, id)
+  arg_is_lgl(create_new)
   arg_is_chr(df_pop_col, suffix, id)
   arg_is_chr(by, allow_null = TRUE)
   if (rate_rescaling <= 0)
@@ -115,8 +112,7 @@ layer_population_scaling <- function(frosting,
       create_new = create_new,
       suffix = suffix,
       id = id
-    ),
-    flag = .flag
+    )
   )
 }
 

R/layer_predict.R

@@ -9,10 +9,6 @@
 #'
 #' @inheritParams parsnip::predict.model_fit
 #' @param frosting a frosting object
-#' #' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
-#' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
 #' @param id a string identifying the layer
 #'
 #'
@@ -49,17 +45,17 @@
 #' p2
 layer_predict <-
   function(frosting, type = NULL, opts = list(), ...,
-           .flag = TRUE,
            id = rand_id("predict_default")) {
+    arg_is_chr_scalar(id)
+    arg_is_chr_scalar(type, allow_null = TRUE)
     add_layer(
       frosting,
       layer_predict_new(
         type = type,
         opts = opts,
         dots_list = rlang::list2(...), # can't figure how to use this
         id = id
-      ),
-      flag = .flag
+      )
     )
   }
 
@@ -71,8 +67,11 @@ layer_predict_new <- function(type, opts, dots_list, id) {
 #' @export
 slather.layer_predict <- function(object, components, the_fit, the_recipe, ...) {
 
-  components$predictions <- predict(the_fit, components$forged$predictors,
-                                    type = object$type, opts = object$opts)
-  components$predictions <- dplyr::bind_cols(components$keys, components$predictions)
+  components$predictions <- predict(
+    the_fit,
+    components$forged$predictors,
+    type = object$type, opts = object$opts)
+  components$predictions <- dplyr::bind_cols(
+    components$keys, components$predictions)
   components
 }

R/layer_predictive_distn.R

@@ -12,8 +12,6 @@
 #' @param dist_type Gaussian or Student's t predictive intervals
 #' @param truncate Do we truncate the distribution to an interval
 #' @param name character. The name for the output column.
-#' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
 #' @param id a random id string
 #'
 #' @return an updated `frosting` postprocessor with additional columns of the
@@ -44,18 +42,17 @@
 #' p <- predict(wf1, latest)
 #' p
 layer_predictive_distn <- function(frosting,
-                                      ...,
-                                      dist_type = c("gaussian", "student_t"),
-                                      truncate = c(-Inf, Inf),
-                                      name = ".pred_distn",
-                                      .flag = TRUE, # mandatory
-                                      id = rand_id("predictive_distn")) {
+                                   ...,
+                                   dist_type = c("gaussian", "student_t"),
+                                   truncate = c(-Inf, Inf),
+                                   name = ".pred_distn",
+                                   id = rand_id("predictive_distn")) {
   rlang::check_dots_empty()
   arg_is_chr_scalar(name, id)
   dist_type <- match.arg(dist_type)
-  stopifnot(length(truncate) == 2L,
-            is.numeric(truncate),
-            truncate[1] < truncate[2])
+  stopifnot(
+    length(truncate) == 2L, is.numeric(truncate), truncate[1] < truncate[2]
+  )
 
   add_layer(
     frosting,
@@ -64,8 +61,7 @@ layer_predictive_distn <- function(frosting,
       truncate = truncate,
       name = name,
       id = id
-    ),
-    flag = .flag
+    )
   )
 }
 

R/layer_quantile_distn.R

@@ -58,8 +58,7 @@ layer_quantile_distn <- function(frosting,
       truncate = truncate,
       name = name,
       id = id
-    ),
-    flag = TRUE
+    )
   )
 }
 

R/layer_residual_quantiles.R

@@ -8,8 +8,6 @@
 #' @param by_key A character vector of keys to group the residuals by before
 #'   calculating quantiles. The default, `c()` performs no grouping.
 #' @param name character. The name for the output column.
-#' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
 #' @param id a random id string
 #'
 #' @return an updated `frosting` postprocessor with additional columns of the
@@ -49,14 +47,13 @@ layer_residual_quantiles <- function(frosting, ...,
                                      symmetrize = TRUE,
                                      by_key = character(0L),
                                      name = ".pred_distn",
-                                     .flag = TRUE,
                                      id = rand_id("residual_quantiles")) {
   rlang::check_dots_empty()
-  arg_is_scalar(symmetrize, .flag)
+  arg_is_scalar(symmetrize)
   arg_is_chr_scalar(name, id)
   arg_is_chr(by_key, allow_null = TRUE)
   arg_is_probabilities(probs)
-  arg_is_lgl(symmetrize, .flag)
+  arg_is_lgl(symmetrize)
   add_layer(
     frosting,
     layer_residual_quantiles_new(
@@ -65,8 +62,7 @@ layer_residual_quantiles <- function(frosting, ...,
       by_key = by_key,
       name = name,
       id = id
-    ),
-    flag = .flag
+    )
   )
 }
 

R/layer_threshold_preds.R

@@ -16,8 +16,6 @@
 #' @param upper Upper threshold for the prediction values. That is, any
 #'   predictions that are greater than this upper bound are set to it.
 #'   Default value is `Inf`.
-#' @param .flag a logical to determine if the layer is added. Passed on to
-#'   `add_layer()`. Default `TRUE`.
 #' @param id a random id string
 #'
 #'
@@ -47,17 +45,18 @@
 #' p <- predict(wf, latest)
 #' p
 layer_threshold <-
-  function(frosting, ..., lower = 0, upper = Inf, .flag = TRUE,
-           id = rand_id("threshold")) {
+  function(frosting, ..., lower = 0, upper = Inf, id = rand_id("threshold")) {
+    arg_is_scalar(lower, upper)
+    arg_is_chr_scalar(id)
+    stopifnot(is.numeric(lower), is.numeric(upper), lower < upper)
     add_layer(
       frosting,
       layer_threshold_new(
         terms = dplyr::enquos(...),
         lower = lower,
         upper = upper,
         id = id
-      ),
-      flag = .flag
+      )
     )
   }
 

R/layers.R

@@ -2,15 +2,14 @@
 #'
 #' @param frosting a `frosting` postprocessor
 #' @param object a `frosting` layer
-#' @param flag logical to determine if the layer is added. Default `TRUE`.
 #'
 #' @return an updated `frosting` postprocessor
 #' @export
-add_layer <- function(frosting, object, flag = TRUE) {
+add_layer <- function(frosting, object) {
   validate_frosting(frosting)
   validate_layer(object)
 
-  if (flag) frosting$layers[[length(frosting$layers) + 1]] <- object
+  frosting$layers[[length(frosting$layers) + 1]] <- object
 
   frosting
 }

R/utils_arg.R

@@ -158,3 +158,13 @@ arg_is_sorted = function(..., allow_null = FALSE) {
 
     })
 }
+
+
+arg_to_date <- function(x, allow_null = FALSE, allow_na = FALSE) {
+  arg_is_scalar(x, allow_null = allow_null, allow_na = allow_na)
+  if (allow_null && !is.null(x)) {
+    x <- tryCatch(as.Date(x), error = function(e) NA)
+  }
+  arg_is_date(x, allow_null = allow_null, allow_na = allow_na)
+  x
+}