The R Project SVN – R – Diff – /trunk/src/appl/pretty.c

 */
 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
 		int eps_correction, int return_bounds)
+{
 /* From version 0.65 on, we had rounding_eps := 1e-5, before, r..eps = 0
  * then, 1e-7 was consistent with seq.default() and seq.int() till 2010-02-03,
  * where it was changed to 1e-10 for seq*(), and in 2017-08-14 for pretty(): */
+    }
 #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
     /*OLD: cell = FLT_EPSILON+ dx / *ndiv; FLT_EPSILON = 1.192e-07 */
     double subsmall = f_min*DBL_MIN;
     if(subsmall == 0.) // subnormals underflowing to zero (not yet seen!)
 	subsmall = DBL_MIN;
     if(cell < subsmall) { // possibly subnormal
+	if(cell > 0)
-	warning(_("R_pretty(): very small range 'cell'=%g, corrected to %g"),
+	  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;
+    }
 #undef MAX_F
 #ifdef DEBUGpr
     REprintf("\t => final cell=%g; base=%g unit=%g; (ns,nu) = (%g,%g)\n",
 	     cell, base, unit, ns, nu);
 #endif
     if(eps_correction && (eps_correction > 1 || !i_small)) {
+#define E_ DBL_EPSILON
-	// FIXME?: assumes 0 <= lo <= up  (what if lo <= up < 0 ?)
+	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- DBL_EPSILON); else *lo = -DBL_MIN;
+	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+ DBL_EPSILON); else *up = +DBL_MIN;
+	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
     if(ns*unit > *lo + rounding_eps*unit)
 	REprintf("\t ns= %.0f -- while(ns*unit > lo + r_eps * u) ns--;\n", ns);
 #endif
     while(ns*unit > *lo + rounding_eps*unit) ns--;
 #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++;
 #ifdef DEBUGpr
 #endif
     while(nu*unit < *up - rounding_eps*unit) nu++;
 #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--;
     int k = (int)(0.5 + nu - ns);
 #ifdef DEBUGpr
 	if(nu * unit > *up) {REprintf("up=%g too small, set to nu*unit\n", *up); *up = nu * unit;}
 #else
 	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;
+    }
 #ifdef DEBUGpr
     REprintf("\t ns=%5.0g ==> lo=%g\n", ns, *lo);

The R Project SVN R

(root)/trunk/src/appl/pretty.c @ 63243 – Rev 87925 → 88880