aseshms: Toolkit for ASES HMS Team

#' 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))
    }
}