static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
{
int k, mode;
SEXP dimnames, dimnamesnames, p, q, r, result, xdims;
const void *vmaxsave = vmaxget();
mode = TYPEOF(x);
xdims = getAttrib(x, R_DimSymbol);
k = length(xdims);
/* k is now the number of dims */
int **subs = (int**)R_alloc(k, sizeof(int*));
int *indx = (int*)R_alloc(k, sizeof(int));
int *bound = (int*)R_alloc(k, sizeof(int));
R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t));
/* Construct a vector to contain the returned values. */
/* Store its extents. */
R_xlen_t n = 1;
r = s;
for (int i = 0; i < k; i++) {
SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call));
bound[i] = LENGTH(CAR(r));
n *= bound[i];
r = CDR(r);
}
PROTECT(result = allocVector(mode, n));
r = s;
for (int i = 0; i < k; i++) {
indx[i] = 0;
subs[i] = INTEGER(CAR(r));
r = CDR(r);
}
offset[0] = 1;
for (int i = 1; i < k; i++)
offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];
/* Transfer the subset elements from "x" to "a". */
for (R_xlen_t i = 0; i < n; i++) {
R_xlen_t ii = 0;
for (int j = 0; j < k; j++) {
int 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_FIX_NAMED(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:
errorcall(call, _("array subscripting not handled for this type"));
break;
}
if (n > 1) {
int j = 0;
while (++indx[j] >= bound[j]) {
indx[j] = 0;
j = (j + 1) % k;
}
}
}
PROTECT(xdims = allocVector(INTSXP, k));
for(int i = 0 ; i < k ; i++)
INTEGER(xdims)[i] = bound[i];
setAttrib(result, R_DimSymbol, xdims);
UNPROTECT(1); /* xdims */
/* 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);
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
if (dimnames != R_NilValue) {
int j = 0;
PROTECT(xdims = allocVector(VECSXP, k));
if (TYPEOF(dimnames) == VECSXP) {
r = s;
for (int 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(int 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); /* xdims */
}
/* This was removed for matrices in 1998
copyMostAttrib(x, result); */
/* Free temporary memory */
vmaxset(vmaxsave);
if (drop)
DropDims(result);
UNPROTECT(2); /* dimnamesnames, result */
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)
{
R_xlen_t n;
int mode;
R_xlen_t 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) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(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) {
if (
((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
)
) {
PROTECT(attrib);
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(2); /* attrib, nattrib */
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
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;
R_xlen_t 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, int_arraySubscript(0, CAR(s), dim, x, call));
sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));
nrs = LENGTH(sr);
ncs = LENGTH(sc);
/* Check this does not overflow: currently only possible on 32-bit */
if ((double)nrs * (double)ncs > R_XLEN_T_MAX)
error(_("dimensions would exceed maximum size of array"));
PROTECT(sr);
PROTECT(sc);
result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) 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:
errorcall(call, _("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_FIX_NAMED(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
errorcall(call, _("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);
PROTECT(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); /* newdimnames */
}
UNPROTECT(1); /* dimnamesnames */
}
/* Probably should not do this:
copyMostAttrib(x, result); */
if (drop)
DropDims(result);
UNPROTECT(3);
return result;
}
SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
SEXP result;
int i, j, nr, nc, nrs, ncs;
int P=0;
SEXP Dim = getAttrib(x, R_DimSymbol);
nrs = nrows(x);ncs = ncols(x);
nr = length(sr); nc = length(sc);
SEXP oindex, nindex;
oindex = getAttrib(x, install("index"));
PROTECT(nindex = allocVector(TYPEOF(oindex), nr)); P++;
PROTECT(result = allocVector(TYPEOF(x), nr*nc)); P++;
j = 0;
double *real_nindex=NULL, *real_oindex, *real_result=NULL, *real_x=NULL;
int *int_nindex=NULL, *int_oindex, *int_result=NULL, *int_x=NULL;
int *int_sr=NULL, *int_sc=NULL;
int_sr = INTEGER(sr);
int_sc = INTEGER(sc);
copyAttributes(x, result);
if(TYPEOF(x)==LGLSXP) {
int_x = LOGICAL(x);
int_result = LOGICAL(result);
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
/* branch into INTSXP and REALSXP, as these are most
common/important types for time series data
*/
if(TYPEOF(x)==INTSXP) {
int_x = INTEGER(x);
int_result = INTEGER(result);
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
/* loop through remaining columns */
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
int_result[i+j*nr] = NA_INTEGER;
else
int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
if(TYPEOF(x)==REALSXP) {
real_x = REAL(x);
real_result = REAL(result);
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
real_result[i+j*nr] = NA_REAL;
else
real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
real_result[i+j*nr] = NA_REAL;
else
real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
real_result[i+j*nr] = NA_REAL;
else
real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
if(TYPEOF(x)==CPLXSXP) {
/*
real_x = REAL(x);
real_result = REAL(result);
*/
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER) {
COMPLEX(result)[i+j*nr].r = NA_REAL;
COMPLEX(result)[i+j*nr].i = NA_REAL;
} else
COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER) {
COMPLEX(result)[i+j*nr].r = NA_REAL;
COMPLEX(result)[i+j*nr].i = NA_REAL;
} else
COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER) {
COMPLEX(result)[i+j*nr].r = NA_REAL;
COMPLEX(result)[i+j*nr].i = NA_REAL;
} else
COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
} else
if(TYPEOF(x)==STRSXP) {
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
SET_STRING_ELT(result, i+j*nr, NA_STRING);
else
SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
SET_STRING_ELT(result, i+j*nr, NA_STRING);
else
SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
SET_STRING_ELT(result, i+j*nr, NA_STRING);
else
SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
}
}
} else
if(TYPEOF(x)==RAWSXP) {
/*
real_x = REAL(x);
real_result = REAL(result);
*/
if(TYPEOF(nindex)==INTSXP) {
int_nindex = INTEGER(nindex);
int_oindex = INTEGER(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
int_nindex[i] = int_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
RAW(result)[i+j*nr] = 0;
else
RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
} else
if(TYPEOF(nindex)==REALSXP) {
real_nindex = REAL(nindex);
real_oindex = REAL(oindex);
for(i=0; i<nr; i++) {
if(int_sr[i] == NA_INTEGER)
error("'i' contains NA");
if(int_sr[i] > nrs || int_sc[j] > ncs)
error("'i' or 'j' out of range");
real_nindex[i] = real_oindex[int_sr[i]-1];
if(int_sc[j] == NA_INTEGER)
RAW(result)[i+j*nr] = 0;
else
RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
copyAttributes(oindex, nindex);
setAttrib(result, install("index"), nindex);
for(j=1; j<nc; j++) {
for(i=0; i<nr; i++) {
if(int_sc[j] == NA_INTEGER)
RAW(result)[i+j*nr] = 0;
else
RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
}
}
}
if(!isNull(Dim) && nr >= 0 && nc >= 0) {
SEXP dim;
PROTECT(dim = allocVector(INTSXP,2));P++;
INTEGER(dim)[0] = nr;
INTEGER(dim)[1] = nc;
setAttrib(result, R_DimSymbol, dim);
if (nr >= 0 && nc >= 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, nr), sr));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, nc), sc));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(CAR(dimnames),
allocVector(STRSXP, nr), sr));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(CADR(dimnames),
allocVector(STRSXP, nc), sc));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1);
}
}
}
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
if(nc == 1 && LOGICAL(drop)[0])
setAttrib(result, R_DimSymbol, R_NilValue);
UNPROTECT(P);
return result;
}
