-
Notifications
You must be signed in to change notification settings - Fork 10
291 date period #297
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
291 date period #297
Changes from 17 commits
dff767e
0667845
edd5134
e3b2907
a624b63
69b21c6
3498fcf
b2b8134
f2f39a2
f9859fe
fb7faae
78ff1f9
3d059f4
de9e00a
0c38723
e036b8d
e6e60cd
845c1a9
8feef06
6d5c379
047caa6
cfde0c9
fc05cd9
1e76059
f5ef88b
c1e3ff9
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,6 +1,6 @@ | ||
Package: epipredict | ||
Title: Basic epidemiology forecasting methods | ||
Version: 0.0.10 | ||
Version: 0.0.11 | ||
Authors@R: c( | ||
person("Daniel", "McDonald", , "[email protected]", role = c("aut", "cre")), | ||
person("Ryan", "Tibshirani", , "[email protected]", role = "aut"), | ||
|
@@ -46,6 +46,7 @@ Imports: | |
tibble, | ||
tidyr, | ||
tidyselect, | ||
tsibble, | ||
usethis, | ||
vctrs, | ||
workflows (>= 1.0.0) | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -63,7 +63,7 @@ | |
#' p3 | ||
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) | ||
# can't validate target_date until we know the time_type | ||
arg_is_chr_scalar(id) | ||
add_layer( | ||
frosting, | ||
|
@@ -84,33 +84,46 @@ slather.layer_add_target_date <- function(object, components, workflow, new_data | |
the_recipe <- workflows::extract_recipe(workflow) | ||
the_frosting <- extract_frosting(workflow) | ||
|
||
if (!is.null(object$target_date)) { | ||
target_date <- as.Date(object$target_date) | ||
} else { # null target date case | ||
if (detect_layer(the_frosting, "layer_add_forecast_date") && | ||
!is.null(extract_argument( | ||
the_frosting, | ||
"layer_add_forecast_date", "forecast_date" | ||
))) { | ||
forecast_date <- extract_argument( | ||
the_frosting, | ||
"layer_add_forecast_date", "forecast_date" | ||
) | ||
expected_time_type <- attr( | ||
workflows::extract_preprocessor(workflow)$template, "metadata" | ||
)$time_type | ||
if (expected_time_type == "week") expected_time_type = "day" | ||
|
||
ahead <- extract_argument(the_recipe, "step_epi_ahead", "ahead") | ||
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." | ||
)) | ||
dsweber2 marked this conversation as resolved.
Show resolved
Hide resolved
|
||
} | ||
target_date <- coerce_time_type(object$target_date, expected_time_type) | ||
} else if ( | ||
detect_layer(the_frosting, "layer_add_forecast_date") && | ||
!is.null(possible_fd <- extract_argument( | ||
the_frosting, "layer_add_forecast_date", "forecast_date" | ||
))) { | ||
|
||
target_date <- forecast_date + ahead | ||
} else { | ||
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) | ||
ahead <- extract_argument(the_recipe, "step_epi_ahead", "ahead") | ||
target_date <- forecast_date + ahead | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Does having this go from There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Separate question: how do the units in ahead change depending on the time type? Is this primarily up to the user to make sure they specify aheads in the right units? There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. On This PR is meant to allow for |
||
} else { | ||
max_time_value <- max( | ||
workflows::extract_preprocessor(workflow)$max_time_value, | ||
workflow$fit$meta$max_time_value, | ||
max(new_data$time_value) | ||
) | ||
|
||
ahead <- extract_argument(the_recipe, "step_epi_ahead", "ahead") | ||
|
||
target_date <- max_time_value + ahead | ||
} | ||
} | ||
|
||
components$predictions <- dplyr::bind_cols(components$predictions, | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -144,6 +144,12 @@ slather.layer_population_scaling <- | |
length(object$df_pop_col) == 1 | ||
) | ||
|
||
if (is.null(object$by)) { | ||
object$by <- intersect( | ||
kill_time_value(epi_keys(components$predictions)), | ||
colnames(dplyr::select(object$df, !object$df_pop_col)) | ||
) | ||
} | ||
try_join <- try( | ||
dplyr::left_join(components$predictions, object$df, | ||
by = object$by | ||
|
@@ -157,8 +163,8 @@ slather.layer_population_scaling <- | |
)) | ||
} | ||
|
||
object$df <- object$df %>% | ||
dplyr::mutate(dplyr::across(tidyselect::where(is.character), tolower)) | ||
# object$df <- object$df %>% | ||
# dplyr::mutate(dplyr::across(tidyselect::where(is.character), tolower)) | ||
Comment on lines
+166
to
+167
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I think this is wrong, but I'm not yet certain that it's safe to remove. There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. doing some timetravel, it looks like it's been here in one form or another forever. What's confusing to me is that this looks like it does nothing. Was the point to make all the characters columns lowercase (such as There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Yeah, I'm not sure why it was there in the first place. I suspect that the included state population dataset used capitals while typical usage from the API gives geos in lower case. But that shouldn't have resulted in hardcoded workarounds here (that are prone to failure). So I think this should go forever, but I wanted to be sure that if some downstream use errored out, I could find this and try to track it more carefully. |
||
pop_col <- rlang::sym(object$df_pop_col) | ||
exprs <- rlang::expr(c(!!!object$terms)) | ||
pos <- tidyselect::eval_select(exprs, components$predictions) | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,48 @@ | ||
guess_time_type <- function(time_value) { | ||
# similar to epiprocess:::guess_time_type() but w/o the gap handling | ||
arg_is_scalar(time_value) | ||
if (is.character(time_value)) { | ||
if (nchar(time_value) <= "10") { | ||
new_time_value <- tryCatch({ | ||
as.Date(time_value) | ||
}, error = function(e) NULL) | ||
} else { | ||
new_time_value <- tryCatch({ | ||
as.POSIXct(time_value) | ||
}, error = function(e) NULL) | ||
} | ||
if (!is.null(new_time_value)) time_value <- new_time_value | ||
} | ||
if (inherits(time_value, "POSIXct")) return("day-time") | ||
if (inherits(time_value, "Date")) return("day") | ||
if (inherits(time_value, "yearweek")) return("yearweek") | ||
if (inherits(time_value, "yearmonth")) return("yearmonth") | ||
if (inherits(time_value, "yearquarter")) return("yearquarter") | ||
if (is.numeric(time_value) && all(time_value == as.integer(time_value)) && | ||
all(time_value >= 1582)) { | ||
return("year") | ||
} | ||
return("custom") | ||
} | ||
|
||
coerce_time_type <- function(x, target_type) { | ||
if (target_type == "year") { | ||
if (is.numeric(x)) return(as.integer(x)) | ||
else return(as.POSIXlt(x)$year + 1900L) | ||
} | ||
switch( | ||
target_type, | ||
"day-time" = as.POSIXct(x), | ||
"day" = as.Date(x), | ||
"week" = as.Date(x), | ||
"yearweek" = tsibble::yearweek(x), | ||
"yearmonth" = tsibble::yearmonth(x), | ||
"yearquarter" = tsibble::yearquarter(x) | ||
) | ||
} | ||
|
||
validate_date <- function(x, expected) { | ||
x <- guess_time_type(x) | ||
ok <- x == expected | ||
enlist(ok, x, expected) | ||
} |
Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.
Uh oh!
There was an error while loading. Please reload this page.