The R Project SVN R

Rev

Rev 60667 | Rev 65085 | Go to most recent revision | 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
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
59075 ripley 4 
 *  Copyright (C) 1997--2012  The R Core Team
2 r 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
42307 ripley 17 
 *  along with this program; if not, a copy is available at
18 
 *  http://www.r-project.org/Licenses/
1895 ihaka 19 
 *
20 
 *
21 
 *  See ./printutils.c	 for general remarks on Printing
22 
 *                       and the Encode.. utils.
23 
 *
24 
 *  See ./format.c	 for the  format_Foo_  functions.
2 r 25 
 */
26 
 
5187 hornik 27 
#ifdef HAVE_CONFIG_H
7701 hornik 28 
#include <config.h>
5187 hornik 29 
#endif
30 
 
2 r 31 
#include "Defn.h"
60667 ripley 32 
#include <Internal.h>
33 
 
41631 ripley 34 
#define imax2(x, y) ((x < y) ? y : x)
41899 ripley 35 
 
2 r 36 
#include "Print.h"
41899 ripley 37 
#include "RBufferUtils.h"
38 
static R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2 r 39 
 
57795 maechler 40 
/*
41 
  .Internal(paste (args, sep, collapse))
42 
  .Internal(paste0(args, collapse))
43 
 
1895 ihaka 44 
 * do_paste uses two passes to paste the arguments (in CAR(args)) together.
465 maechler 45 
 * The first pass calculates the width of the paste buffer,
46 
 * then it is alloc-ed and the second pass stuffs the information in.
47 
 */
43724 ripley 48 
 
45446 ripley 49 
/* Note that NA_STRING is not handled separately here.  This is
43724 ripley 50 
   deliberate -- see ?paste -- and implicitly coerces it to "NA"
51 
*/
36990 ripley 52 
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 53 
{
41495 rgentlem 54 
    SEXP ans, collapse, sep, x;
59046 ripley 55 
    int sepw, u_sepw, ienc;
56 
    R_xlen_t i, j, k, maxlen, nx, pwidth;
57795 maechler 57 
    const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
45847 ripley 58 
    char *buf;
57795 maechler 59 
    Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
59046 ripley 60 
	sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
57795 maechler 61 
	use_sep = (PRIMVAL(op) == 0);
50880 ripley 62 
    const void *vmax;
2 r 63 
 
1895 ihaka 64 
    checkArity(op, args);
465 maechler 65 
 
54753 ripley 66 
    /* We use formatting and so we must initialize printing. */
2 r 67 
 
54049 ripley 68 
    PrintDefaults();
2 r 69 
 
1895 ihaka 70 
    /* Check the arguments */
2 r 71 
 
1895 ihaka 72 
    x = CAR(args);
73 
    if (!isVectorList(x))
41686 ripley 74 
	error(_("invalid first argument"));
59046 ripley 75 
    nx = xlength(x);
2 r 76 
 
57795 maechler 77 
    if(use_sep) { /* paste(..., sep, .) */
78 
	sep = CADR(args);
79 
	if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
80 
	    error(_("invalid separator"));
81 
	sep = STRING_ELT(sep, 0);
82 
	csep = translateChar(sep);
59177 ripley 83 
	u_sepw = sepw = (int) strlen(csep); // will be short
57795 maechler 84 
	sepASCII = strIsASCII(csep);
85 
	sepKnown = ENC_KNOWN(sep) > 0;
86 
	sepUTF8 = IS_UTF8(sep);
87 
	sepBytes = IS_BYTES(sep);
88 
	collapse = CADDR(args);
89 
    } else { /* paste0(..., .) */
90 
	u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
91 
	collapse = CADR(args);
92 
    }
1895 ihaka 93 
    if (!isNull(collapse))
43724 ripley 94 
	if(!isString(collapse) || LENGTH(collapse) <= 0 ||
95 
	   STRING_ELT(collapse, 0) == NA_STRING)
41686 ripley 96 
	    error(_("invalid '%s' argument"), "collapse");
43466 ripley 97 
    if(nx == 0)
98 
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
2 r 99 
 
45446 ripley 100 
 
43466 ripley 101 
    /* Maximum argument length, coerce if needed */
2 r 102 
 
1895 ihaka 103 
    maxlen = 0;
104 
    for (j = 0; j < nx; j++) {
43466 ripley 105 
	if (!isString(VECTOR_ELT(x, j))) {
106 
	    /* formerly in R code: moved to C for speed */
107 
	    SEXP call, xj = VECTOR_ELT(x, j);
108 
	    if(OBJECT(xj)) { /* method dispatch */
109 
		PROTECT(call = lang2(install("as.character"), xj));
110 
		SET_VECTOR_ELT(x, j, eval(call, env));
111 
		UNPROTECT(1);
112 
	    } else if (isSymbol(xj))
113 
		SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
114 
	    else
115 
		SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
116 
 
117 
	    if (!isString(VECTOR_ELT(x, j)))
60844 ripley 118 
		error(_("non-string argument to internal 'paste'"));
43466 ripley 119 
	}
59046 ripley 120 
	if(xlength(VECTOR_ELT(x, j)) > maxlen)
121 
	    maxlen = xlength(VECTOR_ELT(x, j));
1895 ihaka 122 
    }
123 
    if(maxlen == 0)
24842 ripley 124 
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
1895 ihaka 125 
 
126 
    PROTECT(ans = allocVector(STRSXP, maxlen));
127 
 
128 
    for (i = 0; i < maxlen; i++) {
43724 ripley 129 
	/* Strategy for marking the encoding: if all inputs (including
130 
	 * the separator) are ASCII, so is the output and we don't
131 
	 * need to mark.  Otherwise if all non-ASCII inputs are of
132 
	 * declared encoding, we should mark.
133 
	 * Need to be careful only to include separator if it is used.
134 
	 */
54753 ripley 135 
	anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
43724 ripley 136 
	if(nx > 1) {
45847 ripley 137 
	    allKnown = sepKnown || sepASCII;
138 
	    anyKnown = sepKnown;
139 
	    use_UTF8 = sepUTF8;
54753 ripley 140 
	    use_Bytes = sepBytes;
43724 ripley 141 
	}
45446 ripley 142 
 
1895 ihaka 143 
	pwidth = 0;
1839 ihaka 144 
	for (j = 0; j < nx; j++) {
59046 ripley 145 
	    k = xlength(VECTOR_ELT(x, j));
45847 ripley 146 
	    if (k > 0) {
147 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
148 
		if(IS_UTF8(cs)) use_UTF8 = TRUE;
54753 ripley 149 
		if(IS_BYTES(cs)) use_Bytes = TRUE;
45847 ripley 150 
	    }
1820 ihaka 151 
	}
54753 ripley 152 
	if (use_Bytes) use_UTF8 = FALSE;
50880 ripley 153 
	vmax = vmaxget();
45847 ripley 154 
	for (j = 0; j < nx; j++) {
59046 ripley 155 
	    k = xlength(VECTOR_ELT(x, j));
45847 ripley 156 
	    if (k > 0) {
54753 ripley 157 
		if(use_Bytes)
158 
		    pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
159 
		else if(use_UTF8)
45847 ripley 160 
		    pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
161 
		else
162 
		    pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
50880 ripley 163 
		vmaxset(vmax);
45847 ripley 164 
	    }
165 
	}
57795 maechler 166 
	if(use_sep) {
167 
	    if (use_UTF8 && !u_csep) {
168 
		u_csep = translateCharUTF8(sep);
59177 ripley 169 
		u_sepw = (int) strlen(u_csep); // will be short
57795 maechler 170 
	    }
171 
	    pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
45847 ripley 172 
	}
59046 ripley 173 
	if (pwidth > INT_MAX)
174 
	    error(_("result would exceed 2^31-1 bytes"));
41899 ripley 175 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
50880 ripley 176 
	vmax = vmaxget();
1895 ihaka 177 
	for (j = 0; j < nx; j++) {
59046 ripley 178 
	    k = xlength(VECTOR_ELT(x, j));
1895 ihaka 179 
	    if (k > 0) {
43724 ripley 180 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
45847 ripley 181 
		if (use_UTF8) {
182 
		    s = translateCharUTF8(cs);
183 
		    strcpy(buf, s);
184 
		    buf += strlen(s);
185 
		} else {
54753 ripley 186 
		    s = use_Bytes ? CHAR(cs) : translateChar(cs);
45847 ripley 187 
		    strcpy(buf, s);
188 
		    buf += strlen(s);
189 
		    allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
190 
		    anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
191 
		}
1895 ihaka 192 
	    }
57795 maechler 193 
	    if (sepw != 0 && j != nx - 1) {
45847 ripley 194 
		if (use_UTF8) {
195 
		    strcpy(buf, u_csep);
196 
		    buf += u_sepw;
197 
		} else {
198 
		    strcpy(buf, csep);
199 
		    buf += sepw;
200 
		}
1895 ihaka 201 
	    }
50880 ripley 202 
	    vmax = vmaxget();
2 r 203 
	}
45412 ripley 204 
	ienc = 0;
45847 ripley 205 
	if(use_UTF8) ienc = CE_UTF8;
54753 ripley 206 
	else if(use_Bytes) ienc = CE_BYTES;
45847 ripley 207 
	else if(anyKnown && allKnown) {
44986 ripley 208 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
209 
	    if(known_to_be_utf8) ienc = CE_UTF8;
43724 ripley 210 
	}
44986 ripley 211 
	SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
1895 ihaka 212 
    }
2 r 213 
 
1895 ihaka 214 
    /* Now collapse, if required. */
2 r 215 
 
59075 ripley 216 
    if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
10172 luke 217 
	sep = STRING_ELT(collapse, 0);
45847 ripley 218 
	use_UTF8 = IS_UTF8(sep);
54753 ripley 219 
	use_Bytes = IS_BYTES(sep);
220 
	for (i = 0; i < nx; i++) {
45847 ripley 221 
	    if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
54753 ripley 222 
	    if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;
223 
	}
224 
	if(use_Bytes) {
225 
	    csep = CHAR(sep);
226 
	    use_UTF8 = FALSE;
227 
	} else if(use_UTF8)
45847 ripley 228 
	    csep = translateCharUTF8(sep);
229 
	else
230 
	    csep = translateChar(sep);
59177 ripley 231 
	sepw = (int) strlen(csep);
43724 ripley 232 
	anyKnown = ENC_KNOWN(sep) > 0;
44094 ripley 233 
	allKnown = anyKnown || strIsASCII(csep);
1895 ihaka 234 
	pwidth = 0;
50880 ripley 235 
	vmax = vmaxget();
1895 ihaka 236 
	for (i = 0; i < nx; i++)
50880 ripley 237 
	    if(use_UTF8) {
45847 ripley 238 
		pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
50880 ripley 239 
		vmaxset(vmax);
54753 ripley 240 
	    } else /* already translated */
45847 ripley 241 
		pwidth += strlen(CHAR(STRING_ELT(ans, i)));
1895 ihaka 242 
	pwidth += (nx - 1) * sepw;
59046 ripley 243 
	if (pwidth > INT_MAX)
244 
	    error(_("result would exceed 2^31-1 bytes"));
41899 ripley 245 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
50880 ripley 246 
	vmax = vmaxget();
1895 ihaka 247 
	for (i = 0; i < nx; i++) {
248 
	    if(i > 0) {
45446 ripley 249 
		strcpy(buf, csep);
1895 ihaka 250 
		buf += sepw;
251 
	    }
45847 ripley 252 
	    if(use_UTF8)
253 
		s = translateCharUTF8(STRING_ELT(ans, i));
254 
	    else /* already translated */
255 
		s = CHAR(STRING_ELT(ans, i));
45446 ripley 256 
	    strcpy(buf, s);
2584 ihaka 257 
	    while (*buf)
258 
		buf++;
45446 ripley 259 
	    allKnown = allKnown &&
50880 ripley 260 
		(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0));
261 
	    anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0);
262 
	    if(use_UTF8) vmaxset(vmax);
2 r 263 
	}
45446 ripley 264 
	UNPROTECT(1);
45847 ripley 265 
	ienc = CE_NATIVE;
266 
	if(use_UTF8) ienc = CE_UTF8;
54753 ripley 267 
	else if(use_Bytes) ienc = CE_BYTES;
45847 ripley 268 
	else if(anyKnown && allKnown) {
44986 ripley 269 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
270 
	    if(known_to_be_utf8) ienc = CE_UTF8;
43724 ripley 271 
	}
272 
	PROTECT(ans = allocVector(STRSXP, 1));
44986 ripley 273 
	SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
1895 ihaka 274 
    }
41899 ripley 275 
    R_FreeStringBufferL(&cbuff);
1895 ihaka 276 
    UNPROTECT(1);
277 
    return ans;
2 r 278 
}
279 
 
43466 ripley 280 
SEXP attribute_hidden do_filepath(SEXP call, SEXP op, SEXP args, SEXP env)
281 
{
282 
    SEXP ans, sep, x;
283 
    int i, j, k, ln, maxlen, nx, nzero, pwidth, sepw;
284 
    const char *s, *csep, *cbuf; char *buf;
285 
 
286 
    checkArity(op, args);
287 
 
288 
    /* Check the arguments */
289 
 
290 
    x = CAR(args);
291 
    if (!isVectorList(x))
292 
	error(_("invalid first argument"));
293 
    nx = length(x);
294 
    if(nx == 0) return allocVector(STRSXP, 0);
295 
 
45446 ripley 296 
 
43466 ripley 297 
    sep = CADR(args);
43724 ripley 298 
    if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
43466 ripley 299 
	error(_("invalid separator"));
300 
    sep = STRING_ELT(sep, 0);
301 
    csep = CHAR(sep);
59177 ripley 302 
    sepw = (int) strlen(csep); /* hopefully 1 */
43466 ripley 303 
 
304 
    /* Any zero-length argument gives zero-length result */
305 
    maxlen = 0; nzero = 0;
306 
    for (j = 0; j < nx; j++) {
307 
	if (!isString(VECTOR_ELT(x, j))) {
308 
	    /* formerly in R code: moved to C for speed */
309 
	    SEXP call, xj = VECTOR_ELT(x, j);
310 
	    if(OBJECT(xj)) { /* method dispatch */
311 
		PROTECT(call = lang2(install("as.character"), xj));
312 
		SET_VECTOR_ELT(x, j, eval(call, env));
313 
		UNPROTECT(1);
314 
	    } else if (isSymbol(xj))
315 
		SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
316 
	    else
317 
		SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
318 
 
319 
	    if (!isString(VECTOR_ELT(x, j)))
320 
		error(_("non-string argument to Internal paste"));
321 
	}
322 
	ln = length(VECTOR_ELT(x, j));
323 
	if(ln > maxlen) maxlen = ln;
324 
	if(ln == 0) {nzero++; break;}
325 
    }
326 
    if(nzero || maxlen == 0) return allocVector(STRSXP, 0);
327 
 
328 
    PROTECT(ans = allocVector(STRSXP, maxlen));
329 
 
330 
    for (i = 0; i < maxlen; i++) {
331 
	pwidth = 0;
332 
	for (j = 0; j < nx; j++) {
333 
	    k = length(VECTOR_ELT(x, j));
59257 ripley 334 
	    pwidth += (int) strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
43466 ripley 335 
	}
336 
	pwidth += (nx - 1) * sepw;
337 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
338 
	for (j = 0; j < nx; j++) {
339 
	    k = length(VECTOR_ELT(x, j));
340 
	    if (k > 0) {
45489 ripley 341 
		s = translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k));
45446 ripley 342 
		strcpy(buf, s);
43466 ripley 343 
		buf += strlen(s);
344 
	    }
345 
	    if (j != nx - 1 && sepw != 0) {
45446 ripley 346 
		strcpy(buf, csep);
43466 ripley 347 
		buf += sepw;
348 
	    }
349 
	}
350 
	SET_STRING_ELT(ans, i, mkChar(cbuf));
351 
    }
352 
    R_FreeStringBufferL(&cbuff);
353 
    UNPROTECT(1);
354 
    return ans;
355 
}
356 
 
45446 ripley 357 
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
358 
		  scientific) */
36990 ripley 359 
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 360 
{
35263 ripley 361 
    SEXP l, x, y, swd;
60241 ripley 362 
    int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
1895 ihaka 363 
    int w, d, e;
54025 ripley 364 
    int wi, di, ei, scikeep;
41784 ripley 365 
    const char *strp;
60241 ripley 366 
    R_xlen_t i, n;
2 r 367 
 
35262 ripley 368 
    checkArity(op, args);
54049 ripley 369 
    PrintDefaults();
54025 ripley 370 
    scikeep = R_print.scipen;
45446 ripley 371 
 
45639 maechler 372 
    if (isEnvironment(x = CAR(args))) {
373 
	PROTECT(y = allocVector(STRSXP, 1));
374 
	SET_STRING_ELT(y, 0, mkChar(EncodeEnvironment(x)));
375 
	UNPROTECT(1);
376 
	return y;
377 
    }
378 
    else if (!isVector(x))
41686 ripley 379 
	error(_("first argument must be atomic"));
35263 ripley 380 
    args = CDR(args);
381 
 
382 
    trim = asLogical(CAR(args));
35262 ripley 383 
    if (trim == NA_INTEGER)
41686 ripley 384 
	error(_("invalid '%s' argument"), "trim");
35263 ripley 385 
    args = CDR(args);
386 
 
387 
    if (!isNull(CAR(args))) {
388 
	digits = asInteger(CAR(args));
45446 ripley 389 
	if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
35284 ripley 390 
	    || digits > R_MAX_DIGITS_OPT)
41686 ripley 391 
	    error(_("invalid '%s' argument"), "digits");
35263 ripley 392 
	R_print.digits = digits;
393 
    }
394 
    args = CDR(args);
395 
 
396 
    nsmall = asInteger(CAR(args));
35262 ripley 397 
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
41686 ripley 398 
	error(_("invalid '%s' argument"), "nsmall");
35263 ripley 399 
    args = CDR(args);
2 r 400 
 
35263 ripley 401 
    if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
402 
    if(wd == NA_INTEGER)
41686 ripley 403 
	error(_("invalid '%s' argument"), "width");
35263 ripley 404 
    args = CDR(args);
1895 ihaka 405 
 
35263 ripley 406 
    adj = asInteger(CAR(args));
35290 ripley 407 
    if(adj == NA_INTEGER || adj < 0 || adj > 3)
41686 ripley 408 
	error(_("invalid '%s' argument"), "justify");
35284 ripley 409 
    args = CDR(args);
35263 ripley 410 
 
35284 ripley 411 
    na = asLogical(CAR(args));
35290 ripley 412 
    if(na == NA_LOGICAL)
41686 ripley 413 
	error(_("invalid '%s' argument"), "na.encode");
35371 ripley 414 
    args = CDR(args);
415 
    if(LENGTH(CAR(args)) != 1)
41686 ripley 416 
	error(_("invalid '%s' argument"), "scientific");
35371 ripley 417 
    if(isLogical(CAR(args))) {
418 
	int tmp = LOGICAL(CAR(args))[0];
419 
	if(tmp == NA_LOGICAL) sci = NA_INTEGER;
420 
	else sci = tmp > 0 ?-100 : 100;
421 
    } else if (isNumeric(CAR(args))) {
422 
	sci = asInteger(CAR(args));
423 
    } else
41686 ripley 424 
	error(_("invalid '%s' argument"), "scientific");
35371 ripley 425 
    if(sci != NA_INTEGER) R_print.scipen = sci;
35284 ripley 426 
 
60241 ripley 427 
    if ((n = XLENGTH(x)) <= 0) {
35590 ripley 428 
	PROTECT(y = allocVector(STRSXP, 0));
429 
    } else {
430 
	switch (TYPEOF(x)) {
1895 ihaka 431 
 
35590 ripley 432 
	case LGLSXP:
433 
	    PROTECT(y = allocVector(STRSXP, n));
434 
	    if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
435 
	    w = imax2(w, wd);
436 
	    for (i = 0; i < n; i++) {
437 
		strp = EncodeLogical(LOGICAL(x)[i], w);
438 
		SET_STRING_ELT(y, i, mkChar(strp));
439 
	    }
440 
	    break;
1895 ihaka 441 
 
35590 ripley 442 
	case INTSXP:
443 
	    PROTECT(y = allocVector(STRSXP, n));
444 
	    if (trim) w = 0;
445 
	    else formatInteger(INTEGER(x), n, &w);
446 
	    w = imax2(w, wd);
447 
	    for (i = 0; i < n; i++) {
448 
		strp = EncodeInteger(INTEGER(x)[i], w);
449 
		SET_STRING_ELT(y, i, mkChar(strp));
450 
	    }
451 
	    break;
2 r 452 
 
35590 ripley 453 
	case REALSXP:
454 
	    formatReal(REAL(x), n, &w, &d, &e, nsmall);
455 
	    if (trim) w = 0;
456 
	    w = imax2(w, wd);
457 
	    PROTECT(y = allocVector(STRSXP, n));
458 
	    for (i = 0; i < n; i++) {
459 
		strp = EncodeReal(REAL(x)[i], w, d, e, OutDec);
460 
		SET_STRING_ELT(y, i, mkChar(strp));
461 
	    }
462 
	    break;
2 r 463 
 
35590 ripley 464 
	case CPLXSXP:
465 
	    formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
466 
	    if (trim) wi = w = 0;
467 
	    w = imax2(w, wd); wi = imax2(wi, wd);
468 
	    PROTECT(y = allocVector(STRSXP, n));
469 
	    for (i = 0; i < n; i++) {
470 
		strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec);
471 
		SET_STRING_ELT(y, i, mkChar(strp));
472 
	    }
473 
	    break;
2 r 474 
 
35590 ripley 475 
	case STRSXP:
476 
	{
477 
	    /* this has to be different from formatString/EncodeString as
478 
	       we don't actually want to encode here */
57795 maechler 479 
	    const char *s;
51398 ripley 480 
	    char *q;
35590 ripley 481 
	    int b, b0, cnt = 0, j;
40704 ripley 482 
	    SEXP s0, xx;
45446 ripley 483 
 
40704 ripley 484 
	    /* This is clumsy, but it saves rewriting and re-testing
485 
	       this complex code */
486 
	    PROTECT(xx = duplicate(x));
487 
	    for (i = 0; i < n; i++) {
488 
		SEXP tmp =  STRING_ELT(xx, i);
54753 ripley 489 
		if(IS_BYTES(tmp)) {
490 
		    const char *p = CHAR(tmp), *q;
491 
		    char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
492 
		    for (q = p; *q; q++) {
493 
			unsigned char k = (unsigned char) *q;
494 
			if (k >= 0x20 && k < 0x80) {
495 
			    *qq++ = *q;
496 
			} else {
497 
			    snprintf(buf, 5, "\\x%02x", k);
498 
			    for(int j = 0; j < 4; j++) *qq++ = buf[j];
499 
			}
500 
		    }
501 
		    *qq = '\0';
502 
		    s = pp;
503 
		} else s = translateChar(tmp);
40704 ripley 504 
		if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
505 
	    }
45446 ripley 506 
 
507 
	    w = wd;
35590 ripley 508 
	    if (adj != Rprt_adj_none) {
509 
		for (i = 0; i < n; i++)
40704 ripley 510 
		    if (STRING_ELT(xx, i) != NA_STRING)
511 
			w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
35590 ripley 512 
		    else if (na) w = imax2(w, R_print.na_width);
513 
	    } else w = 0;
514 
	    /* now calculate the buffer size needed, in bytes */
35263 ripley 515 
	    for (i = 0; i < n; i++)
40704 ripley 516 
		if (STRING_ELT(xx, i) != NA_STRING) {
517 
		    il = Rstrlen(STRING_ELT(xx, i), 0);
518 
		    cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
41229 ripley 519 
		} else if (na) cnt  = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
59752 ripley 520 
	    R_CheckStack2(cnt+1);
51398 ripley 521 
	    char buff[cnt+1];
35590 ripley 522 
	    PROTECT(y = allocVector(STRSXP, n));
523 
	    for (i = 0; i < n; i++) {
40704 ripley 524 
		if(!na && STRING_ELT(xx, i) == NA_STRING) {
35590 ripley 525 
		    SET_STRING_ELT(y, i, NA_STRING);
526 
		} else {
527 
		    q = buff;
40704 ripley 528 
		    if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
529 
		    else s0 = STRING_ELT(xx, i) ;
35590 ripley 530 
		    s = CHAR(s0);
531 
		    il = Rstrlen(s0, 0);
532 
		    b = w - il;
533 
		    if(b > 0 && adj != Rprt_adj_left) {
534 
			b0 = (adj == Rprt_adj_centre) ? b/2 : b;
535 
			for(j = 0 ; j < b0 ; j++) *q++ = ' ';
536 
			b -= b0;
537 
		    }
538 
		    for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
539 
		    if(b > 0 && adj != Rprt_adj_right)
540 
			for(j = 0 ; j < b ; j++) *q++ = ' ';
541 
		    *q = '\0';
542 
		    SET_STRING_ELT(y, i, mkChar(buff));
35263 ripley 543 
		}
544 
	    }
1895 ihaka 545 
	}
40704 ripley 546 
	UNPROTECT(1);
1895 ihaka 547 
	break;
35590 ripley 548 
	default:
41686 ripley 549 
	    error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
35590 ripley 550 
	}
1895 ihaka 551 
    }
35262 ripley 552 
    if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
1895 ihaka 553 
	setAttrib(y, R_DimSymbol, l);
35262 ripley 554 
	if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
555 
	    setAttrib(y, R_DimNamesSymbol, l);
556 
    } else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
557 
	setAttrib(y, R_NamesSymbol, l);
558 
 
54025 ripley 559 
    /* In case something else forgets to set PrintDefaults(), PR#14477 */
560 
    R_print.scipen = scikeep;
561 
 
1895 ihaka 562 
    UNPROTECT(1);
563 
    return y;
2 r 564 
}
565 
 
566 
/* format.info(obj)  --> 3 integers  (w,d,e) with the formatting information
567 
 *			w = total width (#{chars}) per item
568 
 *			d = #{digits} to RIGHT of "."
465 maechler 569 
 *			e = {0:2}.   0: Fixpoint;
2 r 570 
 *				   1,2: exponential with 2/3 digit expon.
4928 maechler 571 
 *
572 
 * for complex : 2 x 3 integers for (Re, Im)
2 r 573 
 */
1895 ihaka 574 
 
36990 ripley 575 
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 576 
{
1895 ihaka 577 
    SEXP x;
60241 ripley 578 
    int digits, nsmall, no = 1, w, d, e, wi, di, ei;
35281 ripley 579 
 
1895 ihaka 580 
    checkArity(op, args);
581 
    x = CAR(args);
60241 ripley 582 
    R_xlen_t n = XLENGTH(x);
54049 ripley 583 
    PrintDefaults();
35281 ripley 584 
 
585 
    digits = asInteger(CADR(args));
586 
    if (!isNull(CADR(args))) {
587 
	digits = asInteger(CADR(args));
45446 ripley 588 
	if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
35284 ripley 589 
	    || digits > R_MAX_DIGITS_OPT)
41686 ripley 590 
	    error(_("invalid '%s' argument"), "digits");
35281 ripley 591 
	R_print.digits = digits;
592 
    }
593 
    nsmall = asInteger(CADDR(args));
594 
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
41686 ripley 595 
	error(_("invalid '%s' argument"), "nsmall");
35281 ripley 596 
 
1895 ihaka 597 
    w = 0;
598 
    d = 0;
599 
    e = 0;
600 
    switch (TYPEOF(x)) {
601 
 
35281 ripley 602 
    case RAWSXP:
603 
	formatRaw(RAW(x), n, &w);
604 
	break;
605 
 
1895 ihaka 606 
    case LGLSXP:
607 
	formatLogical(LOGICAL(x), n, &w);
608 
	break;
609 
 
610 
    case INTSXP:
611 
	formatInteger(INTEGER(x), n, &w);
612 
	break;
613 
 
614 
    case REALSXP:
35281 ripley 615 
	no = 3;
25241 ripley 616 
	formatReal(REAL(x), n, &w, &d, &e, nsmall);
1895 ihaka 617 
	break;
618 
 
619 
    case CPLXSXP:
35281 ripley 620 
	no = 6;
1895 ihaka 621 
	wi = di = ei = 0;
25241 ripley 622 
	formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
1895 ihaka 623 
	break;
624 
 
625 
    case STRSXP:
60241 ripley 626 
	for (R_xlen_t i = 0; i < n; i++)
35281 ripley 627 
	    if (STRING_ELT(x, i) != NA_STRING) {
60241 ripley 628 
		int il = Rstrlen(STRING_ELT(x, i), 0);
35281 ripley 629 
		if (il > w) w = il;
630 
	    }
1895 ihaka 631 
	break;
632 
 
633 
    default:
41686 ripley 634 
	error(_("atomic vector arguments only"));
1895 ihaka 635 
    }
35281 ripley 636 
    x = allocVector(INTSXP, no);
1895 ihaka 637 
    INTEGER(x)[0] = w;
35281 ripley 638 
    if(no > 1) {
639 
	INTEGER(x)[1] = d;
640 
	INTEGER(x)[2] = e;
641 
    }
642 
    if(no > 3) {
1895 ihaka 643 
	INTEGER(x)[3] = wi;
644 
	INTEGER(x)[4] = di;
645 
	INTEGER(x)[5] = ei;
646 
    }
647 
    return x;
2 r 648 
}