R/mk_lookup_utils.R

In toniprice/jute: Sundry Utility Functions

# ---------------------------------------------------------------------------- #
#' Create lookup utility functions
#'
#' The \code{mk_lookup_utils} function is a closure which returns a list of
#' lookup utility functions.
#'
#' @param lookups A named list of named character vectors. The names are
#'   available types and the elements (each a named character vector) are
#'   key/description pairs for the corresponding lookup type.
#'
#' @return A list of lookup utility functions with the following elements
#'   \strong{(see 'Returned Functions' for details)}:
#'   \describe{
#'     \item{\code{get_all}}{Function to retrieve all available lookups}
#'     \item{\code{get}}{Function to retrieve the lookup options for the given
#'          key}
#'     \item{\code{descrip}}{Function to return the description for a key from
#'          the specified lookup}
#'     \item{\code{get_types}}{Function to retrieve the names of all available
#'          lookup types}
#'     \item{\code{get_choices}}{Function to retrieve the names of all available
#'          choices for the given type}
#'     \item{\code{make}}{Function to create a lookup function for the given
#'          type}
#'     \item{\code{make_all}}{Function to create lookup functions for all
#'          available types}
#'     \item{\code{add_to_env}}{Function to add the given lookup functions to
#'          the specified environment}
#'   }
#'
#' @section Returned Functions:
#'   The returned functions are utilities for managing a lookup list. They are:
#'
#' \preformatted{
#' get_all()
#' }
#' Function to retrieve all available lookups\cr
#' \emph{Value}\cr
#' A list of all available lookups.
#'
#' \preformatted{
#' get(type)
#' }
#' Function to retrieve the lookup options for the given key\cr
#' \emph{Arguments}\cr
#' \describe{
#'   \item{\code{type}}{The name of the type for which to retrieve lookup
#'     options.}
#' }
#' \emph{Value}\cr
#' A named character vector of lookup options for the given type. The character
#'   vector consists of key/value pairs where names are keys and values are
#'   descriptions for the keys.
#'
#' \preformatted{
#' descrip(key, type = NULL, lookup = NULL, tf = FALSE, strip_name = TRUE)
#' }
#' Function to return the description for a key from the specified lookup\cr
#' \emph{Arguments}\cr
#' \describe{
#'    \item{\code{key}}{The key for which to retrieve a description from
#'      the specified lookup.}
#'    \item{\code{type}}{The type (as a string) for which to retrieve the
#'      lookup. If NULL, \code{lookup} must be supplied instead.}
#'    \item{\code{lookup}}{The lookup list (a named list of named character
#'      vectors). If NULL, \code{type} must be supplied instead.}
#'    \item{\code{tf}}{A logical specifying whether the first letter of the
#'      description should be in title case ("tf" stands for "titleize first");
#'      otherwise it will be lower case.}
#'    \item{\code{strip_name}}{A logical specifying whether the name (i.e. the
#'      key) should be removed from the description before it is returned.}
#' }
#' \emph{Value}\cr
#' Description of the specified key within the specified lookup.
#'
#' \preformatted{
#' get_types()
#' }
#' Function to retrieve the names of all available lookup types\cr
#' \emph{Value}\cr
#' A character vector comprising names of all available lookup types.
#'
#' \preformatted{
#' get_choices(type)
#' }
#' Function to retrieve the names of all available choices for the given type\cr
#' \emph{Arguments}\cr
#' \describe{
#'    \item{\code{type}}{The type (as a string) for which to retrieve all
#'      available choices.}
#' }
#' \emph{Value}\cr
#' A character vector comprising names of all available choices for the given
#'   type.
#'
#' \preformatted{
#' make(type)
#' }
#' Function to create a lookup function for the given type\cr
#' \emph{Arguments}\cr
#' \describe{
#'    \item{\code{type}}{The type (as a string) for which to create a lookup
#'      function.}
#' }
#' \emph{Value}\cr
#' A lookup function for the given type.
#'
#' \preformatted{
#' make_all()
#' }
#' Function to create lookup functions for all available types\cr
#' \emph{Value}\cr
#' A list of all available lookup functions.
#'
#' \preformatted{
#' add_to_env(envir = NULL, lst = NULL)
#' }
#' Function to add the given lookup functions to the specified environment\cr
#' \emph{Arguments}\cr
#' \describe{
#'    \item{\code{envir}}{Environment to which the lookup functions should be
#'      added. Note that the default is to create a new environment from within
#'      this function, which would have no effect on its return; this is by
#'      design to avoid any unintended additions to another environment.}
#'    \item{\code{lst}}{A list of functions to add to the specified environment
#'      (or NULL to add all available lookup functions).}
#' }
#' \emph{Value}\cr
#' NULL
#'
#' @examples
#' stuff <- list(
#'   a = c(upper = "red", middle = "yellow", lower = "green"),
#'   b = c(first = "platinum level", second = "silver level")
#' )
#' lookup <- mk_lookup_utils(stuff)
#'
#' lookup$get_all()
#'
#' lookup$get("b")
#'
#' lookup$descrip("lower", lookup = lookup$get("a"))
#' lookup$descrip("lower", "a")
#'
#' lookup$descrip("lower", "a", tf = TRUE)
#'
#' lookup$descrip("lower", "a", strip_name = FALSE)
#'
#' lookup$get_types()
#'
#' lookup$get_choices("b")
#'
#' lookup_a <- lookup$make("a")
#' lookup_a("upper")
#'
#' lookup_lst <- lookup$make_all()
#' lookup_lst$lookup_b("second")
#'
#' an_env <- new.env(parent = emptyenv())
#' lookup$add_to_env(an_env)
#'
#' @export
#'
mk_lookup_utils <- function(lookups) {

  # ---------------------------------- #
  # get
  # ---------------------------------- #
  get <- function(type) {
    if (missing(type)) {
      cli_abort(c(
        "{.var type} must be supplied but is missing"
      ),
      class = "jute_error"
      )
    }

    if (test_null(lookups[[type]])) {
      cli_abort(c(
        "{.var type} must be a known lookup type",
        "x" = "You've supplied an unrecognised type '{type}'."
      ),
      class = "jute_error"
      )
    }

    lookups[[type]]
  }

  # ---------------------------------- #
  # descrip
  # ---------------------------------- #
  descrip <- function(key, type = NULL, lookup = NULL, tf = FALSE,
                      strip_name = TRUE) {
    if (missing(key)) {
      cli_abort(c(
        "{.var key} must be supplied but is missing"
      ),
      class = "jute_error"
      )
    }

    if (test_null(type) && test_null(lookup)) {
      cli_abort(c(
        "You must supply at least one of {.var type} and {.var lookup}",
        "x" = "Both {.var type} and {.var lookup} are NULL."
      ),
      class = "jute_error"
      )
    }

    lookup <- lookup %||% get(type)

    descrip <- lookup[key]
    if (test_scalar_na(unname(descrip))) {
      cli_abort(c(
        "{.var key} must exist in the lookup table",
        "x" = "You've supplied an invalid key '{key}'."
      ),
      class = "jute_error"
      )
    }
    if (strip_name) descrip <- unname(descrip)
    if (tf) descrip <- titleize_first(descrip)
    descrip
  }

  # ---------------------------------- #
  # get_types
  # ---------------------------------- #
  get_types <- function() {
    names(lookups)
  }

  # ---------------------------------- #
  # get_choices
  # ---------------------------------- #
  get_choices <- function(type) {
    names(get(type))
  }

  # ---------------------------------- #
  # make
  # ---------------------------------- #
  make <- function(type) {
    lookup <- get(type)
    function(key, tf = FALSE, strip_name = TRUE) {
      descrip(key, lookup = lookup, tf = tf, strip_name = strip_name)
    }
  }

  # ---------------------------------- #
  # make_all
  # ---------------------------------- #
  make_all <- function() {
    lkup_names <- get_types()

    funcs <- lapply(lkup_names, function(nm) {
      make(nm)
    })
    names(funcs) <- sprintf("lookup_%s", lkup_names)

    funcs
  }

  # ---------------------------------- #
  # add_to_env
  # ---------------------------------- #
  add_to_env <- function(envir = NULL, lst = NULL) {
    envir <- envir %||% new.env(parent = emptyenv())
    lst <- lst %||% make_all()
    # Define functions in the specified environment
    list2env(lst, envir = envir)
    NULL
  }

  # ---------------------------------- #
  list(
    get_all     = function() lookups,
    get         = get,
    descrip     = descrip,
    get_types   = get_types,
    get_choices = get_choices,
    make        = make,
    make_all    = make_all,
    add_to_env  = add_to_env
  )
}

# ---------------------------------------------------------------------------- #