andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 04:27:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

fix: default colors as function

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-03-31 20:41:53 +02:00
commit d397532aed
No known key found for this signature in database
1 changed files with 57 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

86
R/generate_colors.R
View file

@ -56,7 +56,8 @@
#' #'
#' @export #' @export
generate_colors <- function(n, palette = "viridis", ...) { generate_colors <- function(n, palette = "viridis", ...) {
if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { if (!is.numeric(n) ||
length(n) != 1 || n < 1 || n != as.integer(n)) {
stop("`n` must be a single positive integer.") stop("`n` must be a single positive integer.")
} }
@ -69,7 +70,8 @@ generate_colors <- function(n, palette = "viridis", ...) {
stop("`palette` must be a single character string or a function.") stop("`palette` must be a single character string or a function.")
} }
if (!is.numeric(n) || length(n) != 1 || n < 1 || n != as.integer(n)) { if (!is.numeric(n) ||
length(n) != 1 || n < 1 || n != as.integer(n)) {
stop("`n` must be a single positive integer.") stop("`n` must be a single positive integer.")
} }
if (!is.character(palette) || length(palette) != 1) { if (!is.character(palette) || length(palette) != 1) {
@ -78,10 +80,14 @@ generate_colors <- function(n, palette = "viridis", ...) {
palette_lower <- tolower(palette) palette_lower <- tolower(palette)
viridis_palettes <- c( viridis_palettes <- c("viridis",
"viridis", "magma", "plasma", "inferno", "magma",
"cividis", "mako", "rocket", "turbo" "plasma",
) "inferno",
"cividis",
"mako",
"rocket",
"turbo")
if (palette_lower %in% viridis_palettes) { if (palette_lower %in% viridis_palettes) {
viridisLite::viridis(n = n, option = palette_lower, ...) viridisLite::viridis(n = n, option = palette_lower, ...)
@ -114,16 +120,20 @@ generate_colors <- function(n, palette = "viridis", ...) {
grDevices::hcl.colors(n = n, palette = palette, ...) grDevices::hcl.colors(n = n, palette = palette, ...)
} else { } else {
message(paste0( message(
"Unknown palette: '", palette, "'. ", paste0(
"Falling back to default R colors.\n", "Unknown palette: '",
"Available options:\n", palette,
" viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n", "'. ",
" grDevices : hcl, rainbow, heat, terrain, topo\n", "Falling back to default R colors.\n",
" grDevices HCL: use grDevices::hcl.pals() to see all options\n", "Available options:\n",
" grDevices : use grDevices::palette.pals() to see all options\n", " viridisLite : viridis, magma, plasma, inferno, cividis, mako, rocket, turbo\n",
" RColorBrewer : use RColorBrewer::brewer.pal.info to see all options" " grDevices : hcl, rainbow, heat, terrain, topo\n",
)) " grDevices HCL: use grDevices::hcl.pals() to see all options\n",
" grDevices : use grDevices::palette.pals() to see all options\n",
" RColorBrewer : use RColorBrewer::brewer.pal.info to see all options"
)
)
viridisLite::viridis(n = n, option = "viridis") viridisLite::viridis(n = n, option = "viridis")
# grDevices::hcl.colors(n = n) # grDevices::hcl.colors(n = n)
} }
@ -166,7 +176,9 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
ramp <- grDevices::colorRamp(colors) ramp <- grDevices::colorRamp(colors)
function(x) { function(x) {
if (any(x < 0 | x > 1, na.rm = TRUE)) stop("Values must be in [0, 1].") if (any(x < 0 |
x > 1, na.rm = TRUE))
stop("Values must be in [0, 1].")
rgb_vals <- ramp(x) rgb_vals <- ramp(x)
grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255) grDevices::rgb(rgb_vals[, 1], rgb_vals[, 2], rgb_vals[, 3], maxColorValue = 255)
} }
@ -200,18 +212,18 @@ continuous_colors <- function(palette = "viridis", n = 256, ...) {
#' #'
#' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()] #' @seealso [scale_color_generate()], [generate_colors()], [continuous_colors()]
#' @export #' @export
scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) { scale_fill_generate <- function(palette = "viridis",
discrete = TRUE,
...) {
if (discrete) { if (discrete) {
ggplot2::discrete_scale( ggplot2::discrete_scale(
aesthetics = "fill", aesthetics = "fill",
palette = function(n) generate_colors(n, palette), palette = function(n)
generate_colors(n, palette),
... ...
) )
} else { } else {
ggplot2::scale_fill_gradientn( ggplot2::scale_fill_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
...
)
} }
} }
@ -221,17 +233,33 @@ scale_fill_generate <- function(palette = "viridis", discrete = TRUE, ...) {
#' geom_point() + #' geom_point() +
#' scale_color_generate(palette = "Set1") #' scale_color_generate(palette = "Set1")
#' @export #' @export
scale_color_generate <- function(palette = "viridis", discrete = TRUE, ...) { scale_color_generate <- function(palette = "viridis",
discrete = TRUE,
...) {
if (discrete) { if (discrete) {
ggplot2::discrete_scale( ggplot2::discrete_scale(
aesthetics = "colour", aesthetics = "colour",
palette = function(n) generate_colors(n, palette), palette = function(n)
generate_colors(n, palette),
... ...
) )
} else { } else {
ggplot2::scale_color_gradientn( ggplot2::scale_color_gradientn(colors = continuous_colors(palette)(seq(0, 1, length.out = 256)), ...)
colors = continuous_colors(palette)(seq(0, 1, length.out = 256)),
...
)
} }
} }
color_choices <- function() {
c(
"Perceptual (blue-yellow)" = "viridis",
"Perceptual (fire)" = "plasma",
"Colour-blind friendly" = "Okabe-Ito",
"Qualitative (bold)" = "Dark 2",
"Qualitative (paired)" = "Paired",
"Sequential (blues)" = "Blues",
"Diverging (red-blue)" = "RdBu",
"Tableau style" = "Tableau 10",
"Pastel" = "Pastel 1",
"Rainbow" = "rainbow"
)
}