Merge branch 'main' into exponential_breaks

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)
@@ -97,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)
@@ -139,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)
@@ -177,6 +182,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 +201,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

@@ -2,6 +2,10 @@
 
 * `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/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-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")
 #'

R/label-log.R

@@ -1,30 +1,62 @@
 #' 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
 #' @family labels for log scales
 #' @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
+}

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

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

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, ...))
+}

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."
       ))
     }