The R Project SVN R

Rev

Rev 27365 | Rev 28766 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
1016 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
22883 ripley 4 
 *  Copyright (C) 1997--2003  Robert Gentleman, Ross Ihaka and the
8872 pd 5 
 *                            R Development Core Team
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
18 
 *  along with this program; if not, write to the Free Software
5458 ripley 19 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
2 r 20 
 */
21 
 
5187 hornik 22 
#ifdef HAVE_CONFIG_H
7701 hornik 23 
#include <config.h>
5187 hornik 24 
#endif
25 
 
2 r 26 
#include "Defn.h"
27 
 
4562 pd 28 
static int integerOneIndex(int i, int len) {
10921 maechler 29 
    int indx = -1;
4562 pd 30 
 
31 
    if (i > 0)
10921 maechler 32 
	indx = i - 1;
4562 pd 33 
    else if (i == 0 || len < 2)
5731 ripley 34 
	error("attempt to select less than one element");
4562 pd 35 
    else if (len == 2 && i > -3)
10921 maechler 36 
	indx = 2 + i;
4562 pd 37 
    else
5731 ripley 38 
	error("attempt to select more than one element");
10921 maechler 39 
    return(indx);
4562 pd 40 
}
41 
 
22883 ripley 42 
int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname, int pos)
1839 ihaka 43 
{
44 
    SEXP names;
10921 maechler 45 
    int i, indx, nx;
2 r 46 
 
22883 ripley 47 
    if (pos < 0 && length(s) > 1)
5731 ripley 48 
	error("attempt to select more than one element");
22883 ripley 49 
    if (pos < 0 && length(s) < 1)
5731 ripley 50 
	error("attempt to select less than one element");
22883 ripley 51 
    if(pos < 0) pos = 0;
1839 ihaka 52 
 
10921 maechler 53 
    indx = -1;
1839 ihaka 54 
    *newname = R_NilValue;
55 
    switch(TYPEOF(s)) {
56 
    case LGLSXP:
57 
    case INTSXP:
22883 ripley 58 
	indx = integerOneIndex(INTEGER(s)[pos], len);
1839 ihaka 59 
	break;
60 
    case REALSXP:
22883 ripley 61 
	indx = integerOneIndex(REAL(s)[pos], len);
1839 ihaka 62 
	break;
63 
    case STRSXP:
64 
	nx = length(x);
65 
	names = getAttrib(x, R_NamesSymbol);
66 
	if (names != R_NilValue) {
67 
	    /* Try for exact match */
68 
	    for (i = 0; i < nx; i++)
10172 luke 69 
		if (streql(CHAR(STRING_ELT(names, i)),
22883 ripley 70 
			   CHAR(STRING_ELT(s, pos)))) {
10921 maechler 71 
		    indx = i;
1839 ihaka 72 
		    break;
73 
		}
74 
	    /* Try for partial match */
10921 maechler 75 
	    if (partial && indx < 0) {
22883 ripley 76 
		len = strlen(CHAR(STRING_ELT(s, pos)));
1839 ihaka 77 
		for(i = 0; i < nx; i++) {
10172 luke 78 
		    if(!strncmp(CHAR(STRING_ELT(names, i)),
22883 ripley 79 
				CHAR(STRING_ELT(s, pos)), len)) {
10921 maechler 80 
			if(indx == -1 )
81 
			    indx = i;
1839 ihaka 82 
			else
10921 maechler 83 
			    indx = -2;
1839 ihaka 84 
		    }
85 
		}
86 
	    }
87 
	}
10921 maechler 88 
	if (indx == -1)
89 
	    indx = nx;
22883 ripley 90 
	*newname = STRING_ELT(s, pos);
1839 ihaka 91 
	break;
92 
    case SYMSXP:
93 
	nx = length(x);
94 
	names = getAttrib(x, R_NamesSymbol);
95 
	if (names != R_NilValue) {
96 
	    for (i = 0; i < nx; i++)
10172 luke 97 
		if (streql(CHAR(STRING_ELT(names, i)),
1839 ihaka 98 
			   CHAR(PRINTNAME(s)))) {
10921 maechler 99 
		    indx = i;
1839 ihaka 100 
		    break;
101 
		}
102 
	}
10921 maechler 103 
	if (indx == -1)
104 
	    indx = nx;
22883 ripley 105 
	*newname = STRING_ELT(s, pos);
1839 ihaka 106 
	break;
107 
    default:
5731 ripley 108 
	error("invalid subscript type");
1839 ihaka 109 
    }
10921 maechler 110 
    return indx;
1839 ihaka 111 
}
112 
 
22883 ripley 113 
int get1index(SEXP s, SEXP names, int len, Rboolean pok, int pos)
10718 maechler 114 
{
4562 pd 115 
/* Get a single index for the [[ operator.
10718 maechler 116 
   Check that only one index is being selected.
117 
   pok : is "partial ok" ?
118 
*/
10921 maechler 119 
    int indx, i;
6994 pd 120 
    double dblind;
2 r 121 
 
22883 ripley 122 
    if (pos < 0 && length(s) != 1) {
10718 maechler 123 
	if (length(s) > 1)
124 
	    error("attempt to select more than one element");
125 
	else
126 
	    error("attempt to select less than one element");
22883 ripley 127 
    } else
128 
	if(pos >= length(s))
129 
	    error("internal error in use of recursive indexing");
130 
    if(pos < 0) pos = 0;
10921 maechler 131 
    indx = -1;
1839 ihaka 132 
    switch (TYPEOF(s)) {
133 
    case LGLSXP:
134 
    case INTSXP:
22883 ripley 135 
	i = INTEGER(s)[pos];
10718 maechler 136 
	if(i != NA_INTEGER)
10921 maechler 137 
	    indx = integerOneIndex(i, len);
1839 ihaka 138 
	break;
139 
    case REALSXP:
22883 ripley 140 
	dblind = REAL(s)[pos];
10718 maechler 141 
	if(!ISNAN(dblind))
10921 maechler 142 
	    indx = integerOneIndex((int)dblind, len);
1839 ihaka 143 
	break;
144 
    case STRSXP:
145 
	/* Try for exact match */
146 
	for (i = 0; i < length(names); i++)
22883 ripley 147 
	    if (streql(CHAR(STRING_ELT(names, i)),
148 
		       CHAR(STRING_ELT(s, pos)))) {
10921 maechler 149 
		indx = i;
1839 ihaka 150 
		break;
151 
	    }
152 
	/* Try for partial match */
10921 maechler 153 
	if (pok && indx < 0) {
22883 ripley 154 
	    len = strlen(CHAR(STRING_ELT(s, pos)));
1839 ihaka 155 
	    for(i = 0; i < length(names); i++) {
10718 maechler 156 
		if(!strncmp(CHAR(STRING_ELT(names, i)),
22883 ripley 157 
			    CHAR(STRING_ELT(s, pos)), len)) {
10921 maechler 158 
		    if(indx == -1)/* first one */
159 
			indx = i;
1839 ihaka 160 
		    else
10921 maechler 161 
			indx = -2;/* more than one partial match */
544 pd 162 
		}
1839 ihaka 163 
	    }
2 r 164 
	}
1839 ihaka 165 
	break;
166 
    case SYMSXP:
167 
	for (i = 0; i < length(names); i++)
10172 luke 168 
	    if (streql(CHAR(STRING_ELT(names, i)), CHAR(PRINTNAME(s)))) {
10921 maechler 169 
		indx = i;
1839 ihaka 170 
		break;
171 
	    }
172 
    default:
5731 ripley 173 
	error("invalid subscript type");
1839 ihaka 174 
    }
10921 maechler 175 
    return indx;
2 r 176 
}
177 
 
1839 ihaka 178 
/* Special Matrix Subscripting: Handles the case x[i] where */
179 
/* x is an n-way array and i is a matrix with n columns. */
180 
/* This code returns a vector containing the integer subscripts */
181 
/* to be extracted when x is regarded as unravelled. */
2 r 182 
 
183 
SEXP mat2indsub(SEXP dims, SEXP s)
184 
{
1839 ihaka 185 
    int tdim, j, i, nrs = nrows(s);
186 
    SEXP rvec;
2 r 187 
 
1839 ihaka 188 
    PROTECT(rvec = allocVector(INTSXP, nrs));
189 
    s = coerceVector(s, INTSXP);
190 
    setIVector(INTEGER(rvec), nrs, 0);
2 r 191 
 
1839 ihaka 192 
    /* compute 0-based subscripts */
193 
    for (i = 0; i < nrs; i++) {
194 
	tdim = 1;
195 
	for (j = 0; j < LENGTH(dims); j++) {
196 
	    if(INTEGER(s)[i + j * nrs] == NA_INTEGER) {
197 
		INTEGER(rvec)[i] = NA_INTEGER;
198 
		break;
199 
	    }
200 
	    if (INTEGER(s)[i + j * nrs] > INTEGER(dims)[j])
5731 ripley 201 
		error("subscript out of bounds");
1839 ihaka 202 
	    INTEGER(rvec)[i] += (INTEGER(s)[i+j*nrs] - 1) * tdim;
203 
	    tdim *= INTEGER(dims)[j];
2 r 204 
	}
1839 ihaka 205 
	/* transform to 1 based subscripting */
206 
	if(INTEGER(rvec)[i] != NA_INTEGER)
207 
	    INTEGER(rvec)[i]++;
208 
    }
209 
    UNPROTECT(1);
210 
    return (rvec);
2 r 211 
}
212 
 
213 
static SEXP nullSubscript(int n)
214 
{
1839 ihaka 215 
    int i;
10921 maechler 216 
    SEXP indx;
217 
    indx = allocVector(INTSXP, n);
1839 ihaka 218 
    for (i = 0; i < n; i++)
10921 maechler 219 
	INTEGER(indx)[i] = i + 1;
220 
    return indx;
2 r 221 
}
222 
 
4288 ihaka 223 
static SEXP logicalSubscript(SEXP s, int ns, int nx, int *stretch)
2 r 224 
{
4288 ihaka 225 
    int canstretch, count, i, nmax;
10921 maechler 226 
    SEXP indx;
4288 ihaka 227 
    canstretch = *stretch;
228 
    if (!canstretch && ns > nx)
27383 rgentlem 229 
	error("(subscript) logical subscript too long");
4288 ihaka 230 
    nmax = (ns > nx) ? ns : nx;
231 
    *stretch = (ns > nx) ? ns : 0;
3786 pd 232 
    if (ns == 0)
27383 rgentlem 233 
	return(allocVector(INTSXP, 0));
1839 ihaka 234 
    count = 0;
5603 ihaka 235 
    for (i = 0; i < nmax; i++)
27383 rgentlem 236 
	if (LOGICAL(s)[i%ns])
237 
	    count++;
10921 maechler 238 
    indx = allocVector(INTSXP, count);
1839 ihaka 239 
    count = 0;
27383 rgentlem 240 
    for (i = 0; i < nmax; i++)
241 
	if (LOGICAL(s)[i%ns]) {
242 
	    if (LOGICAL(s)[i%ns] == NA_LOGICAL)
243 
		INTEGER(indx)[count++] = NA_INTEGER;
244 
	    else
245 
		INTEGER(indx)[count++] = i + 1;
246 
	}
10921 maechler 247 
    return indx;
2 r 248 
}
249 
 
250 
static SEXP negativeSubscript(SEXP s, int ns, int nx)
251 
{
27383 rgentlem 252 
    SEXP indx;
253 
    int stretch = 0;
254 
    int i;
255 
    PROTECT(indx = allocVector(INTSXP, nx));
1839 ihaka 256 
    for (i = 0; i < nx; i++)
27383 rgentlem 257 
	INTEGER(indx)[i] = 1;
1839 ihaka 258 
    for (i = 0; i < ns; i++)
27383 rgentlem 259 
	if (INTEGER(s)[i] != 0)
260 
	    INTEGER(indx)[-INTEGER(s)[i] - 1] = 0;
261 
    s = logicalSubscript(indx, nx, nx, &stretch);
1839 ihaka 262 
    UNPROTECT(1);
263 
    return s;
2 r 264 
}
265 
 
266 
static SEXP positiveSubscript(SEXP s, int ns, int nx)
267 
{
10921 maechler 268 
    SEXP indx;
1839 ihaka 269 
    int i, zct = 0;
270 
    for (i = 0; i < ns; i++) {
27383 rgentlem 271 
	if (INTEGER(s)[i] == 0)
272 
	    zct++;
1839 ihaka 273 
    }
274 
    if (zct) {
27383 rgentlem 275 
	indx = allocVector(INTSXP, (ns - zct));
276 
	for (i = 0, zct = 0; i < ns; i++)
277 
	    if (INTEGER(s)[i] != 0)
278 
		INTEGER(indx)[zct++] = INTEGER(s)[i];
279 
	return indx;
280 
    }
281 
    else
282 
	return s;
2 r 283 
}
284 
 
285 
static SEXP integerSubscript(SEXP s, int ns, int nx, int *stretch)
286 
{
1839 ihaka 287 
    int i, ii, min, max, canstretch;
288 
    canstretch = *stretch;
289 
    *stretch = 0;
27383 rgentlem 290 
    min = 0;
1839 ihaka 291 
    max = 0;
292 
    for (i = 0; i < ns; i++) {
27383 rgentlem 293 
	ii = INTEGER(s)[i];
294 
	if (ii != NA_INTEGER) {
295 
	    if (ii < min)
296 
		min = ii;
297 
	    if (ii > max)
298 
		max = ii;
299 
	}
1839 ihaka 300 
    }
301 
    if (min < -nx)
27383 rgentlem 302 
	error("subscript out of bounds");
1839 ihaka 303 
    if (max > nx) {
27383 rgentlem 304 
	if(canstretch) *stretch = max;
305 
	else error("subscript out of bounds");
1839 ihaka 306 
    }
307 
    if (min < 0) {
27383 rgentlem 308 
	if (max == 0) return negativeSubscript(s, ns, nx);
309 
	else error("only 0's may mix with negative subscripts");
1839 ihaka 310 
    }
27383 rgentlem 311 
    else return positiveSubscript(s, ns, nx);
312 
    return R_NilValue;
2 r 313 
}
314 
 
27383 rgentlem 315 
typedef SEXP (*StringEltGetter)(SEXP x, int i);
27365 rgentlem 316 
 
317 
static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names,
27383 rgentlem 318 
			    StringEltGetter strg, int *stretch)
2 r 319 
{
10921 maechler 320 
    SEXP indx, indexnames;
1839 ihaka 321 
    int i, j, nnames, sub, extra;
8339 pd 322 
    int canstretch = *stretch;
1839 ihaka 323 
    PROTECT(s);
324 
    PROTECT(names);
10921 maechler 325 
    PROTECT(indx = allocVector(INTSXP, ns));
1839 ihaka 326 
    PROTECT(indexnames = allocVector(STRSXP, ns));
327 
    nnames = nx;
328 
    extra = nnames;
2 r 329 
 
1839 ihaka 330 
    /* Process each of the subscripts */
331 
    /* First we compare with the names on the vector */
332 
    /* and then (if there is no match) with each of */
333 
    /* the previous subscripts. */
2 r 334 
 
1839 ihaka 335 
    for (i = 0; i < ns; i++) {
336 
	sub = 0;
337 
	if (names != R_NilValue) {
27365 rgentlem 338 
	    for (j = 0; j < nnames; j++) {
27383 rgentlem 339 
	        SEXP names_j = strg(names, j);
340 
		if (TYPEOF(names_j) != CHARSXP)
341 
		    error("character vector element does not have type CHARSXP");
342 
		if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {
1839 ihaka 343 
		    sub = j + 1;
10172 luke 344 
		    SET_STRING_ELT(indexnames, i, R_NilValue);
1839 ihaka 345 
		    break;
346 
		}
27383 rgentlem 347 
	    }
2 r 348 
	}
1839 ihaka 349 
	if (sub == 0) {
350 
	    for (j = 0 ; j < i ; j++)
10172 luke 351 
		if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {
10921 maechler 352 
		    sub = INTEGER(indx)[j];
10172 luke 353 
/*		    SET_STRING_ELT(indexnames, i, STRING_ELT(indexnames, sub - 1));*/
354 
		    SET_STRING_ELT(indexnames, i, STRING_ELT(s, j));
1839 ihaka 355 
		    break;
356 
		}
357 
	}
358 
	if (sub == 0) {
8339 pd 359 
	    if (!canstretch)
360 
		error("subscript out of bounds");
1839 ihaka 361 
	    extra += 1;
362 
	    sub = extra;
10172 luke 363 
	    SET_STRING_ELT(indexnames, i, STRING_ELT(s, i));
1839 ihaka 364 
	}
10921 maechler 365 
	INTEGER(indx)[i] = sub;
1839 ihaka 366 
    }
367 
    /* Ghastly hack!  We attach the new names to the attribute */
368 
    /* slot on the returned subscript vector. */
369 
    if (extra != nnames) {
10921 maechler 370 
	SET_ATTRIB(indx, indexnames);
1839 ihaka 371 
    }
8505 pd 372 
    if (canstretch)
373 
	*stretch = extra;
10718 maechler 374 
    UNPROTECT(4);
10921 maechler 375 
    return indx;
2 r 376 
}
377 
 
14913 rgentlem 378 
/* Array Subscripts.
379 
    dim is the dimension (0 to k-1)
380 
    s is the subscript list,
381 
    dims is the dimensions of x
382 
    dng is a function (usually getAttrib) that obtains the dimnames
383 
    x is the array to be subscripted.
384 
*/
2 r 385 
 
27383 rgentlem 386 
typedef SEXP AttrGetter(SEXP x, SEXP data);
14913 rgentlem 387 
 
27383 rgentlem 388 
SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
389 
		    StringEltGetter strg, SEXP x)
2 r 390 
{
2213 maechler 391 
    int nd, ns, stretch = 0;
14913 rgentlem 392 
    SEXP dnames, tmp;
1839 ihaka 393 
    ns = length(s);
394 
    nd = INTEGER(dims)[dim];
2 r 395 
 
1839 ihaka 396 
    switch (TYPEOF(s)) {
397 
    case NILSXP:
398 
	return allocVector(INTSXP, 0);
399 
    case LGLSXP:
4288 ihaka 400 
	return logicalSubscript(s, ns, nd, &stretch);
1839 ihaka 401 
    case INTSXP:
402 
	return integerSubscript(s, ns, nd, &stretch);
403 
    case REALSXP:
2504 pd 404 
    	PROTECT(tmp = coerceVector(s, INTSXP));
405 
	tmp = integerSubscript(tmp, ns, nd, &stretch);
406 
    	UNPROTECT(1);
407 
	return tmp;
1839 ihaka 408 
    case STRSXP:
14913 rgentlem 409 
	dnames = dng(x, R_DimNamesSymbol);
1839 ihaka 410 
	if (dnames == R_NilValue)
5731 ripley 411 
	    error("no dimnames attribute for array");
10172 luke 412 
	dnames = VECTOR_ELT(dnames, dim);
27383 rgentlem 413 
	return stringSubscript(s, ns, nd, dnames, strg, &stretch);
1839 ihaka 414 
    case SYMSXP:
415 
	if (s == R_MissingArg)
416 
	    return nullSubscript(nd);
417 
    default:
5731 ripley 418 
	error("invalid subscript");
1839 ihaka 419 
    }
420 
    return R_NilValue;
2 r 421 
}
422 
 
1839 ihaka 423 
/* Subscript creation.  The first thing we do is check to see */
424 
/* if there are any user supplied NULL's, these result in */
425 
/* returning a vector of length 0. */
15317 rgentlem 426 
/* if stretch is zero on entry then the vector x cannot be
427 
   "stretched",
428 
   otherwise, stretch returns the new required length for x
429 
*/
2 r 430 
 
1839 ihaka 431 
SEXP makeSubscript(SEXP x, SEXP s, int *stretch)
2 r 432 
{
15317 rgentlem 433 
    int nx;
434 
    SEXP ans;
2 r 435 
 
1839 ihaka 436 
    ans = R_NilValue;
437 
    if (isVector(x) || isList(x) || isLanguage(x)) {
438 
	nx = length(x);
15317 rgentlem 439 
 
27383 rgentlem 440 
	ans = vectorSubscript(nx, s, stretch, getAttrib, (STRING_ELT), x);
15317 rgentlem 441 
    }
442 
    else error("subscripting on non-vector");
443 
    return ans;
444 
 
445 
}
446 
 
447 
/* nx is the length of the object being subscripted,
448 
   s is the R subscript value,
449 
   dng gets a given attrib for x, which is the object we are
450 
   subsetting,
451 
*/
452 
 
27383 rgentlem 453 
SEXP vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
454 
		     StringEltGetter strg, SEXP x)
15317 rgentlem 455 
{
456 
    int ns;
15390 ripley 457 
    SEXP ans=R_NilValue, tmp;
15317 rgentlem 458 
 
459 
    ns = length(s);
460 
    /* special case for simple indices -- does not duplicate */
461 
    if (ns == 1 && TYPEOF(s) == INTSXP && ATTRIB(s) == R_NilValue) {
462 
	int i = INTEGER(s)[0];
463 
	if (0 < i && i <= nx) {
10782 luke 464 
	    *stretch = 0;
465 
	    return s;
466 
	}
15317 rgentlem 467 
    }
468 
    PROTECT(s=duplicate(s));
469 
    SET_ATTRIB(s, R_NilValue);
470 
    switch (TYPEOF(s)) {
471 
    case NILSXP:
472 
	*stretch = 0;
473 
	ans = allocVector(INTSXP, 0);
474 
	break;
475 
    case LGLSXP:
476 
	/* *stretch = 0; */
477 
	ans = logicalSubscript(s, ns, nx, stretch);
478 
	break;
479 
    case INTSXP:
1839 ihaka 480 
	    ans = integerSubscript(s, ns, nx, stretch);
481 
	    break;
15317 rgentlem 482 
    case REALSXP:
483 
	PROTECT(tmp = coerceVector(s, INTSXP));
484 
	ans = integerSubscript(tmp, ns, nx, stretch);
485 
	UNPROTECT(1);
486 
	break;
487 
    case STRSXP:
488 
    {
489 
	SEXP names = dng(x, R_NamesSymbol);
490 
	/* *stretch = 0; */
27383 rgentlem 491 
	ans = stringSubscript(s, ns, nx, names, strg, stretch);
15317 rgentlem 492 
    }
493 
    break;
494 
    case SYMSXP:
495 
	*stretch = 0;
496 
	if (s == R_MissingArg) {
497 
	    ans = nullSubscript(nx);
1839 ihaka 498 
	    break;
2 r 499 
	}
15317 rgentlem 500 
    default:
501 
	error("invalid subscript type");
1839 ihaka 502 
    }
15317 rgentlem 503 
    UNPROTECT(1);
1839 ihaka 504 
    return ans;
2 r 505 
}
27383 rgentlem 506 
 
507 
 
508