R/check_progress.R

In domjarkey/crunchscripts: Easily Manage Ad-Hoc and Recurring Crunch Projects in R

#' @import rlang
#' @importFrom crayon red green
#' @importFrom stringr str_detect
#'
#' @title Check Project Progress
#' @description Displays a list of project check points with items coloured green if the checkpoint
#' criterion is met, and red otherwise. Check points should be set out as a named \code{list} or
#' nested lists of logical expressions captured using the \code{`~`} (tilde) operator, and should be
#' defined as an option in the \code{.onLoad} function of a project package using \code{options}.
#' @param item An optional vector of integers and/or characters indicating an item or sublist of the
#' checklist to check. See examples.
#' @param checklist A named list (or list of lists) of captured logical expressions to be evaluated.
#' By default the \code{cs_checklist} option is used if one has been set.
#' @param name A character string to display as the title. By default the \code{cs_projname} option
#' is used if one has been set, or "Progress" otherwise.
#' @return Returns a logical (invisibly), TRUE if all items on the check list are satisfied or FALSE
#' otherwise.
#' @export
check_progress <- function(
  item = NULL,
  checklist = getOption("cs_checklist", default = NULL),
  name = getOption("cs_script_name", default = "Progress")
) {
  if (is.null(checklist)) {
    stop("No checklist found - please supply as argument or set cs_checklist using options().")
  }
  if (is.null(item)) {
    check_item(checklist, name = name, depth = 0)
  } else {
    check_item(
      get_list_item(checklist, item),
      name = get_list_item(checklist, item, get_name = TRUE),
      depth = 0
    )
  }
}

check_item <- function(checklist, name, depth) {
  cat(rep(" ", depth), sep = "")

  if (is_formula(checklist)) {
    # Evaluate the item (this is base case of the recursion), set item_completed as NULL if an
    # object in the captured expression is not in the current environment
    item_completed <- tryCatch(
      eval_tidy(as_quosure(checklist)),
      error = function(e) {
        if (str_detect(e$message, "^object \\'.+\\' not found$")) {
          NULL
        } else {
          stop(e)
        }
      }
    )
    if (is.null(item_completed) || (is_logical(item_completed) && length(item_completed) == 1)) {
      if (is.null(item_completed)) {
        cat(silver(name))
      } else if (item_completed) {
        cat(green(name))
      } else {
        cat(red(name))
      }
      cat("\n")
      return(invisible(item_completed))
    } else {
      stop("checklist must be a list (or a list of lists) of expressions that each return a logical when evaluated.")
    }
  } else if (is_list(checklist) && length(checklist) >= 1) {
    cat(rep(" ", depth), name, "\n", sep = "")
    if (is.null(names(checklist))) {
      names <- rep(".", length(checklist))
    } else {
      names <- names(checklist)
    }
    # Recursively evaluate all subitems on checklist
    subitems <- c()
    for (i in seq_along(checklist)) {
      subitems <- c(subitems, check_item(checklist[[i]], name = names[[i]], depth = depth + 1))
    }
    item_completed <- all(subitems)
    return(invisible(item_completed))
  } else {
    stop("Incorrectly formatted checklist argument.")
  }
}