paletteer_c_wrappers.R

#' Wrappers around continuous palette functions by package
#'
#' These functions provide a function wrapper for each package such that a
#' palette can be generated using only the name of the desired palette and the
#' length.
#'
#' @param name Character, name of palette.
#' @param n Integer, number of colors.
#'
#' @return Vector of color values from specified palette.
#'
#' @name paleteer-c-wrapper
#' @rdname paleteer-c-wrapper
paletteer_c_ggthemes <- function(name, n) {
  check_installed("ggthemes")

  ggthemes_c_seq_names <- c(
    "Blue-Green Sequential", "Blue Light", "Orange Light", "Blue", "Orange",
    "Green", "Red", "Purple", "Brown", "Gray", "Gray Warm", "Blue-Teal",
    "Orange-Gold", "Green-Gold", "Red-Gold", "Classic Green", "Classic Gray",
    "Classic Blue", "Classic Red", "Classic Orange", "Classic Area Red",
    "Classic Area Green", "Classic Area-Brown"
  )

  ggthemes_c_div_names <- c(
    "Orange-Blue Diverging", "Red-Green Diverging", "Green-Blue Diverging",
    "Red-Blue Diverging", "Red-Black Diverging", "Gold-Purple Diverging",
    "Red-Green-Gold Diverging", "Sunset-Sunrise Diverging", "Orange-Blue-White Diverging",
    "Red-Green-White Diverging", "Green-Blue-White Diverging", "Red-Blue-White Diverging",
    "Red-Black-White Diverging", "Orange-Blue Light Diverging", "Temperature Diverging",
    "Classic Red-Green", "Classic Red-Blue", "Classic Red-Black", "Classic Area Red-Green",
    "Classic Orange-Blue", "Classic Green-Blue", "Classic Red-White-Green",
    "Classic Red-White-Black", "Classic Orange-White-Blue", "Classic Red-White-Black Light",
    "Classic Orange-White-Blue Light", "Classic Red-White-Green Light",
    "Classic Red-Green Light"
  )

  name <- try(match.arg(name, c(ggthemes_c_seq_names, ggthemes_c_div_names)), silent = T)

  if (name %in% ggthemes_c_seq_names) {
    pal_gen <- ggthemes::tableau_seq_gradient_pal(palette = name)
  } else {
    pal_gen <- ggthemes::tableau_div_gradient_pal(palette = name)
  }

  pal_gen(x = seq(0, 1, length.out = n))
}

#' @rdname paleteer-c-wrapper
paletteer_c_grDevices <- function(name, n) {
  if (name %in% c(
    "rainbow", "heat.colors", "terrain.colors",
    "topo.colors", "cm.colors"
  )) {
    pal_gen <- getExportedValue("grDevices", name)

    return(pal_gen(n = n))
  } else {
    pal_gen <- function(n) {
      grDevices::hcl.colors(n = n, palette = name)
    }
    return(pal_gen(n = n))
  }
}

#' @rdname paleteer-c-wrapper
paletteer_c_oompaBase <- function(name, n) {
  check_installed("oompaBase")
  pal_gen <- getExportedValue("oompaBase", name)

  pal_gen(N = n)
}

#' @rdname paleteer-c-wrapper
paletteer_c_palr <- function(name, n) {
  check_installed("palr")
  pal_gen <- getExportedValue("palr", name)

  pal_gen(x = n)
}

#' @rdname paleteer-c-wrapper
paletteer_c_pals <- function(name, n) {
  check_installed("pals")
  pal_gen <- getExportedValue("pals", name)

  pal_gen(n = n)
}

#' @rdname paleteer-c-wrapper
paletteer_c_scico <- function(name, n) {
  check_installed("scico")
  scico::scico(n = n, palette = name)
}

#' @rdname paleteer-c-wrapper
paletteer_c_viridis <- function(name, n) {
  check_installed("viridisLite")
  pal_gen <- getExportedValue("viridisLite", name)

  pal_gen(n = n)
}

#' @rdname paleteer-c-wrapper
paletteer_c_harrypotter <- function(name, n) {
  check_installed("harrypotter")
  harrypotter::hp(n = n, option = name)
}

#' paletteer_c_gameofthrones <- function(name, n) {
#'   check_installed("gameofthrones")
#'   gameofthrones::got(n = n, option = name)
#' }

#' List of all wrapper functions used in paletteer_c
#'
#' @format Named list of all wrapper functions
#' @name wrapper_c
#' @noRd
NULL

wrapper_c <- list(
  # gameofthrones = paletteer_c_gameofthrones,
  ggthemes      = paletteer_c_ggthemes,
  grDevices     = paletteer_c_grDevices,
  harrypotter   = paletteer_c_harrypotter,
  oompaBase     = paletteer_c_oompaBase,
  palr          = paletteer_c_palr,
  pals          = paletteer_c_pals,
  scico         = paletteer_c_scico,
  viridis       = paletteer_c_viridis
)