visualizeR/R/color.R

#' Helpers to extract defined colors as hex codes
#'
#' [color()] returns the requested columns, returns NA if absent. [color_pattern()] returns all colors that start with the pattern.
#'
#' @param ... Character names of colors. If NULL returns all colors.
#' @param unname Boolean. Should the output vector be unnamed? Default to `TRUE`.
#' @section Naming of colors:
#' * All branding colors start with "branding";
#' * All , categorical colors start with ", cat_";
#' * All sequential colors start with "seq_";
#'
#' Then, a number indicates the number of colors that belong to the palettes, a string the name of the palette, and, finally, a number the position of the color. E.g., "seq_5_red_4" would be the 4th color of a continuous palettes of 5 colors in the red band. Exception is made for white, light_grey, dark_grey, and black.
#'
#'
#' @return Hex codes named or unnamed.
#'
#' @export
color <- function(..., unname = TRUE) {
  #------ Checks

  # unname is a logical scalar
  checkmate::assert_logical(unname, len = 1)

  # all elements in ... are character strings
  dots <- list(...)
  if (length(dots) > 0) {
    # Check each argument is a single character string
    for (i in seq_along(dots)) {
      checkmate::assert_string(dots[[i]], .var.name = paste0("Argument #", i))
    }
  }

  #------ Prep

  # retrieve colors
  cols <- c(...)

  # define color vector
  colors <- c(
    white = "#FFFFFF",
    lighter_grey = "#F5F5F5",
    light_grey = "#E3E3E3",
    dark_grey = "#464647",
    light_blue_grey = "#B3C6D1",
    grey = "#71716F",
    black = "#000000",
    cat_2_yellow_1 = "#ffc20a",
    cat_2_yellow_2 = "#0c7bdc",
    cat_2_light_1 = "#fefe62",
    cat_2_light_2 = "#d35fb7",
    cat_2_green_1 = "#1aff1a",
    cat_2_green_2 = "#4b0092",
    cat_2_blue_1 = "#1a85ff",
    cat_2_blue_2 = "#d41159",
    cat_5_main_1 = "#083d77", # yale blue
    cat_5_main_2 = "#4ecdc4", # robin egg blue
    cat_5_main_3 = "#f4c095", # peach
    cat_5_main_4 = "#b47eb3", # african violet
    cat_5_main_5 = "#ffd5ff", # mimi pink
    seq_5_main_1 = "#083d77", # yale blue
    seq_5_main_2 = "##396492",
    seq_5_main_3 = "#6b8bad",
    seq_5_main_4 = "#9cb1c9",
    seq_5_main_5 = "#ced8e4",
    cat_5_ibm_1 = "#648fff",
    cat_5_ibm_2 = "#785ef0",
    cat_5_ibm_3 = "#dc267f",
    cat_5_ibm_4 = "#fe6100",
    cat_5_ibm_5 = "#ffb000",
    cat_3_aquamarine_1 = "aquamarine2",
    cat_3_aquamarine_2 = "cornflowerblue",
    cat_3_aquamarine_3 = "brown1",
    cat_3_tol_high_contrast_1 = "#215589",
    cat_3_tol_high_contrast_2 = "#cfaa34",
    cat_3_tol_high_contrast_3 = "#a35364",
    cat_8_tol_adapted_1 = "#332e86",
    cat_8_tol_adapted_2 = "#50504f",
    cat_8_tol_adapted_3 = "#3dab9a",
    cat_8_tol_adapted_4 = "#86ccee",
    cat_8_tol_adapted_5 = "#ddcb77",
    cat_8_tol_adapted_6 = "#ee5859",
    cat_8_tol_adapted_7 = "#aa4599",
    cat_8_tol_adapted_8 = "#721220",
    div_5_orange_blue_1 = "#c85200",
    div_5_orange_blue_2 = "#e48646",
    div_5_orange_blue_3 = "#cccccc",
    div_5_orange_blue_4 = "#6b8ea4",
    div_5_orange_blue_5 = "#366785",
    div_5_green_purple_1 = "#c85200",
    div_5_green_purple_2 = "#e48646",
    div_5_green_purple_3 = "#cccccc",
    div_5_green_purple_4 = "#6b8ea4",
    div_5_green_purple_5 = "#366785"
  )

  #------ Checks

  # Check that if ... is not null, all colors are defined
  if (!is.null(cols)) {
    if (cols %notallin% names(colors)) {
      rlang::abort(c(
        "Some colors not defined",
        "*" = glue::glue_collapse(
          ...[which(!... %in% names(cols))],
          sep = ", ",
          last = ", and "
        ),
        "i" = "Use `color(unname = FALSE)` to see all named available colors."
      ))
    }
  }

  # ------ Return

  if (is.null(cols)) {
    cols_to_return <- colors
  } else {
    cols_to_return <- colors[cols]
  }

  if (unname) {
    cols_to_return <- unname(cols_to_return)
  }

  return(cols_to_return)
}

#' @rdname color
#'
#' @param pattern Pattern of the start of colors' name.
#'
#' @export
color_pattern <- function(pattern, unname = TRUE) {
  #------ Checks

  # Check that pattern is a character scalar
  checkmate::assert_character(pattern, len = 1)

  # Check that unname is a logical scalar
  checkmate::assert_logical(unname, len = 1)

  #------ Get colors

  # Get colors
  col <- color(unname = FALSE)
  col <- col[startsWith(names(col), pattern)]

  if (unname) {
    col <- unname(col)
  }

  # If col is of length 0, warn
  if (length(col) == 0) {
    rlang::warn(c(
      "No colors match the pattern",
      "*" = glue::glue("Pattern used is:'{pattern}'"),
      "i" = "Use `color(unname = FALSE)` to see all named available colors."
    ))
  }

  return(col)
}