#' Hex color vector in a palette
#'
#' Get a vector of hex colors from a designated palette.
#'
#' @details \code{getAetnaPal} generally gets hex value of the colors in a
#' designated palette. The palettes include Aetna palette, palette in packages
#' \pkg{RColorBrewer}, \pkg{ggthemes} and \pkg{viridis}. The following palettes
#' are usable: \cr
#' \describe{
#' \item{Aetna palttes}{'aetnagreen', 'aetnablue', 'aetnaviolet', 'aetnaorange',
#' 'aetnateal', 'aetnacranberry'}
#' \item{RColorBrewer palettes}{'BrBG', 'PiYG', 'PRGn', 'PuOr', 'RdBu', 'RdGy',
#' 'RdYlBu', 'RdYlGn', 'Spectral', 'Accent', 'Dark2', 'Paired', 'Pastel1',
#' 'Pastel2', 'Set1', 'Set2', 'Set3', 'Blues', 'BuGn', 'BuPu', 'GnBu',
#' 'Greens', 'Greys', 'Oranges', 'OrRd', 'PuBu', 'PuBuGn', 'PuRd', 'Purples',
#' 'RdPu', 'Reds', 'YlGn', 'YlGnBu', 'YlOrBr', 'YlOrRd'}
#' \item{ggthemes palettes}{\itemize{
#' \item normal: 'calc', 'economist', 'economist_white', 'excel_line', 'excel_fill',
#' 'excel_new', 'few', 'fivethirtyeight', 'gdocs', 'pander', 'stata', 'stata1',
#' 'stata1r','statamono','hc', 'darkunica','wsj', 'wsj_rgby', 'wsj_red_green',
#' 'wsj_black_green', 'wsj_dem_rep', \cr
#' \item tableau (see \code{\link[ggthemes]{tableau_color_pal}}): \describe{
#' \item{'regular' / 'qual'}{"tableau10", "tableau20", "tbl_colorblind",
#' "tbl_seattle_grays", "tbl_traffic", "tbl_miller_stone", "tbl_superfishel_stone",
#' "tbl_nuriel_stone", "tbl_jewel_bright", "tbl_summer", "tbl_winter", "tbl_gnorte",
#' "tbl_rdbubw", "tbl_pupkgy", "tbl_hue_circle", "tbl_classic10", "tbl_classic10_medium",
#' "tbl_classic10_light", "tbl_classic20", "tbl_classic_gray5", "tbl_classic_colorblind",
#' "tbl_classic_traffic_light", "tbl_classic_pugy6", "tbl_classic_pugy12",
#' "tbl_classic_gnor6", "tbl_classic_gnor12", "tbl_classic_burd6", "tbl_classic_burd12",
#' "tbl_classic_cyclic"}
#' \item{'ordered-diverging' / 'div'}{"tbl_orbu_div", "tbl_rdgn_div", "tbl_gnbu_div",
#' "tbl_rdbu_div", "tbl_rdbl_div", "tbl_gdpu_div", "tbl_rdgngd_div",
#' "tbl_sunset_sunrise_div", "tbl_orbuwi_div", "tbl_rdgnwi_div", "tbl_gnbuwi_div",
#' "tbl_rdbuwi_div", "tbl_rdblwi_div", "tbl_orbu_light_div", "tbl_temperature_div",
#' "tbl_classic_rdgn", "tbl_classic_rdbu", "tbl_classic_rdbl", "tbl_classic_area_rdgn",
#' "tbl_classic_orbu", "tbl_classic_gnbu", "tbl_classic_rdwign", "tbl_classic_rdwibl",
#' "tbl_classic_orwibu", "tbl_classic_rdwibl_light", "tbl_classic_orwibu_light",
#' "tbl_classic_rdwign_light", "tbl_classic_rdgn_light"}
#' \item{'ordered-sequential' / 'seq'}{"tbl_bugn_seq", "tbl_blue_light", "tbl_orange_light",
#' "tbl_blue", "tbl_orange", tbl_green", "tbl_red", "tbl_purple", "tbl_brown",
#' "tbl_gray", "tbl_gray_warm", "tbl_bute", "tbl_orgd", "tbl_gngd", "tbl_rdgd",
#' "tbl_classic_green", "tbl_classic_gray", "tbl_classic_blue", "tbl_classic_red",
#' "tbl_classic_orange", "tbl_classic_area_red", "tbl_classic_area_green",
#' "tbl_classic_area_brown"}
#' }
#' \item solarized: 'solarized','solarized_red', 'solarized_yellow',
#' 'solarized_orange','solarized_magenta','solarized_violet',
#' 'solarized_blue', 'solarized_cyan', 'solarized_green', 'colorblind',
#' 'trafficlight'}}
#' \item{viridis palettes}{'megma', 'inferno', 'plasma', 'viridis', 'cividis'}
#' \item{grDevices palettes}{'rainbow', 'terrain', 'topo', 'heat', 'cm'}
#' }
#' @author Yiying Wang, \email{wangy@@aetna.com}
#' @param palname Palette name.
#' @param n Length of color vector.
#' @param show Logical, whether display the palette. Default FALSE.
#' @param output_func Logical, whether output the function to generate colors. Default
#' FALSE, which indicates that the color vector instead of the function is returned.
#' @param ... Other arguments to pass to the function. E.g., \code{theme='Atlas'}
#' can be passed to \code{\link[ggthemes]{excel_newe_pal}()} when \code{palname='excel_new'};
#' or \code{direction = -1} can be passed to \code{\link[ggthemes]{tableau_color_pal}}
#' when \code{palname='tableau10'}
#'
#' @return A vector of Hex colors (\code{output_func=FALSE}) or the color generation
#' function (\code{output_func=TRUE}).
#' @export
#'
#' @seealso \pkg{\link{RColorBrewer}} \pkg{\link{ggthemes}}
#' @examples
#' \dontrun{
#' ## Get the entire Aetna green palette
#' getAetnaPal("aetnagreen")
#'
#' ## Get 7 colors from palette 'terrain'
#' getAetnaPal("terrain", 7)
#' }
getAetnaPal <- function(palname, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- parse_palname(tolower(palname))
UseMethod(".getNamedPal", pal)
}
#' @importFrom stringr str_to_title
#' @importFrom crayon blue silver cyan
parse_palname <- function(palname=names(PALETTE),
PALETTE=unname(aseshms_env$PALETTE) %>% unlist){
if (is.null(palname) || is.na(palname))
return(structure("default", class="default"))
stopifnot(is.character(palname))
classes <- rep.int(names(aseshms_env$PALETTE),
times=vapply(aseshms_env$PALETTE, length,
FUN.VALUE=numeric(length=1))) %>% str_to_title
palname <- try(match.arg(palname), silent=TRUE)
if (inherits(palname, "try-error")){
warn <- blue("Below are valid palnames (case insensitive):\n")
warn <- c(warn, vapply(names(aseshms_env$PALETTE), function(nm){
c(cyan(nm), ": ", silver(paste(aseshms_env$PALETTE[[nm]], collapse=", ")),
"\n")
}, FUN.VALUE=character(length=4)))
invisible(cat(warn))
stop("Invalid palname!")
}else{
pal <- structure(PALETTE[palname],
class=classes[which(names(PALETTE) == palname)])
}
return(pal)
}
#' @export
#' @importFrom scales show_col
.getNamedPal.Default <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
out <- c('#ff7f50', '#87cefa', '#da70d6', '#32cd32', '#6495ed',
'#ff69b4', '#ba55d3', '#cd5c5c', '#ffa500', '#40e0d0',
'#1e90ff', '#ff6347', '#7b68ee', '#00fa9a', '#ffd700',
'#6b8e23', '#ff00ff', '#3cb371', '#b8860b', '#30e0e0')
fun <- function(n=n){
if (n > length(out)){
invisible(warning("n is larger than length of palette. Will output all the colors."))
n <- length(out)
}
return(out[seq_len(n)])
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
#' @importFrom scales show_col
.getNamedPal.Aetna <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- aseshms_env$PALETTE$aetna[tolower(pal)]
aetna_pal <- list(
aetnagreen=c(
"#7AC143", "#7D3F98", "#F47721", "#D20962", "#00A78E", "#00BCE4",
"#B8D936", "#EE3D94", "#FDB933", "#F58F9F", "#60C3AE", "#5F78BB",
"#5E9732", "#CEA979", "#EF4135", "#7090A5"),
aetnablue=c(
"#00BCE4", "#D20962", "#7AC143", "#F47721", "#7D3F98", "#00A78E",
"#F58F9F", "#B8D936", "#60C3AE", "#FDB933", "#EE3D94", "#5E9732",
"#5F78BB", "#CEA979", "#EF4135", "#7090A5"),
aetnateal=c(
"#00A78E", "#F47721", "#7AC143", "#00BCE4", "#D20962", "#7D3F98",
"#60C3AE", "#FDB933", "#B8D936", "#5F78BB", "#F58F9F", "#EE3D94",
"#5E9732", "#CEA979", "#EF4135", "#7090A5"),
aetnacranberry=c(
"#D20962", "#00BCE4", "#7D3F98", "#7AC143", "#F47721", "#00A78E",
"#F58F9F", "#60C3AE", "#EE3D94", "#B8D936", "#FDB933", "#5E9732",
"#5F78BB", "#CEA979", "#EF4135", "#7090A5"),
aetnaorange=c(
"#F47721", "#7AC143", "#00A78E", "#D20962", "#00BCE4", "#7D3F98",
"#FDB933", "#B8D936", "#60C3AE", "#F58F9F", "#5F78BB", "#EE3D94",
"#5E9732", "#CEA979", "#EF4135", "#7090A5"),
aetnaviolet=c(
"#7D3F98", "#7AC143", "#F47721", "#00A78E", "#00BCE4", "#D20962",
"#F58F9F", "#B8D936", "#FDB933", "#60C3AE", "#5F78BB", "#EE3D94",
"#5E9732", "#CEA979", "#EF4135", "#7090A5"))
fun <- function(n=n) {
o <- tolower(aetna_pal[[pal]])
if (n > length(o)){
invisible(warning("n is larger than length of palette. Will output all the colors."))
n <- length(o)
}
return(o[seq_len(n)])
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
#' @importFrom RColorBrewer brewer.pal.info brewer.pal
#' @importFrom scales show_col
.getNamedPal.Brewer <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- aseshms_env$PALETTE$brewer[tolower(pal)]
maxcolors <- brewer.pal.info[
row.names(brewer.pal.info) == pal, "maxcolors"]
fun <- function(n=n) {
if (n > maxcolors){
invisible(warning("n is larger than length of palette. Will output all the colors."))
n <- maxcolors
}
brewer.pal(n, pal)
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
.getNamedPal.Grdevice <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- aseshms_env$PALETTE$grdevice[tolower(pal)]
if (n == Inf) {
invisible(warning("n is far too large. Will output 100 colors."))
n <- 100
}
fun <- switch(pal,
rainbow=function(n=n) substr(rainbow(n), 1, 7),
terrain=function(n=n) substr(terrain.colors(n), 1, 7),
heat=function(n=n) substr(heat.colors(n), 1, 7),
topo=function(n=n) substr(topo.colors(n), 1, 7),
cm=function(n=n) substr(cm.colors(n), 1, 7)
)
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
#' @import ggthemes
#' @importFrom scales show_col
.getNamedPal.Ggthemes <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- aseshms_env$PALETTE$ggthemes[tolower(pal)]
dots <- substitute(list(...))[-1]
fun <- switch(pal,
pander=palette_pander,
excel_line=excel_pal(line=TRUE),
excel_fill=excel_pal(line=FALSE),
excel_new=excel_new_pal(theme=if ('theme' %in% names(dots)) dots[['theme']]
else "Office Theme")(),
economist=economist_pal(fill=TRUE),
economist_white=economist_pal(fill=FALSE),
darkunica=hc_pal(palette="darkunica"),
calc=calc_pal(),
few=few_pal(),
fivethirtyeight=fivethirtyeight_pal(),
gdocs=gdocs_pal(),
stata=stata_pal(),
stata1=stata_pal(scheme="s1color"),
stata1r=stata_pal(scheme="s1rcolor"),
statamono=stata_pal(scheme="mono"),
hc=hc_pal(),
colorblind=colorblind_pal(),
wsj=wsj_pal(palette="colors6"),
wsj_rgby=wsj_pal(palette="rgby"),
wsj_red_green=wsj_pal(palette="red_green"),
wsj_black_green=wsj_pal(palette="green_black"),
wsj_dem_rep=wsj_pal(palette="dem_rep")
)
if ("max_n" %in% names(attributes(fun))) {
n <- min(n, attr(fun, "max_n"))
}else{
if (n == Inf){
invisible(warning("n is far too large. Will output 100 colors."))
n <- 100
}
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
#' @importFrom ggthemes tableau_color_pal
#' @importFrom scales show_col
.getNamedPal.Ggtableau <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- aseshms_env$PALETTE$ggtableau[tolower(pal)]
dots <- substitute(list(...))[-1]
fun <- tableau_color_pal(palette=aseshms_env$PALETTE$tableau[pal], ...)
if ("max_n" %in% names(attributes(fun))) {
n <- min(n, attr(fun, "max_n"))
}else{
if (n == Inf){
invisible(warning("n is far too large. Will output 100 colors."))
n <- 100
}
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
#' @importFrom scales show_col viridis_pal
.getNamedPal.Viridis <- function(pal, n=Inf, show=FALSE, output_func=FALSE, ...){
pal <- aseshms_env$PALETTE$viridis[tolower(pal)]
dots <- substitute(list(...))[-1]
viridis_opt <- structure(LETTERS[1:5],
names=c("magma", "inferno", "plasma", "viridis", "cividis"))
fun <- viridis_pal(..., option=viridis_opt[pal])
if ("max_n" %in% names(attributes(fun))) {
n <- min(n, attr(fun, "max_n"))
}else{
if (n == Inf){
invisible(warning("n is far too large. Will output 100 colors."))
n <- 100
}
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
#' @export
.getNamedPal.Ggsolarized <- function(pal, n=Inf, show=FALSE, ...){
pal <- aseshms_env$PALETTE$ggsolarized[tolower(pal)]
accent <- unlist(strsplit(pal, "solarized_"))[2]
if (is.na(accent)) accent <- "blue"
fun <- solarized_pal(accent=accent)
if ("max_n" %in% names(attributes(fun))) {
n <- min(n, attr(fun, "max_n"))
}else{
if (n == Inf){
invisible(warning("n is far too large. Will output 100 colors."))
n <- 100
}
}
out <- fun(n)
if (show) show_col(out)
if (output_func) return(fun) else return(out)
}
rgba <- function(vecrgb){
if (is.list(vecrgb)) rgb <- as.vector(unlist(vecrgb))
if (!is.vector(vecrgb)) stop("Must be a vector!")
if (min(vecrgb, na.rm=TRUE) < 0 | max(vecrgb, na.rm=TRUE) > 255) {
stop("All elements should be numeric 0-255!")
}
if (length(vecrgb[!is.na(vecrgb)])==3){
return(rgb(red=vecrgb[1], green=vecrgb[2], blue=vecrgb[3], max=255))
}else if (length(vecrgb[!is.na(vecrgb)])==4){
#return(rgb(red=vecrgb[1], green=vecrgb[2], blue=vecrgb[3],
# alpha=vecrgb[4], max=255))
return(paste0('rgba(', vecrgb[1], ',', vecrgb[2], ',', vecrgb[3], ',',
as.numeric(vecrgb[4])/255, ')'))
}else{
stop("vecrgb must be of length 3 or 4!")
}
}
#' Generalized color values parser
#'
#' Get colors from a named palette or other formats
#' @author Yiying Wang, \email{wangy@@aetna.com}
#' @param palette A palette name with/without number of colors,
#' or a vector of color names, or a hex color value.
#' @param ... ignore
#'
#' @return A vector of hex colors.
#' @seealso \code{\link{getAetnaPal}}
#' @importFrom stringr str_split str_replace_all
#' @export
#'
#' @examples
#' \dontrun{
#' ## Get a hex vector based on color names
#' getHexPal(c("red", "yellow"))
#' # return c("#FF0000", "#FFFF00")
#' getHexPal("red")
#' # return "#FF0000"
#'
#' ## Get a hex vector based on a hex value
#' getHexPal("#fff")
#' # return #ffffff
#'
#' ## Get a hex vector based on palette name
#' getHexPal("terrain(4)")
#' # return c("#00A600", "#E6E600", "#ECB176", "#F2F2F2")
#' }
getHexPal <- function(palette, ...){ # build a function to extract palette info
if (length(palette) == 1) {
if (substr(palette, 1, 1) == "#"){
if (nchar(palette) == 7){
return(palette)
}else if (nchar(palette) == 4){
return(str_replace_all(
palette, "#(.{1})(.{1})(.{1})", "#\\1\\1\\2\\2\\3\\3"))
}else{
palette <- paste0('0x', substring(palette, seq(2, 8, 2), seq(3, 9, 2)))
palette <- strtoi(palette)
return(rgba(palette))
}
}else{
palettes <- unlist(str_split(palette, "[\\(\\)]"))
if (length(palettes) == 1){
if (is.null(getAetnaPal(palettes[1]))){
return(rgba(as.vector(col2rgb(palette))))
} else {
return(getAetnaPal(palettes[1]))
}
}else{
aet.pal <- getAetnaPal(palettes[1], as.numeric(palettes[2]))
if (as.numeric(palettes[2]) < length(aet.pal)){
return(sample(aet.pal, as.numeric(palettes[2])))
}else{
return(aet.pal)
}
}
}
}else if(length(palette) > 1){
aet.pal <- vector()
for (i in 1:length(palette)){
if (!is(try(col2rgb(palette[i]), TRUE), "try-error")){
if (substr(palette[i], 1, 1) == "#"){
aet.pal <- c(aet.pal, toupper(palette[i]))
}else{
vecCol <- as.vector(col2rgb(palette[i]))
aet.pal <- c(aet.pal, rgba(vecCol))
}
}
}
return(aet.pal)
}else{
return(getAetnaPal(NULL))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.