parse_time_formula <- function(index, time_formula) {
# Double up if 1 sided
# length = 2 means that it has ~ and 1 side
if(length(time_formula) == 2) {
.rhs <- rlang::f_rhs(time_formula)
.lhs <- .rhs
.env <- rlang::f_env(time_formula)
time_formula <- rlang::new_formula(.lhs, .rhs, .env)
}
# Split time formula into lhs and rhs and list() each
tf_list <- rlang::lang_args(time_formula)
tf_list <- lapply(tf_list, list)
# Split each formula side into it's time pieces
tf_fully_split <- lapply(tf_list, lang_args_recursive)
# Add default times
# map2 is a bit slow here
tf_final <- list(NA, NA)
tf_final[[1]] <- add_time_defaults(index, tf_fully_split[[1]], "lhs")
tf_final[[2]] <- add_time_defaults(index, tf_fully_split[[2]], "rhs")
tf_final
}
#### Utils ---------------------------------------------------------------------
## Functions for recursively splitting the formula sides --------------------
# Used to recursively apply lang_args to 1 side of the time formula
# End up with a flat list of split time pieces
lang_args_recursive <- function(lang) {
while(needs_recursion(lang)) {
lang <- map_lang_args(lang)
}
lang
}
# If any of the lang sides are longer than 1, it needs splitting
needs_recursion <- function(lang) {
sum(
vapply(
lang,
function(x) length(x) > 1,
FUN.VALUE = logical(1)
)
)
}
# For each tf side, apply a lang_args call
map_lang_args <- function(lang) {
unlist(lapply(lang, safe_lang_args), recursive = FALSE)
}
# A safer version of lang_args for this case
# Safer because if it is not a lang, it returns a list of itself which
# is what is needed for this to flatten correctly
safe_lang_args <- function(lang) {
if(rlang::is_lang(lang)) {
rlang::lang_args(lang)
} else {
list(lang)
}
}
## Functions for adding defaults ------------------------------------------
# Adds default times to fill out the sides of the time formula
add_time_defaults <- function(index, tf_side, side = "lhs") {
# Lookup specific index class defaults
defaults <- lookup_defaults(index, side)
# Check length
if(length(tf_side) > length(defaults)) {
index_class <- class(index)[[1]]
default_names <- paste(names(defaults), collapse = ", ")
stop(paste0("For a ", index_class, " index, time_formula can only include ",
default_names, " specifications."), call. = FALSE)
}
# Overwrite defaults where necessary
for(i in seq_along(tf_side)) {
defaults[[i]] <- tf_side[[i]]
}
# Handle end of month
if(!is.null(defaults$d)) { # If this passes it was Date/POSIX
if(defaults$d == 0) {
# Fake a date to find the number of days in that month
fake_date <- lubridate::make_date(defaults$y, defaults$m, 1)
defaults$d <- lubridate::days_in_month(fake_date)
}
}
defaults
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.