From 80d3d7f65adb0658396923f6047867be081bba49 Mon Sep 17 00:00:00 2001 From: Eric Marcon Date: Mon, 21 Oct 2024 11:19:29 +0200 Subject: [PATCH 1/9] Confusion between y and lambda in the documentation of the Box-Cox transformation (#414) --- R/transform-numeric.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/transform-numeric.R b/R/transform-numeric.R index 641b7f53..d84b3e46 100644 --- a/R/transform-numeric.R +++ b/R/transform-numeric.R @@ -67,16 +67,16 @@ asinh_trans <- transform_asinh #' Box-Cox to also work with negative values. #' #' The Box-Cox power transformation (type 1) requires strictly positive values and -#' takes the following form for `y > 0`: +#' takes the following form for \eqn{\lambda > 0}: #' \deqn{y^{(\lambda)} = \frac{y^\lambda - 1}{\lambda}}{y^(\lambda) = (y^\lambda - 1)/\lambda} -#' When `y = 0`, the natural log transform is used. +#' When \eqn{\lambda = 0}, the natural log transform is used. #' #' The modulus transformation implements a generalisation of the Box-Cox #' transformation that works for data with both positive and negative values. -#' The equation takes the following forms, when `y != 0` : +#' The equation takes the following forms, when \eqn{\lambda \neq 0} : #' \deqn{y^{(\lambda)} = sign(y) * \frac{(|y| + 1)^\lambda - 1}{\lambda}}{ #' y^(\lambda) = sign(y)*((|y|+1)^\lambda - 1)/\lambda} -#' and when `y = 0`: \deqn{y^{(\lambda)} = sign(y) * \ln(|y| + 1)}{ +#' and when \eqn{\lambda = 0}: \deqn{y^{(\lambda)} = sign(y) * \ln(|y| + 1)}{ #' y^(\lambda) = sign(y) * ln(|y| + 1)} #' #' @param p Transformation exponent, \eqn{\lambda}. From 91431a190469fb0a34730b13cb6ccd21f9f91c47 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 21 Oct 2024 11:25:27 +0200 Subject: [PATCH 2/9] Propagate call for error messages (#416) --- DESCRIPTION | 2 +- R/range.R | 9 ++++++--- R/scale-continuous.R | 9 +++++++-- R/scale-discrete.R | 12 +++++++++--- man/train_continuous.Rd | 4 +++- man/train_discrete.Rd | 11 ++++++++++- 6 files changed, 36 insertions(+), 11 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 38d99259..0ee8fe58 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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 diff --git a/R/range.R b/R/range.R index e2aa3476..f74ec500 100644 --- a/R/range.R +++ b/R/range.R @@ -18,9 +18,10 @@ DiscreteRange <- R6::R6Class( inherit = Range, list( factor = NULL, - train = function(x, drop = FALSE, na.rm = FALSE) { + train = function(x, drop = FALSE, na.rm = FALSE, call = caller_env()) { self$factor <- self$factor %||% is.factor(x) - self$range <- train_discrete(x, self$range, drop, na.rm, self$factor) + self$range <- train_discrete(x, self$range, drop, na.rm, + self$factor, call = call) }, reset = function() { self$range <- NULL @@ -35,7 +36,9 @@ ContinuousRange <- R6::R6Class( "ContinuousRange", inherit = Range, list( - train = function(x) self$range <- train_continuous(x, self$range), + train = function(x, call = caller_env()) { + self$range <- train_continuous(x, self$range, call = call) + }, reset = function() self$range <- NULL ) ) diff --git a/R/scale-continuous.R b/R/scale-continuous.R index 102b325f..b5095fbe 100644 --- a/R/scale-continuous.R +++ b/R/scale-continuous.R @@ -37,13 +37,18 @@ cscale <- function(x, palette, na.value = NA_real_, trans = transform_identity() #' #' @inheritParams train_discrete #' @export -train_continuous <- function(new, existing = NULL) { +train_continuous <- function(new, existing = NULL, call = caller_env()) { if (is.null(new)) { return(existing) } if (is.factor(new) || !typeof(new) %in% c("integer", "double")) { - cli::cli_abort("Discrete value supplied to a continuous scale") + example <- unique(new) + example <- example[seq_len(pmin(length(example), 5))] + cli::cli_abort(c( + "Discrete value supplied to a continuous scale.", + i = "Example values: {.and {.val {example}}}." + ), call = call) } # Needs casting to numeric because some `new` vectors can misbehave when diff --git a/R/scale-discrete.R b/R/scale-discrete.R index 3e95e13b..8957583a 100644 --- a/R/scale-discrete.R +++ b/R/scale-discrete.R @@ -25,14 +25,20 @@ is.discrete <- function(x) { #' @param drop `TRUE`, will drop factor levels not associated with data #' @param na.rm If `TRUE`, will remove missing values #' @param fct Treat `existing` as if it came from a factor (ie. don't sort the range) +#' @param call A call to display in error messages #' @export -train_discrete <- function(new, existing = NULL, drop = FALSE, na.rm = FALSE, fct = NA) { +train_discrete <- function(new, existing = NULL, drop = FALSE, + na.rm = FALSE, fct = NA, call = caller_env()) { if (is.null(new)) { return(existing) } - if (!is.discrete(new)) { - cli::cli_abort("Continuous value supplied to a discrete scale") + example <- unique(new) + example <- example[seq_len(pmin(length(example), 5))] + cli::cli_abort(c( + "Continuous value supplied to a discrete scale.", + i = "Example values: {.and {.val {example}}}." + ), call = call) } discrete_range(existing, new, drop = drop, na.rm = na.rm, fct = fct) } diff --git a/man/train_continuous.Rd b/man/train_continuous.Rd index ece41995..16d62955 100644 --- a/man/train_continuous.Rd +++ b/man/train_continuous.Rd @@ -4,12 +4,14 @@ \alias{train_continuous} \title{Train (update) a continuous scale} \usage{ -train_continuous(new, existing = NULL) +train_continuous(new, existing = NULL, call = caller_env()) } \arguments{ \item{new}{New data to add to scale} \item{existing}{Optional existing scale to update} + +\item{call}{A call to display in error messages} } \description{ Strips attributes and always returns a numeric vector diff --git a/man/train_discrete.Rd b/man/train_discrete.Rd index 9e717429..cbeb1ef4 100644 --- a/man/train_discrete.Rd +++ b/man/train_discrete.Rd @@ -4,7 +4,14 @@ \alias{train_discrete} \title{Train (update) a discrete scale} \usage{ -train_discrete(new, existing = NULL, drop = FALSE, na.rm = FALSE, fct = NA) +train_discrete( + new, + existing = NULL, + drop = FALSE, + na.rm = FALSE, + fct = NA, + call = caller_env() +) } \arguments{ \item{new}{New data to add to scale} @@ -16,6 +23,8 @@ train_discrete(new, existing = NULL, drop = FALSE, na.rm = FALSE, fct = NA) \item{na.rm}{If \code{TRUE}, will remove missing values} \item{fct}{Treat \code{existing} as if it came from a factor (ie. don't sort the range)} + +\item{call}{A call to display in error messages} } \description{ Train (update) a discrete scale From 6f2f979a81678c7cd5597b1d18cac78e9cf473c6 Mon Sep 17 00:00:00 2001 From: Colin Douglas Date: Mon, 21 Oct 2024 06:32:39 -0300 Subject: [PATCH 3/9] fix bug in `label_number` when `scale_cut` argument is provided (#413) (#420) --- R/label-number.R | 1 + tests/testthat/test-label-number.R | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/R/label-number.R b/R/label-number.R index a8a335ae..3c06b353 100644 --- a/R/label-number.R +++ b/R/label-number.R @@ -350,6 +350,7 @@ scale_cut <- function(x, breaks, scale = 1, accuracy = NULL, suffix = "") { if (any(bad_break)) { # If the break below result in a perfect cut, prefer it lower_break <- breaks[match(break_suffix[bad_break], names(breaks)) - 1] + lower_break[lower_break == 0] <- 1 # Avoid choosing a non-existent break improved_break <- (x[bad_break] * scale / lower_break) %% 1 == 0 # Unless the break below is a power of 10 change (1.25 is as good as 1250) power10_break <- log10(breaks[break_suffix[bad_break]] / lower_break) %% 1 == 0 diff --git a/tests/testthat/test-label-number.R b/tests/testthat/test-label-number.R index 4a4cd490..ba6094e8 100644 --- a/tests/testthat/test-label-number.R +++ b/tests/testthat/test-label-number.R @@ -179,6 +179,11 @@ test_that("scale_cut prefers clean cuts", { x <- c(518400, 691200) # prefers days over week in second element expect_equal(number(x, scale_cut = cut_time_scale()), c("6d", "8d")) + + # do not select off-scale breaks + x <- c(0, 500, 1500, 2000, 2500) + expect_equal(number(x, scale_cut = cut_short_scale()), c("0", "500", "1.5K", "2.0K", "2.5K")) + }) test_that("built-in functions return expected values", { From 9bcb18247a873781a8f3a5813a96b7f936fc9bda Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 21 Oct 2024 11:39:27 +0200 Subject: [PATCH 4/9] Add `signed` option for negative numbers in `label_log()` (#422) --- NAMESPACE | 1 + NEWS.md | 3 ++ R/label-log.R | 52 ++++++++++++++++++++++++++------- man/label_log.Rd | 18 ++++++++++-- tests/testthat/test-label-log.R | 1 + 5 files changed, 63 insertions(+), 12 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 323e34ba..80d34c6b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -96,6 +96,7 @@ export(exp_trans) export(expand_range) export(extended_breaks) export(format_format) +export(format_log) export(fullseq) export(gradient_n_pal) export(grey_pal) diff --git a/NEWS.md b/NEWS.md index 9646d4a5..6e2d1bb7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # scales (development version) +* `label_log()` has a `signed` argument for displaying negative numbers + (@teunbrand, #421). + # scales 1.3.0 ## Better type support diff --git a/R/label-log.R b/R/label-log.R index 802d2a13..e31e2bb8 100644 --- a/R/label-log.R +++ b/R/label-log.R @@ -1,10 +1,18 @@ #' Label numbers in log format (10^3, 10^6, etc) #' -#' `label_log()` displays numbers as base^exponent, using superscript formatting. +#' `label_log()` and `format_log()` display numbers as base^exponent, using +#' superscript formatting. `label_log()` returns expressions suitable for +#' labelling in scales, whereas `format_log()` returns deparsed text. #' +#' +#' @param x A numeric vector to format #' @param base Base of logarithm to use #' @param digits Number of significant digits to show for the exponent. Argument #' is passed on to [base::format()]. +#' @param signed Should a `+` or `-` be displayed as a prefix? The +#' default, `NULL`, displays signs if there are zeroes or negative numbers +#' present. +#' @param ... Passed on to `format()`. #' @inherit label_number return #' @seealso [breaks_log()] for the related breaks algorithm. #' @export @@ -12,19 +20,43 @@ #' @examples #' demo_log10(c(1, 1e5), labels = label_log()) #' demo_log10(c(1, 1e5), breaks = breaks_log(base = 2), labels = label_log(base = 2)) -label_log <- function(base = 10, digits = 3) { +#' format_log(c(0.1, 1, 10)) +label_log <- function(base = 10, digits = 3, signed = NULL) { function(x) { - if (length(x) == 0) { - return(expression()) - } - - exponent <- format(log(x, base = base), digits = digits) - text <- paste0(base, "^", exponent) + text <- format_log(x, base = base, signed = signed, digits = digits) ret <- parse_safe(text) - # restore NAs from input vector ret[is.na(x)] <- NA - ret } } + +#' @export +#' @rdname label_log +format_log <- function(x, base = 10, signed = NULL, ...) { + + if (length(x) == 0) { + return(character()) + } + prefix <- rep("", length(x)) + finites <- x[is.finite(x)] + + signed <- signed %||% any(finites <= 0) + if (signed) { + sign <- sign(x) + prefix[sign == +1] <- "+" + prefix[sign == -1] <- "-" + x <- abs(x) + x[x == 0] <- 1 + } + + exponent <- format(zapsmall(log(x, base = base)), ...) + text <- paste0(prefix, base, "^", exponent) + + if (signed) { + text[sign == 0] <- "0" + } + text[is.na(x)] <- NA + + text +} diff --git a/man/label_log.Rd b/man/label_log.Rd index daf576fb..d0dee6ab 100644 --- a/man/label_log.Rd +++ b/man/label_log.Rd @@ -2,15 +2,26 @@ % Please edit documentation in R/label-log.R \name{label_log} \alias{label_log} +\alias{format_log} \title{Label numbers in log format (10^3, 10^6, etc)} \usage{ -label_log(base = 10, digits = 3) +label_log(base = 10, digits = 3, signed = NULL) + +format_log(x, base = 10, signed = NULL, ...) } \arguments{ \item{base}{Base of logarithm to use} \item{digits}{Number of significant digits to show for the exponent. Argument is passed on to \code{\link[base:format]{base::format()}}.} + +\item{signed}{Should a \code{+} or \code{-} be displayed as a prefix? The +default, \code{NULL}, displays signs if there are zeroes or negative numbers +present.} + +\item{x}{A numeric vector to format} + +\item{...}{Passed on to \code{format()}.} } \value{ All \code{label_()} functions return a "labelling" function, i.e. a function that @@ -23,11 +34,14 @@ they work similarly for all scales, including those that generate legends rather than axes. } \description{ -\code{label_log()} displays numbers as base^exponent, using superscript formatting. +\code{label_log()} and \code{format_log()} display numbers as base^exponent, using +superscript formatting. \code{label_log()} returns expressions suitable for +labelling in scales, whereas \code{format_log()} returns deparsed text. } \examples{ demo_log10(c(1, 1e5), labels = label_log()) demo_log10(c(1, 1e5), breaks = breaks_log(base = 2), labels = label_log(base = 2)) +format_log(c(0.1, 1, 10)) } \seealso{ \code{\link[=breaks_log]{breaks_log()}} for the related breaks algorithm. diff --git a/tests/testthat/test-label-log.R b/tests/testthat/test-label-log.R index 0a555ae0..2aee4f49 100644 --- a/tests/testthat/test-label-log.R +++ b/tests/testthat/test-label-log.R @@ -5,4 +5,5 @@ test_that("label_log() returns expression", { expect_equal(label_log()(c(0.1, 10)), expression(10^-1, 10^1)) expect_equal(label_log(base = 2)(8), expression(2^3)) expect_equal(label_log(base = 2, digits = 3)(7), expression(2^2.81)) + expect_equal(label_log(signed = TRUE)(c(-100, 100)), expression(-10^2, +10^2)) }) From a4ca0505e3404e3623b46720b2d952ea4f65ba34 Mon Sep 17 00:00:00 2001 From: James McMahon Date: Mon, 21 Oct 2024 11:01:34 +0100 Subject: [PATCH 5/9] Update label-date documentation (#433) --- R/label-date.R | 10 +++++----- man/date_format.Rd | 4 ++-- man/label_date.Rd | 10 +++++----- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/R/label-date.R b/R/label-date.R index 466b1b25..0e2865fd 100644 --- a/R/label-date.R +++ b/R/label-date.R @@ -11,10 +11,10 @@ #' suffix to the input (ns, us, ms, s, m, h, d, w). #' #' @inherit label_number return -#' @param format For `date_format()` and `time_format()` a date/time format +#' @param format For `label_date()` and `label_time()` a date/time format #' string using standard POSIX specification. See [strptime()] for details. #' -#' For `date_short()` a character vector of length 4 giving the format +#' For `label_date_short()` a character vector of length 4 giving the format #' components to use for year, month, day, and hour respectively. #' @param tz a time zone name, see [timezones()]. Defaults #' to UTC @@ -31,9 +31,9 @@ #' #' two_months <- date_range("2020-05-01", 60) #' demo_datetime(two_months) -#' demo_datetime(two_months, labels = date_format("%m/%d")) -#' demo_datetime(two_months, labels = date_format("%e %b", locale = "fr")) -#' demo_datetime(two_months, labels = date_format("%e %B", locale = "es")) +#' demo_datetime(two_months, labels = label_date("%m/%d")) +#' demo_datetime(two_months, labels = label_date("%e %b", locale = "fr")) +#' demo_datetime(two_months, labels = label_date("%e %B", locale = "es")) #' # ggplot2 provides a short-hand: #' demo_datetime(two_months, date_labels = "%m/%d") #' diff --git a/man/date_format.Rd b/man/date_format.Rd index 8d3ab9e3..6de951f4 100644 --- a/man/date_format.Rd +++ b/man/date_format.Rd @@ -10,10 +10,10 @@ date_format(format = "\%Y-\%m-\%d", tz = "UTC", locale = NULL) time_format(format = "\%H:\%M:\%S", tz = "UTC", locale = NULL) } \arguments{ -\item{format}{For \code{date_format()} and \code{time_format()} a date/time format +\item{format}{For \code{label_date()} and \code{label_time()} a date/time format string using standard POSIX specification. See \code{\link[=strptime]{strptime()}} for details. -For \code{date_short()} a character vector of length 4 giving the format +For \code{label_date_short()} a character vector of length 4 giving the format components to use for year, month, day, and hour respectively.} \item{tz}{a time zone name, see \code{\link[=timezones]{timezones()}}. Defaults diff --git a/man/label_date.Rd b/man/label_date.Rd index ea06c22d..539bf5c9 100644 --- a/man/label_date.Rd +++ b/man/label_date.Rd @@ -20,10 +20,10 @@ label_timespan( ) } \arguments{ -\item{format}{For \code{date_format()} and \code{time_format()} a date/time format +\item{format}{For \code{label_date()} and \code{label_time()} a date/time format string using standard POSIX specification. See \code{\link[=strptime]{strptime()}} for details. -For \code{date_short()} a character vector of length 4 giving the format +For \code{label_date_short()} a character vector of length 4 giving the format components to use for year, month, day, and hour respectively.} \item{tz}{a time zone name, see \code{\link[=timezones]{timezones()}}. Defaults @@ -109,9 +109,9 @@ date_range <- function(start, days) { two_months <- date_range("2020-05-01", 60) demo_datetime(two_months) -demo_datetime(two_months, labels = date_format("\%m/\%d")) -demo_datetime(two_months, labels = date_format("\%e \%b", locale = "fr")) -demo_datetime(two_months, labels = date_format("\%e \%B", locale = "es")) +demo_datetime(two_months, labels = label_date("\%m/\%d")) +demo_datetime(two_months, labels = label_date("\%e \%b", locale = "fr")) +demo_datetime(two_months, labels = label_date("\%e \%B", locale = "es")) # ggplot2 provides a short-hand: demo_datetime(two_months, date_labels = "\%m/\%d") From 0c50869d2176c9fbd2c472fe18314e9ebb3ab46e Mon Sep 17 00:00:00 2001 From: Douglas Ezra Morrison Date: Mon, 21 Oct 2024 05:01:17 -0700 Subject: [PATCH 6/9] fix typo in documentation for `label_pvalue()` (#447) --- R/label-pvalue.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/label-pvalue.R b/R/label-pvalue.R index 2564daf0..ef35aa68 100644 --- a/R/label-pvalue.R +++ b/R/label-pvalue.R @@ -4,8 +4,8 @@ #' #' @inherit label_number return params #' @param prefix A character vector of length 3 giving the prefixes to -#' put in front of numbers. The default values are `c("<", "", ">")` -#' if `add_p` is `TRUE` and `c("p<", "p=", "p>")` if `FALSE`. +#' put in front of numbers. The default values are `c("p<", "p=", "p>")` +#' if `add_p` is `TRUE` and `c("<", "", ">")` if `FALSE`. #' @param add_p Add "p=" before the value? #' @export #' @family labels for continuous scales From 88c4beb963da19dce44f4dd7c90369e806f0a046 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 21 Oct 2024 14:08:58 +0200 Subject: [PATCH 7/9] Named palettes (#448) --- NAMESPACE | 6 + NEWS.md | 2 + R/colour-manip.R | 8 ++ R/pal-.R | 16 +++ R/palette-registry.R | 157 +++++++++++++++++++++++++ R/utils.R | 4 + _pkgdown.yml | 1 + man/get_palette.Rd | 53 +++++++++ man/label_pvalue.Rd | 4 +- man/pvalue_format.Rd | 4 +- man/transform_boxcox.Rd | 8 +- tests/testthat/test-palette-registry.R | 41 +++++++ 12 files changed, 296 insertions(+), 8 deletions(-) create mode 100644 R/palette-registry.R create mode 100644 man/get_palette.Rd create mode 100644 tests/testthat/test-palette-registry.R diff --git a/NAMESPACE b/NAMESPACE index 80d34c6b..7515048c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -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) @@ -98,6 +100,7 @@ export(extended_breaks) export(format_format) export(format_log) export(fullseq) +export(get_palette) export(gradient_n_pal) export(grey_pal) export(hms_trans) @@ -177,6 +180,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) @@ -195,10 +199,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) diff --git a/NEWS.md b/NEWS.md index 6e2d1bb7..9566bc81 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # 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). * `label_log()` has a `signed` argument for displaying negative numbers (@teunbrand, #421). diff --git a/R/colour-manip.R b/R/colour-manip.R index 5de30897..c4f15d85 100644 --- a/R/colour-manip.R +++ b/R/colour-manip.R @@ -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) diff --git a/R/pal-.R b/R/pal-.R index 46e34573..8665dfc6 100644 --- a/R/pal-.R +++ b/R/pal-.R @@ -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 @@ -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, ...)) +} diff --git a/R/palette-registry.R b/R/palette-registry.R new file mode 100644 index 00000000..6ef38ab7 --- /dev/null +++ b/R/palette-registry.R @@ -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) +} diff --git a/R/utils.R b/R/utils.R index fc80a5a4..57dea1ef 100644 --- a/R/utils.R +++ b/R/utils.R @@ -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() +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 3e26d4b2..f788498d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -68,6 +68,7 @@ reference: - contains("col") - muted - alpha + - get_palette - title: Non-colour palette functions desc: > diff --git a/man/get_palette.Rd b/man/get_palette.Rd new file mode 100644 index 00000000..e48def8e --- /dev/null +++ b/man/get_palette.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/palette-registry.R +\name{get_palette} +\alias{get_palette} +\alias{set_palette} +\alias{palette_names} +\alias{reset_palettes} +\title{Known palettes} +\usage{ +get_palette(name, ...) + +set_palette(name, palette, warn_conflict = TRUE) + +palette_names() + +reset_palettes() +} +\arguments{ +\item{name}{A string giving the palette name.} + +\item{...}{Additional arguments to pass to palette when it is a function +but not a palette class function.} + +\item{palette}{A \link[=new_continuous_palette]{palette}, \code{function} or character +vector.} + +\item{warn_conflict}{A boolean which if \code{TRUE} (default), warns when +replacing a known palette.} +} +\value{ +The \code{get_palette()} function returns a palette. The \code{set_palette()} +function is called for side effects and returns nothing. +} +\description{ +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 \code{as_continuous_pal()} or \code{as_discrete_pal()}. +} +\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() +} diff --git a/man/label_pvalue.Rd b/man/label_pvalue.Rd index ae9e2b83..a2bdbb87 100644 --- a/man/label_pvalue.Rd +++ b/man/label_pvalue.Rd @@ -23,8 +23,8 @@ Applied to rescaled data.} decimal point.} \item{prefix}{A character vector of length 3 giving the prefixes to -put in front of numbers. The default values are \code{c("<", "", ">")} -if \code{add_p} is \code{TRUE} and \code{c("p<", "p=", "p>")} if \code{FALSE}.} +put in front of numbers. The default values are \code{c("p<", "p=", "p>")} +if \code{add_p} is \code{TRUE} and \code{c("<", "", ">")} if \code{FALSE}.} \item{add_p}{Add "p=" before the value?} } diff --git a/man/pvalue_format.Rd b/man/pvalue_format.Rd index 71e4436a..ddf72dd9 100644 --- a/man/pvalue_format.Rd +++ b/man/pvalue_format.Rd @@ -26,8 +26,8 @@ Applied to rescaled data.} decimal point.} \item{prefix}{A character vector of length 3 giving the prefixes to -put in front of numbers. The default values are \code{c("<", "", ">")} -if \code{add_p} is \code{TRUE} and \code{c("p<", "p=", "p>")} if \code{FALSE}.} +put in front of numbers. The default values are \code{c("p<", "p=", "p>")} +if \code{add_p} is \code{TRUE} and \code{c("<", "", ">")} if \code{FALSE}.} \item{add_p}{Add "p=" before the value?} } diff --git a/man/transform_boxcox.Rd b/man/transform_boxcox.Rd index cc6d8ea5..00d9ca28 100644 --- a/man/transform_boxcox.Rd +++ b/man/transform_boxcox.Rd @@ -29,16 +29,16 @@ Box-Cox to also work with negative values. } \details{ The Box-Cox power transformation (type 1) requires strictly positive values and -takes the following form for \code{y > 0}: +takes the following form for \eqn{\lambda > 0}: \deqn{y^{(\lambda)} = \frac{y^\lambda - 1}{\lambda}}{y^(\lambda) = (y^\lambda - 1)/\lambda} -When \code{y = 0}, the natural log transform is used. +When \eqn{\lambda = 0}, the natural log transform is used. The modulus transformation implements a generalisation of the Box-Cox transformation that works for data with both positive and negative values. -The equation takes the following forms, when \code{y != 0} : +The equation takes the following forms, when \eqn{\lambda \neq 0} : \deqn{y^{(\lambda)} = sign(y) * \frac{(|y| + 1)^\lambda - 1}{\lambda}}{ y^(\lambda) = sign(y)*((|y|+1)^\lambda - 1)/\lambda} -and when \code{y = 0}: \deqn{y^{(\lambda)} = sign(y) * \ln(|y| + 1)}{ +and when \eqn{\lambda = 0}: \deqn{y^{(\lambda)} = sign(y) * \ln(|y| + 1)}{ y^(\lambda) = sign(y) * ln(|y| + 1)} } \examples{ diff --git a/tests/testthat/test-palette-registry.R b/tests/testthat/test-palette-registry.R new file mode 100644 index 00000000..06e09074 --- /dev/null +++ b/tests/testthat/test-palette-registry.R @@ -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() +}) From a7038fc91f2684c709bff31e19e7ff98c86d87c2 Mon Sep 17 00:00:00 2001 From: Alex Hamilton <1622250+Aehmlo@users.noreply.github.com> Date: Mon, 21 Oct 2024 08:10:17 -0400 Subject: [PATCH 8/9] Update warning message for shape overuse (#450) --- R/pal-shape.r | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/pal-shape.r b/R/pal-shape.r index 7090631e..065e0c0f 100644 --- a/R/pal-shape.r +++ b/R/pal-shape.r @@ -8,7 +8,7 @@ pal_shape <- function(solid = TRUE) { if (n > 6) { cli::cli_warn(c( "The shape palette can deal with a maximum of 6 discrete values because more than 6 becomes difficult to discriminate", - i = "you have requested {n} values. Consider specifying shapes manually if you need that many have them." + i = "you have requested {n} values. Consider specifying shapes manually if you need that many of them." )) } From 737eb5cc89c30c2da24075aa0fe30d750f605db7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 21 Oct 2024 14:44:13 +0200 Subject: [PATCH 9/9] Minor break function for log10 ticks (#452) --- NAMESPACE | 1 + R/breaks-log.R | 83 +++++++++++++++++++++++++++++ _pkgdown.yml | 1 + man/minor_breaks_log.Rd | 34 ++++++++++++ tests/testthat/_snaps/breaks-log.md | 16 ++++++ tests/testthat/test-breaks-log.R | 23 ++++++++ 6 files changed, 158 insertions(+) create mode 100644 man/minor_breaks_log.Rd create mode 100644 tests/testthat/_snaps/breaks-log.md diff --git a/NAMESPACE b/NAMESPACE index 7515048c..767761be 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -142,6 +142,7 @@ export(log_trans) export(logit_trans) export(manual_pal) export(math_format) +export(minor_breaks_log) export(minor_breaks_n) export(minor_breaks_width) export(modulus_trans) diff --git a/R/breaks-log.R b/R/breaks-log.R index 79acceb4..cbfe7cfc 100644 --- a/R/breaks-log.R +++ b/R/breaks-log.R @@ -82,6 +82,89 @@ breaks_log <- function(n = 5, base = 10) { #' @rdname breaks_log log_breaks <- breaks_log +#' Minor breaks for log-10 axes +#' +#' This break function is designed to mark every power, multiples of 5 and/or 1 +#' of that power for base 10. +#' +#' @param detail Any of `1`, `5` and `10` to mark multiples of +#' powers, multiples of 5 of powers or just powers respectively. +#' @param smallest Smallest absolute value to mark when the range includes +#' negative numbers. +#' +#' @return A function to generate minor ticks. +#' @export +#' +#' @examples +#' # Standard usage with log10 scale +#' demo_log10(c(1, 1e10), minor_breaks = minor_breaks_log()) +#' # Increasing detail over many powers +#' demo_log10(c(1, 1e10), minor_breaks = minor_breaks_log(detail = 1)) +#' # Adjusting until where to draw minor breaks +#' demo_continuous( +#' c(-1000, 1000), +#' transform = asinh_trans(), +#' minor_breaks = minor_breaks_log(smallest = 1) +#' ) +minor_breaks_log <- function(detail = NULL, smallest = NULL) { + if (!is.null(detail) && (!length(detail) == 1 || !detail %in% c(1, 5, 10))) { + cli::cli_abort("The {.arg detail} argument must be one of 1, 5 or 10.") + } + if (!is.null(smallest) && + (!length(smallest) == 1 || smallest < 1e-100 || !is.finite(smallest))) { + cli::cli_abort( + "The {.arg smallest} argument must be a finite, positive, non-zero number." + ) + } + force(smallest) + function(x, ...) { + + has_negatives <- any(x <= 0) + + if (has_negatives) { + large <- max(abs(x)) + small <- smallest %||% min(c(1, large) * 0.1) + x <- sort(c(small * 10, large)) + } + + start <- floor(log10(min(x))) - 1L + end <- ceiling(log10(max(x))) + 1L + + if (is.null(detail)) { + i <- findInterval(abs(end - start), c(8, 15), left.open = TRUE) + 1L + detail <- c(1, 5, 10)[i] + } + + ladder <- 10^seq(start, end, by = 1L) + tens <- fives <- ones <- numeric() + if (detail %in% c(10, 5, 1)) { + tens <- ladder + } + if (detail %in% c(5, 1)) { + fives <- 5 * ladder + } + if (detail == 1) { + ones <- as.vector(outer(1:9, ladder)) + ones <- setdiff(ones, c(tens, fives)) + } + + if (has_negatives) { + tens <- tens[tens >= small] + tens <- c(tens, -tens, 0) + fives <- fives[fives >= small] + fives <- c(fives, -fives) + ones <- ones[ones >= small] + ones <- c(ones, -ones) + } + + ticks <- c(tens, fives, ones) + n <- c(length(tens), length(fives), length(ones)) + + attr(ticks, "detail") <- rep(c(10, 5, 1), n) + ticks + } +} + #' @author Thierry Onkelinx, \email{thierry.onkelinx@inbo.be} #' @noRd log_sub_breaks <- function(rng, n = 5, base = 10) { diff --git a/_pkgdown.yml b/_pkgdown.yml index f788498d..bf7ea339 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -27,6 +27,7 @@ reference: contents: - starts_with("breaks_") - minor_breaks_width + - minor_breaks_log - title: "Bounds: ranges & rescaling" desc: > diff --git a/man/minor_breaks_log.Rd b/man/minor_breaks_log.Rd new file mode 100644 index 00000000..1efb1da2 --- /dev/null +++ b/man/minor_breaks_log.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/breaks-log.R +\name{minor_breaks_log} +\alias{minor_breaks_log} +\title{Minor breaks for log-10 axes} +\usage{ +minor_breaks_log(detail = NULL, smallest = NULL) +} +\arguments{ +\item{detail}{Any of \code{1}, \code{5} and \code{10} to mark multiples of +powers, multiples of 5 of powers or just powers respectively.} + +\item{smallest}{Smallest absolute value to mark when the range includes +negative numbers.} +} +\value{ +A function to generate minor ticks. +} +\description{ +This break function is designed to mark every power, multiples of 5 and/or 1 +of that power for base 10. +} +\examples{ +# Standard usage with log10 scale +demo_log10(c(1, 1e10), minor_breaks = minor_breaks_log()) +# Increasing detail over many powers +demo_log10(c(1, 1e10), minor_breaks = minor_breaks_log(detail = 1)) +# Adjusting until where to draw minor breaks +demo_continuous( + c(-1000, 1000), + transform = asinh_trans(), + minor_breaks = minor_breaks_log(smallest = 1) +) +} diff --git a/tests/testthat/_snaps/breaks-log.md b/tests/testthat/_snaps/breaks-log.md new file mode 100644 index 00000000..aa7153eb --- /dev/null +++ b/tests/testthat/_snaps/breaks-log.md @@ -0,0 +1,16 @@ +# minor_breaks_log rejects invalid arguments + + Code + minor_breaks_log(7) + Condition + Error in `minor_breaks_log()`: + ! The `detail` argument must be one of 1, 5 or 10. + +--- + + Code + minor_breaks_log(smallest = 0) + Condition + Error in `minor_breaks_log()`: + ! The `smallest` argument must be a finite, positive, non-zero number. + diff --git a/tests/testthat/test-breaks-log.R b/tests/testthat/test-breaks-log.R index be32793e..5cbecb8c 100644 --- a/tests/testthat/test-breaks-log.R +++ b/tests/testthat/test-breaks-log.R @@ -90,3 +90,26 @@ test_that("breaks_log with very small ranges fall back to extended_breaks", { extended_breaks(n = 5)(c(0.95, 3)) )) }) + +test_that("minor_breaks_log has correct amount of detail", { + range <- c(1, 10) + + test <- minor_breaks_log(detail = 1)(range) + expect_true(all(1:10 %in% test)) + + test <- minor_breaks_log(detail = 5)(range) + expect_false(all(1:10 %in% test)) + expect_true(all(c(1, 5, 10) %in% test)) + + test <- minor_breaks_log(detail = 10)(range) + expect_true(all(c(1, 10) %in% test)) + expect_false(5 %in% test) + + test <- minor_breaks_log(detail = 1)(c(-10, 10)) + expect_true(all(-10:10 %in% test)) +}) + +test_that("minor_breaks_log rejects invalid arguments", { + expect_snapshot(minor_breaks_log(7), error = TRUE) + expect_snapshot(minor_breaks_log(smallest = 0), error = TRUE) +})