R/lcars.R

In trekcolors: Star Trek Color Palettes

#' Hex colors from LCARS color names
#'
#' Obtain hex colors from standard LCARS color names.
#'
#' These functions return the hex colors for LCARS color names. If no argument
#' is provided, the functions return their respective LCARS color set.
#' These functions correspond to LCARS color palettes that contain named colors.
#' Other predefined LCARS color palettes are available but do not have names for
#' each color. You can see all LCARS palettes with `lcars_pals()`.
#'
#' @param ... character, LCARS color names.
#'
#' @export
#' @name lcars_colors
#' @seealso [lcars_pals()]
#'
#' @examples
#' lcars_colors()
#' lcars_2357()
#' lcars_colors("rust", "danub")
lcars_colors <- function(...){
  x <- c(...)
  if(is.null(x)) .lcarscolors else .lcarscolors[x]
}

#' @export
#' @rdname lcars_colors
lcars_2357 <- function(...){
  x <- c(...)
  if(is.null(x)) .lcars2357 else .lcars2357[x]
}

#' @export
#' @rdname lcars_colors
lcars_2369 <- function(...){
  x <- c(...)
  if(is.null(x)) .lcars2369 else .lcars2369[x]
}

#' @export
#' @rdname lcars_colors
lcars_2375 <- function(...){
  x <- c(...)
  if(is.null(x)) .lcars2375 else .lcars2375[x]
}

#' @export
#' @rdname lcars_colors
lcars_2379 <- function(...){
  x <- c(...)
  if(is.null(x)) .lcars2379 else .lcars2379[x]
}

#' Palettes and palette generating functions based on LCARS colors
#'
#' Predefined and custom palettes based on LCARS colors.
#'
#' `lcars_pal()` returns a predefined, qualitative LCARS color palette.
#' `lcars_color_pal()` returns a palette generator based on specific colors.
#' `lcars_pals()` is a function that takes no arguments and returns a list of
#' all predefined LCARS palettes.
#'
#' Predefined palettes options for `palette` are `"2357"`, `"2369"`, `"2375"`,
#' `"2379"`, `"alt"`, `"first_contact"`, `"nemesis"`, `"nx01"`, `"23c"`, `"29c"`,
#' `"red_alert"` and `"cardassian"`.
#'
#' Custom palettes can also be constructed by passing a vector of colors to
#' `palette` in `lcars_color_pal()`. This is useful for sequential and divergent
#' palettes. This is essentially a wrapper around `colorRampPalette()` that
#' understands LCARS color names. It accepts any color, allowing you to still
#' use a color like `"white"` or `"#FFFFFF"` as the midpoint in a divergent
#' palette for example. A special case is when you provide only a single color,
#' e.g., `lcars_color_pal("husk")`; this is equivalent to
#' `lcars_color_pal(c("white", "husk"))`.
#'
#' @param palette character, name of a single predefined LCARS palette; or a
#' vector of LCARS or other colors. See details.
#' @param reverse logical, reverse color order.
#' @param ... additional arguments to pass to `colorRampPalette()`.
#'
#' @return a palette generating function that takes an argument, `n`, the number
#' of colors.
#' @export
#'
#' @examples
#' # All predefined LCARS palettes
#' lcars_pals()
#' # predefined palette
#' lcars_pal("2357")
#' # custom palettes
#' lcars_colors_pal("rust")(8) # sequential
#' lcars_colors_pal(c("pale-canary", "rust"))(8)
#' lcars_colors_pal(c("pale-canary", "rust"))(4)
#' lcars_colors_pal(c("mariner", "white", "rust"))(9) # divergent
lcars_pals <- function(){
  .lcars_pals
}

#' @export
#' @rdname lcars_pals
lcars_pal <- function(palette = "2357", reverse = FALSE){
  if(length(palette) > 1 || !palette %in% names(.lcars_pals))
    stop("Invalid LCARS palette name.", call. = FALSE)
  pal <- .lcars_pals[[palette]]
  if(reverse) rev(pal) else pal
}

#' @export
#' @rdname lcars_pals
lcars_colors_pal <- function(palette, reverse = FALSE, ...){
  pal <- palette
  if(length(pal) == 1) pal <- c("#FFFFFF", pal)
  idx <- pal %in% names(lcars_colors())
  if(any(idx)) pal[idx] <- lcars_colors(pal[idx])
  if(reverse) pal <- rev(pal)
  grDevices::colorRampPalette(pal, ...)
}

#' Color and fill scale functions for LCARS colors
#'
#' Scale functions used with ggplot2.
#'
#' @param palette character, name of palette in `lcars_pals()`.
#' @param color character, LCARS color name for sequential palette.
#' @param low character, LCARS color name.
#' @param high character, LCARS color name.
#' @param discrete logical, discrete or continuous palette.
#' @param reverse logical, reverse color order.
#' @param dark logical, use black instead of white for the base color in
#' sequential palette or midpoint in divergent palette.
#' @param divergent logical, use a divergent palette instead of two-color
#' sequential palette.
#' @param ... additional arguments passed to `ggplot2::discrete_scale()` or
#' `ggplot2::scale_*_gradientn()`, for discrete or continuous palettes,
#' respectively.
#'
#' @export
#' @name scale_lcars
#'
#' @examples
#' library(ggplot2)
#' p <- ggplot(diamonds, aes(carat, stat(count), fill = cut)) +
#'   geom_density(position = "fill")
#' p + scale_fill_lcars("2357")
#' p + scale_fill_lcars1("atomic-tangerine", dark = TRUE)
#' p + scale_fill_lcars2("pale-canary", "danub")
scale_color_lcars <- function(palette = "2357", discrete = TRUE, reverse = FALSE, ...){
  pal <- grDevices::colorRampPalette(lcars_pal(palette, reverse))
  if(discrete){
    ggplot2::discrete_scale("colour", paste0("lcars_", palette), palette = pal, ...)
  } else {
    ggplot2::scale_color_gradientn(colours = pal(256), ...)
  }
}

#' @export
#' @rdname scale_lcars
scale_color_lcars1 <- function(color = "atomic-tangerine", discrete = TRUE, reverse = FALSE, dark = FALSE, ...){
  base <- if(dark) "#000000" else "#FFFFFF"
  color <- lcars_colors(color)
  pal <- c(base, color)
  if(reverse) pal <- rev(pal)
  pal <- grDevices::colorRampPalette(pal)
  if(discrete){
    ggplot2::discrete_scale("colour", names(color), palette = pal, ...)
  } else {
    ggplot2::scale_color_gradientn(colours = pal(256), ...)
  }
}

#' @export
#' @rdname scale_lcars
scale_color_lcars2 <- function(low = "atomic-tangerine", high = "near-blue", discrete = TRUE, reverse = FALSE,
                               dark = FALSE, divergent = FALSE, ...){
  pal <- lcars_colors(c(low, high))
  base <- if(dark) "#000000" else "#FFFFFF"
  pal <- c(pal[1], if(divergent) base, pal[2])
  if(reverse) pal <- rev(pal)
  pal <- grDevices::colorRampPalette(pal)
  if(discrete){
    ggplot2::discrete_scale("colour", paste0(low, high, if(divergent) "div", sep = "_"), palette = pal, ...)
  } else {
    ggplot2::scale_color_gradientn(colours = pal(256), ...)
  }
}

#' @export
#' @rdname scale_lcars
scale_fill_lcars <- function(palette = "2357", discrete = TRUE, reverse = FALSE, ...){
  pal <- grDevices::colorRampPalette(lcars_pal(palette, reverse))
  if(discrete){
    ggplot2::discrete_scale("fill", paste0("lcars_", palette), palette = pal, ...)
  } else {
    ggplot2::scale_fill_gradientn(colours = pal(256), ...)
  }
}

#' @export
#' @rdname scale_lcars
scale_fill_lcars1 <- function(color = "atomic-tangerine", discrete = TRUE, reverse = FALSE, dark = FALSE, ...){
  base <- if(dark) "#000000" else "#FFFFFF"
  color <- lcars_colors(color)
  pal <- c(base, color)
  if(reverse) pal <- rev(pal)
  pal <- grDevices::colorRampPalette(pal)
  if(discrete){
    ggplot2::discrete_scale("fill", names(color), palette = pal, ...)
  } else {
    ggplot2::scale_fill_gradientn(colours = pal(256), ...)
  }
}

#' @export
#' @rdname scale_lcars
scale_fill_lcars2 <- function(low = "atomic-tangerine", high = "near-blue", discrete = TRUE, reverse = FALSE,
                               dark = FALSE, divergent = FALSE, ...){
  pal <- lcars_colors(c(low, high))
  base <- if(dark) "#000000" else "#FFFFFF"
  pal <- c(pal[1], if(divergent) base, pal[2])
  if(reverse) pal <- rev(pal)
  pal <- grDevices::colorRampPalette(pal)
  if(discrete){
    ggplot2::discrete_scale("fill", paste0(low, high, if(divergent) "div", sep = "_"), palette = pal, ...)
  } else {
    ggplot2::scale_fill_gradientn(colours = pal(256), ...)
  }
}