// used in GScale(), but also grDevices/src/axis_scales.c :
// (usr, log, n_inp) |--> (axp, n_out) :
void GAxisPars(double *min, double *max, int *n, Rboolean log, int axis)
{
#define EPS_FAC_2 100
Rboolean swap = CXXRCONSTRUCT(Rboolean, *min > *max);
double t_, min_o, max_o;
if(swap) { /* Feature: in R, something like xlim = c(100,0) just works */
t_ = *min; *min = *max; *max = t_;
}
/* save only for the extreme case (EPS_FAC_2): */
min_o = *min; max_o = *max;
if(log) {
/* Avoid infinities */
if(*max > 308) *max = 308;
if(*min < -307) *min = -307;
*min = Rexp10(*min);
*max = Rexp10(*max);
GLPretty(min, max, n);
}
else GEPretty(min, max, n);
double tmp2 = EPS_FAC_2 * DBL_EPSILON;/* << prevent overflow in product below */
if(fabs(*max - *min) < (t_ = fmax2(fabs(*max), fabs(*min)))* tmp2) {
/* Treat this case somewhat similar to the (min ~= max) case above */
/* Too much accuracy here just shows machine differences */
warning(_("relative range of values =%4.0f * EPS, is small (axis %d)")
/*"to compute accurately"*/,
fabs(*max - *min) / (t_*DBL_EPSILON), axis);
/* No pretty()ing anymore */
*min = min_o;
*max = max_o;
double eps = .005 * fabs(*max - *min);/* .005: not to go to DBL_MIN/MAX */
*min += eps;
*max -= eps;
if(log) {
*min = Rexp10(*min);
*max = Rexp10(*max);
}
*n = 1;
}
if(swap) {
t_ = *min; *min = *max; *max = t_;
}
}
static void GLPretty(double *ul, double *uh, int *n)
{
/* Generate pretty tick values -- LOGARITHMIC scale
* __ ul < uh __
* This only does a very simple setup.
* The real work happens when the axis is drawn. */
int p1, p2;
double dl = *ul, dh = *uh;
p1 = int( ceil(log10(dl)));
p2 = int( floor(log10(dh)));
if(p2 <= p1 && dh/dl > 10.0) {
p1 = int( ceil(log10(dl) - 0.5));
p2 = int( floor(log10(dh) + 0.5));
}
if (p2 <= p1) { /* floor(log10(uh)) <= ceil(log10(ul))
* <==> log10(uh) - log10(ul) < 2
* <==> uh / ul < 100 */
/* Very small range : Use tickmarks from a LINEAR scale
* Splus uses n = 9 here, but that is dumb */
GPretty(ul, uh, n);
*n = -*n;
}
else { /* extra tickmarks --> CreateAtVector() in ./plot.c */
/* round to nice "1e<N>" */
*ul = Rexp10((double)p1);
*uh = Rexp10((double)p2);
if (p2 - p1 <= LPR_SMALL)
*n = 3; /* Small range : Use 1,2,5,10 times 10^k tickmarks */
else if (p2 - p1 <= LPR_MEDIUM)
*n = 2; /* Medium range : Use 1,5 times 10^k tickmarks */
else
*n = 1; /* Large range : Use 10^k tickmarks
* But decimate, when there are too many*/
}
}
static void
scientific(double *x, int *neg, int *kpower, int *nsig, Rboolean *roundingwidens)
{
/* for a number x , determine
* neg = 1_{x < 0} {0/1}
* kpower = Exponent of 10;
* nsig = min(R_print.digits, #{significant digits of alpha})
* roundingwidens = TRUE iff rounding causes x to increase in width
*
* where |x| = alpha * 10^kpower and 1 <= alpha < 10
*/
register double alpha;
register double r;
register int kp;
int j;
if (*x == 0.0) {
*kpower = 0;
*nsig = 1;
*neg = 0;
*roundingwidens = FALSE;
} else {
if(*x < 0.0) {
*neg = 1; r = -*x;
} else {
*neg = 0; r = *x;
}
if (R_print.digits >= DBL_DIG + 1) {
format_via_sprintf(r, R_print.digits, kpower, nsig);
*roundingwidens = FALSE;
return;
}
kp = (int) floor(log10(r)) - R_print.digits + 1;/* r = |x|; 10^(kp + digits - 1) <= r */
#if defined(HAVE_LONG_DOUBLE) && (SIZEOF_LONG_DOUBLE > SIZEOF_DOUBLE)
long double r_prec = r;
/* use exact scaling factor in long double precision, if possible */
if (abs(kp) <= 27) {
if (kp > 0) r_prec /= tbl[kp+1]; else if (kp < 0) r_prec *= tbl[ -kp+1];
}
#ifdef HAVE_POWL
else
r_prec /= powl(10.0, (long double) kp);
#else
else if (kp <= R_dec_min_exponent)
r_prec = (r_prec * 1e+303)/Rexp10((double)(kp+303));
else
r_prec /= Rexp10((double) kp);
#endif
if (r_prec < tbl[R_print.digits]) {
r_prec *= 10.0;
kp--;
}
/* round alpha to integer, 10^(digits-1) <= alpha <= 10^digits
accuracy limited by double rounding problem,
alpha already rounded to 64 bits */
alpha = (double) R_nearbyintl(r_prec);
#else
double r_prec = r;
/* use exact scaling factor in double precision, if possible */
if (abs(kp) <= 22) {
if (kp >= 0) r_prec /= tbl[kp+1]; else r_prec *= tbl[ -kp+1];
}
/* on IEEE 1e-308 is not representable except by gradual underflow.
Shifting by 303 allows for any potential denormalized numbers x,
and makes the reasonable assumption that R_dec_min_exponent+303
is in range. Representation of 1e+303 has low error.
*/
else if (kp <= R_dec_min_exponent)
r_prec = (r_prec * 1e+303)/Rexp10((double)(kp+303));
else
r_prec /= Rexp10((double)kp);
if (r_prec < tbl[R_print.digits]) {
r_prec *= 10.0;
kp--;
}
/* round alpha to integer, 10^(digits-1) <= alpha <= 10^digits */
/* accuracy limited by double rounding problem,
alpha already rounded to 53 bits */
alpha = R_nearbyint(r_prec);
#endif
*nsig = R_print.digits;
for (j = 1; j <= R_print.digits; j++) {
alpha /= 10.0;
if (alpha == floor(alpha)) {
(*nsig)--;
} else {
break;
}
}
if (*nsig == 0 && R_print.digits > 0) {
*nsig = 1;
kp += 1;
}
*kpower = kp + R_print.digits - 1;
/* Scientific format may do more rounding than fixed format, e.g.
9996 with 3 digits is 1e+04 in scientific, but 9996 in fixed.
This happens when the true value r is less than 10^(kpower+1)
and would not round up to it in fixed format.
Here rgt is the decimal place that will be cut off by rounding */
int rgt = R_print.digits - *kpower;
/* bound rgt by 0 and KP_MAX */
rgt = rgt < 0 ? 0 : rgt > KP_MAX ? KP_MAX : rgt;
double fuzz = 0.5/(double)tbl[1 + rgt];
// kpower can be bigger than the table.
*roundingwidens = *kpower > 0 && *kpower <= KP_MAX && r < tbl[*kpower + 1] - fuzz;
}
/* used in graphics and grid */
SEXP CreateAtVector(double *axp, double *usr, int nint, Rboolean logflag)
{
/* Create an 'at = ...' vector for axis(.)
* i.e., the vector of tick mark locations,
* when none has been specified (= default).
*
* axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks
* {unless in log case, where nInt \in {1,2,3 ; -1,-2,....}
* and the `nint' argument is used *instead*.}
* The resulting REAL vector must have length >= 1, ideally >= 2
*/
SEXP at = R_NilValue;/* -Wall*/
double umin, umax, dn, rng, small;
int i, n, ne;
if (!logflag || axp[2] < 0) { /* --- linear axis --- Only use axp[] arg. */
n = (int)(fabs(axp[2]) + 0.25);/* >= 0 */
dn = imax2(1, n);
rng = axp[1] - axp[0];
small = fabs(rng)/(100.*dn);
at = allocVector(REALSXP, n + 1);
for (i = 0; i <= n; i++) {
REAL(at)[i] = axp[0] + (i / dn) * rng;
if (fabs(REAL(at)[i]) < small)
REAL(at)[i] = 0;
}
}
else { /* ------ log axis ----- */
Rboolean reversed = FALSE;
n = (int)(axp[2] + 0.5);
/* {xy}axp[2] for 'log': GLpretty() [./graphics.c] sets
n < 0: very small scale ==> linear axis, above, or
n = 1,2,3. see switch() below */
umin = usr[0];
umax = usr[1];
if (umin > umax) {
reversed = (axp[0] > axp[1]);
if (reversed) {
/* have *reversed* log axis -- whereas
* the switch(n) { .. } below assumes *increasing* values
* --> reverse axis direction here, and reverse back at end */
umin = usr[1];
umax = usr[0];
dn = axp[0]; axp[0] = axp[1]; axp[1] = dn;
}
else {
/* can the following still happen... ? */
warning("CreateAtVector \"log\"(from axis()): "
"usr[0] = %g > %g = usr[1] !", umin, umax);
}
}
/* allow a fuzz since we will do things like 0.2*dn >= umin */
umin *= 1 - 1e-12;
umax *= 1 + 1e-12;
dn = axp[0];
if (dn < DBL_MIN) {/* was 1e-300; now seems too cautious */
warning("CreateAtVector \"log\"(from axis()): axp[0] = %g !", dn);
if (dn <= 0) /* real trouble (once for Solaris) later on */
error("CreateAtVector [log-axis()]: axp[0] = %g < 0!", dn);
}
/* You get the 3 cases below by
* for (y in 1e-5*c(1,2,8)) plot(y, log = "y")
*/
switch(n) {
case 1: /* large range: 1 * 10^k */
i = (int)(floor(log10(axp[1])) - ceil(log10(axp[0])) + 0.25);
ne = i / nint + 1;
#ifdef DEBUG_axis
REprintf("CreateAtVector [log-axis(), case 1]: (nint, ne) = (%d,%d)\n",
nint, ne);
#endif
if (ne < 1)
error("log - axis(), 'at' creation, _LARGE_ range: "
"ne = %d <= 0 !!\n"
"\t axp[0:1]=(%g,%g) ==> i = %d; nint = %d",
ne, axp[0],axp[1], i, nint);
rng = Rexp10((double)ne); /* >= 10 */
n = 0;
while (dn < umax) {
n++;
dn *= rng;
}
if (!n)
error("log - axis(), 'at' creation, _LARGE_ range: "
"invalid {xy}axp or par; nint=%d\n"
" axp[0:1]=(%g,%g), usr[0:1]=(%g,%g); i=%d, ni=%d",
nint, axp[0],axp[1], umin,umax, i,ne);
at = allocVector(REALSXP, n);
dn = axp[0];
n = 0;
while (dn < umax) {
REAL(at)[n++] = dn;
dn *= rng;
}
break;
case 2: /* medium range: 1, 5 * 10^k */
n = 0;
if (0.5 * dn >= umin) n++;
for (;;) {
if (dn > umax) break; n++;
if (5 * dn > umax) break; n++;
dn *= 10;
}
if (!n)
error("log - axis(), 'at' creation, _MEDIUM_ range: "
"invalid {xy}axp or par;\n"
" axp[0]= %g, usr[0:1]=(%g,%g)",
axp[0], umin,umax);
at = allocVector(REALSXP, n);
dn = axp[0];
n = 0;
if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
for (;;) {
if (dn > umax) break; REAL(at)[n++] = dn;
if (5 * dn > umax) break; REAL(at)[n++] = 5 * dn;
dn *= 10;
}
break;
case 3: /* small range: 1,2,5,10 * 10^k */
n = 0;
if (0.2 * dn >= umin) n++;
if (0.5 * dn >= umin) n++;
for (;;) {
if (dn > umax) break; n++;
if (2 * dn > umax) break; n++;
if (5 * dn > umax) break; n++;
dn *= 10;
}
if (!n)
error("log - axis(), 'at' creation, _SMALL_ range: "
"invalid {xy}axp or par;\n"
" axp[0]= %g, usr[0:1]=(%g,%g)",
axp[0], umin,umax);
at = allocVector(REALSXP, n);
dn = axp[0];
n = 0;
if (0.2 * dn >= umin) REAL(at)[n++] = 0.2 * dn;
if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
for (;;) {
if (dn > umax) break; REAL(at)[n++] = dn;
if (2 * dn > umax) break; REAL(at)[n++] = 2 * dn;
if (5 * dn > umax) break; REAL(at)[n++] = 5 * dn;
dn *= 10;
}
break;
default:
error("log - axis(), 'at' creation: INVALID {xy}axp[3] = %g",
axp[2]);
}
if (reversed) {/* reverse back again - last assignment was at[n++]= . */
for (i = 0; i < n/2; i++) { /* swap( at[i], at[n-i-1] ) : */
dn = REAL(at)[i];
REAL(at)[i] = REAL(at)[n-i-1];
REAL(at)[n-i-1] = dn;
}
}
} /* linear / log */
return at;
}