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;
}
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;
}
SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
StringEltGetter strg, SEXP x)
{
return int_arraySubscript(dim, s, dims, dng, strg, x, TRUE);
}
