Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Named palettes #448

Merged
merged 15 commits into from
Oct 21, 2024
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -39,4 +39,4 @@ Config/testthat/edition: 3
Encoding: UTF-8
LazyLoad: yes
Roxygen: list(markdown = TRUE, r6 = FALSE)
RoxygenNote: 7.2.3
RoxygenNote: 7.3.2
6 changes: 6 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
# Generated by roxygen2: do not edit by hand

S3method(as_continuous_pal,"function")
S3method(as_continuous_pal,character)
S3method(as_continuous_pal,default)
S3method(as_continuous_pal,pal_discrete)
S3method(as_discrete_pal,"function")
S3method(as_discrete_pal,character)
S3method(as_discrete_pal,default)
S3method(as_discrete_pal,pal_continuous)
S3method(fullseq,Date)
Expand Down Expand Up @@ -97,6 +99,7 @@ export(expand_range)
export(extended_breaks)
export(format_format)
export(fullseq)
export(get_palette)
export(gradient_n_pal)
export(grey_pal)
export(hms_trans)
Expand Down Expand Up @@ -176,6 +179,7 @@ export(pal_seq_gradient)
export(pal_shape)
export(pal_viridis)
export(palette_na_safe)
export(palette_names)
export(palette_nlevels)
export(palette_type)
export(parse_format)
Expand All @@ -194,10 +198,12 @@ export(rescale_max)
export(rescale_mid)
export(rescale_none)
export(rescale_pal)
export(reset_palettes)
export(reverse_trans)
export(scientific)
export(scientific_format)
export(seq_gradient_pal)
export(set_palette)
export(shape_pal)
export(show_col)
export(sqrt_trans)
Expand Down
3 changes: 3 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,5 +1,8 @@
# scales (development version)

* The scales package now keeps track of known palettes. These can be retrieved
using `get_palette()` or registered using `set_palette()` (#396).

# scales 1.3.0

## Better type support
Expand Down
8 changes: 8 additions & 0 deletions R/colour-manip.R
Original file line number Diff line number Diff line change
Expand Up @@ -87,6 +87,14 @@ alpha <- function(colour, alpha = NA) {
show_col <- function(colours, labels = TRUE, borders = NULL, cex_label = 1,
ncol = NULL) {
n <- length(colours)
if (n == 1 && (is.function(colours) || !is_color(colours))) {
colours <- as_discrete_pal(colours)
n <- palette_nlevels(colours)
n <- if (is.na(n)) 16 else n
colours <- colours(n = n)
n <- length(colours)
}

ncol <- ncol %||% ceiling(sqrt(length(colours)))
nrow <- ceiling(n / ncol)

Expand Down
16 changes: 16 additions & 0 deletions R/pal-.R
Original file line number Diff line number Diff line change
Expand Up @@ -156,6 +156,14 @@ as_discrete_pal.pal_continuous <- function(x, ...) {
)
}

#' @export
as_discrete_pal.character <- function(x, ...) {
if (length(x) > 1) {
return(pal_manual(x))
}
as_discrete_pal(get_palette(x, ...))
}

## As continuous palette --------------------------------------------------

#' @rdname new_continuous_palette
Expand Down Expand Up @@ -197,3 +205,11 @@ as_continuous_pal.pal_discrete <- function(x, ...) {
)
)
}

#' @export
as_continuous_pal.character <- function(x, ...) {
if (length(x) > 1) {
return(colour_ramp(x))
}
as_continuous_pal(get_palette(x, ...))
}
157 changes: 157 additions & 0 deletions R/palette-registry.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,157 @@
.known_palettes <- new_environment(parent = empty_env())

#' Known palettes
#'
#' The scales packages keeps track of a set of palettes it considers 'known'.
#' The benefit of a known palette is that it can be called by name in functions
#' as `as_continuous_pal()` or `as_discrete_pal()`.
#'
#' @param name A string giving the palette name.
#' @param palette A [palette][new_continuous_palette], `function` or character
#' vector.
#' @param warn_conflict A boolean which if `TRUE` (default), warns when
#' replacing a known palette.
#' @param ... Additional arguments to pass to palette when it is a function
#' but not a palette class function.
#'
#' @return The `get_palette()` function returns a palette. The `set_palette()`
#' function is called for side effects and returns nothing.
#' @export
#'
#' @examples
#' # Get one of the known palettes
#' get_palette("hue")
#'
#' # Set a new custom palette
#' cols <- c("palegreen", "deepskyblue", "magenta")
#' set_palette("aurora", palette = cols)
#'
#' # Palette is now known
#' "aurora" %in% palette_names()
#' as_continuous_pal("aurora")
#'
#' # Resetting palettes
#' reset_palettes()
get_palette <- function(name, ...) {

name <- tolower(name)
if (!exists(name, envir = .known_palettes)) {
cli::cli_abort("Unknown palette: {name}")
}

pal <- env_get(.known_palettes, name)

# Palette could be factory, in which case we want the product, or
# palette can be a palette function that isn't registered as such,
# in which case we want the colours it gives
if (is_function(pal) && !is_pal(pal)) {
pal <- try_fetch(
pal(...),
error = function(cnd) {
cli::cli_abort("Failed to interpret {name} as palette.", parent = cnd)
}
)
}
if (is.character(pal)) {
pal <- manual_pal(pal, type = "colour")
}
if (is_pal(pal)) {
return(pal)
}
cli::cli_abort("Failed to interpret {name} as palette.")
}

#' @export
#' @rdname get_palette
set_palette <- function(name, palette, warn_conflict = TRUE) {
name <- tolower(name)
if (!is_function(palette) && !is_character(palette)) {
cli::cli_abort(
"The {.arg palette} argument must be a {.cls function} or \\
{.cls character} vector."
)
}
if (warn_conflict & exists(name, envir = .known_palettes)) {
cli::cli_warn("Overwriting pre-existing {.val {name}} palette.")
}
env_bind(.known_palettes, !!name := palette)
invisible(NULL)
}

#' @export
#' @rdname get_palette
palette_names <- function() {
names(.known_palettes)
}

#' @export
#' @rdname get_palette
reset_palettes <- function() {
env_unbind(.known_palettes, palette_names())
init_palettes()
}

init_palettes <- function() {
register_hcl_pals()
register_base_pals()
register_viridis_pals()
register_brewer_pals()
register_dichromat_pals()
set_palette("grey", pal_grey, warn_conflict = FALSE)
set_palette("hue", pal_hue, warn_conflict = FALSE)
}

on_load(init_palettes())

register_hcl_pals <- function(n = 31) {
names <- grDevices::hcl.pals()
for (name in names) {
fun <- colour_ramp(grDevices::hcl.colors(n, palette = name))
set_palette(name, fun, warn_conflict = FALSE)
}
invisible(NULL)
}

register_base_pals <- function() {
if (getRversion() < "4.0.0") {
return(invisible(NULL))
}
names <- utils::getFromNamespace("palette.pals", "grDevices")()
palette <- utils::getFromNamespace("palette.colors", "grDevices")
for (name in names) {
fun <- manual_pal(palette(palette = name), type = "colour")
set_palette(name, fun, warn_conflict = FALSE)
}
invisible(NULL)
}

register_viridis_pals <- function() {
names <- c("magma", "inferno", "plasma", "viridis",
"cividis", "rocket", "mako", "turbo")
for (name in names) {
fun <- pal_viridis(option = name)
set_palette(name, fun, warn_conflict = FALSE)
}
invisible(NULL)
}

register_brewer_pals <- function() {
names <- rownames(RColorBrewer::brewer.pal.info)
for (name in names) {
fun <- pal_brewer(palette = name)
set_palette(name, fun, warn_conflict = FALSE)
}
invisible(NULL)
}

register_dichromat_pals <- function() {
if (!is_installed("dichromat")) {
return(invisible(NULL))
}
names <- names(dichromat::colorschemes)
for (name in names) {
fun <- manual_pal(dichromat::colorschemes[[name]], type = "colour")
set_palette(name, fun, warn_conflict = FALSE)
}
invisible(NULL)
}
4 changes: 4 additions & 0 deletions R/utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -100,3 +100,7 @@ recycle_common <- function(..., size = NULL, call = caller_env()) {
x[to_recycle] <- lapply(x[to_recycle], rep_len, length.out = size)
x
}

.onLoad <- function(lib, pkg) {
run_on_load()
}
1 change: 1 addition & 0 deletions _pkgdown.yml
Original file line number Diff line number Diff line change
Expand Up @@ -68,6 +68,7 @@ reference:
- contains("col")
- muted
- alpha
- get_palette

- title: Non-colour palette functions
desc: >
Expand Down
53 changes: 53 additions & 0 deletions man/get_palette.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

41 changes: 41 additions & 0 deletions tests/testthat/test-palette-registry.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,41 @@
test_that("palette getters and setters work as intended", {

# Test that palettes have been populated in .onLoad
expect_in(c("hue", "grey"), palette_names())

# We cannot get unknown palettes
expect_error(get_palette("rgb"), "Unknown palette")

# We cannot set nonsense palettes
expect_error(
set_palette("foobar", list(a = 1:2, b = "A")),
"must be a"
)

# Test we can set custom palettes
colours <- c("red", "green", 'blue')
set_palette("rgb", palette = colours)
expect_in("rgb", palette_names())

# Test we can get custom palettes
pal <- get_palette("rgb")
expect_equal(pal(length(colours)), colours)

# Test we can reset palettes
reset_palettes()
expect_false("rgb" %in% palette_names())
})

test_that("as_continuous_pal and as_discrete_pal can retrieve known palettes", {

colours <- c("#FF0000", "#00FF00", '#0000FF')
set_palette("rgb", colours)

pal <- as_discrete_pal("rgb")
expect_equal(pal(length(colours)), colours)

pal <- as_continuous_pal("rgb")
expect_equal(pal(seq(0, 1, length.out = length(colours))), colours)

reset_palettes()
})
Loading