Merge branch 'main' into reverse_breaks_width

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

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)
@@ -50,6 +52,7 @@ export(asinh_trans)
 export(asn_trans)
 export(atanh_trans)
 export(boxcox_trans)
+export(breaks_exp)
 export(breaks_extended)
 export(breaks_log)
 export(breaks_pretty)
@@ -96,7 +99,9 @@ export(exp_trans)
 export(expand_range)
 export(extended_breaks)
 export(format_format)
+export(format_log)
 export(fullseq)
+export(get_palette)
 export(gradient_n_pal)
 export(grey_pal)
 export(hms_trans)
@@ -138,6 +143,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)
@@ -149,6 +155,7 @@ export(number)
 export(number_bytes)
 export(number_bytes_format)
 export(number_format)
+export(number_options)
 export(oob_censor)
 export(oob_censor_any)
 export(oob_discard)
@@ -176,6 +183,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)
@@ -194,10 +202,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)

NEWS.md

@@ -1,7 +1,14 @@
 # scales (development version)
-
 * `fullseq()` and by extension `breaks_width()` can now deal with unsorted 
   ranges (#435).
+* New `label_date_short(leading)` argument to replace leading zeroes (#442)
+* `breaks_pretty()` will return the input limit when it has no range (#446)
+* `transform_exp()` now has more sensible breaks, available in `breaks_exp()` 
+  (@teunbrand, #405).
+* 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).
 
 # scales 1.3.0
 

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{[email protected]}
 #' @noRd
 log_sub_breaks <- function(rng, n = 5, base = 10) {

R/breaks.R

@@ -122,6 +122,9 @@ breaks_pretty <- function(n = 5, ...) {
   force_all(n, ...)
   n_default <- n
   function(x, n = n_default) {
+    if (zero_range(as.numeric(x))) {
+      return(x[1])
+    }
     breaks <- pretty(x, n, ...)
     names(breaks) <- attr(breaks, "labels")
     breaks
@@ -182,3 +185,31 @@ breaks_timespan <- function(unit = c("secs", "mins", "hours", "days", "weeks"),
     as.difftime(breaks * scale, units = "secs")
   }
 }
+
+#' Breaks for exponentially transformed data
+#'
+#' This breaks function typically labels zero and the last `n - 1` integers of a
+#' range if that range is large enough (currently: 3). For smaller ranges, it
+#' uses [`breaks_extended()`].
+#'
+#' @inheritParams breaks_extended
+#' @export
+#' @examples
+#' # Small range
+#' demo_continuous(c(100, 102), transform = "exp", breaks = breaks_exp())
+#' # Large range
+#' demo_continuous(c(0, 100), transform = "exp", breaks = breaks_exp(n = 4))
+breaks_exp <- function(n = 5, ...) {
+  n_default <- n
+  default <- extended_breaks(n = n_default, ...)
+  function(x, n = n_default) {
+    # Discard -Infs
+    x <- sort(pmax(x, 0))
+    top <- floor(x[2])
+    if (top >= 3 && abs(diff(x)) >= 3) {
+      unique(c(top - seq_len(min(top, n_default - 1)) + 1, 0))
+    } else {
+      default(x)
+    }
+  }
+}

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)
 

R/label-currency.R

@@ -48,8 +48,11 @@
 #'   scale_cut = c(0, k = 1e3, m = 1e6, bn = 1e9, tn = 1e12)
 #' )
 #' demo_log10(c(1, 1e12), breaks = log_breaks(5, 1e3), labels = gbp)
-label_currency <- function(accuracy = NULL, scale = 1, prefix = "$",
-                           suffix = "", big.mark = ",", decimal.mark = ".",
+label_currency <- function(accuracy = NULL, scale = 1,
+                           prefix = NULL,
+                           suffix = NULL,
+                           big.mark = NULL,
+                           decimal.mark = NULL,
                            trim = TRUE, largest_with_fractional = 100000,
                            ...) {
   force_all(
@@ -144,13 +147,17 @@ dollar_format <- function(accuracy = NULL, scale = 1, prefix = "$",
 #' @export
 #' @rdname dollar_format
 #' @param x A numeric vector
-dollar <- function(x, accuracy = NULL, scale = 1, prefix = "$",
-                   suffix = "", big.mark = ",", decimal.mark = ".",
+dollar <- function(x, accuracy = NULL, scale = 1, prefix = NULL,
+                   suffix = NULL, big.mark = NULL, decimal.mark = NULL,
                    trim = TRUE, largest_with_cents = 100000,
                    negative_parens = deprecated(),
                    style_negative = c("hyphen", "minus", "parens"),
                    scale_cut = NULL,
                    ...) {
+  prefix <- prefix %||% getOption("scales.currency.prefix", default = "$")
+  suffix <- suffix %||% getOption("scales.currency.suffix", default = "")
+  big.mark <- big.mark %||% getOption("scales.currency.big.mark", default = ",")
+  decimal.mark <- decimal.mark %||% getOption("scales.currency.decimal.mark", default = ".")
   if (length(x) == 0) {
     return(character())
   }

R/label-date.R

@@ -11,17 +11,19 @@
 #' 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
 #' @param locale Locale to use when for day and month names. The default
 #'   uses the current locale. Setting this argument requires stringi, and you
 #'   can see a complete list of supported locales with
 #'   [stringi::stri_locale_list()].
+#' @param leading A string to replace leading zeroes with. Can be `""` to
+#'   disable leading characters or `"\u2007"` for figure-spaces.
 #' @export
 #' @examples
 #' date_range <- function(start, days) {
@@ -31,9 +33,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")
 #'
@@ -53,8 +55,9 @@ label_date <- function(format = "%Y-%m-%d", tz = "UTC", locale = NULL) {
 #' @export
 #' @rdname label_date
 #' @param sep Separator to use when combining date formats into a single string.
-label_date_short <- function(format = c("%Y", "%b", "%d", "%H:%M"), sep = "\n") {
-  force_all(format, sep)
+label_date_short <- function(format = c("%Y", "%b", "%d", "%H:%M"), sep = "\n",
+                             leading = "0") {
+  force_all(format, sep, leading)
 
   function(x) {
     dt <- unclass(as.POSIXlt(x))
@@ -90,7 +93,16 @@ label_date_short <- function(format = c("%Y", "%b", "%d", "%H:%M"), sep = "\n")
     )
 
     format <- apply(for_mat, 1, function(x) paste(rev(x[!is.na(x)]), collapse = sep))
-    format(x, format)
+    x <- format(x, format)
+
+    if (isTRUE(leading == "0")) {
+      return(x)
+    }
+
+    # Replace leading 0s with `leading` character
+    x <- gsub("^0", leading, x)
+    x <- gsub(paste0(sep, "0"), paste0(sep, leading), x, fixed = TRUE)
+    x
   }
 }
 
@@ -151,7 +163,7 @@ format_dt <- function(x, format, tz = "UTC", locale = NULL) {
 #' `r lifecycle::badge("superseded")`
 #'
 #' These functions are kept for backward compatibility; you should switch
-#' to [label_date()/[label_time()] for new code.
+#' to [label_date()]/[label_time()] for new code.
 #'
 #' @keywords internal
 #' @export