SEXP attribute_hidden do_earg_drop(SEXP call, SEXP op, SEXP arg_x, SEXP rho) { SEXP x, xdims; int i, n, shorten; x = arg_x; if ((xdims = getDimAttrib(x)) != R_NilValue) { n = LENGTH(xdims); shorten = 0; for (i = 0; i < n; i++) if (INTEGER(xdims)[i] == 1) shorten = 1; if (shorten) { if (MAYBE_REFERENCED(x)) x = duplicate(x); x = DropDims(x); } } return x; }
SEXP attribute_hidden do_drop(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP x, xdims; int i, n, shorten; checkArity(op, args); x = CAR(args); if ((xdims = getAttrib(x, R_DimSymbol)) != R_NilValue) { n = LENGTH(xdims); shorten = 0; for (i = 0; i < n; i++) if (INTEGER(xdims)[i] == 1) shorten = 1; if (shorten) { if (MAYBE_REFERENCED(x)) x = duplicate(x); x = DropDims(x); } } return x; }
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; }
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; }