refactor validate_date() to avoid duplication

Author: dajmcdon

R/layer_add_forecast_date.R

@@ -81,7 +81,6 @@ layer_add_forecast_date <-
   }
 
 layer_add_forecast_date_new <- function(forecast_date, id) {
-
   layer("add_forecast_date", forecast_date = forecast_date, id = id)
 }
 
@@ -93,27 +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
   }
 
   expected_time_type <- attr(
     workflows::extract_preprocessor(workflow)$template, "metadata"
   )$time_type
   if (expected_time_type == "week") expected_time_type <- "day"
-  check <- validate_date(object$forecast_date, expected_time_type)
-
-  if (!check$ok) {
-    cli::cli_abort(c(
-      "The `forecast_date` was given as a {.val {check$x}} while the",
-      `!` = "`time_type` of the training data was {.val {check$expected}}.",
-      i = "See {.topic epiprocess::epi_df} for how these are determined."
-    ))
-  }
-
+  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 = coerce_time_type(object$forecast_date, expected_time_type)
+    forecast_date = forecast_date
   )
+
   components
 }
 

R/layer_add_target_date.R

@@ -91,29 +91,20 @@ slather.layer_add_target_date <- function(object, components, workflow, new_data
   if (expected_time_type == "week") expected_time_type <- "day"
 
   if (!is.null(object$target_date)) {
-    check <- validate_date(object$target_date, expected_time_type)
-    if (!check$ok) {
-      cli::cli_abort(c(
-        "The `target_date` was given as a {.val {check$x}} while the",
-        `!` = "`time_type` of the training data was {.val {check$expected}}.",
-        i = "See {.topic epiprocess::epi_df} for descriptions of these are determined."
-      ))
-    }
-    target_date <- coerce_time_type(object$target_date, expected_time_type)
+    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(possible_fd <- extract_argument(
+      !is.null(forecast_date <- extract_argument(
         the_frosting, "layer_add_forecast_date", "forecast_date"
       ))) {
-    check <- validate_date(possible_fd, expected_time_type)
-    if (!check$ok) {
-      cli::cli_abort(c(
-        "The `forecast_date` was given as a {.val {check$x}} while the",
-        `!` = "`time_type` of the training data was {.val {check$expected}}.",
-        i = "See {.topic epiprocess::epi_df} for how these are determined."
-      ))
-    }
-    forecast_date <- coerce_time_type(possible_fd, expected_time_type)
+    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 {
@@ -126,6 +117,7 @@ slather.layer_add_target_date <- function(object, components, workflow, new_data
     target_date <- max_time_value + ahead
   }
 
+  object$target_date <- target_date
   components$predictions <- dplyr::bind_cols(components$predictions,
     target_date = target_date
   )

R/time_types.R

@@ -59,8 +59,15 @@ coerce_time_type <- function(x, target_type) {
   )
 }
 
-validate_date <- function(x, expected) {
-  x <- guess_time_type(x)
-  ok <- x == expected
-  enlist(ok, x, expected)
+validate_date <- function(x, expected, arg = rlang::caller_arg(x),
+                          call = rlang::caller_env()) {
+  time_type_x <- guess_time_type(x)
+  ok <- time_type_x == expected
+  if (!ok) {
+    cli::cli_abort(c(
+      "The {.arg {arg}} was given as a {.val {time_type_x}} while the",
+      `!` = "`time_type` of the training data was {.val {expected}}.",
+      i = "See {.topic epiprocess::epi_df} for descriptions of these are determined."
+    ), call = call)
+  }
 }