R/plan.R

Defines functions print_plan_steps print_plan_inputs print.planner_plan setdiff_names intersect_names is_plan validate_plan wrap_steps update_steps update_inputs update_something remove_steps remove_inputs remove_something add_steps add_inputs add_something setter updator extractor plan

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