The R Project SVN R

Rev

Rev 25241 | Rev 32380 | 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
24842 ripley 4 
 *  Copyright (C) 1997--2003  The R Development 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
17 
 *  along with this program; if not, write to the Free Software
5458 ripley 18 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
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"
32 
#include "Print.h"
33 
 
1895 ihaka 34 
/*  .Internal(paste(args, sep, collapse))
35 
 *
36 
 * do_paste uses two passes to paste the arguments (in CAR(args)) together.
465 maechler 37 
 * The first pass calculates the width of the paste buffer,
38 
 * then it is alloc-ed and the second pass stuffs the information in.
39 
 */
2 r 40 
SEXP do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
41 
{
2342 maechler 42 
    SEXP ans, collapse, sep, x, tmpchar;
1895 ihaka 43 
    int i, j, k, maxlen, nx, pwidth, sepw;
44 
    char *s, *buf;
2 r 45 
 
1895 ihaka 46 
    checkArity(op, args);
465 maechler 47 
 
1895 ihaka 48 
    /* We use formatting and so we */
49 
    /* must initialize printing. */
2 r 50 
 
1895 ihaka 51 
    PrintDefaults(env);
2 r 52 
 
1895 ihaka 53 
    /* Check the arguments */
2 r 54 
 
1895 ihaka 55 
    x = CAR(args);
56 
    if (!isVectorList(x))
5731 ripley 57 
	errorcall(call, "invalid first argument");
2 r 58 
 
1895 ihaka 59 
    sep = CADR(args);
60 
    if (!isString(sep) || LENGTH(sep) <= 0)
5731 ripley 61 
	errorcall(call, "invalid separator");
10172 luke 62 
    sep = STRING_ELT(sep, 0);
19598 ripley 63 
    sepw = strlen(CHAR(sep)); /* not LENGTH as might contain \0 */
2 r 64 
 
1895 ihaka 65 
    collapse = CADDR(args);
66 
    if (!isNull(collapse))
67 
	if(!isString(collapse) || LENGTH(collapse) <= 0)
5731 ripley 68 
	    errorcall(call, "invalid collapse argument");
2 r 69 
 
1895 ihaka 70 
    /* Maximum argument length and */
71 
    /* check for arguments of list type */
2 r 72 
 
1895 ihaka 73 
    nx = length(x);
74 
    maxlen = 0;
75 
    for (j = 0; j < nx; j++) {
10172 luke 76 
	if (!isString(VECTOR_ELT(x, j)))
5731 ripley 77 
	    error("non-string argument to Internal paste");
10172 luke 78 
	if(length(VECTOR_ELT(x, j)) > maxlen)
79 
	    maxlen = length(VECTOR_ELT(x, j));
1895 ihaka 80 
    }
81 
    if(maxlen == 0)
24842 ripley 82 
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
1895 ihaka 83 
 
84 
    PROTECT(ans = allocVector(STRSXP, maxlen));
85 
 
86 
    for (i = 0; i < maxlen; i++) {
87 
	pwidth = 0;
1839 ihaka 88 
	for (j = 0; j < nx; j++) {
10172 luke 89 
	    k = length(VECTOR_ELT(x, j));
1895 ihaka 90 
	    if (k > 0)
19598 ripley 91 
		pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
1820 ihaka 92 
	}
1895 ihaka 93 
	pwidth += (nx - 1) * sepw;
94 
	tmpchar = allocString(pwidth);
95 
	buf = CHAR(tmpchar);
96 
	for (j = 0; j < nx; j++) {
10172 luke 97 
	    k = length(VECTOR_ELT(x, j));
1895 ihaka 98 
	    if (k > 0) {
10172 luke 99 
		s = CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k));
19598 ripley 100 
                strcpy(buf, s);
101 
		buf += strlen(s);
1895 ihaka 102 
	    }
103 
	    if (j != nx - 1 && sepw != 0) {
13959 duncan 104 
	        strcpy(buf, CHAR(sep));
1895 ihaka 105 
		buf += sepw;
106 
	    }
2 r 107 
	}
10172 luke 108 
	SET_STRING_ELT(ans, i, tmpchar);
1895 ihaka 109 
    }
2 r 110 
 
1895 ihaka 111 
    /* Now collapse, if required. */
2 r 112 
 
1895 ihaka 113 
    if(collapse != R_NilValue && (nx=LENGTH(ans)) != 0) {
10172 luke 114 
	sep = STRING_ELT(collapse, 0);
19598 ripley 115 
	sepw = strlen(CHAR(sep));
1895 ihaka 116 
	pwidth = 0;
117 
	for (i = 0; i < nx; i++)
19598 ripley 118 
	    pwidth += strlen(CHAR(STRING_ELT(ans, i)));
1895 ihaka 119 
	pwidth += (nx - 1) * sepw;
120 
	tmpchar = allocString(pwidth);
121 
	buf = CHAR(tmpchar);
122 
	for (i = 0; i < nx; i++) {
123 
	    if(i > 0) {
13959 duncan 124 
	        strcpy(buf, CHAR(sep));
1895 ihaka 125 
		buf += sepw;
126 
	    }
10172 luke 127 
	    s = CHAR(STRING_ELT(ans, i));
13959 duncan 128 
            strcpy(buf, s);
2584 ihaka 129 
	    while (*buf)
130 
		buf++;
2 r 131 
	}
1895 ihaka 132 
	PROTECT(tmpchar);
133 
	ans = allocVector(STRSXP, 1);
2 r 134 
	UNPROTECT(1);
10172 luke 135 
	SET_STRING_ELT(ans, 0, tmpchar);
1895 ihaka 136 
    }
137 
    UNPROTECT(1);
138 
    return ans;
2 r 139 
}
140 
 
19598 ripley 141 
/* format.default(x, trim, nsmall) : ../library/base/R/format.R
142 
 * --------------   See "FIXME" in that file !
11662 maechler 143 
 */
2 r 144 
SEXP do_format(SEXP call, SEXP op, SEXP args, SEXP env)
145 
{
1895 ihaka 146 
    SEXP l, x, y;
14357 ripley 147 
    int i, n, trim=0, nsmall=0;
1895 ihaka 148 
    int w, d, e;
149 
    int wi, di, ei;
150 
    char *strp;
2 r 151 
 
1895 ihaka 152 
    PrintDefaults(env);
2 r 153 
 
1895 ihaka 154 
    switch (length(args)) {
155 
    case 1:
156 
	break;
14357 ripley 157 
    case 3:
158 
	nsmall = asInteger(CADDR(args));
159 
	if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
160 
	    errorcall(call, "invalid \"nsmall\" argument");
161 
	/* drop through */
1895 ihaka 162 
    case 2:
163 
	trim = asLogical(CADR(args));
164 
	if (trim == NA_INTEGER)
5731 ripley 165 
	    errorcall(call, "invalid \"trim\" argument");
1895 ihaka 166 
	break;
167 
    default:
5731 ripley 168 
	errorcall(call, "incorrect number of arguments");
1895 ihaka 169 
    }
170 
 
171 
    if (!isVector(x = CAR(args)))
5731 ripley 172 
	errorcall(call, "first argument must be atomic");
1895 ihaka 173 
 
174 
    if ((n = LENGTH(x)) <= 0)
175 
	return allocVector(STRSXP, 0);
176 
 
177 
    switch (TYPEOF(x)) {
178 
 
179 
    case LGLSXP:
180 
	PROTECT(y = allocVector(STRSXP, n));
181 
	if (trim)
182 
	    w = 0;
183 
	else
184 
	    formatLogical(LOGICAL(x), n, &w);
185 
	for (i = 0; i < n; i++) {
186 
	    strp = EncodeLogical(LOGICAL(x)[i], w);
10172 luke 187 
	    SET_STRING_ELT(y, i, mkChar(strp));
2 r 188 
	}
1895 ihaka 189 
	UNPROTECT(1);
190 
	break;
2 r 191 
 
1895 ihaka 192 
    case INTSXP:
193 
	PROTECT(y = allocVector(STRSXP, n));
194 
	if (trim) w = 0;
195 
	else formatInteger(INTEGER(x), n, &w);
196 
	for (i = 0; i < n; i++) {
197 
	    strp = EncodeInteger(INTEGER(x)[i], w);
10172 luke 198 
	    SET_STRING_ELT(y, i, mkChar(strp));
1895 ihaka 199 
	}
200 
	UNPROTECT(1);
201 
	break;
2 r 202 
 
1895 ihaka 203 
    case REALSXP:
14357 ripley 204 
	formatReal(REAL(x), n, &w, &d, &e, nsmall);
1895 ihaka 205 
	if (trim) w = 0;
206 
	PROTECT(y = allocVector(STRSXP, n));
207 
	for (i = 0; i < n; i++) {
208 
	    strp = EncodeReal(REAL(x)[i], w, d, e);
10172 luke 209 
	    SET_STRING_ELT(y, i, mkChar(strp));
1895 ihaka 210 
	}
211 
	UNPROTECT(1);
212 
	break;
2 r 213 
 
1895 ihaka 214 
    case CPLXSXP:
14357 ripley 215 
	formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
1895 ihaka 216 
	if (trim) wi = w = 0;
217 
	PROTECT(y = allocVector(STRSXP, n));
218 
	for (i = 0; i < n; i++) {
219 
	    strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei);
10172 luke 220 
	    SET_STRING_ELT(y, i, mkChar(strp));
2 r 221 
	}
222 
	UNPROTECT(1);
1895 ihaka 223 
	break;
224 
 
11662 maechler 225 
    case STRSXP: /* this is *UN*used now (1.2) */
226 
 
10172 luke 227 
	formatString(STRING_PTR(x), n, &w, 0);
1895 ihaka 228 
	if (trim) w = 0;
229 
	PROTECT(y = allocVector(STRSXP, n));
230 
	for (i = 0; i < n; i++) {
10172 luke 231 
	    strp = EncodeString(CHAR(STRING_ELT(x, i)), w, 0, Rprt_adj_left);
232 
	    SET_STRING_ELT(y, i, mkChar(strp));
1895 ihaka 233 
	}
234 
	UNPROTECT(1);
235 
	break;
2342 maechler 236 
    default:
5731 ripley 237 
	errorcall(call, "Impossible mode ( x )"); y = R_NilValue;/* -Wall */
1895 ihaka 238 
    }
239 
    PROTECT(y);
240 
    if((l = getAttrib(x, R_DimSymbol)) != R_NilValue)
241 
	setAttrib(y, R_DimSymbol, l);
242 
    if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
243 
	setAttrib(y, R_DimNamesSymbol, l);
244 
    UNPROTECT(1);
245 
    return y;
2 r 246 
}
247 
 
248 
/* format.info(obj)  --> 3 integers  (w,d,e) with the formatting information
249 
 *			w = total width (#{chars}) per item
250 
 *			d = #{digits} to RIGHT of "."
465 maechler 251 
 *			e = {0:2}.   0: Fixpoint;
2 r 252 
 *				   1,2: exponential with 2/3 digit expon.
4928 maechler 253 
 *
254 
 * for complex : 2 x 3 integers for (Re, Im)
2 r 255 
 */
1895 ihaka 256 
 
2 r 257 
SEXP do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
258 
{
1895 ihaka 259 
    SEXP x;
25241 ripley 260 
    int n, nsmall, w, d, e;
1895 ihaka 261 
    int wi, di, ei;
262 
    checkArity(op, args);
263 
    x = CAR(args);
264 
    n = LENGTH(x);
25241 ripley 265 
    nsmall = asInteger(CADR(args));
1895 ihaka 266 
    w = 0;
267 
    d = 0;
268 
    e = 0;
269 
    switch (TYPEOF(x)) {
270 
 
271 
    case LGLSXP:
272 
	formatLogical(LOGICAL(x), n, &w);
273 
	break;
274 
 
275 
    case INTSXP:
276 
	formatInteger(INTEGER(x), n, &w);
277 
	break;
278 
 
279 
    case REALSXP:
25241 ripley 280 
	formatReal(REAL(x), n, &w, &d, &e, nsmall);
1895 ihaka 281 
	break;
282 
 
283 
    case CPLXSXP:
284 
	wi = di = ei = 0;
25241 ripley 285 
	formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
1895 ihaka 286 
	n = -1;/* complex 'code' */
287 
	break;
288 
 
289 
    case STRSXP:
10172 luke 290 
	formatString(STRING_PTR(x), n, &w, 0);
1895 ihaka 291 
	break;
292 
 
293 
    default:
5731 ripley 294 
	errorcall(call, "vector arguments only");
1895 ihaka 295 
    }
296 
    x = allocVector(INTSXP, (n >= 0) ? 3 : 6);
297 
    INTEGER(x)[0] = w;
298 
    INTEGER(x)[1] = d;
299 
    INTEGER(x)[2] = e;
300 
    if(n < 0) { /*- complex -*/
301 
	INTEGER(x)[3] = wi;
302 
	INTEGER(x)[4] = di;
303 
	INTEGER(x)[5] = ei;
304 
    }
305 
    return x;
2 r 306 
}