From 01493b759df3fd25e18338b8dc4fc78dfcc40a13 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Wed, 1 Nov 2023 13:03:49 +0100 Subject: [PATCH 1/7] Properly fix #383 --- NEWS.md | 3 +++ R/scale-discrete.R | 11 ++++++++--- tests/testthat/test-range.R | 1 + 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index f3fbfb85..ba5d2afc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,9 @@ (@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. # scales 1.2.1 diff --git a/R/scale-discrete.R b/R/scale-discrete.R index 4ead4e64..38ec0c36 100644 --- a/R/scale-discrete.R +++ b/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) { diff --git a/tests/testthat/test-range.R b/tests/testthat/test-range.R index be6f0ef8..77d16b84 100644 --- a/tests/testthat/test-range.R +++ b/tests/testthat/test-range.R @@ -44,4 +44,5 @@ test_that("factor discrete ranges stay in order", { expect_equal(discrete_range(f, f), letters[3:1]) expect_equal(discrete_range(f, "c"), letters[3:1]) expect_equal(discrete_range(f, c("a", "b", "c")), letters[3:1]) + expect_equal(discrete_range(f, c("a", "b", "c", NA), na.rm = FALSE), letters[3:1]) }) From eeae014abe324b4ed3e3fd188dc6545e386453c3 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Wed, 1 Nov 2023 13:09:29 +0100 Subject: [PATCH 2/7] Fix #382 --- NAMESPACE | 1 + NEWS.md | 1 + R/bounds.R | 4 ++++ man/rescale.Rd | 3 +++ tests/testthat/test-range.R | 2 +- 5 files changed, 10 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 4405d0ee..f6964735 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ S3method(print,trans) S3method(rescale,"NULL") S3method(rescale,Date) S3method(rescale,POSIXt) +S3method(rescale,difftime) S3method(rescale,dist) S3method(rescale,integer64) S3method(rescale,logical) diff --git a/NEWS.md b/NEWS.md index ba5d2afc..fd768ee1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,7 @@ * 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) # scales 1.2.1 diff --git a/R/bounds.R b/R/bounds.R index b66059db..20ebdf94 100644 --- a/R/bounds.R +++ b/R/bounds.R @@ -58,6 +58,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 + #' Rescale vector to have specified minimum, midpoint, and maximum #' diff --git a/man/rescale.Rd b/man/rescale.Rd index 1383eeea..b271bc99 100644 --- a/man/rescale.Rd +++ b/man/rescale.Rd @@ -8,6 +8,7 @@ \alias{rescale.POSIXt} \alias{rescale.Date} \alias{rescale.integer64} +\alias{rescale.difftime} \title{Rescale continuous vector to have specified minimum and maximum} \usage{ rescale(x, to, from, ...) @@ -23,6 +24,8 @@ rescale(x, to, from, ...) \method{rescale}{Date}(x, to = c(0, 1), from = range(x, na.rm = TRUE, finite = TRUE), ...) \method{rescale}{integer64}(x, to = c(0, 1), from = range(x, na.rm = TRUE), ...) + +\method{rescale}{difftime}(x, to = c(0, 1), from = range(x, na.rm = TRUE, finite = TRUE), ...) } \arguments{ \item{x}{continuous vector of values to manipulate.} diff --git a/tests/testthat/test-range.R b/tests/testthat/test-range.R index 77d16b84..f8a84710 100644 --- a/tests/testthat/test-range.R +++ b/tests/testthat/test-range.R @@ -44,5 +44,5 @@ test_that("factor discrete ranges stay in order", { expect_equal(discrete_range(f, f), letters[3:1]) expect_equal(discrete_range(f, "c"), letters[3:1]) expect_equal(discrete_range(f, c("a", "b", "c")), letters[3:1]) - expect_equal(discrete_range(f, c("a", "b", "c", NA), na.rm = FALSE), letters[3:1]) + expect_equal(discrete_range(f, c("a", "b", "c", NA), na.rm = FALSE), c(letters[3:1], NA)) }) From 170c51efa48fb6155e728d7cab6e422163446b59 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Wed, 1 Nov 2023 14:43:16 +0100 Subject: [PATCH 3/7] fix unit test surfaced by fixes in discrete_range behavior --- tests/testthat/test-range.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-range.R b/tests/testthat/test-range.R index f8a84710..edacb67d 100644 --- a/tests/testthat/test-range.R +++ b/tests/testthat/test-range.R @@ -17,7 +17,7 @@ test_that("Mutable ranges work", { x <- DiscreteRange$new() x$train(factor(letters[1:3])) expect_equal(x$range, c("a", "b", "c")) - x$train(factor("a", "h")) + x$train(factor(c("a", "h"))) expect_equal(x$range, c("a", "b", "c", "h")) x$reset() expect_equal(x$range, NULL) From 48f82cf81a14bd5108dae1b62df2d8a9c2f4b56b Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Wed, 1 Nov 2023 14:43:32 +0100 Subject: [PATCH 4/7] Fix #346 --- NEWS.md | 2 ++ R/label-number.R | 10 +++------- tests/testthat/_snaps/label-number.md | 5 ----- tests/testthat/test-label-number.R | 1 - 4 files changed, 5 insertions(+), 13 deletions(-) diff --git a/NEWS.md b/NEWS.md index fd768ee1..85eb828c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,8 @@ 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) +* The `scale_cut` argument in `number()` now works as advertised for values + below the lowest cut value (#346) # scales 1.2.1 diff --git a/R/label-number.R b/R/label-number.R index 0e8e1a2e..5ae60123 100644 --- a/R/label-number.R +++ b/R/label-number.R @@ -327,9 +327,6 @@ 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), @@ -337,14 +334,13 @@ scale_cut <- function(x, breaks, scale = 1, accuracy = NULL, suffix = "") { 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) diff --git a/tests/testthat/_snaps/label-number.md b/tests/testthat/_snaps/label-number.md index 49fdbe97..c70d7aa6 100644 --- a/tests/testthat/_snaps/label-number.md +++ b/tests/testthat/_snaps/label-number.md @@ -10,11 +10,6 @@ Condition Error in `scale_cut()`: ! `scale_cut` must be a named numeric vector - Code - number(1, scale_cut = c(x = 1, y = 2)) - Condition - Error in `scale_cut()`: - ! Smallest value of `scales_cut` must be zero Code number(1, scale_cut = c(x = 0, NA)) Condition diff --git a/tests/testthat/test-label-number.R b/tests/testthat/test-label-number.R index 60b11522..2f4a9399 100644 --- a/tests/testthat/test-label-number.R +++ b/tests/testthat/test-label-number.R @@ -171,7 +171,6 @@ test_that("scale_cut checks its inputs", { expect_snapshot(error = TRUE, { number(1, scale_cut = 0) number(1, scale_cut = "x") - number(1, scale_cut = c(x = 1, y = 2)) number(1, scale_cut = c(x = 0, NA)) }) }) From 2e8d601254395454f30267c247d8707278d604d1 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 2 Nov 2023 08:28:48 +0100 Subject: [PATCH 5/7] Fix #344 --- NAMESPACE | 1 + NEWS.md | 1 + R/{label-dollar.R => label-currency.R} | 99 +++++++++++++------ man/dollar_format.Rd | 28 ++++-- man/label_bytes.Rd | 2 +- man/{label_dollar.Rd => label_currency.Rd} | 47 +++++---- man/label_number_auto.Rd | 2 +- man/label_number_si.Rd | 2 +- man/label_ordinal.Rd | 2 +- man/label_parse.Rd | 2 +- man/label_percent.Rd | 2 +- man/label_pvalue.Rd | 2 +- man/label_scientific.Rd | 2 +- ...t-label-dollar.R => test-label-currency.R} | 12 +-- 14 files changed, 126 insertions(+), 78 deletions(-) rename R/{label-dollar.R => label-currency.R} (57%) rename man/{label_dollar.Rd => label_currency.Rd} (73%) rename tests/testthat/{test-label-dollar.R => test-label-currency.R} (58%) diff --git a/NAMESPACE b/NAMESPACE index f6964735..50dbb621 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -86,6 +86,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) diff --git a/NEWS.md b/NEWS.md index 85eb828c..b5e686c0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,7 @@ * Add a rescale method for `difftime` objects (#382) * 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) # scales 1.2.1 diff --git a/R/label-dollar.R b/R/label-currency.R similarity index 57% rename from R/label-dollar.R rename to R/label-currency.R index 25485eaa..84561463 100644 --- a/R/label-dollar.R +++ b/R/label-currency.R @@ -1,26 +1,25 @@ -#' 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 = ".", @@ -28,32 +27,31 @@ #' ) #' 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 diff --git a/man/dollar_format.Rd b/man/dollar_format.Rd index fdf73383..fc65b2df 100644 --- a/man/dollar_format.Rd +++ b/man/dollar_format.Rd @@ -1,9 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/label-dollar.R +% Please edit documentation in R/label-currency.R \name{dollar_format} \alias{dollar_format} \alias{dollar} -\title{Superseded interface to \code{label_dollar()}} +\alias{label_dollar} +\title{Superseded interface to \code{label_currency()}} \usage{ dollar_format( accuracy = NULL, @@ -33,13 +34,21 @@ dollar( scale_cut = NULL, ... ) + +label_dollar( + accuracy = NULL, + scale = 1, + prefix = "$", + suffix = "", + big.mark = ",", + decimal.mark = ".", + trim = TRUE, + largest_with_cents = 1e+05, + negative_parens = deprecated(), + ... +) } \arguments{ -\item{accuracy, largest_with_cents}{Number to round to. If \code{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 \code{largest_with_cents} which by default is 100,000.} - \item{scale}{A scaling factor: \code{x} will be multiplied by \code{scale} before formatting. This is useful if the underlying data is very small or very large.} @@ -54,6 +63,9 @@ decimal point.} \item{trim}{Logical, if \code{FALSE}, values are right-justified to a common width (see \code{\link[base:format]{base::format()}}).} +\item{largest_with_cents}{Like \code{largest_with_fractional()} in +\code{\link[=label_currency]{label_currency()}}} + \item{negative_parens}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Use \code{style_negative = "parens"} instead.} @@ -65,6 +77,6 @@ width (see \code{\link[base:format]{base::format()}}).} \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#superseded}{\figure{lifecycle-superseded.svg}{options: alt='[Superseded]'}}}{\strong{[Superseded]}} These functions are kept for backward compatibility; you should switch -to \code{\link[=label_dollar]{label_dollar()}} for new code. +to \code{\link[=label_currency]{label_currency()}} for new code. } \keyword{internal} diff --git a/man/label_bytes.Rd b/man/label_bytes.Rd index 35120545..d25cae27 100644 --- a/man/label_bytes.Rd +++ b/man/label_bytes.Rd @@ -97,7 +97,7 @@ demo_continuous(c(1, 1024^2), } \seealso{ Other labels for continuous scales: -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_number_si}()}, \code{\link{label_ordinal}()}, diff --git a/man/label_dollar.Rd b/man/label_currency.Rd similarity index 73% rename from man/label_dollar.Rd rename to man/label_currency.Rd index ef5cee8b..d7a6e128 100644 --- a/man/label_dollar.Rd +++ b/man/label_currency.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/label-dollar.R -\name{label_dollar} -\alias{label_dollar} -\title{Label currencies ($100, $2.50, etc)} +% Please edit documentation in R/label-currency.R +\name{label_currency} +\alias{label_currency} +\title{Label currencies ($100, €2.50, etc)} \usage{ -label_dollar( +label_currency( accuracy = NULL, scale = 1, prefix = "$", @@ -12,16 +12,16 @@ label_dollar( big.mark = ",", decimal.mark = ".", trim = TRUE, - largest_with_cents = 1e+05, - negative_parens = deprecated(), + largest_with_fractional = 1e+05, ... ) } \arguments{ -\item{accuracy, largest_with_cents}{Number to round to. If \code{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 \code{largest_with_cents} which by default is 100,000.} +\item{accuracy, largest_with_fractional}{Number to round +to. If \code{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 \code{largest_with_fractional} which by default +is 100,000.} \item{scale}{A scaling factor: \code{x} will be multiplied by \code{scale} before formatting. This is useful if the underlying data is very small or very @@ -37,9 +37,6 @@ decimal point.} \item{trim}{Logical, if \code{FALSE}, values are right-justified to a common width (see \code{\link[base:format]{base::format()}}).} -\item{negative_parens}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Use -\code{style_negative = "parens"} instead.} - \item{...}{ Arguments passed on to \code{\link[=number]{number}} \describe{ @@ -81,16 +78,16 @@ they work similarly for all scales, including those that generate legends rather than axes. } \description{ -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. } \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 = ".", @@ -98,23 +95,23 @@ euro <- label_dollar( ) 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) ) diff --git a/man/label_number_auto.Rd b/man/label_number_auto.Rd index 220dfe55..a660cbec 100644 --- a/man/label_number_auto.Rd +++ b/man/label_number_auto.Rd @@ -29,7 +29,7 @@ demo_log10(c(1, 1e7), labels = label_number_auto()) \seealso{ Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_si}()}, \code{\link{label_ordinal}()}, \code{\link{label_parse}()}, diff --git a/man/label_number_si.Rd b/man/label_number_si.Rd index df2d0d57..85019af4 100644 --- a/man/label_number_si.Rd +++ b/man/label_number_si.Rd @@ -94,7 +94,7 @@ demo_continuous(c(1, 1e9), labels = label_number(scale_cut = cut_short_scale())) \seealso{ Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_ordinal}()}, \code{\link{label_parse}()}, diff --git a/man/label_ordinal.Rd b/man/label_ordinal.Rd index 68be92f5..62945380 100644 --- a/man/label_ordinal.Rd +++ b/man/label_ordinal.Rd @@ -110,7 +110,7 @@ demo_continuous(c(1, 10), \seealso{ Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_number_si}()}, \code{\link{label_parse}()}, diff --git a/man/label_parse.Rd b/man/label_parse.Rd index 5636233c..7dd7d29d 100644 --- a/man/label_parse.Rd +++ b/man/label_parse.Rd @@ -47,7 +47,7 @@ demo_continuous(c(1, 5), labels = label_math()) Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_number_si}()}, \code{\link{label_ordinal}()}, diff --git a/man/label_percent.Rd b/man/label_percent.Rd index ffb018ea..ffef1e54 100644 --- a/man/label_percent.Rd +++ b/man/label_percent.Rd @@ -98,7 +98,7 @@ demo_continuous(c(0, .01), labels = french_percent) \seealso{ Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_number_si}()}, \code{\link{label_ordinal}()}, diff --git a/man/label_pvalue.Rd b/man/label_pvalue.Rd index 1cff3fce..ae9e2b83 100644 --- a/man/label_pvalue.Rd +++ b/man/label_pvalue.Rd @@ -54,7 +54,7 @@ demo_continuous(c(0, 1), labels = label_pvalue(prefix = prefix)) \seealso{ Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_number_si}()}, \code{\link{label_ordinal}()}, diff --git a/man/label_scientific.Rd b/man/label_scientific.Rd index 0447c010..97db3367 100644 --- a/man/label_scientific.Rd +++ b/man/label_scientific.Rd @@ -54,7 +54,7 @@ demo_log10(c(1, 1e9)) \seealso{ Other labels for continuous scales: \code{\link{label_bytes}()}, -\code{\link{label_dollar}()}, +\code{\link{label_currency}()}, \code{\link{label_number_auto}()}, \code{\link{label_number_si}()}, \code{\link{label_ordinal}()}, diff --git a/tests/testthat/test-label-dollar.R b/tests/testthat/test-label-currency.R similarity index 58% rename from tests/testthat/test-label-dollar.R rename to tests/testthat/test-label-currency.R index 9b804638..cdb23d7c 100644 --- a/tests/testthat/test-label-dollar.R +++ b/tests/testthat/test-label-currency.R @@ -1,5 +1,5 @@ test_that("negative comes before prefix", { - expect_equal(label_dollar()(-1), "-$1") + expect_equal(label_currency()(-1), "-$1") }) test_that("negative_parens is deprecated", { @@ -10,21 +10,21 @@ test_that("negative_parens is deprecated", { }) test_that("preserves NAs", { - expect_equal(label_dollar()(NA_real_), NA_character_) + expect_equal(label_currency()(NA_real_), NA_character_) }) test_that("preserves names", { - expect_named(label_dollar()(c(a = 1)), "a") + expect_named(label_currency()(c(a = 1)), "a") }) test_that("decimal.mark could be modified", { - expect_equal(label_dollar(decimal.mark = ",")(123.45), "$123,45") + expect_equal(label_currency(decimal.mark = ",")(123.45), "$123,45") }) test_that("can rescale with scale_cut", { - lab <- label_dollar(scale_cut = cut_short_scale()) + lab <- label_currency(scale_cut = cut_short_scale()) expect_equal(lab(c(1, 1e3, 1e6)), c("$1", "$1K", "$1M")) - lab <- label_dollar(scale_cut = cut_short_scale(), prefix = "", suffix = " USD") + lab <- label_currency(scale_cut = cut_short_scale(), prefix = "", suffix = " USD") expect_equal(lab(c(1, 1e3, 1e6)), c("1 USD", "1K USD", "1M USD")) }) From 60a4ca1dc41c7ea0ad074cad1a4520e623379810 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 2 Nov 2023 08:48:10 +0100 Subject: [PATCH 6/7] Fix #214 --- NEWS.md | 2 ++ R/trans-numeric.R | 2 +- tests/testthat/test-trans.R | 4 ++++ 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index b5e686c0..d4778712 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,6 +11,8 @@ * 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) # scales 1.2.1 diff --git a/R/trans-numeric.R b/R/trans-numeric.R index dd718d2d..259c067d 100644 --- a/R/trans-numeric.R +++ b/R/trans-numeric.R @@ -335,7 +335,7 @@ sqrt_trans <- function() { trans_new( "sqrt", "sqrt", - function(x) x^2, + function(x) ifelse(x < 0, NA_real_, x ^ 2), domain = c(0, Inf) ) } diff --git a/tests/testthat/test-trans.R b/tests/testthat/test-trans.R index d07a29b1..7030d43f 100644 --- a/tests/testthat/test-trans.R +++ b/tests/testthat/test-trans.R @@ -27,3 +27,7 @@ test_that("trans has useful print method", { trans_new("test", transform = identity, inverse = identity) }) }) + +test_that("inverse of trans_sqrt() returns NA for values outside of range", { + expect_equal(sqrt_trans()$inverse(-2), NA_real_) +}) From 1777a8d598140379c5a02e0ca7d99744b00d6830 Mon Sep 17 00:00:00 2001 From: Thomas Lin Pedersen Date: Thu, 2 Nov 2023 10:21:23 +0100 Subject: [PATCH 7/7] Fix #212 --- NAMESPACE | 4 +++ NEWS.md | 5 ++++ R/breaks.R | 42 +++++++++++++++++++++++++++++ R/label-date.R | 30 +++++++++++++++++++++ R/trans-date.R | 61 ++++++++++++++++++++++++++---------------- R/utils.R | 6 +++++ man/breaks_timespan.Rd | 23 ++++++++++++++++ man/demo_continuous.Rd | 3 +++ man/hms_trans.Rd | 20 -------------- man/label_date.Rd | 43 +++++++++++++++++++++++++++++ man/timespan_trans.Rd | 37 +++++++++++++++++++++++++ 11 files changed, 231 insertions(+), 43 deletions(-) create mode 100644 man/breaks_timespan.Rd delete mode 100644 man/hms_trans.Rd create mode 100644 man/timespan_trans.Rd diff --git a/NAMESPACE b/NAMESPACE index 50dbb621..2fdba310 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,6 +41,7 @@ export(boxcox_trans) export(breaks_extended) export(breaks_log) export(breaks_pretty) +export(breaks_timespan) export(breaks_width) export(brewer_pal) export(cbreaks) @@ -66,6 +67,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) @@ -101,6 +103,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 +161,7 @@ export(squish) export(squish_infinite) export(time_format) export(time_trans) +export(timespan_trans) export(train_continuous) export(train_discrete) export(trans_breaks) diff --git a/NEWS.md b/NEWS.md index d4778712..5d94c33b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -13,6 +13,11 @@ * `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 diff --git a/R/breaks.R b/R/breaks.R index 439580f7..947f3aa6 100644 --- a/R/breaks.R +++ b/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") + } +} diff --git a/R/label-date.R b/R/label-date.R index af89dc20..730fb7b5 100644 --- a/R/label-date.R +++ b/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) diff --git a/R/trans-date.R b/R/trans-date.R index 51424b36..7bf67874 100644 --- a/R/trans-date.R +++ b/R/trans-date.R @@ -61,15 +61,49 @@ time_trans <- function(tz = NULL) { #' Transformation for times (class hms) #' +#' `timespan_trans()` provides transformations for data encoding time passed +#' along with breaks and label formatting showing standard unit of time fitting +#' the range of the data. `hms_trans()` provides the same but using standard hms +#' idioms and formatting. +#' #' @export #' @examples +#' # timespan_trans allows you to specify the time unit numeric data is +#' # interpreted in +#' min_trans <- timespan_trans("mins") +#' demo_timespan(seq(0, 100), trans = min_trans) +#' # Input already in difftime format is interpreted correctly +#' demo_timespan(as.difftime(seq(0, 100), units = "secs"), trans = min_trans) +#' #' if (require("hms")) { +#' # hms_trans always assumes seconds #' hms <- round(runif(10) * 86400) #' t <- hms_trans() #' t$transform(hms) #' t$inverse(t$transform(hms)) #' t$breaks(hms) +#' # The break labels also follow the hms format +#' demo_timespan(hms, trans = t) #' } +#' +timespan_trans <- function(unit = c("secs", "mins", "hours", "days", "weeks")) { + unit <- arg_match(unit) + trans_new( + "timespan", + transform = function(x) { + structure(as.numeric(as.difftime(x, units = unit), units = "secs"), names = names(x)) + }, + inverse = function(x) { + x <- as.difftime(x, units = "secs") + units(x) <- unit + x + }, + breaks = breaks_timespan(unit), + format = label_timespan(unit) + ) +} +#' @rdname timespan_trans +#' @export hms_trans <- function() { trans_new( "hms", @@ -77,32 +111,13 @@ hms_trans <- function() { structure(as.numeric(x), names = names(x)) }, inverse = hms::as_hms, - breaks = time_breaks() + breaks = breaks_hms() ) } -time_breaks <- function(n = 5) { - force(n) +breaks_hms <- function(n = 5) { + base_breaks <- breaks_timespan("secs", n) function(x) { - rng <- as.numeric(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 { - scale <- 86400 - } - - rng <- rng / scale - breaks <- labeling::extended( - rng[1], rng[2], n, - Q = c(1, 2, 1.5, 4, 3), - only.loose = FALSE - ) - hms::as_hms(breaks * scale) + hms::as_hms(base_breaks(x)) } } diff --git a/R/utils.R b/R/utils.R index e1928597..27ae7021 100644 --- a/R/utils.R +++ b/R/utils.R @@ -55,3 +55,9 @@ demo_datetime <- function(x, ...) { demo_time <- function(x, ...) { demo_ggplot(x, "scale_x_time", ...) } + +#' @rdname demo_continuous +#' @export +demo_timespan <- function(x, ...) { + demo_ggplot(x, "scale_x_continuous", ...) +} diff --git a/man/breaks_timespan.Rd b/man/breaks_timespan.Rd new file mode 100644 index 00000000..dc750729 --- /dev/null +++ b/man/breaks_timespan.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/breaks.R +\name{breaks_timespan} +\alias{breaks_timespan} +\title{Breaks for timespan data} +\usage{ +breaks_timespan(unit = c("secs", "mins", "hours", "days", "weeks"), n = 5) +} +\arguments{ +\item{unit}{The unit used to interpret numeric data input} + +\item{n}{Desired number of breaks. You may get slightly more or fewer +breaks that requested.} +} +\description{ +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 +} +\examples{ +demo_timespan(seq(0, 100), breaks = breaks_timespan()) + +} diff --git a/man/demo_continuous.Rd b/man/demo_continuous.Rd index 94576fe3..d062595f 100644 --- a/man/demo_continuous.Rd +++ b/man/demo_continuous.Rd @@ -6,6 +6,7 @@ \alias{demo_discrete} \alias{demo_datetime} \alias{demo_time} +\alias{demo_timespan} \title{Demonstrate scales functions with ggplot2 code} \usage{ demo_continuous(x, ...) @@ -17,6 +18,8 @@ demo_discrete(x, ...) demo_datetime(x, ...) demo_time(x, ...) + +demo_timespan(x, ...) } \arguments{ \item{x}{A vector of data} diff --git a/man/hms_trans.Rd b/man/hms_trans.Rd deleted file mode 100644 index e01bfa2a..00000000 --- a/man/hms_trans.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/trans-date.R -\name{hms_trans} -\alias{hms_trans} -\title{Transformation for times (class hms)} -\usage{ -hms_trans() -} -\description{ -Transformation for times (class hms) -} -\examples{ -if (require("hms")) { - hms <- round(runif(10) * 86400) - t <- hms_trans() - t$transform(hms) - t$inverse(t$transform(hms)) - t$breaks(hms) -} -} diff --git a/man/label_date.Rd b/man/label_date.Rd index 427f52b2..eb00a960 100644 --- a/man/label_date.Rd +++ b/man/label_date.Rd @@ -4,6 +4,7 @@ \alias{label_date} \alias{label_date_short} \alias{label_time} +\alias{label_timespan} \title{Label date/times} \usage{ label_date(format = "\%Y-\%m-\%d", tz = "UTC", locale = NULL) @@ -11,6 +12,8 @@ label_date(format = "\%Y-\%m-\%d", tz = "UTC", locale = NULL) label_date_short(format = c("\%Y", "\%b", "\%d", "\%H:\%M"), sep = "\\n") label_time(format = "\%H:\%M:\%S", tz = "UTC", locale = NULL) + +label_timespan(unit = c("secs", "mins", "hours", "days", "weeks"), ...) } \arguments{ \item{format}{For \code{date_format()} and \code{time_format()} a date/time format @@ -28,6 +31,44 @@ can see a complete list of supported locales with \code{\link[stringi:stri_locale_list]{stringi::stri_locale_list()}}.} \item{sep}{Separator to use when combining date formats into a single string.} + +\item{unit}{The unit used to interpret numeric input} + +\item{...}{ + Arguments passed on to \code{\link[=number]{number}} + \describe{ + \item{\code{accuracy}}{A number to round to. Use (e.g.) \code{0.01} to show 2 decimal +places of precision. If \code{NULL}, the default, uses a heuristic that should +ensure breaks have the minimum number of digits needed to show the +difference between adjacent values. + +Applied to rescaled data.} + \item{\code{scale}}{A scaling factor: \code{x} will be multiplied by \code{scale} before +formatting. This is useful if the underlying data is very small or very +large.} + \item{\code{prefix}}{Additional text to display before the number. The suffix is +applied to absolute value before \code{style_positive} and \code{style_negative} are +processed so that \code{prefix = "$"} will yield (e.g.) \verb{-$1} and \verb{($1)}.} + \item{\code{suffix}}{Additional text to display after the number.} + \item{\code{big.mark}}{Character used between every 3 digits to separate thousands.} + \item{\code{decimal.mark}}{The character to be used to indicate the numeric +decimal point.} + \item{\code{style_positive}}{A string that determines the style of positive numbers: +\itemize{ +\item \code{"none"} (the default): no change, e.g. \code{1}. +\item \code{"plus"}: preceded by \code{+}, e.g. \code{+1}. +}} + \item{\code{style_negative}}{A string that determines the style of negative numbers: +\itemize{ +\item \code{"hyphen"} (the default): preceded by a standard hypen \code{-}, e.g. \code{-1}. +\item \code{"minus"}, uses a proper Unicode minus symbol. This is a typographical +nicety that ensures \code{-} aligns with the horizontal bar of the +the horizontal bar of \code{+}. +\item \code{"parens"}, wrapped in parentheses, e.g. \code{(1)}. +}} + \item{\code{trim}}{Logical, if \code{FALSE}, values are right-justified to a common +width (see \code{\link[base:format]{base::format()}}).} + }} } \value{ All \code{label_()} functions return a "labelling" function, i.e. a function that @@ -47,6 +88,8 @@ sufficient to uniquely identify labels. It's inspired by matplotlib's but uses a slightly different approach: \code{ConciseDateFormatter} formats "firsts" (e.g. first day of month, first day of day) specially; \code{date_short()} formats changes (e.g. new month, new year) specially. +\code{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). } \examples{ date_range <- function(start, days) { diff --git a/man/timespan_trans.Rd b/man/timespan_trans.Rd new file mode 100644 index 00000000..adc94257 --- /dev/null +++ b/man/timespan_trans.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/trans-date.R +\name{timespan_trans} +\alias{timespan_trans} +\alias{hms_trans} +\title{Transformation for times (class hms)} +\usage{ +timespan_trans(unit = c("secs", "mins", "hours", "days", "weeks")) + +hms_trans() +} +\description{ +\code{timespan_trans()} provides transformations for data encoding time passed +along with breaks and label formatting showing standard unit of time fitting +the range of the data. \code{hms_trans()} provides the same but using standard hms +idioms and formatting. +} +\examples{ +# timespan_trans allows you to specify the time unit numeric data is +# interpreted in +min_trans <- timespan_trans("mins") +demo_timespan(seq(0, 100), trans = min_trans) +# Input already in difftime format is interpreted correctly +demo_timespan(as.difftime(seq(0, 100), units = "secs"), trans = min_trans) + +if (require("hms")) { + # hms_trans always assumes seconds + hms <- round(runif(10) * 86400) + t <- hms_trans() + t$transform(hms) + t$inverse(t$transform(hms)) + t$breaks(hms) + # The break labels also follow the hms format + demo_timespan(hms, trans = t) +} + +}