R/build.R

Defines functions build_function_env build_function_body build_function_args build_function execute

#' @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
}
shunsambongi/planner documentation built on Aug. 19, 2022, 9:57 a.m.