New labeller: label_dictionary() (#461)

NAMESPACE

@@ -121,6 +121,7 @@ export(label_comma)
 export(label_currency)
 export(label_date)
 export(label_date_short)
+export(label_dictionary)
 export(label_dollar)
 export(label_glue)
 export(label_log)

NEWS.md

@@ -10,6 +10,7 @@
   using `get_palette()` or registered using `set_palette()` (#396).
 * `label_log()` has a `signed` argument for displaying negative numbers 
   (@teunbrand, #421).
+* New `label_dictionary()` for named lookup of labels (#458).
 
 * New function `compose_label()` to chain together label formatting functions 
   (#462)

R/label-dictionary.R

@@ -0,0 +1,54 @@
+
+#' Labels from lookup tables
+#'
+#' Use `label_dictionary()` for looking up succinct breaks in a named character
+#' vector giving complete labels.
+#'
+#' @param dictionary A named character vector of labels. The names are expected
+#'   to match the breaks, and the values become the labels.
+#' @param nomatch A string to label breaks that do not match any name in
+#'  `dictionary`. When `NULL` (default), the breaks are not translated but are
+#'  kept as-is.
+#'
+#' @return A labeller function that takes a character vector of breaks and
+#'   returns a character vector of labels.
+#' @export
+#' @family labels for discrete scales
+#' @examples
+#' # Example lookup table
+#' lut <- c(
+#'   "4" = "four wheel drive",
+#'   "r" = "rear wheel drive",
+#'   "f" = "front wheel drive"
+#' )
+#'
+#' # Typical usage
+#' demo_discrete(c("4", "r", "f"), labels = label_dictionary(lut))
+#' # By default, extra values ('w') will remain as-is
+#' demo_discrete(c("4", "r", "f", "w"), labels = label_dictionary(lut))
+#' # Alternatively, you can relabel extra values
+#' demo_discrete(
+#'   c("4", "r", "f", "w"),
+#'   labels = label_dictionary(lut, nomatch = "unknown")
+#' )
+label_dictionary <- function(dictionary = character(), nomatch = NULL) {
+
+  if (!is.character(dictionary)) {
+    cli::cli_abort("The {.arg dictionary} argument must be a character vector.")
+  }
+  if (!is_named2(dictionary)) {
+    cli::cli_abort("The {.arg dictionary} argument must have names.")
+  }
+  names <- names(dictionary)
+  values <- unname(dictionary)
+
+  force(nomatch)
+
+  function(x) {
+    i <- match(x, names, nomatch = NA_integer_)
+    out <- values[i]
+    missing <- is.na(i)
+    out[missing] <- if (is.null(nomatch)) x[missing] else nomatch
+    out
+  }
+}

tests/testthat/test-label-dictionary.R

@@ -0,0 +1,11 @@
+test_that("label_dictionary gives correct answers", {
+
+  short <- c("A", "B", "C")
+  lut <- c("A" = "Apple", "C" = "Cherry", "D" = "Date")
+
+  expect_equal(label_dictionary(lut)(short), c("Apple", "B", "Cherry"))
+  expect_equal(
+    label_dictionary(lut, nomatch = "Banana")(short),
+    c("Apple", "Banana", "Cherry")
+  )
+})