1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1998-2017 The R Core Team.
4 * Copyright (C) 1995-1998 Robert Gentleman and Ross Ihaka
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 *
20 * EXPORTS printVector()
21 * printNamedVector()
22 * printRealVector()
23 * printRealVectorS()
24 * printIntegerVector()
25 * printIntegerVectorS()
26 * printComplexVector()
27 * printComplexVectorS()
28 *
29 * See ./printutils.c for remarks on Printing and the Encoding utils.
30 * See ./format.c for the formatXXXX functions used below.
31 */
32
33 #ifdef HAVE_CONFIG_H
34 #include <config.h>
35 #endif
36
37 #include "Rinternals.h"
38 #include "Print.h"
39 #include <R_ext/Itermacros.h> /* for ITERATE_BY_REGION */
40
41 #define DO_first_lab \
42 if (indx) { \
43 labwidth = IndexWidth(n) + 2; \
44 /* labwidth may well be \
45 one more than desired ..*/ \
46 VectorIndex(1, labwidth); \
47 width = labwidth; \
48 } \
49 else width = 0
50
51 #define DO_newline \
52 Rprintf("\n"); \
53 if (indx) { \
54 VectorIndex(i + 1, labwidth); \
55 width = labwidth; \
56 } \
57 else \
58 width = 0
59
60 /* print*Vector (* in {Real, Integer, Complex}) are exported, but no
61 longer directly called by internal R sources (which now call
62 print*VectorS for ALTREP support). Macros are used to prevent drift
63 between print*Vector and print*VectorS.
64
65 printIntegerVector(INTEGER(x)) and printIntegerVector(x) must
66 always give identical output, unless INTEGER(x) fails, en.g. during
67 allocation. */
68
69 /* i must be defined and contain the overall position in the vector
70 because DO_newline uses it
71 ENCCALL is the full invocation of Encode*() which
72 is passed to Rprintf
73 */
74
75 /* used for logical, integer, numeric and complex vectors */
76 #define NUMVECTOR_TIGHTLOOP(ENCCALL) do { \
77 if (i > 0 && width + w > R_print.width) { \
78 DO_newline; \
79 } \
80 Rprintf("%s", ENCCALL); \
81 width += w; \
82 } while(0)
83
84 /* used when printing character vectors */
85 #define CHARVECTOR_TIGHTLOOP(ENCCALL) do { \
86 if (i > 0 && width + w + R_print.gap > R_print.width) { \
87 DO_newline; \
88 } \
89 Rprintf("%*s%s", R_print.gap, "", \
90 ENCCALL); \
91 width += w + R_print.gap; \
92 } while (0)
93
94 /* used for raw vectors. Could be combined with character vectors
95 above but NB the different second conditions for the if
96 (width + w vs width + w + R_print.gap) and the different increment
97 on width.
98 */
99 #define RAWVECTOR_TIGHTLOOP(ptr, pos) do { \
100 if (i > 0 && width + w > R_print.width) { \
101 DO_newline; \
102 } \
103 Rprintf("%*s%s", R_print.gap, "", EncodeRaw(ptr[pos], "")); \
104 width += w; \
105 } while (0)
106
107 static
printLogicalVectorS(SEXP x,R_xlen_t n,int indx)108 void printLogicalVectorS(SEXP x, R_xlen_t n, int indx) {
109 int w, labwidth=0, width;
110 R_xlen_t i;
111 DO_first_lab;
112 formatLogicalS(x, n, &w);
113 w += R_print.gap;
114
115 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, int, LOGICAL, 0, n,
116 for(R_xlen_t j = 0; j < nb; j++) {
117 i = idx + j; /* for Do_newline */
118 NUMVECTOR_TIGHTLOOP( EncodeLogical(px[j], w) );
119 });
120 Rprintf("\n");
121 }
122
123 attribute_hidden
printIntegerVector(const int * x,R_xlen_t n,int indx)124 void printIntegerVector(const int *x, R_xlen_t n, int indx)
125 {
126 int w, labwidth=0, width;
127
128 DO_first_lab;
129 formatInteger(x, n, &w);
130 w += R_print.gap;
131
132 for (R_xlen_t i = 0; i < n; i++) {
133 NUMVECTOR_TIGHTLOOP(EncodeInteger(x[i], w));
134 }
135 Rprintf("\n");
136 }
137
138 attribute_hidden
printIntegerVectorS(SEXP x,R_xlen_t n,int indx)139 void printIntegerVectorS(SEXP x, R_xlen_t n, int indx)
140 {
141 int w, labwidth=0, width;
142 R_xlen_t i;
143 DO_first_lab;
144 formatIntegerS(x, n, &w);
145 w += R_print.gap;
146
147 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, int, INTEGER, 0, n,
148 for (R_xlen_t j = 0; j < nb; j++) {
149 i = idx + j; /* for macros */
150 NUMVECTOR_TIGHTLOOP(EncodeInteger(px[j], w));
151 });
152
153 Rprintf("\n");
154 }
155
156 // used in uncmin.c
157 // Not easily converted to printRealVectorS calls
158 attribute_hidden
printRealVector(const double * x,R_xlen_t n,int indx)159 void printRealVector(const double *x, R_xlen_t n, int indx)
160 {
161 int w, d, e, labwidth=0, width;
162
163 DO_first_lab;
164 formatReal(x, n, &w, &d, &e, 0);
165 w += R_print.gap;
166
167 for (R_xlen_t i = 0; i < n; i++) {
168 NUMVECTOR_TIGHTLOOP( EncodeReal0(x[i], w, d, e, OutDec) );
169 }
170 Rprintf("\n");
171 }
172
173 attribute_hidden
printRealVectorS(SEXP x,R_xlen_t n,int indx)174 void printRealVectorS(SEXP x, R_xlen_t n, int indx)
175 {
176 int w, d, e, labwidth=0, width;
177 R_xlen_t i;
178 DO_first_lab;
179 formatRealS(x, n, &w, &d, &e, 0);
180 w += R_print.gap;
181
182 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, double, REAL, 0, n,
183 for(R_xlen_t j = 0; j < nb; j++) {
184 i = idx + j; /* for macros */
185 NUMVECTOR_TIGHTLOOP(EncodeReal0(px[j], w, d, e, OutDec));
186 });
187
188 Rprintf("\n");
189 }
190
191 #define CMPLX_ISNA(cplx) (ISNA(cplx.r) || ISNA(cplx.i))
192 attribute_hidden
printComplexVector(const Rcomplex * x,R_xlen_t n,int indx)193 void printComplexVector(const Rcomplex *x, R_xlen_t n, int indx)
194 {
195 int w, wr, dr, er, wi, di, ei, labwidth=0, width;
196
197 DO_first_lab;
198 formatComplex(x, n, &wr, &dr, &er, &wi, &di, &ei, 0);
199
200 w = wr + wi + 2; /* +2 for "+" and "i" */
201 w += R_print.gap;
202
203 for (R_xlen_t i = 0; i < n; i++) {
204 NUMVECTOR_TIGHTLOOP(CMPLX_ISNA(x[i]) ?
205 EncodeReal0(NA_REAL, w, 0, 0, OutDec) :
206 EncodeComplex(x[i], wr + R_print.gap,
207 dr, er, wi, di, ei, OutDec));
208 }
209 Rprintf("\n");
210 }
211
212 attribute_hidden
printComplexVectorS(SEXP x,R_xlen_t n,int indx)213 void printComplexVectorS(SEXP x, R_xlen_t n, int indx)
214 {
215 int w, wr, dr, er, wi, di, ei, labwidth=0, width;
216 R_xlen_t i;
217 DO_first_lab;
218 formatComplexS(x, n, &wr, &dr, &er, &wi, &di, &ei, 0);
219
220 w = wr + wi + 2; /* +2 for "+" and "i" */
221 w += R_print.gap;
222
223 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, Rcomplex, COMPLEX, 0, n,
224 for(R_xlen_t j = 0; j < nb; j++) {
225 i = idx + j; /* for macros */
226 NUMVECTOR_TIGHTLOOP(CMPLX_ISNA(px[j]) ?
227 EncodeReal0(NA_REAL, w, 0, 0, OutDec) :
228 EncodeComplex(px[j], wr + R_print.gap , dr, er, wi, di, ei, OutDec));
229 });
230 Rprintf("\n");
231 }
232
233
printStringVector(const SEXP * x,R_xlen_t n,int quote,int indx)234 static void printStringVector(const SEXP *x, R_xlen_t n, int quote, int indx)
235 {
236 int w, labwidth=0, width;
237
238 DO_first_lab;
239 formatString(x, n, &w, quote);
240
241 for (R_xlen_t i = 0; i < n; i++) {
242 if (i > 0 && width + w + R_print.gap > R_print.width) {
243 DO_newline;
244 }
245 Rprintf("%*s%s", R_print.gap, "",
246 EncodeString(x[i], w, quote, R_print.right));
247 width += w + R_print.gap;
248 }
249 Rprintf("\n");
250 }
251
printStringVectorS(SEXP x,R_xlen_t n,int quote,int indx)252 static void printStringVectorS(SEXP x, R_xlen_t n, int quote, int indx)
253 {
254 /* because there's no get_region method for ALTSTRINGs
255 we hit the old version if we can to avoid the
256 STRING_ELT in the tight loop.
257
258 This will work for all nonALTREP STRSXPs as well as whenever
259 the ALTSTRING class is willing to give us a full dataptr from
260 Dataptr_or_null method. */
261
262 const SEXP *xptr = (const SEXP *) DATAPTR_OR_NULL(x);
263 if(xptr != NULL) {
264 printStringVector(xptr, n, quote, indx);
265 return;
266 }
267
268 int w, labwidth=0, width;
269
270 DO_first_lab;
271 formatStringS(x, n, &w, quote);
272
273 for (R_xlen_t i = 0; i < n; i++) {
274 CHARVECTOR_TIGHTLOOP(
275 EncodeString(STRING_ELT(x, i), w, quote, R_print.right)
276 );
277 }
278 Rprintf("\n");
279 }
280
281
282
283
284 attribute_hidden
printRawVector(const Rbyte * x,R_xlen_t n,int indx)285 void printRawVector(const Rbyte *x, R_xlen_t n, int indx)
286 {
287 int w, labwidth=0, width;
288
289 DO_first_lab;
290 formatRaw(x, n, &w);
291 w += R_print.gap;
292
293 for (R_xlen_t i = 0; i < n; i++) {
294 RAWVECTOR_TIGHTLOOP(x, i);
295 }
296 Rprintf("\n");
297 }
298
299
300 static
printRawVectorS(SEXP x,R_xlen_t n,int indx)301 void printRawVectorS(SEXP x, R_xlen_t n, int indx)
302 {
303 int w, labwidth=0, width;
304 R_xlen_t i;
305 DO_first_lab;
306 formatRawS(x, n, &w);
307 w += R_print.gap;
308
309 ITERATE_BY_REGION_PARTIAL(x, px, idx, nb, Rbyte, RAW, 0, n,
310 for(R_xlen_t j = 0; j < nb; j++) {
311 i = idx + j; /* for macros */
312 RAWVECTOR_TIGHTLOOP(px, j);
313 });
314 Rprintf("\n");
315 }
316
317
printVector(SEXP x,int indx,int quote)318 void printVector(SEXP x, int indx, int quote)
319 {
320 /* print R vector x[]; if(indx) print indices; if(quote) quote strings */
321 R_xlen_t n;
322
323 if ((n = XLENGTH(x)) != 0) {
324 R_xlen_t n_pr = (n <= R_print.max +1) ? n : R_print.max;
325 /* '...max +1' ==> will omit at least 2 ==> plural in msg below */
326 switch (TYPEOF(x)) {
327 case LGLSXP:
328 printLogicalVectorS(x, n_pr, indx);
329 break;
330 case INTSXP:
331 printIntegerVectorS(x, n_pr, indx);
332 break;
333 case REALSXP:
334 printRealVectorS(x, n_pr, indx);
335 break;
336 case STRSXP:
337 if (quote)
338 printStringVectorS(x, n_pr, '"', indx);
339 else
340 printStringVectorS(x, n_pr, 0, indx);
341 break;
342 case CPLXSXP:
343 printComplexVectorS(x, n_pr, indx);
344 break;
345 case RAWSXP:
346 printRawVectorS(x, n_pr, indx);
347 break;
348 }
349 if(n_pr < n)
350 Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
351 n - n_pr);
352 }
353 else
354 #define PRINT_V_0 \
355 switch (TYPEOF(x)) { \
356 case LGLSXP: Rprintf("logical(0)\n"); break; \
357 case INTSXP: Rprintf("integer(0)\n"); break; \
358 case REALSXP: Rprintf("numeric(0)\n"); break; \
359 case CPLXSXP: Rprintf("complex(0)\n"); break; \
360 case STRSXP: Rprintf("character(0)\n"); break; \
361 case RAWSXP: Rprintf("raw(0)\n"); break; \
362 }
363 PRINT_V_0;
364 }
365
366 #undef DO_first_lab
367 #undef DO_newline
368
369
370 /* The following code prints vectors which have every element named.
371
372 * Primitives for each type of vector are presented first, followed
373 * by the main (dispatching) function.
374 * 1) These primitives are almost identical... ==> use PRINT_N_VECTOR_SEXP macro
375 * 2) S prints a _space_ in the first column for named vectors; we dont.
376 */
377
378 #define PRINT_N_VECTOR_SEXP(INI_FORMAT, PRINT_1) \
379 { \
380 int i, j, k, nlines, nperline, w, wn; \
381 INI_FORMAT; \
382 \
383 formatStringS(names, n, &wn, 0); \
384 if (w < wn) w = wn; \
385 nperline = R_print.width / (w + R_print.gap); \
386 if (nperline <= 0) nperline = 1; \
387 nlines = n / nperline; \
388 if (n % nperline) nlines += 1; \
389 \
390 for (i = 0; i < nlines; i++) { \
391 if (i) Rprintf("\n"); \
392 for (j = 0; j < nperline && (k = i * nperline + j) < n; j++) \
393 Rprintf("%s%*s", \
394 EncodeString(STRING_ELT(names, k), w, 0, \
395 Rprt_adj_right), \
396 R_print.gap, ""); \
397 Rprintf("\n"); \
398 for (j = 0; j < nperline && (k = i * nperline + j) < n; j++) \
399 PRINT_1; \
400 } \
401 Rprintf("\n"); \
402 }
403
printNamedLogicalVectorS(SEXP x,int n,SEXP names)404 static void printNamedLogicalVectorS(SEXP x, int n, SEXP names)
405 PRINT_N_VECTOR_SEXP(formatLogicalS(x, n, &w),
406 Rprintf("%s%*s", EncodeLogical(LOGICAL_ELT(x, k), w),
407 R_print.gap,""))
408
409 static void printNamedIntegerVectorS(SEXP x, int n, SEXP names)
410 PRINT_N_VECTOR_SEXP(formatIntegerS(x, n, &w),
411 Rprintf("%s%*s", EncodeInteger(INTEGER_ELT(x, k), w),
412 R_print.gap,""))
413
414 #undef INI_F_REAL_S
415 #define INI_F_REAL_S int d, e; formatRealS(x, n, &w, &d, &e, 0)
416
417 static void printNamedRealVectorS(SEXP x, int n, SEXP names)
418 PRINT_N_VECTOR_SEXP(INI_F_REAL_S,
419 Rprintf("%s%*s",
420 EncodeReal0(REAL_ELT(x, k), w, d, e, OutDec),
421 R_print.gap,""))
422
423 #undef INI_F_CPLX_S
424 #define INI_F_CPLX_S \
425 int wr, dr, er, wi, di, ei; \
426 formatComplexS(x, n, &wr, &dr, &er, &wi, &di, &ei, 0); \
427 w = wr + wi + 2; \
428 Rcomplex tmp
429
430 #undef P_IMAG_NA
431 #define P_IMAG_NA(VALUE) \
432 if(ISNAN(VALUE.i)) \
433 Rprintf("+%si", "NaN"); \
434 else
435
436 static void printNamedComplexVectorS(SEXP x, int n, SEXP names)
437 PRINT_N_VECTOR_SEXP(INI_F_CPLX_S,
438 { /* PRINT_1 */
439 tmp = COMPLEX_ELT(x, k);
440 if(j) Rprintf("%*s", R_print.gap, "");
441 if (ISNA(tmp.r) || ISNA(tmp.i)) {
442 Rprintf("%s", EncodeReal0(NA_REAL, w, 0, 0, OutDec));
443 }
444 else {
445 Rprintf("%s", EncodeReal0(tmp.r, wr, dr, er, OutDec));
446 P_IMAG_NA(tmp)
447 if (tmp.i >= 0)
448 Rprintf("+%si", EncodeReal0(tmp.i, wi, di, ei, OutDec));
449 else
450 Rprintf("-%si", EncodeReal0(-tmp.i, wi, di, ei, OutDec));
451 }
452 })
453
454 static void printNamedStringVectorS(SEXP x, int n, int quote, SEXP names)
455 PRINT_N_VECTOR_SEXP(formatStringS(x, n, &w, quote),
456 Rprintf("%s%*s",
457 EncodeString(STRING_ELT(x, k), w, quote,
458 Rprt_adj_right),
459 R_print.gap, ""))
460
461 static void printNamedRawVectorS(SEXP x, int n, SEXP names)
462 PRINT_N_VECTOR_SEXP(formatRawS(x, n, &w),
463 Rprintf("%*s%s%*s", w - 2, "",
464 EncodeRaw(RAW_ELT(x, k), ""), R_print.gap,""))
465
466 attribute_hidden
467 void printNamedVector(SEXP x, SEXP names, int quote, const char *title)
468 {
469 int n;
470
471 if (title != NULL)
472 Rprintf("%s\n", title);
473
474 if ((n = LENGTH(x)) != 0) {
475 int n_pr = (n <= R_print.max +1) ? n : R_print.max;
476 /* '...max +1' ==> will omit at least 2 ==> plural in msg below */
477 switch (TYPEOF(x)) {
478 case LGLSXP:
479 printNamedLogicalVectorS(x, n_pr, names);
480 break;
481 case INTSXP:
482 printNamedIntegerVectorS(x, n_pr, names);
483 break;
484 case REALSXP:
485 printNamedRealVectorS(x, n_pr, names);
486 break;
487 case CPLXSXP:
488 printNamedComplexVectorS(x, n_pr, names);
489 break;
490 case STRSXP:
491 if(quote) quote = '"';
492 printNamedStringVectorS(x, n_pr, quote, names);
493 break;
494 case RAWSXP:
495 printNamedRawVectorS(x, n_pr, names);
496 break;
497 }
498 if(n_pr < n)
499 Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
500 n - n_pr);
501
502 }
503 else {
504 Rprintf("named ");
505 PRINT_V_0;
506 }
507 }
508