/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
* Copyright (C) 1997-2006 The R Development Core Team
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street Fifth Floor, Boston, MA 02110-1301 USA
*
*
* Vector and List Subsetting
*
* There are three kinds of subscripting [, [[, and $.
* We have three different functions to compute these.
*
*
* Note on Matrix Subscripts
*
* The special [ subscripting where dim(x) == ncol(subscript matrix)
* is handled inside VectorSubset. The subscript matrix is turned
* into a subscript vector of the appropriate size and then
* VectorSubset continues. This provides coherence especially
* regarding attributes etc. (it would be quicker to handle this case
* separately, but then we would have more to keep in step.
*/
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include "Defn.h"
/* ExtractSubset does the transfer of elements from "x" to "result" */
/* according to the integer subscripts given in "indx". */
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx, SEXP call)
{
int i, ii, n, nx, mode;
SEXP tmp, tmp2;
mode = TYPEOF(x);
n = LENGTH(indx);
nx = length(x);
tmp = result;
if (x == R_NilValue)
return x;
for (i = 0; i < n; i++) {
ii = INTEGER(indx)[i];
if (ii != NA_INTEGER)
ii--;
switch (mode) {
case LGLSXP:
if (0 <= ii && ii < nx && ii != NA_LOGICAL)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_INTEGER;
break;
case INTSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
}
else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
case EXPRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case LISTSXP:
/* cannot happen: pairlists are coerced to lists */
case LANGSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
tmp2 = nthcdr(x, ii);
SETCAR(tmp, CAR(tmp2));
SET_TAG(tmp, TAG(tmp2));
}
else
SETCAR(tmp, R_NilValue);
tmp = CDR(tmp);
break;
case RAWSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
errorcall(call, R_MSG_ob_nonsub);
}
}
return result;
}
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
int n, mode, stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && (isInteger(s) || isReal(s)) &&
ncols(s) == length(attrib)) {
s = mat2indsub(attrib, s);
UNPROTECT(1);
PROTECT(s);
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch));
n = LENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue &&
(
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
)) {
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(1);
}
UNPROTECT(3);
return result;
}
static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
{
SEXP attr, result, sr, sc, dim;
int nr, nc, nrs, ncs;
int i, j, ii, jj, ij, iijj;
nr = nrows(x);
nc = ncols(x);
/* Note that "s" is protected on entry. */
/* The following ensures that pointers remain protected. */
dim = getAttrib(x, R_DimSymbol);
sr = SETCAR(s, arraySubscript(0, CAR(s), dim, getAttrib,
(STRING_ELT), x));
sc = SETCADR(s, arraySubscript(1, CADR(s), dim, getAttrib,
(STRING_ELT), x));
nrs = LENGTH(sr);
ncs = LENGTH(sc);
PROTECT(sr);
PROTECT(sc);
result = allocVector(TYPEOF(x), nrs*ncs);
PROTECT(result);
for (i = 0; i < nrs; i++) {
ii = INTEGER(sr)[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
errorcall(call, R_MSG_subs_o_b);
ii--;
}
for (j = 0; j < ncs; j++) {
jj = INTEGER(sc)[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
errorcall(call, R_MSG_subs_o_b);
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(result)[ij] = NA_INTEGER;
break;
case REALSXP:
REAL(result)[ij] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
error(_("matrix subscripting not handled for this type"));
break;
}
}
else {
iijj = ii + jj * nr;
switch (TYPEOF(x)) {
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
INTEGER(result)[ij] = INTEGER(x)[iijj];
break;
case REALSXP:
REAL(result)[ij] = REAL(x)[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
error(_("matrix subscripting not handled for this type"));
break;
}
}
}
}
if(nrs >= 0 && ncs >= 0) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
INTEGER(attr)[1] = ncs;
setAttrib(result, R_DimSymbol, attr);
UNPROTECT(1);
}
/* The matrix elements have been transferred. Now we need to */
/* transfer the attributes. Most importantly, we need to subset */
/* the dimnames of the returned value. */
if (nrs >= 0 && ncs >= 0) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, ncs), sc, call));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(CAR(dimnames),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(CADR(dimnames),
allocVector(STRSXP, ncs), sc, call));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1);
}
}
/* Probably should not do this:
copyMostAttrib(x, result); */
if (drop)
DropDims(result);
UNPROTECT(3);
return result;
}
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
{
int i, j, k, ii, jj, mode, n;
int **subs, *indx, *offset, *bound;
SEXP dimnames, dimnamesnames, p, q, r, result, xdims;
char *vmaxsave;
mode = TYPEOF(x);
xdims = getAttrib(x, R_DimSymbol);
k = length(xdims);
vmaxsave = vmaxget();
subs = (int**)R_alloc(k, sizeof(int*));
indx = (int*)R_alloc(k, sizeof(int));
offset = (int*)R_alloc(k, sizeof(int));
bound = (int*)R_alloc(k, sizeof(int));
/* Construct a vector to contain the returned values. */
/* Store its extents. */
n = 1;
r = s;
for (i = 0; i < k; i++) {
SETCAR(r, arraySubscript(i, CAR(r), xdims, getAttrib,
(STRING_ELT), x));
bound[i] = LENGTH(CAR(r));
n *= bound[i];
r = CDR(r);
}
PROTECT(result = allocVector(mode, n));
r = s;
for (i = 0; i < k; i++) {
indx[i] = 0;
subs[i] = INTEGER(CAR(r));
r = CDR(r);
}
offset[0] = 1;
for (i = 1; i < k; i++)
offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];
/* Transfer the subset elements from "x" to "a". */
for (i = 0; i < n; i++) {
ii = 0;
for (j = 0; j < k; j++) {
jj = subs[j][indx[j]];
if (jj == NA_INTEGER) {
ii = NA_INTEGER;
goto assignLoop;
}
if (jj < 1 || jj > INTEGER(xdims)[j])
errorcall(call, R_MSG_subs_o_b);
ii += (jj - 1) * offset[j];
}
assignLoop:
switch (mode) {
case LGLSXP:
if (ii != NA_INTEGER)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_LOGICAL;
break;
case INTSXP:
if (ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
}
else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
if (ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case RAWSXP:
if (ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
error(_("array subscripting not handled for this type"));
break;
}
if (n > 1) {
j = 0;
while (++indx[j] >= bound[j]) {
indx[j] = 0;
j = (j + 1) % k;
}
}
}
PROTECT(xdims = allocVector(INTSXP, k));
for(i = 0 ; i < k ; i++)
INTEGER(xdims)[i] = bound[i];
setAttrib(result, R_DimSymbol, xdims);
UNPROTECT(1);
/* The array elements have been transferred. */
/* Now we need to transfer the attributes. */
/* Most importantly, we need to subset the */
/* dimnames of the returned value. */
dimnames = getAttrib(x, R_DimNamesSymbol);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
if (dimnames != R_NilValue) {
/*SEXP xdims;
int */ j = 0;
PROTECT(xdims = allocVector(VECSXP, k));
if (TYPEOF(dimnames) == VECSXP) {
r = s;
for (i = 0; i < k ; i++) {
if (bound[i] > 0) {
SET_VECTOR_ELT(xdims, j++,
ExtractSubset(VECTOR_ELT(dimnames, i),
allocVector(STRSXP, bound[i]),
CAR(r), call));
} else { /* 0-length dims have NULL dimnames */
SET_VECTOR_ELT(xdims, j++, R_NilValue);
}
r = CDR(r);
}
}
else {
p = dimnames;
q = xdims;
r = s;
for(i = 0 ; i < k; i++) {
SETCAR(q, allocVector(STRSXP, bound[i]));
SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call));
p = CDR(p);
q = CDR(q);
r = CDR(r);
}
}
setAttrib(xdims, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, xdims);
UNPROTECT(1);
}
/* This was removed for matrices in 1998
copyMostAttrib(x, result); */
/* Free temporary memory */
vmaxset(vmaxsave);
if (drop)
DropDims(result);
UNPROTECT(1);
return result;
}
/* Extracts the drop argument, if present, from the argument list.
The object being subsetted must be the first argument. */
static void ExtractDropArg(SEXP el, int *drop)
{
SEXP last = el;
for (el = CDR(el); el != R_NilValue; el = CDR(el)) {
if(TAG(el) == R_DropSymbol) {
*drop = asLogical(CAR(el));
if (*drop == NA_LOGICAL) *drop = 1;
SETCDR(last, CDR(el));
}
else last = el;
}
}
/* The "[" subset operator.
* This provides the most general form of subsetting. */
SEXP attribute_hidden do_subset(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
/* If the first argument is an object and there is an */
/* approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall through */
/* to the generic code below. Note that evaluation */
/* retains any missing argument indicators. */
if(DispatchOrEval(call, op, "[", args, rho, &ans, 0, 0))
return(ans);
/* Method dispatch has failed, we now */
/* run the generic internal code. */
return do_subset_dflt(call, op, ans, rho);
}
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
PROTECT(args);
/* Handle case of extracting a single element from a simple vector
directly to improve speed for this simple case. */
if (CDDR(args) == R_NilValue) {
int i;
SEXP x = CAR(args);
SEXP s = CADR(args);
if (ATTRIB(x) == R_NilValue && ATTRIB(s) == R_NilValue) {
switch (TYPEOF(x)) {
case REALSXP:
switch (TYPEOF(s)) {
case REALSXP: i = (LENGTH(s) == 1) ? REAL(s)[0] : -1; break;
case INTSXP: i = (LENGTH(s) == 1) ? INTEGER(s)[0] : -1; break;
default: i = -1;
}
if (i >= 1 && i <= LENGTH(x)) {
ans = allocVector(REALSXP, 1);
REAL(ans)[0] = REAL(x)[i-1];
UNPROTECT(1);
return ans;
}
break;
case INTSXP:
switch (TYPEOF(s)) {
case REALSXP: i = (LENGTH(s) == 1) ? REAL(s)[0] : -1; break;
case INTSXP: i = (LENGTH(s) == 1) ? INTEGER(s)[0] : -1; break;
default: i = -1;
}
if (i >= 1 && i <= LENGTH(x)) {
ans = allocVector(INTSXP, 1);
INTEGER(ans)[0] = INTEGER(x)[i-1];
UNPROTECT(1);
return ans;
}
break;
default: break;
}
}
}
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs);
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub);
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg), call);
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
PROTECT(ans);
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
UNPROTECT(1);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0,
getAttrib(ans, R_NamesSymbol));
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(1);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
}
PROTECT(ans);
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) {
setAttrib(ans, R_TspSymbol, R_NilValue);
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
/* The [[ subset operator. It needs to be fast. */
/* The arguments to this call are evaluated on entry. */
SEXP attribute_hidden do_subset2(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
/* If the first argument is an object and there is */
/* an approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall */
/* through to the generic code below. Note that */
/* evaluation retains any missing argument indicators. */
if(DispatchOrEval(call, op, "[[", args, rho, &ans, 0, 0))
return(ans);
/* Method dispatch has failed. */
/* We now run the generic internal code. */
return do_subset2_dflt(call, op, ans, rho);
}
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, dims, dimnames, indx, subs, x;
int i, ndims, nsubs, offset = 0;
int drop = 1;
PROTECT(args);
ExtractDropArg(args, &drop);
x = CAR(args);
/* This code was intended for compatibility with S, */
/* but in fact S does not do this. Will anyone notice? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
/* Get the subscripting and dimensioning information */
/* and check that any array subscripting is compatible. */
subs = CDR(args);
if(0 == (nsubs = length(subs)))
errorcall(call, _("no index specified"));
dims = getAttrib(x, R_DimSymbol);
ndims = length(dims);
if(nsubs > 1 && nsubs != ndims)
errorcall(call, _("incorrect number of subscripts"));
/* split out ENVSXP for now */
if( TYPEOF(x) == ENVSXP ) {
if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
error(_("wrong arguments for subsetting an environment"));
ans = findVarInFrame(x, install(CHAR(STRING_ELT(CAR(subs),
0))));
if( TYPEOF(ans) == PROMSXP ) {
PROTECT(ans);
ans = eval(ans, R_GlobalEnv);
UNPROTECT(1);
} else {
SET_NAMED(ans, 2);
}
UNPROTECT(1);
if(ans == R_UnboundValue )
return(R_NilValue);
return(ans);
}
/* back to the regular program */
if (!(isVector(x) || isList(x) || isLanguage(x)))
errorcall(call, R_MSG_ob_nonsub);
if(nsubs == 1) { /* vector indexing */
SEXP thesub = CAR(subs);
int i =-1, len = length(thesub);
/* new case in 1.7.0, one vector index for a list */
if(isVectorList(x) && length(CAR(subs)) > 1) {
for(i = 0; i < len - 1; i++) {
if(!isVectorList(x))
error(_("recursive indexing failed at level %d\n"), i+1);
offset = get1index(CAR(subs), getAttrib(x, R_NamesSymbol),
length(x), /*partial ok*/TRUE, i);
if(offset < 0 || offset >= length(x))
error(_("no such index at level %d\n"), i+1);
x = VECTOR_ELT(x, offset);
}
}
offset = get1index(CAR(subs), getAttrib(x, R_NamesSymbol),
length(x), /*partial ok*/TRUE, i);
if (offset < 0 || offset >= length(x)) {
/* a bold attempt to get the same */
/* behaviour for $ and [[ */
if (offset < 0 && (isNewList(x) ||
isExpression(x) ||
isList(x) ||
isLanguage(x))) {
UNPROTECT(1);
return R_NilValue;
}
else errorcall(call, R_MSG_subs_o_b);
}
} else { /* matrix indexing */
/* Here we use the fact that: */
/* CAR(R_NilValue) = R_NilValue */
/* CDR(R_NilValue) = R_NilValue */
int ndn; /* Number of dimnames. Unlikely to be anything but
0 or nsubs, but just in case... */
PROTECT(indx = allocVector(INTSXP, nsubs));
dimnames = getAttrib(x, R_DimNamesSymbol);
ndn = length(dimnames);
for (i = 0; i < nsubs; i++) {
INTEGER(indx)[i] =
get1index(CAR(subs), (i < ndn) ? VECTOR_ELT(dimnames, i) :
R_NilValue,
INTEGER(indx)[i], /*partial ok*/TRUE, -1);
subs = CDR(subs);
if (INTEGER(indx)[i] < 0 ||
INTEGER(indx)[i] >= INTEGER(dims)[i])
errorcall(call, R_MSG_subs_o_b);
}
offset = 0;
for (i = (nsubs - 1); i > 0; i--)
offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
offset += INTEGER(indx)[0];
UNPROTECT(1);
}
if(isPairList(x)) {
ans = CAR(nthcdr(x, offset));
if (NAMED(x) > NAMED(ans))
SET_NAMED(ans, NAMED(x));
} else if(isVectorList(x)) {
/* did unconditional duplication before 2.4.0 */
ans = VECTOR_ELT(x, offset);
if (NAMED(x) > NAMED(ans))
SET_NAMED(ans, NAMED(x));
} else {
ans = allocVector(TYPEOF(x), 1);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(ans)[0] = INTEGER(x)[offset];
break;
case REALSXP:
REAL(ans)[0] = REAL(x)[offset];
break;
case CPLXSXP:
COMPLEX(ans)[0] = COMPLEX(x)[offset];
break;
case STRSXP:
SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
break;
case RAWSXP:
RAW(ans)[0] = RAW(x)[offset];
break;
default:
UNIMPLEMENTED_TYPE("do_subset2", x);
}
}
UNPROTECT(1);
return ans;
}
/* A helper to partially match tags against a candidate. */
/* Returns: */
static
enum pmatch {
NO_MATCH,
EXACT_MATCH,
PARTIAL_MATCH
}
pstrmatch(SEXP target, SEXP input, int slen)
{
char *st="";
if(target == R_NilValue)
return NO_MATCH;
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = CHAR(target);
break;
}
if(strncmp(st, CHAR(input), slen) == 0) {
if (strlen(st) == slen)
return EXACT_MATCH;
else
return PARTIAL_MATCH;
}
else return NO_MATCH;
}
/* The $ subset operator.
We need to be sure to only evaluate the first argument.
The second will be a symbol that needs to be matched, not evaluated.
*/
SEXP attribute_hidden do_subset3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP input, nlist, ans;
checkArity(op, args);
/* first translate CADR of args into a string so that we can
pass it down to DispatchorEval and have it behave correctly */
input = PROTECT(allocVector(STRSXP, 1));
nlist = CADR(args);
if(isSymbol(nlist) )
SET_STRING_ELT(input, 0, PRINTNAME(nlist));
else if(isString(nlist) )
SET_STRING_ELT(input, 0, STRING_ELT(nlist, 0));
else {
errorcall_return(call, _("invalid subscript type"));
}
/* replace the second argument with a string */
/* Previously this was SETCADR(args, input); */
/* which could cause problems when nlist was */
/* ..., as in PR#8718 */
PROTECT(args = CONS(CAR(args), CONS(input, R_NilValue)));
/* If the first argument is an object and there is */
/* an approriate method, we dispatch to that method, */
/* otherwise we evaluate the arguments and fall */
/* through to the generic code below. Note that */
/* evaluation retains any missing argument indicators. */
if(DispatchOrEval(call, op, "$", args, env, &ans, 0, 0)) {
UNPROTECT(2);
return(ans);
}
UNPROTECT(2);
return R_subset3_dflt(CAR(ans), STRING_ELT(input, 0));
}
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input)
{
SEXP y, nlist;
int slen;
PROTECT(x);
PROTECT(input);
/* Optimisation to prevent repeated recalculation */
slen = strlen(CHAR(input));
/* If this is not a list object we return NULL. */
/* Or should this be allocVector(VECSXP, 0)? */
if (isPairList(x)) {
SEXP xmatch=R_NilValue;
int havematch;
UNPROTECT(2);
havematch = 0;
for (y = x ; y != R_NilValue ; y = CDR(y)) {
switch(pstrmatch(TAG(y), input, slen)) {
case EXACT_MATCH:
y = CAR(y);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
xmatch = y;
break;
case NO_MATCH:
break;
}
}
if (havematch == 1) {
y = CAR(xmatch);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if (isVectorList(x)) {
int i, n, havematch, imatch=-1;
nlist = getAttrib(x, R_NamesSymbol);
UNPROTECT(2);
n = length(nlist);
havematch = 0;
for (i = 0 ; i < n ; i = i + 1) {
switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
case EXACT_MATCH:
y = VECTOR_ELT(x, i);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
imatch = i;
break;
case NO_MATCH:
break;
}
}
if(havematch == 1) {
y = VECTOR_ELT(x, imatch);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if( isEnvironment(x) ){
y = findVarInFrame(x, install(CHAR(input)));
if( TYPEOF(y) == PROMSXP ) {
PROTECT(y);
y = eval(y, R_GlobalEnv);
UNPROTECT(1);
}
UNPROTECT(2);
if( y != R_UnboundValue ) {
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return(y);
}
return R_NilValue;
}
UNPROTECT(2);
return R_NilValue;
}
syntax highlighted by Code2HTML, v. 0.9.1