#' @export
execute <- function(plan, ..., .envir = caller_env(), .return = ..last..) {
func <- build_function(plan, .envir = .envir, .return = {{.return}})
func(...)
}
# function ----------------------------------------------------------------
#' @export
build_function <- function(plan, .envir = caller_env(), .return = ..last..) {
plan <- validate_plan(plan)
args <- build_function_args(plan)
body <- build_function_body(plan, .return = {{.return}})
env <- build_function_env(plan, .envir)
new_function(args, body, env)
}
build_function_args <- function(plan) {
extract_plan_inputs(plan)
}
build_function_body <- function(plan, .return) {
build_input <- function(input, name) {
expr(force(!!sym(name)))
}
inputs <- extract_plan_inputs(plan)
input_calls <- purrr::imap(inputs, build_input)
build_step <- function(step, name) {
fmls <- fn_fmls_syms(step)
sym <- sym(name)
expr(!!sym <- .execute_step(!!name, !!!fmls))
}
steps <- extract_plan_steps(plan)
step_calls <- purrr::imap(steps, build_step)
.return <- quo_get_expr(enquo(.return))
if (is_empty(step_calls)) {
return_call <- list()
# retval <- sym(names2(step_calls)[length(step_calls)])
# step_calls <- c(step_calls, retval)
} else if (identical(.return, quote(..last..))) {
return_call <- exprs(.return_step(!!names(steps)[length(steps)]))
} else if (identical(.return, quote(..all..))) {
return_call <- exprs(.return_all())
} else if (is_string(.return) && .return %in% names(steps)) {
return_call <- exprs(.return_step(!!.return))
} else {
glubort("Unknown step")
}
body <- expr({
!!!input_calls
!!!step_calls
!!!return_call
})
body
}
build_function_env <- function(plan, .envir) {
func_env <- new_environment(parent = .envir)
steps <- extract_plan_steps(plan)
results <- rep_named(names(steps), list(NULL))
env <- env(func_env, steps = steps, results = results)
execute_step <- function(name, ...) {
msg <- glue::glue("EXECUTING STEP: {name}")
message(msg)
func <- steps[[name]]
out <- results[[name]] <<- withVisible(func(...))
out$value
}
environment(execute_step) <- env
func_env[[".execute_step"]] <- execute_step
return_step <- function(name) {
out <- results[[name]]
if (out$visible) {
out$value
} else {
invisible(out$value)
}
}
environment(return_step) <- env
func_env[['.return_step']] <- return_step
return_all <- function() {
lapply(results, function(x) x$value)
}
environment(return_all) <- env
func_env[['.return_all']] <- return_all
func_env
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.