#' @export
plan <- function(...) {
out <- structure(
list2(
inputs = make_inputs_impl(...),
steps = list(),
),
class = "planner_plan"
)
validate_plan(out)
}
# templates ---------------------------------------------------------------
extractor <- function(name) {
function(plan) {
plan[[name]]
}
}
extract_plan_inputs <- extractor("inputs")
extract_plan_steps <- extractor("steps")
updator <- function(name, impl) {
function(plan, new) {
plan[[name]] <- impl(plan[[name]], new)
plan
}
}
update_plan_inputs <- updator("inputs", update_inputs_impl)
update_plan_steps <- updator("steps", update_steps_impl)
setter <- function(name) {
function(plan, new) {
plan[[name]] <- new
plan
}
}
set_plan_inputs <- setter("inputs")
set_plan_steps <- setter("steps")
# add something -----------------------------------------------------------
add_something <- function(.plan, ..., .extractor, .make_impl, .ensure_message,
.updator) {
plan <- validate_plan(.plan)
old <- .extractor(plan)
new <- .make_impl(...)
existing_names <- intersect_names(old, new)
ensure_empty(existing_names, .ensure_message)
.updator(plan, new)
}
#' @export
add_inputs <- function(.plan, ...) {
add_something(
.plan,
.extractor = extract_plan_inputs,
.make_impl = make_inputs_impl,
.ensure_message = "Inputs already exist",
.updator = update_plan_inputs,
...
)
}
#' @export
add_steps <- function(.plan, ...) {
add_something(
.plan,
.extractor = extract_plan_steps,
.make_impl = make_steps_impl,
.ensure_message = "Steps already exist",
.updator = update_plan_steps,
...
)
}
# remove something --------------------------------------------------------
remove_something <- function(.plan, ..., .extractor, .remove_impl, .setter) {
plan <- validate_plan(.plan)
new <- .remove_impl(.extractor(plan), ...)
.setter(plan, new)
}
#' @export
remove_inputs <- function(.plan, ...) {
remove_something(
.plan,
.extractor = extract_plan_inputs,
.remove_impl = remove_inputs_impl,
.setter = set_plan_inputs,
...
)
}
#' @export
remove_steps <- function(.plan, ...) {
remove_something(
.plan,
.extractor = extract_plan_steps,
.remove_impl = remove_steps_impl,
.setter = set_plan_steps,
...
)
}
# update something --------------------------------------------------------
update_something <- function(.plan, ..., .extractor, .make_impl,
.ensure_message, .updator) {
plan <- validate_plan(.plan)
old <- .extractor(plan)
new <- .make_impl(...)
unknown_names <- setdiff_names(new, old)
ensure_empty(unknown_names, .ensure_message)
.updator(plan, new)
}
#' @export
update_inputs <- function(.plan, ...) {
update_something(
.plan,
.extractor = extract_plan_inputs,
.make_impl = make_inputs_impl,
.ensure_message = "Unknown inputs",
.updator = update_plan_inputs,
...
)
}
#' @export
update_steps <- function(.plan, ...) {
update_something(
.plan,
.extractor = extract_plan_steps,
.make_impl = make_steps_impl,
.ensure_message = "Unknown steps",
.updator = update_plan_steps,
...
)
}
# wrap steps --------------------------------------------------------------
#' @export
wrap_steps <- function(.plan, ...) {
plan <- validate_plan(.plan)
wrappers <- dots_list(..., .homonyms = "error")
if (!is_named(wrappers)) {
glubort("All wrappers must be named")
}
old <- extract_plan_steps(plan)
unknown_names <- setdiff_names(wrappers, old)
ensure_empty(unknown_names, "Unknown steps")
new <- purrr::imap(wrappers, function(wrapper, name) {
if (!is_function(wrapper)) {
glubort("Wrapper must be a function: {name}")
}
arg_length <- length(fn_fmls(wrapper))
if (arg_length != 1) {
glubort("Wrapper must have exactly one argument: {name} has {arg_length}.")
}
wrapper(old[[name]])
})
non_functions <- names(purrr::discard(new, is_function))
ensure_empty(non_functions, "Wrappers did not return functions")
update_plan_steps(plan, new)
}
# validation --------------------------------------------------------------
validate_plan <- function(x, arg = deparse(substitute(x))) {
if (!is_plan(x)) {
glubort("{arg} must be a planner::plan.")
}
x
}
is_plan <- function(x) {
has_plan_class <- "planner_plan" %in% class(x)
if (!has_plan_class) return(FALSE)
x <- unclass(x)
has_correct_structure <- is_list(x)
if (!has_correct_structure) return(FALSE)
has_names <- is_named(x)
if (!has_names) return(FALSE)
has_correct_names <- all(names2(x) == c("inputs", "steps"))
if (!has_correct_names) return(FALSE)
# TODO validate_inputs?
# TODO validate_steps?
TRUE
}
# utils -------------------------------------------------------------------
intersect_names <- function(x, y) {
intersect(names2(x), names2(y))
}
setdiff_names <- function(x, y) {
setdiff(names2(x), names2(y))
}
# print -------------------------------------------------------------------
#' @export
print.planner_plan <- function(x, ...) {
cat_line("<PLAN>")
print_plan_inputs(x)
print_plan_steps(x)
invisible(x)
}
print_plan_inputs <- function(x) {
cat_line("inputs:")
purrr::iwalk(x$inputs, function(input, name) {
label <- as_label(input)
if (is_missing(input)) {
label <- crayon::red(label)
}
cat_line("{name}: {label}", indent = 1)
})
}
print_plan_steps <- function(x) {
inputs <- x$inputs
inputs_exists <- function(name) name %in% names(inputs)
input_is_missing <- function(name) is_missing(inputs[[name]])
step_results <- list()
step_already_executed <- function(name) name %in% names(step_results)
step_is_valid <- function(name) step_results[[name]]
cat_line("steps:")
purrr::iwalk(x$steps, function(step, name) {
cat_line("{name}: ", indent = 1)
fmls <- fn_fmls(step)
status <- "VALID"
purrr::iwalk(fn_fmls(step), function(fml, name) {
if (step_already_executed(name)) {
label <- "<step>"
if (!step_is_valid(name)) {
label <- crayon::yellow(label)
}
} else if (inputs_exists(name)) {
label <- "<input>"
if (input_is_missing(name)) {
label <- crayon::yellow(label)
status <<- "INVALID"
}
} else {
label <- as_label(fml)
if (is_missing(fml)) {
label <- crayon::red(label)
status <<- "INVALID"
}
}
cat_line("{name}: {label}", indent = 2)
})
step_results[[name]] <<- status == "VALID"
})
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.