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; }