pretty(): get bounds arg; chkDots; fix typo in (and extend) old checks for eps.correct=2

git-svn-id: https://svn.r-project.org/R/trunk@88881 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: maechler

doc/NEWS.Rd

@@ -130,6 +130,11 @@
       replacement versions now accept \code{i2 = NULL} to mean \dQuote{to
       the end_of_string}, thus fulfilling \I{Kevin Ushey} (and others')
       suggestions in \PR{18851}.
+
+      \item The default method for \code{pretty()} gets a new switch \code{bounds} for
+      completeness, corresponding to \code{.pretty()}.  Also, it now
+      catches typos such as \code{eps.corrected = 2}, noted in \PR{18521}
+      by \I{Mikko Korpela}.
     }
   }
 

src/library/base/R/pretty.R

@@ -1,7 +1,7 @@
 #  File src/library/base/R/pretty.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2021 The R Core Team
+#  Copyright (C) 1995-2025 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -30,13 +30,16 @@ pretty <- function(x, ...) UseMethod("pretty")
 pretty.default <-
     function(x, n = 5L, min.n = n %/% 3L, shrink.sml = 0.75,
              high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,
-             eps.correct = 0L, f.min = 2^-20, ...)
+             eps.correct = 0L, f.min = 2^-20, bounds = TRUE, ...)
 {
+    chkDots(...) # avoid typos
     x <- x[is.finite(x <- as.numeric(x))]
     if(!length(x)) return(x)
     z <- .Internal(pretty(min(x), max(x), n, min.n, shrink.sml,
-                          c(high.u.bias, u5.bias, f.min), eps.correct, TRUE))
+                          c(high.u.bias, u5.bias, f.min), eps.correct, bounds))
     n <- z$n
+    if(!bounds) z <- list(l = z$ns * z$unit,
+                          u = z$nu * z$unit)
     s <- seq.int(z$l, z$u, length.out = n + 1L)
     if(!eps.correct && n) { # maybe zap smalls from seq() rounding errors
         ## better than zapsmall(s, digits = 14) :

src/library/base/man/pretty.Rd

@@ -13,7 +13,7 @@ pretty(x, \dots)
 
 \method{pretty}{default}(x, n = 5, min.n = n \%/\% 3,  shrink.sml = 0.75,
        high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,
-       eps.correct = 0, f.min = 2^-20, \dots)
+       eps.correct = 0, f.min = 2^-20, bounds = TRUE, \dots)
 
 .pretty(x, n = 5L, min.n = n \%/\% 3,  shrink.sml = 0.75,
        high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,

tests/reg-tests-1d.R

@@ -14,10 +14,17 @@ getVaW <- function(expr) {
                             invokeRestart("muffleWarning") })
     structure(val, warning = W)
 }
+(sysinf <- Sys.info())
+Lnx   <- sysinf[["sysname"]] == "Linux"
+isMac <- sysinf[["sysname"]] == "Darwin"
+arch  <- sysinf[["machine"]]
+x86 <- arch == "x86_64"
 onWindows <- .Platform$OS.type == "windows"
-.M <- .Machine
-str(.M[grep("^sizeof", names(.M))]) ## also differentiate long-double..
-b64 <- .M$sizeof.pointer == 8
+str(.Machine[grep("^sizeof", names(.Machine))]) ## also differentiate long-double..
+(b64 <- .Machine$sizeof.pointer == 8L)
+(noLdbl  <- .Machine$sizeof.longdouble <= 8L) ## TRUE when --disable-long-double
+(longD16 <- .Machine$sizeof.longdouble >= 16L)
+
 options(nwarnings = 10000, # (rather than just 50)
         width = 99) # instead of 80
 
@@ -2772,7 +2779,6 @@ spois     <- summary( poisfit)
 sqpois    <- summary(qpoisfit)
 sqpois.d1 <- summary(qpoisfit, dispersion=1)
 SE1 <- sqrt(diag(V <- vcov(poisfit)))
-(noLdbl <- (.Machine$sizeof.longdouble <= 8)) ## TRUE when --disable-long-double
 stopifnot(exprs = { ## Same variances and same as V
     all.equal(vcov(spois), V)
     all.equal(vcov(qpoisfit, dispersion=1), V) ## << was wrong
@@ -4886,10 +4892,11 @@ for(i.n in seq_along(ns)) {
 stopifnot(abs(rr-1) < 3.3/ns)
 ## many of these pretty() calls errored (because internally gave Inf) in R <= 4.1.0
 ##
+
 ##---------------- very small ranges ------------------
 ## The really smallest positive number (unless subnormals do "not exist"):
 mm <- with(.Machine, double.xmin * double.eps)
-log2(mm) == -1074 # T
+log2(mm) == -1074 # TRUE (everywhere ??)
 ## "of course", this an extreme *sub normal* number, e.g.
 mm == c(0.50001, 1.49999) * mm # TRUE TRUE (!)
 (1.5*mm) / mm #  2  (!!)
@@ -4904,23 +4911,49 @@ fsS <- fs[fs <= 0.75]
 options(warn=0) # (collect warnings)
 psmm <- lapply(h.u, function(hu)
     lapply(fsS, function(f)
-        lapply(nns, pretty, x = c(0, mm/f), high.u=hu, eps.correction = 2)))
-summary(warnings())## many; mostly  "very small range 'cell'=0, corrected to 2.122e-314"
+        lapply(nns, pretty, x = c(0, mm/f), high.u.bias=hu)))
+summary(warnings())## many "very small range 'cell'=<nnn>e+32<n>, corrected to 2.122e-314"
 (T <- table(psA <- unlist(psmm))) # is this portable?
 (nT <- as.numeric(names(T)))
 range(rEd <- abs(2e-314/diff(nT) - 1))
-stopifnot(nT >= 0, length(nT) == 11,
-          rEd <= 2^-50) # only seen rEd == 0
-##
+stopifnot(exprs = {
+    nT >= 0
+    (nn <- length(nT)) <= 15 # always = 11 on  Lnx 64b
+    7 <= nn
+    rEd <= if(b64) 2^-50 else 0.9 # Lnx 64b: only seen rEd == 0;  32bit ppc : 0.8 (!)
+})
+## This used to be _very_ slow in R <= 4.5.1 because it produced _HUGE_ (non-pretty!) vectors;
+## On Linux, an OS daemon would typically kill the R process for using too much resources:
+psm2 <- lapply(h.u, function(hu) {
+    ## cat(sprintf("hu:%6g -- f =", hu)); on.exit(cat("\n"))
+    lapply(fsS, function(f) {
+       ## cat(sprintf(" %g", f))
+       lapply(nns, \(n) pretty(c(0, mm/f), n=n, high.u.bias=hu, eps.correct = 2))
+    })
+})
+apply(sapply(psmm, \(L) sapply(L,lengths)), 2L, quantile)
+apply(sapply(psm2, \(L) sapply(L,lengths)), 2L, quantile)
 psmm.o <- lapply(h.u, function(hu)
     lapply(fsS, function(f) # older R: f.min = 20 hardwired:
         lapply(nns, pretty, x = c(0, mm/f), high.u=hu, f.min = 20) ))
 summary(warnings())## many; mostly  "very small range 'cell'=0, corrected to 4.45015e-307"
 (To <- table(psAo <- signif(unlist(psmm.o), 13)))
 (nTo <- as.numeric(names(To)))
-range(rEdo <- abs(5e-307/diff(nTo) - 1))
-stopifnot(nTo >= 0, length(nTo) == 11,
-          rEdo <= 2^-44) # seen max of 2^-51 on Lnx_64; 2^-44.5 on Win64
+range(rEdo <- abs(5e-307/diff(nTo) - 1)) # 0 2.33e-15
+r1 <- apply(sapply(psmm,  \(L) sapply(L,lengths)), 2L, range)
+r2 <- apply(sapply(psm2,  \(L) sapply(L,lengths)), 2L, range)
+r3 <- apply(sapply(psmm.o,\(L) sapply(L,lengths)), 2L, range)
+stopifnot(exprs = {
+    nTo >= 0
+    (nn <- length(nTo)) <= 15 ## length(nTo) == 11
+    7 <= nn
+    rEdo <= if(b64) 2^-44 else 0.9 # Lnx 64b: seen max of 2^-48.608 (prev. 2^-51) Lnx_64; 2^-44.5 on Win64; ppc ??
+    if(b64 && x86) { ## platform ?
+        r1 == c(2, 11)
+        r2 == c(3, 11)
+        r3 == c(1, 11)
+    } else TRUE
+})
 
 
 ## graphics::axis(), but also *engine* GScale() / GPretty() etc