The R Project SVN
R
(root)/branches/R-groups/src/main/format.c – Rev 80555
Rev 80347 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
/** R : A Computer Language for Statistical Data Analysis* Copyright (C) 1997--2021 The R Core Team* Copyright (C) 2003--2016 The R Foundation* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka** 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* the Free Software Foundation; either version 2 of the License, or* (at your option) any later version.** This program is distributed in the hope that it will be useful,* but WITHOUT ANY WARRANTY; without even the implied warranty of* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the* GNU General Public License for more details.** You should have received a copy of the GNU General Public License* along with this program; if not, a copy is available at* https://www.R-project.org/Licenses/*** Object Formatting** See ./paste.c for do_paste() , do_format() and do_formatinfo() and* ./util.c for do_formatC()* See ./printutils.c for general remarks on Printing and the Encode.. utils.* See ./print.c for do_printdefault, do_prmatrix, etc.** Exports* formatString* formatStringS* formatLogical* formatLogicalS* formatInteger* formatIntegerS* formatReal* formatRealS* formatComplex* formatComplexS** These formatFOO() functions determine the proper width, digits, etc.** formatFOOS() functions behave identically to formatFOO* except that they accept a SEXP rather than a data pointer*/#ifdef HAVE_CONFIG_H#include <config.h>#endif#include <Defn.h>#include <float.h> /* for DBL_EPSILON */#include <Rmath.h>#include <Print.h>#include <R_ext/Itermacros.h> /* for ITERATE_BY_REGION *//* this is just for conformity with other types */attribute_hiddenvoid formatRaw(const Rbyte *x, R_xlen_t n, int *fieldwidth){*fieldwidth = 2;}attribute_hiddenvoid formatRawS(SEXP x, R_xlen_t n, int *fieldwidth){*fieldwidth = 2;}attribute_hiddenvoid formatString(const SEXP *x, R_xlen_t n, int *fieldwidth, int quote){int xmax = 0;int l;for (R_xlen_t i = 0; i < n; i++) {if (x[i] == NA_STRING) {l = quote ? R_print.na_width : R_print.na_width_noquote;} else l = Rstrlen(x[i], quote) + (quote ? 2 : 0);if (l > xmax) xmax = l;}*fieldwidth = xmax;}/* currently there is no STRING_GET_REGION */attribute_hiddenvoid formatStringS(SEXP x, R_xlen_t n, int *fieldwidth, int quote){int xmax = 0;int l;for (R_xlen_t i = 0; i < n; i++) {if (STRING_ELT(x, i) == NA_STRING) {l = quote ? R_print.na_width : R_print.na_width_noquote;} else l = Rstrlen(STRING_ELT(x, i), quote) + (quote ? 2 : 0);if (l > xmax) xmax = l;}*fieldwidth = xmax;}void formatLogical(const int *x, R_xlen_t n, int *fieldwidth){*fieldwidth = 1;for(R_xlen_t i = 0 ; i < n; i++) {if (x[i] == NA_LOGICAL) {if(*fieldwidth < R_print.na_width)*fieldwidth = R_print.na_width;} else if (x[i] != 0 && *fieldwidth < 4) {*fieldwidth = 4;} else if (x[i] == 0 && *fieldwidth < 5 ) {*fieldwidth = 5;break;/* this is the widest it can be, so stop */}}}void formatLogicalS(SEXP x, R_xlen_t n, int *fieldwidth) {*fieldwidth = 1;int tmpfieldwidth = 1;ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, int, LOGICAL, 0, n,{formatLogical(px, nb, &tmpfieldwidth);if( tmpfieldwidth > *fieldwidth )*fieldwidth = tmpfieldwidth;if( *fieldwidth == 5)break; /* break iteration loop */});return;}/* needed in 2 places so rolled out into macroto avoid divergence*/#define FORMATINT_RETLOGIC do { \if (naflag) *fieldwidth = R_print.na_width; \else *fieldwidth = 1; \\if (xmin < 0) { \l = IndexWidth(-xmin) + 1; /* +1 for sign */ \if (l > *fieldwidth) *fieldwidth = l; \} \if (xmax > 0) { \l = IndexWidth(xmax); \if (l > *fieldwidth) *fieldwidth = l; \} \} while(0)void formatInteger(const int *x, R_xlen_t n, int *fieldwidth){int xmin = INT_MAX, xmax = INT_MIN, naflag = 0;int l;for (R_xlen_t i = 0; i < n; i++) {if (x[i] == NA_INTEGER)naflag = 1;else {if (x[i] < xmin) xmin = x[i];if (x[i] > xmax) xmax = x[i];}}FORMATINT_RETLOGIC;}void formatIntegerS(SEXP x, R_xlen_t n, int *fieldwidth){int xmin = INT_MAX, xmax = INT_MIN, naflag = 0,sorted;SEXP tmpmin = NULL, tmpmax = NULL;/*min and max should be VERY cheap when sortednessis known, so better to call them both than loopthrough whole vector even onceShouldn't need to check for ALTREPness herebecause KNOWN_SORTED(sorted) will never betrue for non-ALTREPs or "exploded" ALTREPs*/sorted = INTEGER_IS_SORTED(x);/* if we're not formatting/printing the whole thingALTINTEGER_MIN/MAX will give us the wrong thinganyway */if(n == XLENGTH(x) && KNOWN_SORTED(sorted)) {tmpmin = PROTECT(ALTINTEGER_MIN(x, TRUE));tmpmax = PROTECT(ALTINTEGER_MAX(x, TRUE));naflag = KNOWN_NA_1ST(sorted) ?INTEGER_ELT(x, 0) == NA_INTEGER :INTEGER_ELT(x, XLENGTH(x) - 1) == NA_INTEGER;UNPROTECT(2); /* tmpmin, tmpmax */}/*If we don't have min/max methods or they need to puntfor some reason we will get NULL.The data are integers, so the only reason we would notget INTSXP answers is if we got Inf/-Inf becauseeverything was NA.In both of the above cases we willdo things the hard way below*/if(tmpmin != NULL && tmpmax != NULL &&TYPEOF(tmpmin) == INTSXP && TYPEOF(tmpmax) == INTSXP) {int l; /* only needed here so defined locally */PROTECT(tmpmin);PROTECT(tmpmax);xmin = INTEGER_ELT(tmpmin, 0);xmax = INTEGER_ELT(tmpmax, 0);UNPROTECT(2); /* tmpmin, tmpmax *//* naflag set above *//* this is identical logic to what formatIntegerdoes */FORMATINT_RETLOGIC;} else {/*no fastpass so just format using formatIntegerby region. No need for FORMATINT_RETLOGIChere because it happens inside all theformatInteger calls.*/int tmpfw = 1;*fieldwidth = 1;ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, int, INTEGER, 0, n,{formatInteger(px, nb, &tmpfw);if(tmpfw > *fieldwidth)*fieldwidth = tmpfw;});}}/*---------------------------------------------------------------------------* scientific format determination for real numbers.* This is time-critical code. It is worth optimizing.** nsig digits altogether* kpower+1 digits to the left of "."* kpower+1+sgn including sign** Using GLOBAL R_print.digits -- had #define MAXDIG R_print.digits*//* Very likely everyone has nearbyintl now (2018), but it took until2012 for FreeBSD to get it, and longer for Cygwin.*/#if defined(HAVE_LONG_DOUBLE) && (SIZEOF_LONG_DOUBLE > SIZEOF_DOUBLE)# ifdef HAVE_NEARBYINTL# define R_nearbyintl nearbyintl# elif defined(HAVE_RINTL)# define R_nearbyintl rintl# else# define R_nearbyintl private_nearbyintlLDOUBLE private_nearbyintl(LDOUBLE x){LDOUBLE x1;x1 = - floorl(-x + 0.5);x = floorl(x + 0.5);if (x == x1) return(x);else {/* FIXME: we should really test for floorl, also C99.But FreeBSD 7.x does have it, but not nearbyintl */if (x/2.0 == floorl(x/2.0)) return(x); else return(x1);}}# endif#endif#define NB 1000static void format_via_sprintf(double r, int d, int *kpower, int *nsig){static char buff[NB];int i;snprintf(buff, NB, "%#.*e", d - 1, r);*kpower = (int) strtol(buff + (d + 2), NULL, 10);for (i = d; i >= 2; i--)if (buff[i] != '0') break;*nsig = i;}#if defined(HAVE_LONG_DOUBLE) && (SIZEOF_LONG_DOUBLE > SIZEOF_DOUBLE)static const long double tbl[] ={/* Powers exactly representable with 64 bit mantissa */1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09,1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,1e20, 1e21, 1e22, 1e23, 1e24, 1e25, 1e26, 1e27};#define KP_MAX 27#elsestatic const double tbl[] ={1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09,1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,1e20, 1e21, 1e22};#define KP_MAX 22#endifstatic voidscientific(const 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) <= KP_MAX) {if (kp > 0) r_prec /= tbl[kp]; else if (kp < 0) r_prec *= tbl[ -kp];}#ifdef HAVE_POWL// powl is C99 but only added to FreeBSD in 2017.elser_prec /= powl(10.0, (long double) kp);#elseelse if (kp <= R_dec_min_exponent)r_prec = (r_prec * 1e+303)/Rexp10((double)(kp+303));elser_prec /= Rexp10((double) kp);#endifif (r_prec < tbl[R_print.digits - 1]) {r_prec *= 10.0;kp--;}/* round alpha to integer, 10^(digits-1) <= alpha <= 10^digitsaccuracy limited by double rounding problem,alpha already rounded to 64 bits */alpha = (double) R_nearbyintl(r_prec);#else /* not using long doubles */double r_prec = r;/* use exact scaling factor in double precision, if possible */if (abs(kp) <= KP_MAX) {if (kp >= 0) r_prec /= tbl[kp]; else r_prec *= tbl[ -kp];}/* For IEC60559 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+303is 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));elser_prec /= Rexp10((double)kp);if (r_prec < tbl[R_print.digits - 1]) {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 = 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[rgt];// kpower can be bigger than the table.*roundingwidens = *kpower > 0 && *kpower <= KP_MAX && r < tbl[*kpower] - fuzz;}}/*The return values arew : the required field widthd : use %w.df in fixed format, %#w.de in scientific formate : use scientific format if != 0, value is number of exp digits - 1nsmall specifies the minimum number of decimal digits in fixed format:it is 0 except when called from do_format.*/void formatReal(const double *x, R_xlen_t n, int *w, int *d, int *e, int nsmall){Rbooleannaflag = FALSE, nanflag = FALSE,posinf = FALSE, neginf = FALSE;int neg = 0;int mnl = INT_MAX,mxl, rgt, mxsl, mxns;mxl = rgt = mxsl = mxns = INT_MIN;for (R_xlen_t i = 0; i < n; i++) {if (!R_FINITE(x[i])) {if(ISNA(x[i])) naflag = TRUE;else if(ISNAN(x[i])) nanflag = TRUE;else if(x[i] > 0) posinf = TRUE;else neginf = TRUE;} else {int neg_i, kpower, nsig;Rboolean roundingwidens;scientific(&x[i], &neg_i, &kpower, &nsig, &roundingwidens);int left = kpower + 1;if (roundingwidens) left--;int sleft = neg_i + ((left <= 0) ? 1 : left); /* >= 1 */int right = nsig - left; /* #{digits} right of '.' ( > 0 often)*/if (neg_i) neg = 1; /* if any < 0, need extra space for sign *//* Infinite precision "F" Format : */if (right > rgt) rgt = right; /* max digits to right of . */if (left > mxl) mxl = left; /* max digits to left of . */if (left < mnl) mnl = left; /* min digits to left of . */if (sleft> mxsl) mxsl = sleft; /* max left including sign(s)*/if (nsig > mxns) mxns = nsig; /* max sig digits */}}/* F Format: use "F" format WHENEVER we use not more space than 'E'* and still satisfy 'R_print.digits' {but as if nsmall==0 !}** E Format has the form [S]X[.XXX]E+XX[X]** This is indicated by setting *e to non-zero (usually 1)* If the additional exponent digit is required *e is set to 2*//*-- These 'mxsl' & 'rgt' are used in F Format* AND in the ____ if(.) "F" else "E" ___ below: */if (R_print.digits == 0) rgt = 0;if (mxl < 0) mxsl = 1 + neg; /* we use %#w.dg, so have leading zero *//* use nsmall only *after* comparing "F" vs "E": */if (rgt < 0) rgt = 0;int wF = mxsl + rgt + (rgt != 0); /* width for F format *//*-- 'see' how "E" Exponential format would be like : */*e = (mxl > 100 || mnl <= -99) ? 2 /* 3 digit exponent */ : 1;if (mxns != INT_MIN) {*d = mxns - 1;*w = neg + (*d > 0) + *d + 4 + *e; /* width for E format */if (wF <= *w + R_print.scipen) { /* Fixpoint if it needs less space */*e = 0;if (nsmall > rgt) {rgt = nsmall;wF = mxsl + rgt + (rgt != 0);}*d = rgt;*w = wF;} /* else : "E" Exponential format -- all done above */}else { /* when all x[i] are non-finite */*w = 0;/* to be increased */*d = 0;*e = 0;}if (naflag && *w < R_print.na_width)*w = R_print.na_width;if (nanflag && *w < 3) *w = 3;if (posinf && *w < 3) *w = 3;if (neginf && *w < 4) *w = 4;}void formatRealS(SEXP x, R_xlen_t n, int *w, int *d, int *e, int nsmall){/** iterate by region and just take the most extreme* values across all the regions for final w, d, and e*/int tmpw, tmpd, tmpe;*w = 0;*d = 0;*e = 0;ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, double, REAL, 0, n,{formatReal(px, nb, &tmpw, &tmpd, &tmpe, nsmall);if(tmpw > *w) *w = tmpw;if(!*d && tmpd) *d = tmpd;if(tmpe > *e) *e = tmpe;});}#ifdef formatComplex_USING_signif/* From complex.c. */void z_prec_r(Rcomplex *r, const Rcomplex *x, double digits);#endif/* As from 2.2.0 the number of digits applies to real and imaginary partstogether, not separately */void formatComplex(const Rcomplex *x, R_xlen_t n,int *wr, int *dr, int *er, // (w,d,e) for Re(.)int *wi, int *di, int *ei, // (w,d,e) for Im(.)int nsmall){/* format.info() for x[1..n] for both Re & Im */Rboolean all_re_zero = TRUE, all_im_zero = TRUE,naflag = FALSE,rnan = FALSE, rposinf = FALSE, rneginf = FALSE,inan = FALSE, iposinf = FALSE;int neg = 0;int rt, mnl, mxl, mxsl, mxns, wF, i_wF;int i_rt, i_mnl, i_mxl, i_mxsl, i_mxns;rt = mxl = mxsl = mxns = INT_MIN;i_rt= i_mxl= i_mxsl= i_mxns= INT_MIN;i_mnl = mnl = INT_MAX;for (R_xlen_t i = 0; i < n; i++) {Rcomplex tmp;#ifdef formatComplex_USING_signif/* Now round */z_prec_r(&tmp, &(x[i]), R_print.digits);#elsetmp.r = x[i].r;tmp.i = x[i].i;#endifif(ISNA(tmp.r) || ISNA(tmp.i)) {naflag = TRUE;} else {Rboolean roundingwidens;int left, right, sleft,neg_i, kpower, nsig;/* real part */if(!R_FINITE(tmp.r)) {if (ISNAN(tmp.r)) rnan = TRUE;else if (tmp.r > 0) rposinf = TRUE;else rneginf = TRUE;} else {if(x[i].r != 0) all_re_zero = FALSE;scientific(&(tmp.r), &neg_i, &kpower, &nsig, &roundingwidens);left = kpower + 1;if (roundingwidens) left--;sleft = neg_i + ((left <= 0) ? 1 : left); /* >= 1 */right = nsig - left; /* #{digits} right of '.' ( > 0 often)*/if (neg_i) neg = 1; /* if any < 0, need extra space for sign */if (right > rt) rt = right; /* max digits to right of . */if (left > mxl) mxl = left; /* max digits to left of . */if (left < mnl) mnl = left; /* min digits to left of . */if (sleft> mxsl) mxsl = sleft; /* max left including sign(s) */if (nsig > mxns) mxns = nsig; /* max sig digits */}/* imaginary part *//* this is always unsigned *//* we explicitly put the sign in when we print */if(!R_FINITE(tmp.i)) {if (ISNAN(tmp.i)) inan = TRUE;else iposinf = TRUE;} else {if(x[i].i != 0) all_im_zero = FALSE;scientific(&(tmp.i), &neg_i, &kpower, &nsig, &roundingwidens);left = kpower + 1;if (roundingwidens) left--;sleft = ((left <= 0) ? 1 : left);right = nsig - left;if (right > i_rt) i_rt = right;if (left > i_mxl) i_mxl = left;if (left < i_mnl) i_mnl = left;if (sleft> i_mxsl) i_mxsl = sleft;if (nsig > i_mxns) i_mxns = nsig;}/* done: ; */}}/* see comments in formatReal() for details on this *//* overall format for real part */if (R_print.digits == 0) rt = 0;if (mxl != INT_MIN) {if (mxl < 0) mxsl = 1 + neg;if (rt < 0) rt = 0;wF = mxsl + rt + (rt != 0);*er = (mxl > 100 || mnl < -99) ? 2 : 1;*dr = mxns - 1;*wr = neg + (*dr > 0) + *dr + 4 + *er;} else {*er = 0;*wr = 0;*dr = 0;wF = 0;}/* overall format for imaginary part */if (R_print.digits == 0) i_rt = 0;if (i_mxl != INT_MIN) {if (i_mxl < 0) i_mxsl = 1;if (i_rt < 0) i_rt = 0;i_wF = i_mxsl + i_rt + (i_rt != 0);*ei = (i_mxl > 100 || i_mnl < -99) ? 2 : 1;*di = i_mxns - 1;*wi = (*di > 0) + *di + 4 + *ei;} else {*ei = 0;*wi = 0;*di = 0;i_wF = 0;}/* Now make the fixed/scientific decision */if(all_re_zero) {*er = *dr = 0;*wr = wF;if (i_wF <= *wi + R_print.scipen) {*ei = 0;if (nsmall > i_rt) {i_rt = nsmall; i_wF = i_mxsl + i_rt + (i_rt != 0);}*di = i_rt;*wi = i_wF;}} else if(all_im_zero) {if (wF <= *wr + R_print.scipen) {*er = 0;if (nsmall > rt) {rt = nsmall; wF = mxsl + rt + (rt != 0);}*dr = rt;*wr = wF;}*ei = *di = 0;*wi = i_wF;} else if(wF + i_wF < *wr + *wi + 2*R_print.scipen) {*er = 0;if (nsmall > rt) {rt = nsmall; wF = mxsl + rt + (rt != 0);}*dr = rt;*wr = wF;*ei = 0;if (nsmall > i_rt) {i_rt = nsmall;i_wF = i_mxsl + i_rt + (i_rt != 0);}*di = i_rt;*wi = i_wF;} /* else scientific for both */if(*wr < 0) *wr = 0;if(*wi < 0) *wi = 0;/* Ensure space for Inf and NaN */if (rnan && *wr < 3) *wr = 3;if (rposinf && *wr < 3) *wr = 3;if (rneginf && *wr < 4) *wr = 4;if (inan && *wi < 3) *wi = 3;if (iposinf && *wi < 3) *wi = 3;/* finally, ensure that there is space for NA */if (naflag && *wr+*wi+2 < R_print.na_width)*wr += (R_print.na_width -(*wr + *wi + 2));}void formatComplexS(SEXP x, R_xlen_t n, int *wr, int *dr, int *er,int *wi, int *di, int *ei, int nsmall){/* format.info() for x[1..n] for both Re & Im */int tmpwr, tmpdr, tmper, tmpwi, tmpdi, tmpei;*wr = 0;*wi = 0;*dr = 0;*di = 0;*er = 0;*ei = 0;ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, Rcomplex, COMPLEX, 0, n,{formatComplex(px, nb, &tmpwr, &tmpdr, &tmper,&tmpwi, &tmpdi, &tmpei, nsmall);if(tmpwr > *wr) *wr = tmpwr;if(tmpdr && !*dr) *dr = tmpdr;if(tmper > *er) *er = tmper;if(tmpwi > *wi) *wi = tmpwi;if(tmpdi && !*di) *di = tmpdi;if(tmpei > *ei) *ei = tmpei;});}