resolve merge conflict

Merge branch 'main' into asis_rescale

# Conflicts:
#	NEWS.md
#	R/bounds.R
#	man/rescale.Rd

NAMESPACE

@@ -15,6 +15,7 @@ S3method(rescale,"NULL")
 S3method(rescale,AsIs)
 S3method(rescale,Date)
 S3method(rescale,POSIXt)
+S3method(rescale,difftime)
 S3method(rescale,dist)
 S3method(rescale,integer64)
 S3method(rescale,logical)
@@ -42,6 +43,7 @@ export(boxcox_trans)
 export(breaks_extended)
 export(breaks_log)
 export(breaks_pretty)
+export(breaks_timespan)
 export(breaks_width)
 export(brewer_pal)
 export(cbreaks)
@@ -67,6 +69,7 @@ export(demo_datetime)
 export(demo_discrete)
 export(demo_log10)
 export(demo_time)
+export(demo_timespan)
 export(dichromat_pal)
 export(discard)
 export(div_gradient_pal)
@@ -87,6 +90,7 @@ export(identity_trans)
 export(is.trans)
 export(label_bytes)
 export(label_comma)
+export(label_currency)
 export(label_date)
 export(label_date_short)
 export(label_dollar)
@@ -101,6 +105,7 @@ export(label_percent)
 export(label_pvalue)
 export(label_scientific)
 export(label_time)
+export(label_timespan)
 export(label_wrap)
 export(linetype_pal)
 export(log10_trans)
@@ -158,6 +163,7 @@ export(squish)
 export(squish_infinite)
 export(time_format)
 export(time_trans)
+export(timespan_trans)
 export(train_continuous)
 export(train_discrete)
 export(trans_breaks)

NEWS.md

@@ -4,8 +4,22 @@
   (@teunbrand, #369).
 * Training on factor data no longer sorts the range after multiple training 
   passes (#383)
+* Attempt to make the sort behavior of the range consistent for character 
+  vectors during training. Mixing of character and factor data will still lead
+  to different results depending on the training order.
+* Add a rescale method for `difftime` objects (#382)
 * `rescale(I(x), ...)` and `rescale_mid(I(x), ...)` return `I(x)` unaltered 
   (@teunbrand, #403).
+* The `scale_cut` argument in `number()` now works as advertised for values 
+  below the lowest cut value (#346)
+* `label_dollar()` has been superseeded by `label_currency()` for clarity (#344)
+* `sqrt_trans()` no longer returns an inverse for values outside of its domain 
+  (#214)
+* Add better support for `difftime` objects. `label_timespan()` adds 
+  functionality for adding correct unit suffix to timespan data, 
+  `breaks_timespan()` adds functionality for finding pleasant breakpoints across
+  the various bases in time units, while `timespan_trans()` wraps it all 
+  together and provides an alternative to `hms_trans()` (#212)
 
 # scales 1.2.1
 

R/bounds.R

@@ -61,6 +61,10 @@ rescale.integer64 <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE), ..
   (x - from[1]) / diff(from) * diff(to) + to[1]
 }
 
+#' @rdname rescale
+#' @export
+rescale.difftime <- rescale.numeric
+
 #' @rdname rescale
 #' @export
 rescale.AsIs <- function(x, to, from, ...) x

R/breaks.R

@@ -140,3 +140,45 @@ breaks_pretty <- function(n = 5, ...) {
 #' @export
 #' @inheritParams breaks_pretty
 pretty_breaks <- breaks_pretty
+
+#' Breaks for timespan data
+#'
+#' As timespan units span a variety of bases (1000 below seconds, 60 for second
+#' and minutes, 24 for hours, and 7 for days), the range of the input data
+#' determines the base used for calculating breaks
+#'
+#' @param unit The unit used to interpret numeric data input
+#' @inheritParams breaks_extended
+#' @export
+#' @examples
+#' demo_timespan(seq(0, 100), breaks = breaks_timespan())
+#'
+breaks_timespan <- function(unit = c("secs", "mins", "hours", "days", "weeks"), n = 5) {
+  unit <- arg_match(unit)
+  force(n)
+  function(x) {
+    x <- as.numeric(as.difftime(x, units = unit), units = "secs")
+    rng <- range(x)
+    diff <- rng[2] - rng[1]
+
+    if (diff <= 2 * 60) {
+      scale <- 1
+    } else if (diff <= 2 * 3600) {
+      scale <- 60
+    } else if (diff <= 2 * 86400) {
+      scale <- 3600
+    } else if (diff <= 2 * 604800) {
+      scale <- 86400
+    } else {
+      scale <- 604800
+    }
+
+    rng <- rng / scale
+    breaks <- labeling::extended(
+      rng[1], rng[2], n,
+      Q = c(1, 2, 1.5, 4, 3),
+      only.loose = FALSE
+    )
+    as.difftime(breaks * scale, units = "secs")
+  }
+}

R/label-dollar.R → R/label-currency.R

@@ -1,59 +1,57 @@
-#' Label currencies ($100, $2.50, etc)
+#' Label currencies ($100, €2.50, etc)
 #'
-#' Format numbers as currency, rounding values to dollars or cents using
-#' a convenient heuristic.
+#' Format numbers as currency, rounding values to monetary or fractional
+#' monetary using unit a convenient heuristic.
 #'
 #' @inherit label_number return params
-#' @param accuracy,largest_with_cents Number to round to. If `NULL`, the default,
-#'   values will be rounded to the nearest integer, unless any of the
-#'   values has non-zero fractional component (e.g. cents) and the largest
-#'   value is less than `largest_with_cents` which by default is 100,000.
+#' @param accuracy,largest_with_fractional Number to round
+#'   to. If `NULL`, the default, values will be rounded to the nearest integer,
+#'   unless any of the values has non-zero fractional component (e.g. cents) and
+#'   the largest value is less than `largest_with_fractional` which by default
+#'   is 100,000.
 #' @param prefix,suffix Symbols to display before and after value.
-#' @param negative_parens `r lifecycle::badge("deprecated")` Use
-#'   `style_negative = "parens"` instead.
 #' @inheritDotParams number
 #' @export
 #' @family labels for continuous scales
 #' @examples
-#' demo_continuous(c(0, 1), labels = label_dollar())
-#' demo_continuous(c(1, 100), labels = label_dollar())
+#' demo_continuous(c(0, 1), labels = label_currency())
+#' demo_continuous(c(1, 100), labels = label_currency())
 #'
 #' # Customise currency display with prefix and suffix
-#' demo_continuous(c(1, 100), labels = label_dollar(prefix = "USD "))
-#' euro <- label_dollar(
+#' demo_continuous(c(1, 100), labels = label_currency(prefix = "USD "))
+#' euro <- label_currency(
 #'   prefix = "",
 #'   suffix = "\u20ac",
 #'   big.mark = ".",
 #'   decimal.mark = ","
 #' )
 #' demo_continuous(c(1000, 1100), labels = euro)
 #'
-#' # Use negative_parens = TRUE for finance style display
-#' demo_continuous(c(-100, 100), labels = label_dollar(style_negative = "parens"))
+#' # Use style_negative = "parens" for finance style display
+#' demo_continuous(c(-100, 100), labels = label_currency(style_negative = "parens"))
 #'
 #' # Use scale_cut to use K/M/B where appropriate
 #' demo_log10(c(1, 1e16),
 #'   breaks = log_breaks(7, 1e3),
-#'   labels = label_dollar(scale_cut = cut_short_scale())
+#'   labels = label_currency(scale_cut = cut_short_scale())
 #' )
 #' # cut_short_scale() uses B = one thousand million
 #' # cut_long_scale() uses B = one million million
 #' demo_log10(c(1, 1e16),
 #'   breaks = log_breaks(7, 1e3),
-#'   labels = label_dollar(scale_cut = cut_long_scale())
+#'   labels = label_currency(scale_cut = cut_long_scale())
 #' )
 #'
 #' # You can also define your own breaks
-#' gbp <- label_dollar(
+#' gbp <- label_currency(
 #'   prefix = "\u00a3",
 #'   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_dollar <- function(accuracy = NULL, scale = 1, prefix = "$",
-                         suffix = "", big.mark = ",", decimal.mark = ".",
-                         trim = TRUE, largest_with_cents = 100000,
-                         negative_parens = deprecated(),
-                         ...) {
+label_currency <- function(accuracy = NULL, scale = 1, prefix = "$",
+                           suffix = "", big.mark = ",", decimal.mark = ".",
+                           trim = TRUE, largest_with_fractional = 100000,
+                           ...) {
   force_all(
     accuracy,
     scale,
@@ -62,8 +60,7 @@ label_dollar <- function(accuracy = NULL, scale = 1, prefix = "$",
     big.mark,
     decimal.mark,
     trim,
-    largest_with_cents,
-    negative_parens,
+    largest_with_fractional,
     ...
   )
   function(x) {
@@ -76,8 +73,7 @@ label_dollar <- function(accuracy = NULL, scale = 1, prefix = "$",
       big.mark = big.mark,
       decimal.mark = decimal.mark,
       trim = trim,
-      largest_with_cents = largest_with_cents,
-      negative_parens = negative_parens,
+      largest_with_cents = largest_with_fractional,
       ...
     )
   }
@@ -95,18 +91,55 @@ needs_cents <- function(x, threshold) {
   !all(x == floor(x), na.rm = TRUE)
 }
 
-#' Superseded interface to `label_dollar()`
+#' Superseded interface to `label_currency()`
 #'
 #' @description
 #' `r lifecycle::badge("superseded")`
 #'
 #' These functions are kept for backward compatibility; you should switch
-#' to [label_dollar()] for new code.
+#' to [label_currency()] for new code.
 #'
 #' @keywords internal
 #' @export
-#' @inheritParams label_dollar
-dollar_format <- label_dollar
+#' @inheritParams label_currency
+#' @param largest_with_cents Like `largest_with_fractional()` in
+#'   [label_currency()]
+#' @param negative_parens `r lifecycle::badge("deprecated")` Use
+#'   `style_negative = "parens"` instead.
+dollar_format <- function(accuracy = NULL, scale = 1, prefix = "$",
+                          suffix = "", big.mark = ",", decimal.mark = ".",
+                          trim = TRUE, largest_with_cents = 100000,
+                          negative_parens = deprecated(),
+                          ...) {
+  force_all(
+    accuracy,
+    scale,
+    prefix,
+    suffix,
+    big.mark,
+    decimal.mark,
+    trim,
+    largest_with_cents,
+    negative_parens,
+    ...
+  )
+  function(x) {
+    dollar(
+      x,
+      accuracy = accuracy,
+      scale = scale,
+      prefix = prefix,
+      suffix = suffix,
+      big.mark = big.mark,
+      decimal.mark = decimal.mark,
+      trim = trim,
+      largest_with_cents = largest_with_cents,
+      negative_parens = negative_parens,
+      ...
+    )
+  }
+}
+
 
 #' @export
 #' @rdname dollar_format
@@ -151,3 +184,7 @@ dollar <- function(x, accuracy = NULL, scale = 1, prefix = "$",
     ...
   )
 }
+
+#' @export
+#' @rdname dollar_format
+label_dollar <- dollar_format

R/label-date.R

@@ -7,6 +7,8 @@
 #' but uses a slightly different approach: `ConciseDateFormatter` formats
 #' "firsts" (e.g. first day of month, first day of day) specially;
 #' `date_short()` formats changes (e.g. new month, new year) specially.
+#' `label_timespan()` is intended to show time passed and adds common time units
+#' suffix to the input (ns, µs, ms, s, m, h, d, w).
 #'
 #' @inherit label_number return
 #' @param format For `date_format()` and `time_format()` a date/time format
@@ -114,6 +116,34 @@ label_time <- function(format = "%H:%M:%S", tz = "UTC", locale = NULL) {
   }
 }
 
+#' @export
+#' @rdname label_date
+#' @param unit The unit used to interpret numeric input
+#' @inheritDotParams number accuracy scale prefix suffix big.mark decimal.mark style_positive style_negative trim
+label_timespan <- function(unit = c("secs", "mins", "hours", "days", "weeks"),
+                           ...) {
+  unit <- arg_match(unit)
+  force_all(...)
+  function(x) {
+    x <- as.numeric(as.difftime(x, units = unit), units = "secs")
+    number(
+      x,
+      scale_cut = c(
+        0,
+        "ns" = 1e-9,
+        "µs" = 1e-6,
+        "ms" = 1e-3,
+        "s" = 1,
+        "m" = 60,
+        "h" = 3600,
+        "d" = 24 * 3600,
+        "w" = 7 * 24 * 3600
+      ),
+      ...
+    )
+  }
+}
+
 format_dt <- function(x, format, tz = "UTC", locale = NULL) {
   if (is.null(locale)) {
     format(x, format = format, tz = tz)

R/label-number.R

@@ -327,24 +327,20 @@ scale_cut <- function(x, breaks, scale = 1, accuracy = NULL, suffix = "") {
   if (any(is.na(breaks))) {
     cli::cli_abort("{.arg scale_cut} values must not be missing")
   }
-  if (!identical(breaks[[1]], 0) && !identical(breaks[[1]], 0L)) {
-    cli::cli_abort("Smallest value of {.arg scales_cut} must be zero")
-  }
 
   break_suffix <- as.character(cut(
     abs(x * scale),
     breaks = c(unname(breaks), Inf),
     labels = c(names(breaks)),
     right = FALSE
   ))
-  break_suffix[is.na(break_suffix)] <- names(which.min(breaks))
+  break_suffix[is.na(break_suffix)] <- ""
 
   break_scale <- scale * unname(1 / breaks[break_suffix])
   break_scale[which(break_scale %in% c(Inf, NA))] <- scale
 
-  # exact zero is not scaled
-  x_zero <- which(abs(x) == 0)
-  scale[x_zero] <- 1
+  # exact zero is not scaled, nor are values below lowest break
+  break_scale[abs(x) == 0 | is.na(break_scale)] <- 1
 
   suffix <- paste0(break_suffix, suffix)
   accuracy <- accuracy %||% stats::ave(x * break_scale, break_scale, FUN = precision)

R/scale-discrete.R

@@ -37,11 +37,16 @@ train_discrete <- function(new, existing = NULL, drop = FALSE, na.rm = FALSE) {
 }
 
 discrete_range <- function(old, new, drop = FALSE, na.rm = FALSE) {
+  is_factor <- is.factor(new) || is.factor(old)
   new <- clevels(new, drop = drop, na.rm = na.rm)
   if (is.null(old)) {
     return(new)
   }
-  if (!is.character(old)) old <- clevels(old, na.rm = na.rm)
+  if (!is.character(old)) {
+    old <- clevels(old, na.rm = na.rm)
+  } else {
+    old <- sort(old, na.last = if (na.rm) NA else TRUE)
+  }
 
   new_levels <- setdiff(new, as.character(old))
 
@@ -53,10 +58,10 @@ discrete_range <- function(old, new, drop = FALSE, na.rm = FALSE) {
 
   # Avoid sorting levels when dealing with factors to mimick behaviour of
   # clevels()
-  if (is.factor(new)) {
+  if (is_factor) {
     return(range)
   }
-  sort(range)
+  sort(range, na.last = if (na.rm) NA else TRUE)
 }
 
 clevels <- function(x, drop = FALSE, na.rm = FALSE) {