#' continuous palettes of colors for figures
#'
#' Creates different color palette functions
#'
#' @param palette Character string indicating a palette of colors.
#' @param reverse logical value indicating whether the color palette should be reversed. Defaults
#' to \code{FALSE}
#' @param interpolate Character string for color interpolation method.
#' "linear" or "spline" interpolation available
#' @param ... other arguments to be passed to \code{\link[grDevices]{colorRampPalette}}.
#' See \code{\link[grDevices]{colorRampPalette}} for details
#' @return returns a function that takes an integer argument (the required number of colors), which
#' then returns a character vector of colors
#' @export
#' @importFrom grDevices colorRampPalette
#' @examples
#'
#' colfunc <- jcolors_contin()
#' jcols <- colfunc(1000)
#' n <- length(jcols)
#' image(1:n, 1, as.matrix(1:n),
#' col = jcols,
#' xlab = "", ylab = "",
#' xaxt = "n", yaxt = "n", bty = "n")
#'
jcolors_contin <- function(palette = c("default",
"pal2",
"pal3",
"pal4",
"pal10",
"pal11",
"pal12",
"rainbow"),
reverse = FALSE,
interpolate = c("spline", "linear"),
...)
{
interpolate <- match.arg(interpolate)
reverse <- as.logical(reverse)
default <- c('yankees_blue' = "#101324", ##"#202547",
'purple_taupe' = "#53354A",
'deep_taupe' = "#7A6C5D",
'straw' = "#E3D26F")
if (reverse) default <- rev(default)
default.func <- colorRampPalette(default,
interpolate = interpolate,
...)
pal2 <- c("#1a1334",
"#26294a",
"#01545a",
"#017351",
"#03c383",
"#aad962")
if (reverse) pal2 <- rev(pal2)
pal2.func <- colorRampPalette(pal2,
interpolate = interpolate,
...)
pal3 <- c("#110141",
"#710162",
"#a12a5e",
"#ed0345",
"#ef6a32",
"#fbbf45")
if (reverse) pal3 <- rev(pal3)
pal3.func <- colorRampPalette(pal3,
interpolate = interpolate,
...)
rainbow <- c('rosso_corsa' = "#D12600",
'spanish_orange' = "#DB6A00",
'green_yellow' = "#B2FF2E",
'green' = "#00AD00",
'pale_cerulean' = "#9CCADE",
'sea_blue' = "#005B94",
'st_patricks_blue' = "#1E2085",
'tyrian_purple' = "#610052",
'amaranth_deep_purple' = "#953272")
if (reverse) rainbow <- rev(rainbow)
rainbow.func <- colorRampPalette(rainbow,
interpolate = interpolate,
...)
pal4 <- c('yankees_blue' = "#202547",
'purple_taupe' = "#53354A",
'deep_taupe' = "#7A6C5D",
'raspberry' = "#BE3144",
'mango' = "#FF7844",
'straw' = "#E3D26F")
pal10 <- c('#3e71a8',
'#577f9f',
'#698e96',
'#779d8d',
'#84ad83',
'#8fbd77',
'#99cd6b',
'#a2dd5c',
'#aaee49',
'#b2ff2e')
pal11 <- c('#202547',
'#323649',
'#41474b',
'#4e5a4c',
'#5c6c4c',
'#68804c',
'#75944b',
'#81a949',
'#8ebe45',
'#9ad340',
'#a6e939',
'#b2ff2e')
pal12 <- c('#202547',
'#43444a',
'#5f654a',
'#7b8948',
'#97b043',
'#b2d736',
'#ceff1a',
'#d8e01b',
'#dfc11b',
'#e2a11b',
'#e37f1b',
'#e1581a',
'#de1a1a')
if (reverse) pal4 <- rev(pal4)
pal4.func <- colorRampPalette(pal4,
interpolate = interpolate,
...)
if (reverse) pal10 <- rev(pal10)
pal10.func <- colorRampPalette(pal10,
interpolate = interpolate,
...)
if (reverse) pal11 <- rev(pal11)
pal11.func <- colorRampPalette(pal11,
interpolate = interpolate,
...)
if (reverse) pal12 <- rev(pal12)
pal12.func <- colorRampPalette(pal12,
interpolate = interpolate,
...)
switch(match.arg(palette),
default = default.func,
pal2 = pal2.func,
pal3 = pal3.func,
pal4 = pal4.func,
pal10 = pal10.func,
pal11 = pal11.func,
pal12 = pal12.func,
rainbow = rainbow.func)
}
# display.jcolors continuous
#' Display jcolors_contin
#'
#' displays the continuous jcolors palettes
#'
#' @param palette Character string indicating a palette of colors.
#' @export
#' @examples
#' display_jcolors_contin()
display_jcolors_contin <- function(palette = c("default",
"pal2",
"pal3",
"pal4",
"pal10",
"pal11",
"pal12",
"rainbow"))
{
palette <- match.arg(palette)
colfunc <- jcolors_contin(palette)
jcols <- colfunc(512L)
image(1:length(jcols),
1, as.matrix(1:length(jcols)),
col = jcols,
xlab = "", ylab = "",
xaxt = "n", yaxt = "n", bty = "n")
}
# display.jcolors continuous
#' Display every jcolors_contin palette
#'
#' displays all of the continuous jcolors palettes
#'
#' @export
#' @examples
#' display_all_jcolors_contin()
display_all_jcolors_contin <- function()
{
palette <- c("default",
"pal2",
"pal3",
"pal4",
"pal10",
"pal11",
"pal12",
"rainbow")
jcols <- sapply(palette, function(pal) jcolors_contin(pal)(512L))
maxlen <- 512L
ncols <- ncol(jcols)
lr.margin <- 25
plot(0, 0, type = "n", xlab = "", ylab = "", xlim = c(0, maxlen + 2 * lr.margin),
ylim = c((ncols + 1) * 2, 0), yaxs = "i",
xaxt = "n", yaxt = "n", xaxs = "i")
yseq <- seq(2, ncols * 2, length.out = ncols)
axis(side = 2, at = yseq, palette, las = 1)
for (c in 1:ncols)
{
pal <- jcols[,c]
rect(xleft = lr.margin + seq(along = pal) - 0.5,
ybottom = yseq[c] - 0.85,
xright = lr.margin+ seq(along = pal) + 0.5,
ytop = yseq[c] + 0.85,
border = NA,
lwd = 0,
col = pal)
}
}
#' continuous jcolors color scales
#'
#' @inheritParams jcolors_contin
#' @export scale_color_jcolors_contin
#' @importFrom ggplot2 discrete_scale
#' @importFrom scales manual_pal
#' @rdname scale_jcolors
#'
#' @examples
#' library(ggplot2)
#'
#' plt <- ggplot(data.frame(x = rnorm(10000), y = rexp(10000, 1.5)), aes(x = x, y = y)) +
#' geom_hex() + coord_fixed()
#'
#' plt + scale_fill_jcolors_contin() + theme_bw()
#'
#' plt + scale_fill_jcolors_contin("pal2", bias = 1.5) + theme_bw()
#'
#' plt + scale_fill_jcolors_contin("pal3") + theme_bw()
#'
#'
scale_color_jcolors_contin = function (palette = c("default",
"pal2",
"pal3",
"pal4",
"pal10",
"pal11",
"pal12",
"rainbow"),
...)
{
palette <- match.arg(palette)
colours <- jcolors_contin(palette, ...)(512L)
local_scale_color <- function(...,
bias, space, alpha, ## args not to pass to gradientn
reverse, interpolate)
scale_color_gradientn(colours = colours, ...)
local_scale_color(...)
}
#' @export scale_colour_jcolors_contin
#' @rdname scale_jcolors
scale_colour_jcolors_contin = scale_color_jcolors_contin
#' @export scale_fill_jcolors_contin
#' @importFrom ggplot2 discrete_scale
#' @rdname scale_jcolors
scale_fill_jcolors_contin = function (palette = c("default",
"pal2",
"pal3",
"pal4",
"pal10",
"pal11",
"pal12",
"rainbow"),
...)
{
palette <- match.arg(palette)
colours <- jcolors_contin(palette, ...)(512L)
local_scale_fill <- function(...,
bias, space, alpha, ## args not to pass to gradientn
reverse, interpolate)
scale_fill_gradientn(colours = colours, ...)
local_scale_fill(...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.