The R Project SVN R

Rev

Rev 14913 | Rev 15390 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 14913 Rev 15317
Line 383... Line 383...
383 
    dims is the dimensions of x
 383 
    dims is the dimensions of x
384 
    dng is a function (usually getAttrib) that obtains the dimnames
 384 
    dng is a function (usually getAttrib) that obtains the dimnames
385 
    x is the array to be subscripted.
385 
    x is the array to be subscripted.
386 
*/
 386 
*/
387 
 
 387 
 
388 
typedef SEXP DimNamesGetter(SEXP x, SEXP data);
 388 
typedef SEXP AttrGetter(SEXP x, SEXP data);
389 
 
 389 
 
390 
SEXP arraySubscript(int dim, SEXP s, SEXP dims, DimNamesGetter dng, SEXP x)
 390 
SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng, SEXP x)
391 
{
 391 
{
392 
    int nd, ns, stretch = 0;
 392 
    int nd, ns, stretch = 0;
393 
    SEXP dnames, tmp;
 393 
    SEXP dnames, tmp;
394 
    ns = length(s);
 394 
    ns = length(s);
395 
    nd = INTEGER(dims)[dim];
 395 
    nd = INTEGER(dims)[dim];
Line 422... Line 422...
422 
}
 422 
}
423 
 
 423 
 
424 
/* Subscript creation.  The first thing we do is check to see */
 424 
/* Subscript creation.  The first thing we do is check to see */
425 
/* if there are any user supplied NULL's, these result in */
 425 
/* if there are any user supplied NULL's, these result in */
426 
/* returning a vector of length 0. */
 426 
/* returning a vector of length 0. */
- 
 
 427 
/* if stretch is zero on entry then the vector x cannot be
- 
 
 428 
   "stretched",
- 
 
 429 
   otherwise, stretch returns the new required length for x
- 
 
 430 
*/
427 
 
 431 
 
428 
SEXP makeSubscript(SEXP x, SEXP s, int *stretch)
 432 
SEXP makeSubscript(SEXP x, SEXP s, int *stretch)
429 
{
 433 
{
430 
    int nx, ns;
 434 
    int nx;
431 
    SEXP ans, tmp;
 435 
    SEXP ans;
432 
 
 436 
 
433 
    ans = R_NilValue;
 437 
    ans = R_NilValue;
434 
    if (isVector(x) || isList(x) || isLanguage(x)) {
 438 
    if (isVector(x) || isList(x) || isLanguage(x)) {
435 
	nx = length(x);
 439 
	nx = length(x);
- 
 
 440 
 
- 
 
 441 
	ans = vectorSubscript(nx, s, stretch, getAttrib, x);
- 
 
 442 
    }
- 
 
 443 
    else error("subscripting on non-vector");
- 
 
 444 
    return ans;
- 
 
 445 
 
- 
 
 446 
}
- 
 
 447 
 
- 
 
 448 
/* nx is the length of the object being subscripted,
- 
 
 449 
   s is the R subscript value,
- 
 
 450 
   dng gets a given attrib for x, which is the object we are
- 
 
 451 
   subsetting,
- 
 
 452 
*/
- 
 
 453
- 
 
 454 
SEXP vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
- 
 
 455 
		     SEXP x)
- 
 
 456 
{
- 
 
 457 
    int ns;
- 
 
 458 
    SEXP ans, tmp;
- 
 
 459 
 
436 
	ns = length(s);
 460 
    ns = length(s);
437 
	/* special case for simple indices -- does not duplicate */
 461 
    /* special case for simple indices -- does not duplicate */
438 
	if (ns == 1 && TYPEOF(s) == INTSXP && ATTRIB(s) == R_NilValue) {
 462 
    if (ns == 1 && TYPEOF(s) == INTSXP && ATTRIB(s) == R_NilValue) {
439 
	  int i = INTEGER(s)[0];
 463 
	int i = INTEGER(s)[0];
440 
	  if (0 < i && i <= nx) {
 464 
	if (0 < i && i <= nx) {
441 
	    *stretch = 0;
 465 
	    *stretch = 0;
442 
	    return s;
 466 
	    return s;
443 
	  }
 - 
 
444 
	}
 467 
	}
- 
 
 468 
    }
445 
	PROTECT(s=duplicate(s));
 469 
    PROTECT(s=duplicate(s));
446 
	SET_ATTRIB(s, R_NilValue);
 470 
    SET_ATTRIB(s, R_NilValue);
447 
	switch (TYPEOF(s)) {
 471 
    switch (TYPEOF(s)) {
448 
	case NILSXP:
 472 
    case NILSXP:
449 
	    *stretch = 0;
 473 
	*stretch = 0;
450 
	    ans = allocVector(INTSXP, 0);
 474 
	ans = allocVector(INTSXP, 0);
451 
	    break;
 475 
	break;
452 
	case LGLSXP:
 476 
    case LGLSXP:
453 
	    /* *stretch = 0; */
 477 
	/* *stretch = 0; */
454 
	    ans = logicalSubscript(s, ns, nx, stretch);
 478 
	ans = logicalSubscript(s, ns, nx, stretch);
455 
	    break;
 479 
	break;
456 
	case INTSXP:
 480 
    case INTSXP:
457 
	    ans = integerSubscript(s, ns, nx, stretch);
 481 
	    ans = integerSubscript(s, ns, nx, stretch);
458 
	    break;
 482 
	    break;
459 
	case REALSXP:
 483 
    case REALSXP:
460 
	    PROTECT(tmp = coerceVector(s, INTSXP));
 484 
	PROTECT(tmp = coerceVector(s, INTSXP));
461 
	    ans = integerSubscript(tmp, ns, nx, stretch);
 485 
	ans = integerSubscript(tmp, ns, nx, stretch);
462 
	    UNPROTECT(1);
 486 
	UNPROTECT(1);
463 
	    break;
 487 
	break;
464 
	case STRSXP:
 488 
    case STRSXP:
465 
	    {
 489 
    {
466 
		SEXP names = getAttrib(x, R_NamesSymbol);
 490 
	SEXP names = dng(x, R_NamesSymbol);
467 
		/* *stretch = 0; */
 491 
	/* *stretch = 0; */
468 
		ans = stringSubscript(s, ns, nx, names, stretch);
 492 
	ans = stringSubscript(s, ns, nx, names, stretch);
469 
	    }
 493 
    }
- 
 
 494 
    break;
- 
 
 495 
    case SYMSXP:
- 
 
 496 
	*stretch = 0;
- 
 
 497 
	if (s == R_MissingArg) {
- 
 
 498 
	    ans = nullSubscript(nx);
470 
	    break;
 499 
	    break;
471 
	case SYMSXP:
 - 
 
472 
	    *stretch = 0;
 - 
 
473 
	    if (s == R_MissingArg) {
 - 
 
474 
		ans = nullSubscript(nx);
 - 
 
475 
		break;
 - 
 
476 
	    }
 - 
 
477 
	default:
 - 
 
478 
	    error("invalid subscript type");
 - 
 
479 
	}
 500 
	}
480 
	UNPROTECT(1);
 501 
    default:
- 
 
 502 
	error("invalid subscript type");
481 
    }
 503 
    }
482 
    else error("subscripting on non-vector");
 504 
    UNPROTECT(1);
483 
    return ans;
 505 
    return ans;
484 
}
 506 
}
- 
 
 507 
 
- 
 
 508 
 
- 
 
 509