did_you_mean

did_you_mean.R

# TODO: handle multiple, optional partial matching, among() and multiple_among() in signature

#' Validate a choice
#'
#' Alternative to `base::match.arg()`
#'
#' @param x A string to test
#' @param choices A character vector of choices, if empty acts like `match.args()`
#' @param show_some,show_all Message to show, depending on `max_show_all`.
#'   Note the asterisk in "{choices*}" that means choices are enumerated, use
#'   "{choices**}" if you'd like a bullet list instead. `choices` is modified to add
#'   quotes depending on the `quotes` parameter, and for `show_some()`
#'   it is reduced to the `n` best candidates.
#' @param n A number
#' @param max_show_all A number
#' @param quotes A character among "double", "single" and "none"
#' @param prompt Whether to prompt, and then user might correct their choice and
#'   continue, we can prompt through the console or using a popup.
#' @export
#'
#' @examples
#' \dontrun{
#' x <- "az"
#' did_you_mean(x, letters)
#' did_you_mean(x, letters[1:5])
#' did_you_mean(x, letters, "{x} is not allowed, closest alternatives: {choices**}")
#' did_you_mean(x, letters, prompt = "console")
#' did_you_mean(x, letters, prompt = "dialog")
#' foo <- function(bar = c("a", "b")) {
#'   did_you_mean(bar)
#' }
#' foo("c")
#' }
did_you_mean <- function(
    x,
    choices,
    show_some = "`{arg}` cannot be {x}, did you mean {choices*}?",
    show_all = "`{arg}` is {x}, it should be one of {choices*}.",
    n = 2,
    max_show_all = 10,
    quotes = c("double", "single", "none"),
    prompt = c("none", "console", "dialog")
) {
  x_nm <- as.character(substitute(x))
  if (missing(choices)) {
    # if the x was missing from parent fun and choices were missing here
    if (do.call(missing, list(substitute(x)), envir = parent.frame())) {
      return(x[[1]])
    }
    # borrowed from match.arg
    formal.args <- formals(sys.function(sysP <- sys.parent()))
    choices <- eval(formal.args[[x_nm]], envir = sys.frame(sysP))
  }
  if (length(x) != 1) rlang::abort(sprintf("`%s` must be of length 1", x_nm))
  if (x %in% choices) return(x)
  quotes <- did_you_mean(quotes)
  prompt <- did_you_mean(prompt)
  did_you_mean_impl(
    x,
    choices = choices,
    show_some = show_some,
    show_all = show_all,
    n = n,
    max_show_all = max_show_all,
    quotes = quotes,
    prompt = prompt,
    x_nm = x_nm,
    envir = parent.frame()
  )
}

did_you_mean_impl <- function(
    x,
    choices,
    show_some,
    show_all ,
    n,
    max_show_all,
    quotes,
    prompt,
    x_nm,
    envir
) {
  # valid choice, return choice invisibly
  if (x %in% choices) {
    return(x)
  }

  n_choices <- length(choices)
  quote <- c(double = "\"", single = "'", none = "")[quotes]
  x_quoted <- paste0(quote, x, quote)
  if (n_choices <= max_show_all) {
    candidates <- paste0(quote, choices, quote)
    pattern <- show_all
  } else {
    dist <- stringdist::stringdist(tolower(x), tolower(choices))
    candidates <- choices[order(dist)][seq_len(n)]
    candidates <- paste0(quote, candidates, quote)
    pattern <- show_some
  }

  msg <- glue::glue(
    pattern,
    .envir = list2env(
      list(x = x_quoted, choices = candidates, arg = x_nm),
      parent = parent.frame()
    ),
    .transformer = transformer
  )

  if (prompt == "none") {
    rlang::abort(msg, call = envir)
  }

  if (prompt == "console") {
    rlang::inform(msg)
    out <- readline("Try again: ")
  } else {
    out <- svDialogs::dlg_input(msg, "Try again!")$res
    # if cancel
    if (!length(out)) {
      rlang::abort(msg, call = envir)
    }
  }
  out <- did_you_mean_impl(
    out,
    choices = choices,
    show_some = show_some,
    show_all = show_all,
    n = n,
    max_show_all = max_show_all,
    quotes = quotes,
    prompt = prompt,
    x_nm = x_nm,
    envir = envir
  )
  out
}

transformer <- function(text, envir) {
  one_star <- grepl("[*]$", text)
  if (!one_star) return (eval(parse(text = text), envir))
  two_stars <- grepl("[*][*]$", text)
  if (two_stars) {
    out <- sub("[*][*]$", "", text)
    out <- eval(parse(text = out), envir)
    out <- rlang::format_error_bullets(out)
    out <- paste0("\n", out)
    return(out)
  }
  out <- sub("[*]$", "", text)
  out <- eval(parse(text = out), envir)
  out <- glue::glue_collapse(out, sep = " ,", last = " or ")
  out
}