1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1997--2019 The R Core Team
4 * Copyright (C) 2003--2016 The R Foundation
5 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
6 *
7 * This program is free software; you can redistribute it and/or modify
8 * it under the terms of the GNU General Public License as published by
9 * the Free Software Foundation; either version 2 of the License, or
10 * (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, a copy is available at
19 * https://www.R-project.org/Licenses/
20 *
21 *
22 * Object Formatting
23 *
24 * See ./paste.c for do_paste() , do_format() and do_formatinfo() and
25 * ./util.c for do_formatC()
26 * See ./printutils.c for general remarks on Printing and the Encode.. utils.
27 * See ./print.c for do_printdefault, do_prmatrix, etc.
28 *
29 * Exports
30 * formatString
31 * formatStringS
32 * formatLogical
33 * formatLogicalS
34 * formatInteger
35 * formatIntegerS
36 * formatReal
37 * formatRealS
38 * formatComplex
39 * formatComplexS
40 *
41 * These formatFOO() functions determine the proper width, digits, etc.
42 *
43 * formatFOOS() functions behave identically to formatFOO
44 * except that they accept a SEXP rather than a data pointer
45 */
46
47 #ifdef HAVE_CONFIG_H
48 #include <config.h>
49 #endif
50
51 #include <Defn.h>
52 #include <float.h> /* for DBL_EPSILON */
53 #include <Rmath.h>
54 #include <Print.h>
55 #include <R_ext/Itermacros.h> /* for ITERATE_BY_REGION */
56
57 /* this is just for conformity with other types */
58 attribute_hidden
formatRaw(const Rbyte * x,R_xlen_t n,int * fieldwidth)59 void formatRaw(const Rbyte *x, R_xlen_t n, int *fieldwidth)
60 {
61 *fieldwidth = 2;
62 }
63
64 attribute_hidden
formatRawS(SEXP x,R_xlen_t n,int * fieldwidth)65 void formatRawS(SEXP x, R_xlen_t n, int *fieldwidth)
66 {
67 *fieldwidth = 2;
68 }
69
70
71 attribute_hidden
formatString(const SEXP * x,R_xlen_t n,int * fieldwidth,int quote)72 void formatString(const SEXP *x, R_xlen_t n, int *fieldwidth, int quote)
73 {
74 int xmax = 0;
75 int l;
76
77 for (R_xlen_t i = 0; i < n; i++) {
78 if (x[i] == NA_STRING) {
79 l = quote ? R_print.na_width : R_print.na_width_noquote;
80 } else l = Rstrlen(x[i], quote) + (quote ? 2 : 0);
81 if (l > xmax) xmax = l;
82 }
83 *fieldwidth = xmax;
84 }
85
86 /* currently there is no STRING_GET_REGION */
87
88 attribute_hidden
formatStringS(SEXP x,R_xlen_t n,int * fieldwidth,int quote)89 void formatStringS(SEXP x, R_xlen_t n, int *fieldwidth, int quote)
90 {
91 int xmax = 0;
92 int l;
93
94 for (R_xlen_t i = 0; i < n; i++) {
95 if (STRING_ELT(x, i) == NA_STRING) {
96 l = quote ? R_print.na_width : R_print.na_width_noquote;
97 } else l = Rstrlen(STRING_ELT(x, i), quote) + (quote ? 2 : 0);
98 if (l > xmax) xmax = l;
99 }
100 *fieldwidth = xmax;
101 }
102
103
104
formatLogical(const int * x,R_xlen_t n,int * fieldwidth)105 void formatLogical(const int *x, R_xlen_t n, int *fieldwidth)
106 {
107 *fieldwidth = 1;
108 for(R_xlen_t i = 0 ; i < n; i++) {
109 if (x[i] == NA_LOGICAL) {
110 if(*fieldwidth < R_print.na_width)
111 *fieldwidth = R_print.na_width;
112 } else if (x[i] != 0 && *fieldwidth < 4) {
113 *fieldwidth = 4;
114 } else if (x[i] == 0 && *fieldwidth < 5 ) {
115 *fieldwidth = 5;
116 break;
117 /* this is the widest it can be, so stop */
118 }
119 }
120 }
121
formatLogicalS(SEXP x,R_xlen_t n,int * fieldwidth)122 void formatLogicalS(SEXP x, R_xlen_t n, int *fieldwidth) {
123 *fieldwidth = 1;
124 int tmpfieldwidth = 1;
125 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, int, LOGICAL, 0, n,
126 {
127 formatLogical(px, nb, &tmpfieldwidth);
128 if( tmpfieldwidth > *fieldwidth )
129 *fieldwidth = tmpfieldwidth;
130 if( *fieldwidth == 5)
131 break; /* break iteration loop */
132 });
133 return;
134 }
135
136
137 /* needed in 2 places so rolled out into macro
138 to avoid divergence
139 */
140 #define FORMATINT_RETLOGIC do { \
141 if (naflag) *fieldwidth = R_print.na_width; \
142 else *fieldwidth = 1; \
143 \
144 if (xmin < 0) { \
145 l = IndexWidth(-xmin) + 1; /* +1 for sign */ \
146 if (l > *fieldwidth) *fieldwidth = l; \
147 } \
148 if (xmax > 0) { \
149 l = IndexWidth(xmax); \
150 if (l > *fieldwidth) *fieldwidth = l; \
151 } \
152 } while(0)
153
formatInteger(const int * x,R_xlen_t n,int * fieldwidth)154 void formatInteger(const int *x, R_xlen_t n, int *fieldwidth)
155 {
156 int xmin = INT_MAX, xmax = INT_MIN, naflag = 0;
157 int l;
158
159 for (R_xlen_t i = 0; i < n; i++) {
160 if (x[i] == NA_INTEGER)
161 naflag = 1;
162 else {
163 if (x[i] < xmin) xmin = x[i];
164 if (x[i] > xmax) xmax = x[i];
165 }
166 }
167 FORMATINT_RETLOGIC;
168 }
169
formatIntegerS(SEXP x,R_xlen_t n,int * fieldwidth)170 void formatIntegerS(SEXP x, R_xlen_t n, int *fieldwidth)
171 {
172
173 int xmin = INT_MAX, xmax = INT_MIN, naflag = 0,
174 sorted;
175 SEXP tmpmin = NULL, tmpmax = NULL;
176 /*
177 min and max should be VERY cheap when sortedness
178 is known, so better to call them both than loop
179 through whole vector even once
180
181 Shouldn't need to check for ALTREPness here
182 because KNOWN_SORTED(sorted) will never be
183 true for non-ALTREPs or "exploded" ALTREPs
184 */
185 sorted = INTEGER_IS_SORTED(x);
186 /* if we're not formatting/printing the whole thing
187 ALTINTEGER_MIN/MAX will give us the wrong thing
188 anyway */
189 if(n == XLENGTH(x) && KNOWN_SORTED(sorted)) {
190 tmpmin = ALTINTEGER_MIN(x, TRUE);
191 tmpmax = ALTINTEGER_MAX(x, TRUE);
192 naflag = KNOWN_NA_1ST(sorted) ?
193 INTEGER_ELT(x, 0) == NA_INTEGER :
194 INTEGER_ELT(x, XLENGTH(x) - 1) == NA_INTEGER;
195 }
196
197 /*
198 If we don't have min/max methods or they need to punt
199 for some reason we will get NULL.
200
201 The data are integers, so the only reason we would not
202 get INTSXP answers is if we got Inf/-Inf because
203 everything was NA.
204
205 In both of the above cases we will
206 do things the hard way below
207 */
208 if(tmpmin != NULL && tmpmax != NULL &&
209 TYPEOF(tmpmin) == INTSXP && TYPEOF(tmpmax) == INTSXP) {
210 int l; /* only needed here so defined locally */
211 xmin = INTEGER_ELT(tmpmin, 0);
212 xmax = INTEGER_ELT(tmpmax, 0);
213 /* naflag set above */
214
215 /* this is identical logic to what formatInteger
216 does */
217 FORMATINT_RETLOGIC;
218 } else {
219 /*
220 no fastpass so just format using formatInteger
221 by region. No need for FORMATINT_RETLOGIC
222 here because it happens inside all the
223 formatInteger calls.
224 */
225 int tmpfw = 1;
226 *fieldwidth = 1;
227 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, int, INTEGER, 0, n,
228 {
229 formatInteger(px, nb, &tmpfw);
230 if(tmpfw > *fieldwidth)
231 *fieldwidth = tmpfw;
232 });
233 }
234 }
235
236 /*---------------------------------------------------------------------------
237 * scientific format determination for real numbers.
238 * This is time-critical code. It is worth optimizing.
239 *
240 * nsig digits altogether
241 * kpower+1 digits to the left of "."
242 * kpower+1+sgn including sign
243 *
244 * Using GLOBAL R_print.digits -- had #define MAXDIG R_print.digits
245 */
246
247 /* Very likely everyone has nearbyintl now (2018), but it took until
248 2012 for FreeBSD to get it, and longer for Cygwin.
249 */
250 #if defined(HAVE_LONG_DOUBLE) && (SIZEOF_LONG_DOUBLE > SIZEOF_DOUBLE)
251 # ifdef HAVE_NEARBYINTL
252 # define R_nearbyintl nearbyintl
253 # elif defined(HAVE_RINTL)
254 # define R_nearbyintl rintl
255 # else
256 # define R_nearbyintl private_nearbyintl
private_nearbyintl(LDOUBLE x)257 LDOUBLE private_nearbyintl(LDOUBLE x)
258 {
259 LDOUBLE x1;
260 x1 = - floorl(-x + 0.5);
261 x = floorl(x + 0.5);
262 if (x == x1) return(x);
263 else {
264 /* FIXME: we should really test for floorl, also C99.
265 But FreeBSD 7.x does have it, but not nearbyintl */
266 if (x/2.0 == floorl(x/2.0)) return(x); else return(x1);
267 }
268 }
269 # endif
270 #endif
271
272 #define NB 1000
format_via_sprintf(double r,int d,int * kpower,int * nsig)273 static void format_via_sprintf(double r, int d, int *kpower, int *nsig)
274 {
275 static char buff[NB];
276 int i;
277 snprintf(buff, NB, "%#.*e", d - 1, r);
278 *kpower = (int) strtol(buff + (d + 2), NULL, 10);
279 for (i = d; i >= 2; i--)
280 if (buff[i] != '0') break;
281 *nsig = i;
282 }
283
284
285 #if defined(HAVE_LONG_DOUBLE) && (SIZEOF_LONG_DOUBLE > SIZEOF_DOUBLE)
286 static const long double tbl[] =
287 {
288 /* Powers exactly representable with 64 bit mantissa (except the first, which is only used with digits=0) */
289 1e-1,
290 1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09,
291 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,
292 1e20, 1e21, 1e22, 1e23, 1e24, 1e25, 1e26, 1e27
293 };
294 #define KP_MAX 27
295 #else
296 static const double tbl[] =
297 {
298 1e-1,
299 1e00, 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09,
300 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,
301 1e20, 1e21, 1e22
302 };
303 #define KP_MAX 22
304 #endif
305
306 static void
scientific(const double * x,int * neg,int * kpower,int * nsig,Rboolean * roundingwidens)307 scientific(const double *x, int *neg, int *kpower, int *nsig, Rboolean *roundingwidens)
308 {
309 /* for a number x , determine
310 * neg = 1_{x < 0} {0/1}
311 * kpower = Exponent of 10;
312 * nsig = min(R_print.digits, #{significant digits of alpha})
313 * roundingwidens = TRUE iff rounding causes x to increase in width
314 *
315 * where |x| = alpha * 10^kpower and 1 <= alpha < 10
316 */
317 register double alpha;
318 register double r;
319 register int kp;
320 int j;
321
322 if (*x == 0.0) {
323 *kpower = 0;
324 *nsig = 1;
325 *neg = 0;
326 *roundingwidens = FALSE;
327 } else {
328 if(*x < 0.0) {
329 *neg = 1; r = -*x;
330 } else {
331 *neg = 0; r = *x;
332 }
333 if (R_print.digits >= DBL_DIG + 1) {
334 format_via_sprintf(r, R_print.digits, kpower, nsig);
335 *roundingwidens = FALSE;
336 return;
337 }
338 kp = (int) floor(log10(r)) - R_print.digits + 1;/* r = |x|; 10^(kp + digits - 1) <= r */
339 #if defined(HAVE_LONG_DOUBLE) && (SIZEOF_LONG_DOUBLE > SIZEOF_DOUBLE)
340 long double r_prec = r;
341 /* use exact scaling factor in long double precision, if possible */
342 if (abs(kp) <= KP_MAX) {
343 if (kp > 0) r_prec /= tbl[kp+1]; else if (kp < 0) r_prec *= tbl[ -kp+1];
344 }
345 #ifdef HAVE_POWL
346 // powl is C99 but only added to FreeBSD in 2017.
347 else
348 r_prec /= powl(10.0, (long double) kp);
349 #else
350 else if (kp <= R_dec_min_exponent)
351 r_prec = (r_prec * 1e+303)/Rexp10((double)(kp+303));
352 else
353 r_prec /= Rexp10((double) kp);
354 #endif
355 if (r_prec < tbl[R_print.digits]) {
356 r_prec *= 10.0;
357 kp--;
358 }
359 /* round alpha to integer, 10^(digits-1) <= alpha <= 10^digits
360 accuracy limited by double rounding problem,
361 alpha already rounded to 64 bits */
362 alpha = (double) R_nearbyintl(r_prec);
363 #else /* not using long doubles */
364 double r_prec = r;
365 /* use exact scaling factor in double precision, if possible */
366 if (abs(kp) <= KP_MAX) {
367 if (kp >= 0) r_prec /= tbl[kp+1]; else r_prec *= tbl[ -kp+1];
368 }
369 /* For IEC60559 1e-308 is not representable except by gradual underflow.
370 Shifting by 303 allows for any potential denormalized numbers x,
371 and makes the reasonable assumption that R_dec_min_exponent+303
372 is in range. Representation of 1e+303 has low error.
373 */
374 else if (kp <= R_dec_min_exponent)
375 r_prec = (r_prec * 1e+303)/Rexp10((double)(kp+303));
376 else
377 r_prec /= Rexp10((double)kp);
378 if (r_prec < tbl[R_print.digits]) {
379 r_prec *= 10.0;
380 kp--;
381 }
382 /* round alpha to integer, 10^(digits-1) <= alpha <= 10^digits */
383 /* accuracy limited by double rounding problem,
384 alpha already rounded to 53 bits */
385 alpha = nearbyint(r_prec);
386 #endif
387 *nsig = R_print.digits;
388 for (j = 1; j <= R_print.digits; j++) {
389 alpha /= 10.0;
390 if (alpha == floor(alpha)) {
391 (*nsig)--;
392 } else {
393 break;
394 }
395 }
396 if (*nsig == 0 && R_print.digits > 0) {
397 *nsig = 1;
398 kp += 1;
399 }
400 *kpower = kp + R_print.digits - 1;
401
402 /* Scientific format may do more rounding than fixed format, e.g.
403 9996 with 3 digits is 1e+04 in scientific, but 9996 in fixed.
404 This happens when the true value r is less than 10^(kpower+1)
405 and would not round up to it in fixed format.
406 Here rgt is the decimal place that will be cut off by rounding */
407
408 int rgt = R_print.digits - *kpower;
409 /* bound rgt by 0 and KP_MAX */
410 rgt = rgt < 0 ? 0 : rgt > KP_MAX ? KP_MAX : rgt;
411 double fuzz = 0.5/(double)tbl[1 + rgt];
412 // kpower can be bigger than the table.
413 *roundingwidens = *kpower > 0 && *kpower <= KP_MAX && r < tbl[*kpower + 1] - fuzz;
414 }
415 }
416
417 /*
418 The return values are
419 w : the required field width
420 d : use %w.df in fixed format, %#w.de in scientific format
421 e : use scientific format if != 0, value is number of exp digits - 1
422
423 nsmall specifies the minimum number of decimal digits in fixed format:
424 it is 0 except when called from do_format.
425 */
426
formatReal(const double * x,R_xlen_t n,int * w,int * d,int * e,int nsmall)427 void formatReal(const double *x, R_xlen_t n, int *w, int *d, int *e, int nsmall)
428 {
429 Rboolean
430 naflag = FALSE, nanflag = FALSE,
431 posinf = FALSE, neginf = FALSE;
432 int neg = 0;
433 int mnl = INT_MAX,
434 mxl, rgt, mxsl, mxns;
435 mxl = rgt = mxsl = mxns = INT_MIN;
436
437 for (R_xlen_t i = 0; i < n; i++) {
438 if (!R_FINITE(x[i])) {
439 if(ISNA(x[i])) naflag = TRUE;
440 else if(ISNAN(x[i])) nanflag = TRUE;
441 else if(x[i] > 0) posinf = TRUE;
442 else neginf = TRUE;
443 } else {
444 int neg_i, kpower, nsig;
445 Rboolean roundingwidens;
446 scientific(&x[i], &neg_i, &kpower, &nsig, &roundingwidens);
447
448 int left = kpower + 1;
449 if (roundingwidens) left--;
450
451 int sleft = neg_i + ((left <= 0) ? 1 : left); /* >= 1 */
452 int right = nsig - left; /* #{digits} right of '.' ( > 0 often)*/
453 if (neg_i) neg = 1; /* if any < 0, need extra space for sign */
454
455 /* Infinite precision "F" Format : */
456 if (right > rgt) rgt = right; /* max digits to right of . */
457 if (left > mxl) mxl = left; /* max digits to left of . */
458 if (left < mnl) mnl = left; /* min digits to left of . */
459 if (sleft> mxsl) mxsl = sleft; /* max left including sign(s)*/
460 if (nsig > mxns) mxns = nsig; /* max sig digits */
461 }
462 }
463 /* F Format: use "F" format WHENEVER we use not more space than 'E'
464 * and still satisfy 'R_print.digits' {but as if nsmall==0 !}
465 *
466 * E Format has the form [S]X[.XXX]E+XX[X]
467 *
468 * This is indicated by setting *e to non-zero (usually 1)
469 * If the additional exponent digit is required *e is set to 2
470 */
471
472 /*-- These 'mxsl' & 'rgt' are used in F Format
473 * AND in the ____ if(.) "F" else "E" ___ below: */
474 if (R_print.digits == 0) rgt = 0;
475 if (mxl < 0) mxsl = 1 + neg; /* we use %#w.dg, so have leading zero */
476
477 /* use nsmall only *after* comparing "F" vs "E": */
478 if (rgt < 0) rgt = 0;
479 int wF = mxsl + rgt + (rgt != 0); /* width for F format */
480
481 /*-- 'see' how "E" Exponential format would be like : */
482 *e = (mxl > 100 || mnl <= -99) ? 2 /* 3 digit exponent */ : 1;
483 if (mxns != INT_MIN) {
484 *d = mxns - 1;
485 *w = neg + (*d > 0) + *d + 4 + *e; /* width for E format */
486 if (wF <= *w + R_print.scipen) { /* Fixpoint if it needs less space */
487 *e = 0;
488 if (nsmall > rgt) {
489 rgt = nsmall;
490 wF = mxsl + rgt + (rgt != 0);
491 }
492 *d = rgt;
493 *w = wF;
494 } /* else : "E" Exponential format -- all done above */
495 }
496 else { /* when all x[i] are non-finite */
497 *w = 0;/* to be increased */
498 *d = 0;
499 *e = 0;
500 }
501 if (naflag && *w < R_print.na_width)
502 *w = R_print.na_width;
503 if (nanflag && *w < 3) *w = 3;
504 if (posinf && *w < 3) *w = 3;
505 if (neginf && *w < 4) *w = 4;
506 }
507
formatRealS(SEXP x,R_xlen_t n,int * w,int * d,int * e,int nsmall)508 void formatRealS(SEXP x, R_xlen_t n, int *w, int *d, int *e, int nsmall)
509 {
510 /*
511 * iterate by region and just take the most extreme
512 * values across all the regions for final w, d, and e
513 */
514 int tmpw, tmpd, tmpe;
515
516 *w = 0;
517 *d = 0;
518 *e = 0;
519
520 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, double, REAL, 0, n,
521 {
522 formatReal(px, nb, &tmpw, &tmpd, &tmpe, nsmall);
523 if(tmpw > *w) *w = tmpw;
524 if(!*d && tmpd) *d = tmpd;
525 if(tmpe > *e) *e = tmpe;
526 });
527 }
528
529 #ifdef formatComplex_USING_signif
530 /* From complex.c. */
531 void z_prec_r(Rcomplex *r, const Rcomplex *x, double digits);
532 #endif
533
534 /* As from 2.2.0 the number of digits applies to real and imaginary parts
535 together, not separately */
formatComplex(const Rcomplex * x,R_xlen_t n,int * wr,int * dr,int * er,int * wi,int * di,int * ei,int nsmall)536 void formatComplex(const Rcomplex *x, R_xlen_t n,
537 int *wr, int *dr, int *er, // (w,d,e) for Re(.)
538 int *wi, int *di, int *ei, // (w,d,e) for Im(.)
539 int nsmall)
540 {
541 /* format.info() for x[1..n] for both Re & Im */
542 Rboolean all_re_zero = TRUE, all_im_zero = TRUE,
543 naflag = FALSE,
544 rnan = FALSE, rposinf = FALSE, rneginf = FALSE,
545 inan = FALSE, iposinf = FALSE;
546 int neg = 0;
547 int rt, mnl, mxl, mxsl, mxns, wF, i_wF;
548 int i_rt, i_mnl, i_mxl, i_mxsl, i_mxns;
549 rt = mxl = mxsl = mxns = INT_MIN;
550 i_rt= i_mxl= i_mxsl= i_mxns= INT_MIN;
551 i_mnl = mnl = INT_MAX;
552
553 for (R_xlen_t i = 0; i < n; i++) {
554 Rcomplex tmp;
555 #ifdef formatComplex_USING_signif
556 /* Now round */
557 z_prec_r(&tmp, &(x[i]), R_print.digits);
558 #else
559 tmp.r = x[i].r;
560 tmp.i = x[i].i;
561 #endif
562 if(ISNA(tmp.r) || ISNA(tmp.i)) {
563 naflag = TRUE;
564 } else {
565 Rboolean roundingwidens;
566 int left, right, sleft,
567 neg_i, kpower, nsig;
568
569 /* real part */
570
571 if(!R_FINITE(tmp.r)) {
572 if (ISNAN(tmp.r)) rnan = TRUE;
573 else if (tmp.r > 0) rposinf = TRUE;
574 else rneginf = TRUE;
575 } else {
576 if(x[i].r != 0) all_re_zero = FALSE;
577 scientific(&(tmp.r), &neg_i, &kpower, &nsig, &roundingwidens);
578
579 left = kpower + 1;
580 if (roundingwidens) left--;
581 sleft = neg_i + ((left <= 0) ? 1 : left); /* >= 1 */
582 right = nsig - left; /* #{digits} right of '.' ( > 0 often)*/
583 if (neg_i) neg = 1; /* if any < 0, need extra space for sign */
584
585 if (right > rt) rt = right; /* max digits to right of . */
586 if (left > mxl) mxl = left; /* max digits to left of . */
587 if (left < mnl) mnl = left; /* min digits to left of . */
588 if (sleft> mxsl) mxsl = sleft; /* max left including sign(s) */
589 if (nsig > mxns) mxns = nsig; /* max sig digits */
590
591 }
592 /* imaginary part */
593
594 /* this is always unsigned */
595 /* we explicitly put the sign in when we print */
596
597 if(!R_FINITE(tmp.i)) {
598 if (ISNAN(tmp.i)) inan = TRUE;
599 else iposinf = TRUE;
600 } else {
601 if(x[i].i != 0) all_im_zero = FALSE;
602 scientific(&(tmp.i), &neg_i, &kpower, &nsig, &roundingwidens);
603
604 left = kpower + 1;
605 if (roundingwidens) left--;
606 sleft = ((left <= 0) ? 1 : left);
607 right = nsig - left;
608
609 if (right > i_rt) i_rt = right;
610 if (left > i_mxl) i_mxl = left;
611 if (left < i_mnl) i_mnl = left;
612 if (sleft> i_mxsl) i_mxsl = sleft;
613 if (nsig > i_mxns) i_mxns = nsig;
614 }
615 /* done: ; */
616 }
617 }
618
619 /* see comments in formatReal() for details on this */
620
621 /* overall format for real part */
622
623 if (R_print.digits == 0) rt = 0;
624 if (mxl != INT_MIN) {
625 if (mxl < 0) mxsl = 1 + neg;
626 if (rt < 0) rt = 0;
627 wF = mxsl + rt + (rt != 0);
628
629 *er = (mxl > 100 || mnl < -99) ? 2 : 1;
630 *dr = mxns - 1;
631 *wr = neg + (*dr > 0) + *dr + 4 + *er;
632 } else {
633 *er = 0;
634 *wr = 0;
635 *dr = 0;
636 wF = 0;
637 }
638
639 /* overall format for imaginary part */
640
641 if (R_print.digits == 0) i_rt = 0;
642 if (i_mxl != INT_MIN) {
643 if (i_mxl < 0) i_mxsl = 1;
644 if (i_rt < 0) i_rt = 0;
645 i_wF = i_mxsl + i_rt + (i_rt != 0);
646
647 *ei = (i_mxl > 100 || i_mnl < -99) ? 2 : 1;
648 *di = i_mxns - 1;
649 *wi = (*di > 0) + *di + 4 + *ei;
650 } else {
651 *ei = 0;
652 *wi = 0;
653 *di = 0;
654 i_wF = 0;
655 }
656
657 /* Now make the fixed/scientific decision */
658 if(all_re_zero) {
659 *er = *dr = 0;
660 *wr = wF;
661 if (i_wF <= *wi + R_print.scipen) {
662 *ei = 0;
663 if (nsmall > i_rt) {i_rt = nsmall; i_wF = i_mxsl + i_rt + (i_rt != 0);}
664 *di = i_rt;
665 *wi = i_wF;
666 }
667 } else if(all_im_zero) {
668 if (wF <= *wr + R_print.scipen) {
669 *er = 0;
670 if (nsmall > rt) {rt = nsmall; wF = mxsl + rt + (rt != 0);}
671 *dr = rt;
672 *wr = wF;
673 }
674 *ei = *di = 0;
675 *wi = i_wF;
676 } else if(wF + i_wF < *wr + *wi + 2*R_print.scipen) {
677 *er = 0;
678 if (nsmall > rt) {rt = nsmall; wF = mxsl + rt + (rt != 0);}
679 *dr = rt;
680 *wr = wF;
681
682 *ei = 0;
683 if (nsmall > i_rt) {
684 i_rt = nsmall;
685 i_wF = i_mxsl + i_rt + (i_rt != 0);
686 }
687 *di = i_rt;
688 *wi = i_wF;
689 } /* else scientific for both */
690 if(*wr < 0) *wr = 0;
691 if(*wi < 0) *wi = 0;
692
693 /* Ensure space for Inf and NaN */
694 if (rnan && *wr < 3) *wr = 3;
695 if (rposinf && *wr < 3) *wr = 3;
696 if (rneginf && *wr < 4) *wr = 4;
697 if (inan && *wi < 3) *wi = 3;
698 if (iposinf && *wi < 3) *wi = 3;
699
700 /* finally, ensure that there is space for NA */
701
702 if (naflag && *wr+*wi+2 < R_print.na_width)
703 *wr += (R_print.na_width -(*wr + *wi + 2));
704 }
705
formatComplexS(SEXP x,R_xlen_t n,int * wr,int * dr,int * er,int * wi,int * di,int * ei,int nsmall)706 void formatComplexS(SEXP x, R_xlen_t n, int *wr, int *dr, int *er,
707 int *wi, int *di, int *ei, int nsmall)
708 {
709 /* format.info() for x[1..n] for both Re & Im */
710 int tmpwr, tmpdr, tmper, tmpwi, tmpdi, tmpei;
711
712 *wr = 0;
713 *wi = 0;
714 *dr = 0;
715 *di = 0;
716 *er = 0;
717 *ei = 0;
718 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, Rcomplex, COMPLEX, 0, n,
719 {
720 formatComplex(px, nb, &tmpwr, &tmpdr, &tmper,
721 &tmpwi, &tmpdi, &tmpei, nsmall);
722 if(tmpwr > *wr) *wr = tmpwr;
723 if(tmpdr && !*dr) *dr = tmpdr;
724 if(tmper > *er) *er = tmper;
725 if(tmpwi > *wi) *wi = tmpwi;
726 if(tmpdi && !*di) *di = tmpdi;
727 if(tmpei > *ei) *ei = tmpei;
728 });
729 }
730