The R Project SVN R

Rev

Rev 87891 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
465 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
87761 maechler 3 
 *  Copyright (C) 2000--2025	The R Core Team
86902 maechler 4 
 *  Copyright (C) 2001--2012	The R Foundation
8552 maechler 5 
 *  Copyright (C) 1995, 1996	Robert Gentleman and Ross Ihaka
2 r 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
42307 ripley 18 
 *  along with this program; if not, a copy is available at
68947 ripley 19 
 *  https://www.R-project.org/Licenses/
1895 ihaka 20 
 *
21 
 *
22 
 *  EXPORTS	printMatrix()
4717 maechler 23 
 *		printArray()
1754 pd 24 
 *
1895 ihaka 25 
 *  See ./printutils.c	 for general remarks on Printing
4717 maechler 26 
 *			 and the Encode.. utils.
1895 ihaka 27 
 *
28 
 *  See ./format.c	 for the  format_FOO_  functions used below.
2 r 29 
 */
1895 ihaka 30 
 
5187 hornik 31 
#ifdef HAVE_CONFIG_H
7701 hornik 32 
#include <config.h>
5187 hornik 33 
#endif
34 
 
84211 ripley 35 
#include <Defn.h>
36 
#include <Print.h>
2 r 37 
 
39079 ripley 38 
#include <stdlib.h> /* for div() */
39 
 
69366 ripley 40 
/* We need display width of a string.
41 
   Used only for row/column names found by GetMatrixDimnames,
42 
   so in native encoding.  (NULL ones from do_prmatrix are skipped.)
43 
*/
87474 maechler 44 
int Rstrwid(const char *str, int slen, cetype_t ienc, int quote); /* from printutils.c */
59177 ripley 45 
#define strwidth(x) Rstrwid(x, (int) strlen(x), CE_NATIVE, 0)
34073 ripley 46 
 
38980 maechler 47 
/* ceil_DIV(a,b) :=  ceil(a / b)  in _int_ arithmetic : */
48 
static R_INLINE
49 
int ceil_DIV(int a, int b)
50 
{
51 
    div_t div_res = div(a, b);
52 
    return div_res.quot + ((div_res.rem != 0) ? 1 : 0);
53 
}
54 
 
42077 ripley 55 
/* moved from printutils.c */
38980 maechler 56 
 
42077 ripley 57 
static void MatrixColumnLabel(SEXP cl, int j, int w)
58 
{
59 
    if (!isNull(cl)) {
66734 maechler 60 
	SEXP tmp = STRING_ELT(cl, j);
61 
	int l = (tmp == NA_STRING) ? R_print.na_width_noquote : Rstrlen(tmp, 0);
42077 ripley 62 
	Rprintf("%*s%s", w-l, "",
63 
		EncodeString(tmp, l, 0, Rprt_adj_left));
64 
    }
65 
    else {
85535 kalibera 66 
	Rprintf("%*s[,%ld]", w-IndexWidth(j+1)-3, "", (long)j+1);
42077 ripley 67 
    }
68 
}
69 
 
70 
static void RightMatrixColumnLabel(SEXP cl, int j, int w)
71 
{
72 
    if (!isNull(cl)) {
66734 maechler 73 
	SEXP tmp = STRING_ELT(cl, j);
74 
	int l = (tmp == NA_STRING) ? R_print.na_width_noquote : Rstrlen(tmp, 0);
42077 ripley 75 
	/* This does not work correctly at least on FC3
76 
	Rprintf("%*s", R_print.gap+w,
77 
		EncodeString(tmp, l, 0, Rprt_adj_right)); */
78 
	Rprintf("%*s%s", R_print.gap+w-l, "",
45446 ripley 79 
		EncodeString(tmp, l, 0, Rprt_adj_right));
42077 ripley 80 
    }
81 
    else {
88856 kalibera 82 
	Rprintf("%*s[,%ld]", R_print.gap+w-IndexWidth(j+1)-3, "", (long)j+1);
42077 ripley 83 
    }
84 
}
85 
 
86 
static void LeftMatrixColumnLabel(SEXP cl, int j, int w)
87 
{
88 
    if (!isNull(cl)) {
66734 maechler 89 
	SEXP tmp = STRING_ELT(cl, j);
90 
	int l = (tmp == NA_STRING) ? R_print.na_width_noquote : Rstrlen(tmp, 0);
42077 ripley 91 
	Rprintf("%*s%s%*s", R_print.gap, "",
92 
		EncodeString(tmp, l, 0, Rprt_adj_left), w-l, "");
93 
    }
94 
    else {
85535 kalibera 95 
	Rprintf("%*s[,%ld]%*s", R_print.gap, "", (long)j+1, w-IndexWidth(j+1)-3, "");
42077 ripley 96 
    }
97 
}
98 
 
99 
static void MatrixRowLabel(SEXP rl, int i, int rlabw, int lbloff)
100 
{
101 
    if (!isNull(rl)) {
66734 maechler 102 
	SEXP tmp = STRING_ELT(rl, i);
103 
	int l = (tmp == NA_STRING) ? R_print.na_width_noquote : Rstrlen(tmp, 0);
42077 ripley 104 
	Rprintf("\n%*s%s%*s", lbloff, "",
105 
		EncodeString(tmp, l, 0, Rprt_adj_left),
106 
		rlabw-l-lbloff, "");
107 
    }
108 
    else {
85535 kalibera 109 
	Rprintf("\n%*s[%ld,]", rlabw-3-IndexWidth(i + 1), "", (long)i+1);
42077 ripley 110 
    }
111 
}
112 
 
113 
 
114 
 
38954 maechler 115 
/* This is the first (of 6)  print<TYPE>Matrix()  functions.
116 
 * We define macros that will be re-used in the other functions,
117 
 * and comment the common code here (only):
118 
*/
38961 maechler 119 
static void printLogicalMatrix(SEXP sx, int offset, int r_pr, int r, int c,
66734 maechler 120 
			       SEXP rl, SEXP cl, const char *rn, const char *cn,
87891 ripley 121 
			       bool print_ij)
2 r 122 
{
38954 maechler 123 
/* initialization; particularly of row labels, rl= dimnames(.)[[1]] and
124 
 * rn = names(dimnames(.))[1] : */
125 
#define _PRINT_INIT_rl_rn				\
58298 maechler 126 
    int *w = (int *) R_alloc(c, sizeof(int));		\
38954 maechler 127 
    int width, rlabw = -1, clabw = -1; /* -Wall */	\
128 
    int i, j, jmin = 0, jmax = 0, lbloff = 0;		\
129 
							\
130 
    if (!isNull(rl))					\
73750 luke 131 
	formatString(STRING_PTR_RO(rl), r, &rlabw, 0);	\
38954 maechler 132 
    else						\
133 
	rlabw = IndexWidth(r + 1) + 3;			\
134 
							\
135 
    if (rn) {						\
136 
	int rnw = strwidth(rn);				\
137 
	if ( rnw < rlabw + R_MIN_LBLOFF )		\
138 
	    lbloff = R_MIN_LBLOFF;			\
139 
	else						\
140 
	    lbloff = rnw - rlabw;			\
141 
							\
142 
	rlabw += lbloff;				\
143 
    }
4731 pd 144 
 
66734 maechler 145 
#   define _COMPUTE_W2_(_FORMAT_j_, _LAST_j_)				\
146 
    /* compute w[j] = column-width of j(+1)-th column : */		\
147 
    for (j = 0; j < c; j++) {						\
148 
	if(print_ij) { _FORMAT_j_; } else w[j] = 0;			\
149 
									\
150 
	if (!isNull(cl)) {						\
151 
	    const void *vmax = vmaxget();				\
152 
	    if(STRING_ELT(cl, j) == NA_STRING)				\
153 
		clabw = R_print.na_width_noquote;			\
40705 ripley 154 
	    else clabw = strwidth(translateChar(STRING_ELT(cl, j)));	\
66734 maechler 155 
	    vmaxset(vmax);						\
156 
	} else								\
157 
	    clabw = IndexWidth(j + 1) + 3;				\
158 
									\
159 
	if (w[j] < clabw)						\
160 
	    w[j] = clabw;						\
161 
	_LAST_j_;							\
162 
    }
38954 maechler 163 
 
66734 maechler 164 
#   define _COMPUTE_W_(F_j) _COMPUTE_W2_(F_j, w[j] += R_print.gap)
165 
    //                               _LAST_j  ------------------- for all but String
38954 maechler 166 
 
66734 maechler 167 
#   define _PRINT_ROW_LAB			\
168 
						\
169 
    if (cn != NULL)				\
170 
	Rprintf("%*s%s\n", rlabw, "", cn);	\
171 
    if (rn != NULL)				\
172 
	Rprintf("%*s", -rlabw, rn);		\
173 
    else					\
174 
	Rprintf("%*s", rlabw, "")
38954 maechler 175 
 
66734 maechler 176 
#   define _PRINT_MATRIX_(_W_EXTRA_, DO_COLUMN_LABELS, ENCODE_I_J)	\
177 
									\
178 
    if (c == 0) {							\
179 
	_PRINT_ROW_LAB;							\
180 
	for (i = 0; i < r; i++)						\
181 
	    MatrixRowLabel(rl, i, rlabw, lbloff);			\
182 
	Rprintf("\n");							\
183 
    }									\
184 
    else while (jmin < c) {						\
185 
	/* print columns  jmin:(jmax-1)	 where jmax has to be determined first */ \
186 
									\
187 
	width = rlabw;							\
188 
	/* initially, jmax = jmin */					\
189 
	do {								\
190 
	    width += w[jmax] _W_EXTRA_;					\
191 
	    jmax++;							\
192 
	}								\
193 
	while (jmax < c && width + w[jmax] _W_EXTRA_ < R_print.width);	\
194 
									\
195 
	_PRINT_ROW_LAB;							\
196 
									\
197 
	DO_COLUMN_LABELS;						\
198 
									\
199 
	for (i = 0; i < r_pr; i++) {					\
200 
	    MatrixRowLabel(rl, i, rlabw, lbloff); /* starting with an "\n" */ \
201 
	    if(print_ij) for (j = jmin; j < jmax; j++) {		\
202 
		ENCODE_I_J;						\
203 
	    }								\
204 
	}								\
205 
	Rprintf("\n");							\
206 
	jmin = jmax;							\
20812 ripley 207 
    }
38954 maechler 208 
 
66734 maechler 209 
#   define STD_ColumnLabels			\
210 
	for (j = jmin; j < jmax ; j++)		\
211 
	    MatrixColumnLabel(cl, j, w[j])
38954 maechler 212 
 
66734 maechler 213 
    _PRINT_INIT_rl_rn;
73728 luke 214 
    const int *x = LOGICAL_RO(sx) + offset;
4731 pd 215 
 
74734 kalibera 216 
    _COMPUTE_W_( formatLogical(&x[j * (R_xlen_t) r], (R_xlen_t) r, &w[j]) );
38961 maechler 217 
 
66734 maechler 218 
    _PRINT_MATRIX_( , STD_ColumnLabels,
74734 kalibera 219 
		   Rprintf("%s", EncodeLogical(x[i + j * (R_xlen_t) r], w[j])));
2 r 220 
}
221 
 
38961 maechler 222 
static void printIntegerMatrix(SEXP sx, int offset, int r_pr, int r, int c,
66734 maechler 223 
			       SEXP rl, SEXP cl, const char *rn, const char *cn,
87891 ripley 224 
			       bool print_ij)
2 r 225 
{
38954 maechler 226 
    _PRINT_INIT_rl_rn;
73728 luke 227 
    const int *x = INTEGER_RO(sx) + offset;
4717 maechler 228 
 
74734 kalibera 229 
    _COMPUTE_W_( formatInteger(&x[j * (R_xlen_t) r], (R_xlen_t) r, &w[j]) );
4710 pd 230 
 
66734 maechler 231 
    _PRINT_MATRIX_( , STD_ColumnLabels,
74734 kalibera 232 
		   Rprintf("%s", EncodeInteger(x[i + j * (R_xlen_t) r], w[j])));
2 r 233 
}
234 
 
38961 maechler 235 
static void printRealMatrix(SEXP sx, int offset, int r_pr, int r, int c,
66734 maechler 236 
			    SEXP rl, SEXP cl, const char *rn, const char *cn,
87891 ripley 237 
			    bool print_ij)
2 r 238 
{
38954 maechler 239 
    _PRINT_INIT_rl_rn;
73728 luke 240 
    const double *x = REAL_RO(sx) + offset;
58298 maechler 241 
    int *d = (int *) R_alloc(c, sizeof(int)),
242 
	*e = (int *) R_alloc(c, sizeof(int));
2 r 243 
 
74734 kalibera 244 
    _COMPUTE_W_( formatReal(&x[j * (R_xlen_t) r], (R_xlen_t) r, &w[j],
86902 maechler 245 
			    &d[j], &e[j], 0) );
4731 pd 246 
 
66734 maechler 247 
    _PRINT_MATRIX_( , STD_ColumnLabels,
74734 kalibera 248 
		   Rprintf("%s", EncodeReal0(x[i + j * (R_xlen_t) r],
86902 maechler 249 
					     w[j], d[j], e[j], OutDec)) );
2 r 250 
}
251 
 
38961 maechler 252 
static void printComplexMatrix(SEXP sx, int offset, int r_pr, int r, int c,
66734 maechler 253 
			       SEXP rl, SEXP cl, const char *rn, const char *cn,
87891 ripley 254 
			       bool print_ij)
2 r 255 
{
38954 maechler 256 
    _PRINT_INIT_rl_rn;
73728 luke 257 
    const Rcomplex *x = COMPLEX_RO(sx) + offset;
58298 maechler 258 
    int *dr = (int *) R_alloc(c, sizeof(int)),
259 
	*er = (int *) R_alloc(c, sizeof(int)),
260 
	*wr = (int *) R_alloc(c, sizeof(int)),
261 
	*di = (int *) R_alloc(c, sizeof(int)),
262 
	*ei = (int *) R_alloc(c, sizeof(int)),
263 
	*wi = (int *) R_alloc(c, sizeof(int));
2 r 264 
 
580 ihaka 265 
    /* Determine the column widths */
74734 kalibera 266 
    _COMPUTE_W_( formatComplex(&x[j * (R_xlen_t) r], (R_xlen_t) r,
66734 maechler 267 
			       &wr[j], &dr[j], &er[j],
268 
			       &wi[j], &di[j], &ei[j], 0);
269 
		 w[j] = wr[j] + wi[j] + 2 );
2 r 270 
 
66734 maechler 271 
    _PRINT_MATRIX_( , STD_ColumnLabels,
74734 kalibera 272 
		   if (ISNA(x[i + j * (R_xlen_t) r].r) ||
273 
		       ISNA(x[i + j * (R_xlen_t) r].i))
274 
 
66734 maechler 275 
		       Rprintf("%s", EncodeReal0(NA_REAL, w[j], 0, 0, OutDec));
276 
		   else
70352 murdoch 277 
		       /* Note that the label printing may modify w[j], so wr[j] is not
278 
		          necessarily still valid, and we use w[j] - wi[j] - 2  */
66734 maechler 279 
		       Rprintf("%s",
74734 kalibera 280 
			       EncodeComplex(x[i + j * (R_xlen_t) r],
70352 murdoch 281 
					     w[j] - wi[j] - 2, dr[j], er[j],
66734 maechler 282 
					     wi[j], di[j], ei[j], OutDec)) )
2 r 283 
}
284 
 
38961 maechler 285 
static void printStringMatrix(SEXP sx, int offset, int r_pr, int r, int c,
4717 maechler 286 
			      int quote, int right, SEXP rl, SEXP cl,
87891 ripley 287 
			      const char *rn, const char *cn, bool print_ij)
2 r 288 
{
38954 maechler 289 
    _PRINT_INIT_rl_rn;
73750 luke 290 
    const SEXP *x = STRING_PTR_RO(sx)+offset;
2 r 291 
 
74734 kalibera 292 
    _COMPUTE_W2_( formatString(&x[j * (R_xlen_t) r], (R_xlen_t) r,
293 
                               &w[j], quote), );
4731 pd 294 
 
66734 maechler 295 
    _PRINT_MATRIX_( + R_print.gap,
296 
	           /* DO_COLUMN_LABELS = */
297 
		   if (right) {
298 
		       for (j = jmin; j < jmax ; j++)
299 
			   RightMatrixColumnLabel(cl, j, w[j]);
300 
		   }
301 
		   else {
302 
		       for (j = jmin; j < jmax ; j++)
303 
			   LeftMatrixColumnLabel(cl, j, w[j]);
304 
		   },
305 
		   /* ENCODE_I = */
306 
		   Rprintf("%*s%s", R_print.gap, "",
74734 kalibera 307 
			   EncodeString(x[i + j * (R_xlen_t) r],
308 
		                        w[j], quote, right)) );
2 r 309 
}
310 
 
38961 maechler 311 
static void printRawMatrix(SEXP sx, int offset, int r_pr, int r, int c,
66734 maechler 312 
			   SEXP rl, SEXP cl, const char *rn, const char *cn,
87891 ripley 313 
			   bool print_ij)
34538 ripley 314 
{
38954 maechler 315 
    _PRINT_INIT_rl_rn;
73728 luke 316 
    const Rbyte *x = RAW_RO(sx) + offset;
34538 ripley 317 
 
74734 kalibera 318 
    _COMPUTE_W_( formatRaw(&x[j * (R_xlen_t) r], (R_xlen_t) r, &w[j]) )
34538 ripley 319 
 
66734 maechler 320 
    _PRINT_MATRIX_( , STD_ColumnLabels,
74734 kalibera 321 
		   Rprintf("%*s%s", w[j]-2, "",
322 
		   EncodeRaw(x[i + j * (R_xlen_t) r], "")) );
34538 ripley 323 
}
324 
 
69366 ripley 325 
/* rm and cn are found by GetMatrixDimnames so in native encoding */
61776 ripley 326 
attribute_hidden
1858 ihaka 327 
void printMatrix(SEXP x, int offset, SEXP dim, int quote, int right,
41784 ripley 328 
		 SEXP rl, SEXP cl, const char *rn, const char *cn)
2 r 329 
{
38954 maechler 330 
/* 'rl' and 'cl' are dimnames(.)[[1]] and dimnames(.)[[2]]  whereas
331 
 * 'rn' and 'cn' are the  names(dimnames(.))
332 
 */
63155 luke 333 
    const void *vmax = vmaxget();
73728 luke 334 
    const int *pdim = INTEGER_RO(dim);
335 
    int r = pdim[0];
86902 maechler 336 
    int c = pdim[1];
12976 pd 337 
    /* PR#850 */
38980 maechler 338 
    if ((rl != R_NilValue) && (r > length(rl)))
32871 ripley 339 
	error(_("too few row labels"));
38980 maechler 340 
    if ((cl != R_NilValue) && (c > length(cl)))
32871 ripley 341 
	error(_("too few column labels"));
66734 maechler 342 
    if (r == 0 && c == 0) { // FIXME?  names(dimnames(.)) :
20812 ripley 343 
	Rprintf("<0 x 0 matrix>\n");
344 
	return;
345 
    }
86902 maechler 346 
 
347 
    int r_pr = r,
348 
	/* Make sure we don't display more columns than max elements, see PR#15027 */
349 
	c_pr = c > R_print.max ? R_print.max : c;
350 
 
38961 maechler 351 
    if(c > 0 && R_print.max / c < r) /* avoid integer overflow */
38980 maechler 352 
	/* using floor(), not ceil(), since 'c' could be huge: */
38961 maechler 353 
	r_pr = R_print.max / c;
86902 maechler 354 
    /* Display at least one row in case of truncation */
355 
    if (c > c_pr && r_pr < 1 && r > 0)
356 
	r_pr = 1;
1820 ihaka 357 
    switch (TYPEOF(x)) {
358 
    case LGLSXP:
87891 ripley 359 
	printLogicalMatrix(x, offset, r_pr, r, c_pr, rl, cl, rn, cn, true);
1820 ihaka 360 
	break;
361 
    case INTSXP:
87891 ripley 362 
	printIntegerMatrix(x, offset, r_pr, r, c_pr, rl, cl, rn, cn, true);
1820 ihaka 363 
	break;
364 
    case REALSXP:
87891 ripley 365 
	printRealMatrix	  (x, offset, r_pr, r, c_pr, rl, cl, rn, cn, true);
1820 ihaka 366 
	break;
367 
    case CPLXSXP:
87891 ripley 368 
	printComplexMatrix(x, offset, r_pr, r, c_pr, rl, cl, rn, cn, true);
1820 ihaka 369 
	break;
370 
    case STRSXP:
371 
	if (quote) quote = '"';
87891 ripley 372 
	printStringMatrix (x, offset, r_pr, r, c_pr, quote, right, rl, cl, rn, cn, true);
1820 ihaka 373 
	break;
34538 ripley 374 
    case RAWSXP:
87891 ripley 375 
	printRawMatrix	  (x, offset, r_pr, r, c_pr, rl, cl, rn, cn, true);
34538 ripley 376 
	break;
34547 ripley 377 
    default:
378 
	UNIMPLEMENTED_TYPE("printMatrix", x);
1820 ihaka 379 
    }
86902 maechler 380 
    if (r_pr < r || c_pr < c) {
87167 maechler 381 
	Rprintf(" [ reached 'max' / getOption(\"max.print\") -- omitted");
86902 maechler 382 
	if (r_pr < r) {
383 
    	    Rprintf(ngettext(" %d row", " %d rows", r - r_pr), r - r_pr);
384 
	}
385 
	if (c_pr < c) {
386 
	    if (r_pr < r) Rprintf(_(" and"));
387 
	    Rprintf(ngettext(" %d column", " %d columns", c - c_pr), c - c_pr);
388 
	}
389 
	Rprintf(" ]\n");
390 
    }
63155 luke 391 
    vmaxset(vmax);
1820 ihaka 392 
}
393 
 
61776 ripley 394 
attribute_hidden
395 
void printArray(SEXP x, SEXP dim, int quote, int right, SEXP dimnames)
1820 ihaka 396 
{
3076 pd 397 
/* == printArray(.) */
63155 luke 398 
    const void *vmax = vmaxget();
78127 kalibera 399 
    int ndim = LENGTH(dim), nprotect = 0;
41937 ripley 400 
    const char *rn = NULL, *cn = NULL;
1820 ihaka 401 
 
402 
    if (ndim == 1)
403 
	printVector(x, 1, quote);
404 
    else if (ndim == 2) {
405 
	SEXP rl, cl;
4710 pd 406 
	GetMatrixDimnames(x, &rl, &cl, &rn, &cn);
407 
	printMatrix(x, 0, dim, quote, 0, rl, cl, rn, cn);
1820 ihaka 408 
    }
38961 maechler 409 
    else { /* ndim >= 3 */
38915 maechler 410 
	SEXP dn, dnn, dn0, dn1;
73728 luke 411 
	const int *dims = INTEGER_RO(dim);
87761 maechler 412 
	int i, j, nb, nb_pr, ne_last, nc_last, nr_last,
73728 luke 413 
	    nr = dims[0], nc = dims[1],
66734 maechler 414 
	    b = nr * nc;
87891 ripley 415 
	bool max_reached, has_dimnames = (dimnames != R_NilValue),
66734 maechler 416 
	    has_dnn = has_dimnames;
38961 maechler 417 
 
66734 maechler 418 
	if (!has_dimnames) {
1858 ihaka 419 
	    dn0 = R_NilValue;
420 
	    dn1 = R_NilValue;
38915 maechler 421 
	    dnn = R_NilValue; /* -Wall */
1858 ihaka 422 
	}
423 
	else {
10172 luke 424 
	    dn0 = VECTOR_ELT(dimnames, 0);
425 
	    dn1 = VECTOR_ELT(dimnames, 1);
4710 pd 426 
	    dnn = getAttrib(dimnames, R_NamesSymbol);
4717 maechler 427 
	    has_dnn = !isNull(dnn);
4710 pd 428 
	    if ( has_dnn ) {
78127 kalibera 429 
		PROTECT(dnn);
430 
		nprotect++;
41784 ripley 431 
		rn = (char *) translateChar(STRING_ELT(dnn, 0));
432 
		cn = (char *) translateChar(STRING_ELT(dnn, 1));
4710 pd 433 
	    }
1858 ihaka 434 
	}
38961 maechler 435 
	/* nb := #{entries} in a slice such as x[1,1,..] or equivalently,
436 
	 *       the number of matrix slices   x[ , , *, ..]  which
437 
	 *       are printed as matrices -- if options("max.print") allows */
438 
	for (i = 2, nb = 1; i < ndim; i++)
66734 maechler 439 
	    nb *= dims[i];
38980 maechler 440 
	max_reached = (b > 0 && R_print.max / b < nb);
441 
	if (max_reached) { /* i.e., also  b > 0, nr > 0, nc > 0, nb > 0 */
442 
	    /* nb_pr := the number of matrix slices to be printed */
443 
	    nb_pr = ceil_DIV(R_print.max, b);
444 
	    /* for the last, (nb_pr)th matrix slice, use only nr_last rows;
445 
	     *  using floor(), not ceil(), since 'nc' could be huge: */
87761 maechler 446 
	    ne_last = R_print.max - b * (nb_pr - 1);
87770 maechler 447 
	    nc_last = (ne_last < nc) ? ne_last : nc;
448 
	    nr_last = (ne_last < nc) ? 1 : ne_last / nc;
87761 maechler 449 
	    if(nr_last == 0) { nb_pr--; nc_last = nc; nr_last = nr;}
38980 maechler 450 
	} else {
66734 maechler 451 
	    nb_pr = (nb > 0) ? nb : 1; // do print *something* when dim = c(a,b,0)
87761 maechler 452 
	    ne_last = b;
453 
	    nc_last = nc;
38980 maechler 454 
	    nr_last = nr;
455 
	}
456 
	for (i = 0; i < nb_pr; i++) {
87891 ripley 457 
	    bool do_ij = nb > 0,
66734 maechler 458 
		i_last = (i == nb_pr - 1); /* for the last slice */
87761 maechler 459 
	    int	use_nc = i_last ? nc_last : nc,
460 
		use_nr = i_last ? nr_last : nr;
66734 maechler 461 
	    if(do_ij) {
462 
		int k = 1;
463 
		Rprintf(", ");
464 
		for (j = 2 ; j < ndim; j++) {
465 
		    int l = (i / k) % dims[j] + 1;
466 
		    if (has_dimnames &&
467 
			((dn = VECTOR_ELT(dimnames, j)) != R_NilValue)) {
468 
			if ( has_dnn )
469 
			    Rprintf(", %s = %s",
470 
				    translateChar(STRING_ELT(dnn, j)),
471 
				    translateChar(STRING_ELT(dn, l - 1)));
472 
			else
473 
			    Rprintf(", %s", translateChar(STRING_ELT(dn, l - 1)));
474 
		    } else
475 
			Rprintf(", %d", l);
476 
		    k *= dims[j];
477 
		}
478 
		Rprintf("\n\n");
479 
	    } else { // nb == 0 -- e.g. <2 x 3 x 0 array of logical>
480 
		for (i = 0; i < ndim; i++)
481 
		    Rprintf("%s%d", (i == 0) ? "<" : " x ", dims[i]);
482 
		Rprintf(" array of %s>\n", CHAR(type2str_nowarn(TYPEOF(x))));
38980 maechler 483 
	    }
1820 ihaka 484 
	    switch (TYPEOF(x)) {
485 
	    case LGLSXP:
87761 maechler 486 
		printLogicalMatrix(x, i * b, use_nr, nr, use_nc, dn0, dn1, rn, cn, do_ij);
2 r 487 
		break;
1820 ihaka 488 
	    case INTSXP:
87761 maechler 489 
		printIntegerMatrix(x, i * b, use_nr, nr, use_nc, dn0, dn1, rn, cn, do_ij);
2 r 490 
		break;
1820 ihaka 491 
	    case REALSXP:
87761 maechler 492 
		printRealMatrix   (x, i * b, use_nr, nr, use_nc, dn0, dn1, rn, cn, do_ij);
2 r 493 
		break;
1820 ihaka 494 
	    case CPLXSXP:
87761 maechler 495 
		printComplexMatrix(x, i * b, use_nr, nr, use_nc, dn0, dn1, rn, cn, do_ij);
2 r 496 
		break;
1820 ihaka 497 
	    case STRSXP:
2 r 498 
		if (quote) quote = '"';
87761 maechler 499 
		printStringMatrix (x, i * b, use_nr, nr, use_nc,
66734 maechler 500 
				   quote, right, dn0, dn1, rn, cn, do_ij);
2 r 501 
		break;
34538 ripley 502 
	    case RAWSXP:
87761 maechler 503 
		printRawMatrix    (x, i * b, use_nr, nr, use_nc, dn0, dn1, rn, cn, do_ij);
34538 ripley 504 
		break;
1820 ihaka 505 
	    }
506 
	    Rprintf("\n");
2 r 507 
	}
38980 maechler 508 
 
87761 maechler 509 
	if (max_reached) {
87167 maechler 510 
	    Rprintf(" [ reached 'max' / getOption(\"max.print\") -- omitted");
87761 maechler 511 
	    if (nb_pr < nb)
512 
		Rprintf(ngettext(" %d slice", " %d slices", nb - nb_pr), nb - nb_pr);
513 
	    else if (nb_pr == nb) {
514 
		if((nr -= nr_last) > 0) Rprintf(ngettext(" %d row",    " %d rows",    nr), nr);
515 
		if((nc -= nc_last) > 0) Rprintf(ngettext(" %d column", " %d columns", nc), nc);
516 
	    }
517 
	    Rprintf(" ] \n");
38980 maechler 518 
	}
1820 ihaka 519 
    }
78127 kalibera 520 
    UNPROTECT(nprotect);
63155 luke 521 
    vmaxset(vmax);
2 r 522 
}