R/match-arg.R

In jeanmathieupotvin/dotprofile: Create and Manage Configuration Profiles

#' Match a function's argument against candidates
#'
#' @description  Function [match_arg()] is a safer, more flexible alternative
#' to [match.arg()][base::match.arg()].
#'
#'   1. It expects scalar values only.
#'   2. It only works when called by another function.
#'   3. A default value can be explicitly defined as such.
#'   4. In case of no match, the error message is customizable, and prettier
#'   by default.
#'
#' @param arg `[atomic(1)]`
#'
#'   The argument to match. It is passed to [pmatch()][base::pmatch()] and
#'   is eventually converted to a [character vector][base::character()] by
#'   this function.
#'
#' @param error `[character(1)]`
#'
#'   Passed to [ui_stop()]. See details.
#'
#' @param ... `[any]`
#'
#'   Further calls passed to [ui_stop()]. See details.
#'
#' @param ..force_empty_stack `[logical(1)]`
#'
#'   __Never ever use that argument.__ This is a flag only relevant when
#'   debugging and testing [match_arg()].
#'
#' @returns An `atomic(1)`. Its type matches types of `arg`.
#'
#' @details When customizing error messages via `error` and/or `...`, you
#'   must ensure that any expression(s) embedded into these error messages
#'   are properly evaluated in their own scope before being passed down to
#'   [match_arg()]. Else, you will get an error. See examples.
#'
#' @examples
#' ## It always fails when called outside of another function.
#' \dontrun{match_arg()}
#'
#' ## It matches the usual behavior of match.arg().
#' wrap <- function(foo = c("a", "b", "c")) {
#'     return(match_arg(foo))
#' }
#'
#' identical(wrap(),    "a")
#' identical(wrap("b"), "b")
#'
#' ## Error messages are much more beautiful and match dotprofile's styling.
#' \dontrun{wrap("d")}
#'
#' ## You can explicitly mark a value as being the default one.
#' wrap2 <- function(foo = c("a", "b", default = "c")) {
#'     return(match_arg(foo))
#' }
#'
#' identical(wrap2(),    "c")
#' identical(wrap2("b"), "b")
#'
#' ## Customize error messages.
#' wrap3 <- function(foo = c("a", "b", default = "c")) {
#'     error <- cli::format_inline("{.arg {foo}} contains an error.")
#'     return(
#'         match_arg(foo, error,
#'             ui_todo("It must be equal to a valid value.")))
#' }
#'
#' \dontrun{wrap3("d")}
#'
#' @export
match_arg <- function(arg, error = NULL, ..., ..force_empty_stack = FALSE)
{
    # Get symbol that was passed to `arg`
    # in previous execution environment
    # and coerce it to a character(1).
    arg_name <- deparse(substitute(arg))

    # In order to reach 100% code coverage,
    # we must force an empty stack to test
    # the first `if` branch of `arg_formals`
    # below. Setting `..force_empty_stack`
    # equal to TRUE will set `parent_fun`
    # equal to NULL. This is only relevant
    # when testing the function. It should
    # be ignored otherwise.
    which <- if (..force_empty_stack) -sys.nframe() else -1L

    # Get function that called this one, and
    # extract its formal arguments. Then, try
    # extracting / evaluating the default value
    # of `arg_name`. For safety, the underlying
    # expression is evaluated in its execution
    # environment. Most of the time, this will
    # be overkill. This is still required,
    # because `formals()` returns a pairlist.
    arg_formals <- if (is_nul(parent_fun <- sys.function(which))) {

        # If the previous execution environment is not
        # tied to a function, then we set `arg_values`
        # equal to NULL to later throw an error.
        NULL
    } else {
        eval(formals(parent_fun)[[arg_name]], -1L)
    }

    if (is_nul(arg_formals)) {
        ui_stop("{.arg {arg_name}} has no formal default value.")
    }

    # If no value was passed explicitly to `arg`
    # in the parent execution environment, `arg`
    # will just be equal to `arg_formals`. In
    # that case, we return a default value.
    if (identical(arg, arg_formals)) {

        # A value that is explicitly marked as
        # being the `default` one has precedence.
        # Else, we just return the first valid
        # value.
        if (is.na(default <- arg_formals["default"])) {
            return(arg_formals[[1L]])
        } else {
            return(default[[1L]]) # drop names
        }
    }

    # Match `arg` against candidates.
    # Duplicates are never accepted,
    # we strictly focus on scalar values.
    match_pos <- pmatch(arg, arg_formals, nomatch = 0L, duplicates.ok = FALSE)

    # Return an error in case of no match.
    if (length(match_pos) != 1L || match_pos == 0L) {
        error <- error %||% "{.arg {arg_name}} must be equal to either {.val {enum(arg_formals)}}."
        ui_stop(error, ...)
    }

    return(arg_formals[[match_pos]])
}