data-raw/color_reference.R

In r-lib/prettyunits: Pretty, Human Readable Formatting of Quantities

library(tidyverse)
library(assertr)

# From https://stackoverflow.com/a/57926144/3831096
paste_missing <- function(..., sep = " ", collapse = NULL) {
  ret <-
    apply(
      X = cbind(...),
      MARGIN = 1,
      FUN = function(x) {
        if (all(is.na(x))) {
          NA_character_
        } else {
          paste(x[!is.na(x)], collapse = sep)
        }
      }
    )
  if (!is.null(collapse)) {
    paste(ret, collapse = collapse)
  } else {
    ret
  }
}

color_ref_files <- list.files(path = "color_reference/", full.names = TRUE)
color_ref_files <-
  setNames(
    object = color_ref_files,
    nm = gsub(
      x = basename(color_ref_files),
      pattern = ".js",
      replacement = "",
      fixed = TRUE
    )
  )
color_reference_list <-
  lapply(
    X = setNames(names(color_ref_files), nm = names(color_ref_files)),
    FUN = function(source_name) {
      # Drop the variable naming from the beginning of the file and the brackets
      all_colors <-
        gsub(
          x = paste(readLines(color_ref_files[source_name]), collapse = " "),
          pattern = "^.*\\[ *\\{ *(.*) *\\} *\\]$",
          replacement = "\\1"
        )
      # Remove difficult to use characters
      all_colors_clean <-
        gsub(
          x = all_colors,
          pattern = "[^A-Za-z0-9 :'\"\\(\\),{}/]",
          replacement = ""
        )
      extract_color <-
        extract(
          data = tibble(
            color_def = strsplit(all_colors_clean, split = " *\\}, *\\{ *")[[1]]
          ),
          col = "color_def",
          into = c(source_name, "hex"),
          regex = "^['\"]?name['\"]?: *['\"]([A-Za-z0-9'/ \\(\\)]+)['\"] *, *['\"]?hex['\"]?: *['\"]#?([A-Fa-f0-9]{6})['\"] *$"
        ) |>
        verify(!is.na(hex)) |>
        mutate(hex = tolower(hex))
      extract_color
    }
  )
# Add the standard R colors to the list
color_reference_list$R <-
  tibble(
    R = grDevices::colors(),
    hex = tolower(rgb(t(col2rgb(grDevices::colors())), maxColorValue = 255))
  )

color_reference_name_hex_all <- Reduce(f = full_join, x = color_reference_list)

# Preference order for choosing alternate names
alt_name_order <- c("roygbiv", "basic", "html", "R", "pantone", "x11", "ntc")
if (
  length(missing_names <- setdiff(names(color_reference_list), alt_name_order))
) {
  stop(
    "alt_name_order needs additional names in it: ",
    paste(missing_names, collapse = ", ")
  )
}

color_reference_prep <-
  color_reference_name_hex_all |>
  # Ensure that priority order of the "name" is in the order of alt_name_order.
  select_at(.vars = c("hex", alt_name_order)) |>
  mutate(hex = gsub(x = hex, pattern = "#", replacement = "", fixed = TRUE)) |>
  group_by(hex) |>
  nest() |>
  mutate(
    # All available names
    name_alt = purrr::map(
      .x = data,
      .f = function(x) unique(na.omit(unlist(x)))
    ),
    # The preferred name
    name = purrr::map_chr(
      .x = name_alt,
      .f = function(x) x[1]
    ),
    # Which color sources have the name in them?
    containing_set = purrr::map(
      .x = data,
      .f = function(x)
        as.data.frame(lapply(X = x, FUN = function(y) any(!is.na(y))))
    )
  ) |>
  select(-data, hex, name, name_alt, containing_set) |>
  unnest(containing_set)

color_reference <-
  color_reference_prep |>
  bind_cols(
    as.data.frame(
      convertColor(
        t(col2rgb(paste0("#", color_reference_prep$hex))),
        from = "sRGB",
        to = "Lab",
        scale.in = 256
      )
    )
  ) |>
  select(hex, L, a, b, name, name_alt, everything())

usethis::use_data(color_reference, overwrite = TRUE, internal = TRUE)