Merge pull request #359 from r-lib/f-97-extra-sigfig

- `num()` gains `extra_sigfig` argument to automatically show more significant figures for numbers of the same magnitude with subtle differences (#97).
r-lib · Jul 28, 2021 · 4c83ba5 · 4c83ba5
2 parents cb82b4d + 86f3b1e
commit 4c83ba5
Show file tree

Hide file tree

Showing 6 changed files with 85 additions and 9 deletions.
diff --git a/R/num.R b/R/num.R
@@ -43,6 +43,9 @@
 #'   Use the same exponent for all numbers in scientific, engineering or SI notation.
 #'   `-Inf` uses the smallest, `+Inf` the largest fixed_exponent present in the data.
 #'   The default is to use varying exponents.
+#' @param extra_sigfig
+#'   If `TRUE`, increase the number of significant digits if the data consists of
+#'   numbers of the same magnitude with subtle differences.
 #' @export
 #' @examples
 #' # Display as a vector
@@ -97,11 +100,20 @@
 #'   scilarge = num(10^(-7:6) * 123, notation = "sci", fixed_exponent = 3),
 #'   scimax   = num(10^(-7:6) * 123, notation = "sci", fixed_exponent = Inf)
 #' )
+#'
+#' #' Extra significant digits
+#' tibble::tibble(
+#'   default = num(100 + 1:3 * 0.001),
+#'   extra1 = num(100 + 1:3 * 0.001, extra_sigfig = TRUE),
+#'   extra2 = num(100 + 1:3 * 0.0001, extra_sigfig = TRUE),
+#'   extra3 = num(10000 + 1:3 * 0.00001, extra_sigfig = TRUE)
+#' )
 num <- function(x, ...,
                 sigfig = NULL, digits = NULL,
                 label = NULL, scale = NULL,
                 notation = c("fit", "dec", "sci", "eng", "si"),
-                fixed_exponent = NULL) {
+                fixed_exponent = NULL,
+                extra_sigfig = NULL) {
 
   stopifnot(is.numeric(x))
   check_dots_empty()
@@ -121,7 +133,8 @@ num <- function(x, ...,
     label = label,
     scale = scale,
     notation = notation,
-    fixed_exponent = fixed_exponent
+    fixed_exponent = fixed_exponent,
+    extra_sigfig = extra_sigfig
   )
 
   # FIXME: Include class(x) to support subclassing/mixin?
@@ -234,7 +247,8 @@ set_num_opts <- function(x, ...,
                          sigfig = NULL, digits = NULL,
                          label = NULL, scale = NULL,
                          notation = c("fit", "dec", "sci", "eng", "si"),
-                         fixed_exponent = NULL) {
+                         fixed_exponent = NULL,
+                         extra_sigfig = NULL) {
 
   check_dots_empty()
 
@@ -254,14 +268,19 @@ set_num_opts <- function(x, ...,
     abort("Must set `label` if `scale` is provided.")
   }
 
+  if (!is.null(digits) && !is.null(extra_sigfig)) {
+    abort("Incompatible arguments: `extra_sigfig` and `digits`.")
+  }
+
   pillar_attr <- structure(
     list(
       sigfig = sigfig,
       digits = digits,
       label = label,
       scale = scale,
       notation = notation,
-      fixed_exponent = fixed_exponent
+      fixed_exponent = fixed_exponent,
+      extra_sigfig = extra_sigfig
     ),
     class = c("pillar_num_attr", "pillar_vctr_attr", "tibble_vec_attr")
   )
@@ -281,6 +300,7 @@ format.pillar_num_attr <- function(x, ...) {
   sigfig <- x$sigfig
   digits <- x$digits
   label <- x$label
+  extra_sigfig <- x$extra_sigfig
 
   if (!is.null(digits)) {
     if (digits >= 0) {
@@ -290,6 +310,12 @@ format.pillar_num_attr <- function(x, ...) {
     }
   } else if (!is.null(sigfig)) {
     out <- paste0(class, ":", sigfig)
+
+    if (isTRUE(extra_sigfig)) {
+      out <- paste0(out, "*")
+    }
+  } else if (isTRUE(extra_sigfig)) {
+    out <- paste0(class, "*")
   } else {
     out <- class
   }

diff --git a/R/shaft-.R b/R/shaft-.R
@@ -134,11 +134,12 @@ pillar_shaft.numeric <- function(x, ..., sigfig = NULL) {
     sigfig %||% pillar_attr$sigfig,
     pillar_attr$digits,
     pillar_attr$notation,
-    pillar_attr$fixed_exponent
+    pillar_attr$fixed_exponent,
+    pillar_attr$extra_sigfig
   )
 }
 
-pillar_shaft_number <- function(x, sigfig, digits, notation, fixed_exponent) {
+pillar_shaft_number <- function(x, sigfig, digits, notation, fixed_exponent, extra_sigfig) {
   if (!is.null(digits)) {
     if (!is.numeric(digits) || length(digits) != 1) {
       abort("`digits` must be a number.")
@@ -148,6 +149,10 @@ pillar_shaft_number <- function(x, sigfig, digits, notation, fixed_exponent) {
     sigfig <- get_pillar_option_sigfig()
   }
 
+  if (isTRUE(extra_sigfig)) {
+    sigfig <- sigfig + compute_extra_sigfig(x)
+  }
+
   if (is.null(notation) || notation == "fit") {
     dec <- split_decimal(x, sigfig = sigfig, digits = digits)
     sci <- split_decimal(x, sigfig = sigfig, digits = digits, sci_mod = 1, fixed_exponent = fixed_exponent)
@@ -202,7 +207,7 @@ pillar_shaft_number <- function(x, sigfig, digits, notation, fixed_exponent) {
 
 # registered in .onLoad()
 pillar_shaft.integer64 <- function(x, ..., sigfig = NULL) {
-  pillar_shaft_number(x, sigfig, digits = NULL, notation = NULL, fixed_exponent = NULL)
+  pillar_shaft_number(x, sigfig, digits = NULL, notation = NULL, fixed_exponent = NULL, extra_sigfig = NULL)
 }
 
 # registered in .onLoad()

diff --git a/R/sigfig.R b/R/sigfig.R
@@ -236,6 +236,19 @@ compute_min_sigfig <- function(x) {
   ret
 }
 
+compute_extra_sigfig <- function(x) {
+  x <- sort(abs(x))
+  delta <- diff(x)
+  x <- x[-1]
+
+  keep <- which((delta != 0) & is.finite(delta))
+  if (length(keep) == 0) {
+    return(0)
+  }
+
+  ceiling(log10(max(x[keep] / delta[keep]))) - 1
+}
+
 LOG_10 <- log(10)
 
 compute_exp <- function(x, sigfig, digits) {

diff --git a/man/num.Rd b/man/num.Rd
diff --git a/tests/testthat/_snaps/num.md b/tests/testthat/_snaps/num.md
@@ -115,6 +115,17 @@
       12   1230000000     e-3   1230           e3   1.23           M
       13  12300000000     e-3  12300           e3  12.3            M
       14 123000000000     e-3 123000           e3 123              M
+    Code
+      tibble::tibble(default = num(100 + 1:3 * 0.001), extra1 = num(100 + 1:3 * 0.001,
+      extra_sigfig = TRUE), extra2 = num(100 + 1:3 * 1e-04, extra_sigfig = TRUE),
+      extra3 = num(10000 + 1:3 * 1e-05, extra_sigfig = TRUE))
+    Output
+      # A tibble: 3 x 4
+        default  extra1   extra2      extra3
+          <num>   <num>    <num>       <num>
+      1    100. 100.001 100.0001 10000.00001
+      2    100. 100.002 100.0002 10000.00002
+      3    100. 100.003 100.0003 10000.00003
 
 # many digits
 

diff --git a/tests/testthat/test-num.R b/tests/testthat/test-num.R
@@ -47,6 +47,14 @@ test_that("output test", {
       scilarge = num(10^(-7:6) * 123, notation = "eng", fixed_exponent = 3),
       scimax   = num(10^(-7:6) * 123, notation = "si",  fixed_exponent = Inf)
     )
+
+    # Extra significant figures
+    tibble::tibble(
+      default = num(100 + 1:3 * 0.001),
+      extra1 = num(100 + 1:3 * 0.001, extra_sigfig = TRUE),
+      extra2 = num(100 + 1:3 * 0.0001, extra_sigfig = TRUE),
+      extra3 = num(10000 + 1:3 * 0.00001, extra_sigfig = TRUE)
+    )
   })
 })