From 40171c37845ae55e0880faf19d980a8b41e31182 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 10 Oct 2024 11:13:54 +0200 Subject: [PATCH 1/6] add common class --- R/pal-.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/pal-.R b/R/pal-.R index 46e34573..d4670622 100644 --- a/R/pal-.R +++ b/R/pal-.R @@ -65,7 +65,7 @@ new_continuous_palette <- function(fun, type, na_safe = NA) { if (!is.function(fun)) { cli::cli_abort("{.arg fun} must be a function.") } - class(fun) <- union("pal_continuous", class(fun)) + class(fun) <- union(c("pal_continuous", "scales_pal"), class(fun)) attr(fun, "type") <- type attr(fun, "na_safe") <- na_safe fun @@ -77,7 +77,7 @@ new_discrete_palette <- function(fun, type, nlevels = NA) { if (!is.function(fun)) { cli::cli_abort("{.arg fun} must be a function.") } - class(fun) <- union("pal_discrete", class(fun)) + class(fun) <- union(c("pal_discrete", "scales_pal"), class(fun)) attr(fun, "type") <- type attr(fun, "nlevels") <- nlevels fun From d4e291fb7bc7e424ffa08e6f5413b57c6e01b6f0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 10 Oct 2024 11:15:50 +0200 Subject: [PATCH 2/6] make colour adjustments S3 generics/methods --- NAMESPACE | 8 +++++++ R/colour-manip.R | 56 ++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 62 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 323e34ba..44ed043a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,14 @@ S3method(as_continuous_pal,pal_discrete) S3method(as_discrete_pal,"function") S3method(as_discrete_pal,default) S3method(as_discrete_pal,pal_continuous) +S3method(col_lighter,default) +S3method(col_lighter,scales_pal) +S3method(col_mix,default) +S3method(col_mix,scales_pal) +S3method(col_saturate,default) +S3method(col_saturate,scales_pal) +S3method(col_shift,default) +S3method(col_shift,scales_pal) S3method(fullseq,Date) S3method(fullseq,POSIXt) S3method(fullseq,difftime) diff --git a/R/colour-manip.R b/R/colour-manip.R index 5de30897..72894666 100644 --- a/R/colour-manip.R +++ b/R/colour-manip.R @@ -131,6 +131,11 @@ show_col <- function(colours, labels = TRUE, borders = NULL, cex_label = 1, #' # Not recommended: #' col_mix("blue", "red", space = "hcl") # green! col_mix <- function(a, b, amount = 0.5, space = "rgb") { + UseMethod("col_mix") +} + +#' @export +col_mix.default <- function(a, b, amount = 0.5, space = "rgb") { input <- recycle_common(a = a, b = b, amount = amount) if (any(input$amount < 0 | input$amount > 1)) { cli::cli_abort("{.arg amount} must be between (0, 1).") @@ -142,6 +147,11 @@ col_mix <- function(a, b, amount = 0.5, space = "rgb") { farver::encode_colour(new, alpha = alpha, from = space) } +#' @export +col_mix.scales_pal <- function(a, b, amount = 0.5, space = "rgb") { + wrap_col_adjustment(a, col_mix, list(b = b, amount = amount, space = space)) +} + #' Colour manipulation #' #' These are a set of convenience functions for standard colour manipulation @@ -175,29 +185,71 @@ NULL #' @export #' @rdname colour_manip col_shift <- function(col, amount = 10) { + UseMethod("col_shift") +} + +#' @export +col_shift.default <- function(col, amount = 10) { input <- recycle_common(col = col, amount = amount) new <- farver::decode_colour(input$col, alpha = TRUE, to = "hcl") new[, "h"] <- (new[, "h"] + input$amount) %% 360 farver::encode_colour(new, new[, "alpha"], from = "hcl") } +#' @export +col_shift.scales_pal <- function(col, amount = 10) { + wrap_col_adjustment(col, col_shift, list(amount = amount)) +} + #' @export #' @rdname colour_manip col_lighter <- function(col, amount = 10) { + UseMethod("col_lighter") +} + +#' @export +col_lighter.default <- function(col, amount = 10) { input <- recycle_common(col = col, amount = amount) farver::add_to_channel(input$col, "l", input$amount, space = "hsl") } +#' @export +col_lighter.scales_pal <- function(col, amount = 10) { + wrap_col_adjustment(col, col_lighter, list(amount = amount)) +} + #' @export #' @rdname colour_manip col_darker <- function(col, amount = 10) { - input <- recycle_common(col = col, amount = amount) - farver::add_to_channel(input$col, "l", -input$amount, space = "hsl") + col_lighter(col, amount = -amount) } #' @export #' @rdname colour_manip col_saturate <- function(col, amount = 10) { + UseMethod("col_saturate") +} + +#' @export +col_saturate.default <- function(col, amount = 10) { input <- recycle_common(col = col, amount = amount) farver::add_to_channel(input$col, "s", input$amount, space = "hsl") } + +#' @export +col_saturate.scales_pal <- function(col, amount = 10) { + wrap_col_adjustment(col, col_saturate, list(amount = amount)) +} + +wrap_col_adjustment <- function(inner, outer, args, call = caller_env()) { + if (!is_colour_pal(inner)) { + cli::cli_abort("palette must be a {.field colour} palette.", call = call) + } + force_all(inner, outer, args) + fun <- function(...) inject(outer(inner(...), !!!args)) + if (is_discrete_pal(inner)) { + new_discrete_palette(fun, type = "colour", nlevels = palette_nlevels(inner)) + } else { + new_continuous_palette(fun, type = "colour", na_safe = palette_na_safe(inner)) + } +} From 2cbd7082a2f967d3893a3729cbe70e7266f8e70b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 10 Oct 2024 11:30:45 +0200 Subject: [PATCH 3/6] add plot methods --- NAMESPACE | 2 ++ R/pal-.R | 12 ++++++++++++ 2 files changed, 14 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 44ed043a..dd73d11a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,8 @@ S3method(offset_by,Date) S3method(offset_by,POSIXt) S3method(offset_by,difftime) S3method(offset_by,numeric) +S3method(plot,pal_continuous) +S3method(plot,pal_discrete) S3method(plot,transform) S3method(print,transform) S3method(rescale,"NULL") diff --git a/R/pal-.R b/R/pal-.R index d4670622..8c310e3c 100644 --- a/R/pal-.R +++ b/R/pal-.R @@ -197,3 +197,15 @@ as_continuous_pal.pal_discrete <- function(x, ...) { ) ) } + +# Utility ----------------------------------------------------------------- + +#' @export +plot.pal_discrete <- function(x, y, ..., n_max = 25) { + show_col(x(pmin(n_max, palette_nlevels(x))), ...) +} + +#' @export +plot.pal_continuous <- function(x, y, ..., n_max = 25) { + show_col(x(seq(0, 1, length.out = n_max)), ...) +} From 40f6adc570523e52e79dfa2b3e0501847ab061e4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 10 Oct 2024 11:32:24 +0200 Subject: [PATCH 4/6] redocument --- R/colour-manip.R | 5 +++-- man/col_mix.Rd | 4 +++- man/colour_manip.Rd | 2 +- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/R/colour-manip.R b/R/colour-manip.R index 72894666..797372ba 100644 --- a/R/colour-manip.R +++ b/R/colour-manip.R @@ -113,7 +113,8 @@ show_col <- function(colours, labels = TRUE, borders = NULL, cex_label = 1, #' #' Produces an interpolation of two colours. #' -#' @param a,b A character vector of colours. +#' @param a Either a character vector of colours or a colour palette function. +#' @param b A character vector of colours. #' @param amount A numeric fraction between 0 and 1 giving the contribution of #' the `b` colour. #' @param space A string giving a colour space to perform mixing operation in. @@ -157,7 +158,7 @@ col_mix.scales_pal <- function(a, b, amount = 0.5, space = "rgb") { #' These are a set of convenience functions for standard colour manipulation #' operations. #' -#' @param col A character vector of colours. +#' @param col A character vector of colours or a colour palette function. #' @param amount A numeric vector giving the change. The interpretation depends #' on the function: #' * `col_shift()` takes a number between -360 and 360 for shifting hues in diff --git a/man/col_mix.Rd b/man/col_mix.Rd index ae40f3ac..f5181402 100644 --- a/man/col_mix.Rd +++ b/man/col_mix.Rd @@ -7,7 +7,9 @@ col_mix(a, b, amount = 0.5, space = "rgb") } \arguments{ -\item{a, b}{A character vector of colours.} +\item{a}{Either a character vector of colours or a colour palette function.} + +\item{b}{A character vector of colours.} \item{amount}{A numeric fraction between 0 and 1 giving the contribution of the \code{b} colour.} diff --git a/man/colour_manip.Rd b/man/colour_manip.Rd index 2dae5274..ff023c69 100644 --- a/man/colour_manip.Rd +++ b/man/colour_manip.Rd @@ -17,7 +17,7 @@ col_darker(col, amount = 10) col_saturate(col, amount = 10) } \arguments{ -\item{col}{A character vector of colours.} +\item{col}{A character vector of colours or a colour palette function.} \item{amount}{A numeric vector giving the change. The interpretation depends on the function: From ef30220bde54b7e640b653555a2978ec5c23a160 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 10 Oct 2024 11:41:29 +0200 Subject: [PATCH 5/6] add tests --- tests/testthat/test-colour-manip.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/test-colour-manip.R b/tests/testthat/test-colour-manip.R index a2f93225..744abb7e 100644 --- a/tests/testthat/test-colour-manip.R +++ b/tests/testthat/test-colour-manip.R @@ -72,3 +72,14 @@ test_that("col_saturate can (de)saturate colours", { expect_equal(col_saturate(x, -30), c("#996666", "#669966", "#666699")) }) +test_that("colour manipulation functions work on palettes", { + + pal <- pal_manual(c("#FF0000", "#00FF00", "#0000FF")) + + expect_equal(col_shift(pal, 180)(3), c("#00B8B8", "#FF92FF", "#535300")) + expect_equal(col_darker(pal, 30)(3), c("#660000", "#006600", "#000066")) + expect_equal(col_lighter(pal, 30)(3), c("#FF9999", "#99FF99", "#9999FF")) + expect_equal(col_saturate(pal, -50)(3), c("#BF4040", "#40BF40", "#4040BF")) + expect_equal(col_mix(pal, "white")(3), c("#FF8080", "#80FF80", "#8080FF")) + +}) From 0c47e9d6bd9efc98e4eb0c85418d96c522b78b25 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 22 Oct 2024 10:23:03 +0200 Subject: [PATCH 6/6] use `check_object()` --- R/colour-manip.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/colour-manip.R b/R/colour-manip.R index 30a6f0f3..95f8fdc6 100644 --- a/R/colour-manip.R +++ b/R/colour-manip.R @@ -251,9 +251,7 @@ col_saturate.scales_pal <- function(col, amount = 10) { } wrap_col_adjustment <- function(inner, outer, args, call = caller_env()) { - if (!is_colour_pal(inner)) { - cli::cli_abort("palette must be a {.field colour} palette.", call = call) - } + check_object(inner, is_colour_pal, "a {.field colour} palette") force_all(inner, outer, args) fun <- function(...) inject(outer(inner(...), !!!args)) if (is_discrete_pal(inner)) {