pretty(): fix boundary cases for eps.correct=2 (+ enhance docu)

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

Author: maechler

doc/NEWS.Rd

@@ -16,7 +16,7 @@
 
   \subsection{NEW FEATURES}{
     \itemize{
-      \item The default \code{AIC} and \code{BIC} methods now check whether 
+      \item The default \code{AIC} and \code{BIC} methods now check whether
       the \pkg{methods} namespace is loaded rather than \pkg{stats4}. They
       still use \code{stats4::logLik} (and \code{stats4::nobs}), but packages
       no longer need to load \pkg{stats4} explicitly.
@@ -394,6 +394,9 @@
 
       \item The Cairo-based SVG device uses \code{pt} as the default
       document unit also with Cairo >= 1.17.8 (\PR{18912}).
+
+      \item \code{pretty(*, eps.correct = 2)} has been fixed, e.g., to
+      avoid over 1 mio length result for \code{pretty(c(0, 1e-322), eps.correct = 2)}.
     }
   }
 }

src/appl/pretty.c

@@ -75,7 +75,7 @@
 attribute_hidden
 double R_pretty(double *lo, double *up, int *ndiv, int min_n,
 		double shrink_sml,
-		const double high_u_fact[], // = (h, h5, f_min) below 
+		const double high_u_fact[], // = (h, h5, f_min) below
 		int eps_correction, int return_bounds)
 {
 /* From version 0.65 on, we had rounding_eps := 1e-5, before, r..eps = 0
@@ -110,7 +110,7 @@ double R_pretty(double *lo, double *up, int *ndiv, int min_n,
 #ifdef DEBUGpr
     REprintf("R_pretty(lo=%g,up=%g,ndiv=%d,min_n=%d,shrink=%g,high_u=(%g,%g,%g),eps=%d,bnds=%d)"
 	     "\n\t => dx=%g; i_small:%s. ==> first cell=%g\n",
-	     lo_, up_, *ndiv, min_n, shrink_sml, h, h5, min_f,
+	     lo_, up_, *ndiv, min_n, shrink_sml, h, h5, f_min,
 	     eps_correction, return_bounds,
 	     dx, i_small ? "TRUE" : "F", cell);
 #endif
@@ -142,11 +142,12 @@ double R_pretty(double *lo, double *up, int *ndiv, int min_n,
     if(subsmall == 0.) // subnormals underflowing to zero (not yet seen!)
 	subsmall = DBL_MIN;
     if(cell < subsmall) { // possibly subnormal
-	warning(_("R_pretty(): very small range 'cell'=%g, corrected to %g"),
+	if(cell > 0)
+	  warning(_("R_pretty(): very small range 'cell'=%.3g, increased to %g"),
 		cell, subsmall);
 	cell = subsmall;
     } else if(cell > DBL_MAX/MAX_F) {
-	warning(_("R_pretty(): very large range 'cell'=%g, corrected to %g"),
+	warning(_("R_pretty(): very large range 'cell'=%.3g, decreased to %g"),
 		cell, DBL_MAX/MAX_F);
 	cell = DBL_MAX/MAX_F;
     }
@@ -181,9 +182,18 @@ double R_pretty(double *lo, double *up, int *ndiv, int min_n,
 	     cell, base, unit, ns, nu);
 #endif
     if(eps_correction && (eps_correction > 1 || !i_small)) {
-	// FIXME?: assumes 0 <= lo <= up  (what if lo <= up < 0 ?)
-	if(lo_ != 0.) *lo *= (1- DBL_EPSILON); else *lo = -DBL_MIN;
-	if(up_ != 0.) *up *= (1+ DBL_EPSILON); else *up = +DBL_MIN;
+#define E_ DBL_EPSILON
+	const double D_max = DBL_MAX*(1. - ldexp(E_, -1));
+	/* move *lo  to the left, assuming <subnorm>*(1-E_) does not underflow to 0 : */
+	if(lo_ < 0.) *lo *= (1+E_); else if(lo_ > 0) *lo *= (1-E_);  else *lo = -fmin2(unit, DBL_MIN);
+	/* and  *up  to the right : */
+	if(up_ < 0.) *up *= (1-E_); else if(up_ > 0.) {
+				     if(up_ < D_max) *up *= (1+E_);} else *up = +fmin2(unit, DBL_MIN);
+#undef E_
+#ifdef DEBUGpr
+	REprintf("  eps_correction (assuming lo=%g <= %g=up): new *lo=%g, *up=%g\n",
+		 lo_, up_, *lo, *up);
+#endif
     }
 
 #ifdef DEBUGpr
@@ -194,7 +204,7 @@ double R_pretty(double *lo, double *up, int *ndiv, int min_n,
 
 #ifdef DEBUGpr
     if(!R_FINITE(ns*unit))
-	REprintf("\t infinite (ns=%.0f)*(unit=%g)  ==> ns++\n", ns, unit);
+	REprintf("\t while(!finite((ns=%.0f)*(unit=%g))) ns++\n", ns, unit);
 #endif
     while(!R_FINITE(ns*unit)) ns++;
 
@@ -207,7 +217,7 @@ double R_pretty(double *lo, double *up, int *ndiv, int min_n,
 
 #ifdef DEBUGpr
     if(!R_FINITE(nu*unit))
-	REprintf("\t infinite (nu=%.0f)*(unit=%g)  ==> nu--\n", nu, unit);
+	REprintf("\t while(!finite((nu=%.0f)*(unit=%g)) nu--\n", nu, unit);
 #endif
     while(!R_FINITE(nu*unit)) nu--;
 
@@ -246,7 +256,7 @@ double R_pretty(double *lo, double *up, int *ndiv, int min_n,
 	if(ns * unit < *lo) *lo = ns * unit;
 	if(nu * unit > *up) *up = nu * unit;
 #endif
-    } else { // used in graphics GEpretty(), hence grid::grid.pretty()
+    } else { // used in graphics GEPretty(), hence grid::grid.pretty()
 	*lo = ns;
 	*up = nu;
     }

src/library/base/man/pretty.Rd

@@ -1,6 +1,6 @@
 % File src/library/base/man/pretty.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2021 R Core Team
+% Copyright 1995-2025 R Core Team
 % Distributed under GPL 2 or later
 
 \name{pretty}
@@ -35,23 +35,26 @@ pretty(x, \dots)
   \item{u5.bias}{non-negative numeric
     multiplier favoring factor 5 over 2.  Default and \sQuote{optimal}:
     \code{u5.bias = .5 + 1.5*high.u.bias}.}
-  \item{eps.correct}{integer code, one of \{0,1,2\}. If non-0, an
+  \item{eps.correct}{integer code, one of \{0,1,2\}.  If non-0, an
     \emph{epsilon correction} is made at the boundaries such that
     the result boundaries will be outside \code{range(x)}; in the
-    \emph{small} case, the correction is only done if \code{eps.correct >= 2}.}
+    \emph{small} case, this correction happens only if \code{eps.correct >= 2},
+    allowing \code{eps.correct = 2} to reproduce how \R's graphics engine
+    computes axis tick locations, see \sQuote{Details}.}
   \item{f.min}{positive factor multiplied by \code{\link{.Machine}$double.xmin}
     to get the smallest \dQuote{acceptable} \code{cell} \eqn{c_m} which
     determines the \code{unit} of the algorithm.  Smaller \code{cell}
     values are set to \eqn{c_n} signalling a \code{\link{warning}} about
     being \dQuote{corrected}.
     New from \R 4.2.0,: previously \code{f.min = 20} was
     hardcoded in the algorithm.}
-  \item{bounds}{a \code{\link{logical}} indicating if the resulting vector
+  \item{bounds}{a \code{\link{logical}} indicating  if the resulting vector
     should \emph{cover} the full \code{range(x)}, i.e., strictly include
-    the bounds of \code{x}.  New from \R 4.2.0, allowing \code{bound=FALSE}
-    to reproduce how \R's graphics engine computes axis tick locations (in
-    \code{GEPretty()}).}
-  \item{\dots}{further arguments for methods.}
+    the bounds of \code{x}.  New from \R 4.2.0, allowing \code{bounds=FALSE}
+    to reproduce how \R's graphics engine computes axis extents and tick
+    locations, see \sQuote{Details}; also, for \code{.pretty()}, it determines
+    which parts of the C level computations should be returned.}
+  \item{\dots}{further arguments for methods; unused in default method.}
 }
 \description{
   Compute a  sequence of about \code{n+1} equally spaced \sQuote{round}
@@ -75,13 +78,22 @@ pretty(x, \dots)
   =}\code{high.u.bias} and \eqn{f =}\code{u5.bias}.
 
   \dots\dots\dots
+
+
+  \R's graphics engine \code{GEPretty()} C function calls % ../../../main/engine.c
+  \code{R_pretty()} and is used in both packages \pkg{graphics} and
+  \pkg{grid} (and hence \CRANpkg{lattice}, \CRANpkg{ggplot2}, etc.) for
+  axis range and tick computations.  For these, partly for back
+  compatibility reasons, the optional arguments are set, corresponding to
+\preformatted{
+  (min.n = 1, shrink.sml = 0.25, high.u.bias = 0.8, u5.bias = 1.7,
+   f.min = 1.125, eps.correct = 2, bounds = FALSE)}
 }
 \value{\code{pretty()} returns an numeric vector of \emph{approximately}
   \code{n} increasing numbers which are \dQuote{pretty} in decimal notation.
   (in extreme range cases, the numbers can no longer be \dQuote{pretty}
   given the other constraints; e.g., for \code{pretty(..)} %  <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< FIXME
-
-  For ease of investigating the underlying C \code{R_pretty()}
+  For ease of investigating the underlying C \code{R_pretty()} % ../../../appl/pretty.c
   function, \code{.pretty()} returns a named \code{\link{list}}.  By
   default, when \code{bounds=TRUE}, the entries are \code{l}, \code{u},
   and \code{n}, whereas for \code{bounds=FALSE}, they are

tests/reg-tests-1e.R

@@ -2286,6 +2286,14 @@ stopifnot(exprs = {
 }) ## were all FALSE in R <= 4.5.1: `last = 1000000L' was not large enough
 
 
+## pretty(<very small>, eps.correct=2) would produce huge vectors
+assertWarnV(pp <- .pretty(c(0, 1e-322), eps.correct = 2))
+str(pp)
+E <- 2e-314
+stopifnot(all.equal(list(l = -E, u = E, n = 2L), pp, tolerance = 1e-12))
+## n = 1112538 (Lnx 64b) in R <= 4.5.1  ^^^^^^
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,