static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
Rboolean replace, SEXP rho)
{
SEXP ans, names, klass;
int i, j, n;
Rboolean matched = FALSE;
/* if X is a list, recurse. Otherwise if it matches classes call f */
if(isNewList(X)) {
n = length(X);
if (replace) {
PROTECT(ans = shallow_duplicate(X));
} else {
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
}
for(i = 0; i < n; i++)
SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
deflt, replace, rho));
UNPROTECT(1);
return ans;
}
if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
matched = TRUE;
else {
PROTECT(klass = R_data_class(X, FALSE));
for(i = 0; i < LENGTH(klass); i++)
for(j = 0; j < length(classes); j++)
if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
matched = TRUE;
UNPROTECT(1);
}
if(matched) {
/* This stores value to which the function is to be applied in
a variable X in the environment of the rapply closure call
that calls into the rapply .Internal. */
SEXP R_fcall; /* could allocate once and preserve for re-use */
SEXP Xsym = install("X");
defineVar(Xsym, X, rho);
INCREMENT_NAMED(X);
/* PROTECT(R_fcall = lang2(FUN, Xsym)); */
PROTECT(R_fcall = lang3(FUN, Xsym, R_DotsSymbol));
ans = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(ans))
ans = lazy_duplicate(ans);
UNPROTECT(1);
return(ans);
} else if(replace) return lazy_duplicate(X);
else return lazy_duplicate(deflt);
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises.
FUN must be unevaluated for use in e.g. bquote .
*/
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
PROTECT_INDEX px;
checkArity(op, args);
SEXP X, XX, FUN;
PROTECT_WITH_INDEX(X =CAR(args), &px);
XX = PROTECT(eval(CAR(args), rho));
R_xlen_t n = xlength(XX); // a vector, so will be valid.
FUN = CADR(args);
Rboolean realIndx = n > INT_MAX;
SEXP ans = PROTECT(allocVector(VECSXP, n));
SEXP names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP ind = PROTECT(allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP isym = install("i");
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
SEXP tmp = PROTECT(LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
SEXP R_fcall = PROTECT(LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
for(R_xlen_t i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
tmp = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(tmp)) tmp = lazy_duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(6);
return ans;
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; /* initialize to avoid a warning */
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = n > INT_MAX;
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
// check once here
if (commonType != CPLXSXP && commonType != REALSXP &&
commonType != INTSXP && commonType != LGLSXP &&
commonType != RAWSXP && commonType != STRSXP &&
commonType != VECSXP)
error(_("type '%s' is not supported"), type2char(commonType));
dim_v = getAttrib(value, R_DimSymbol);
array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1);
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP isym = install("i");
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(tmp = LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
int common_len_offset = 0;
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
val = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(val))
val = lazy_duplicate(val); // Need to duplicate? Copying again anyway
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
Rboolean okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
// two cases - only for efficiency
if(commonLen == 1) { // common case
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i] = COMPLEX(val)[0]; break;
case REALSXP: REAL(ans) [i] = REAL (val)[0]; break;
case INTSXP: INTEGER(ans)[i] = INTEGER(val)[0]; break;
case LGLSXP: LOGICAL(ans)[i] = LOGICAL(val)[0]; break;
case RAWSXP: RAW(ans) [i] = RAW (val)[0]; break;
case STRSXP: SET_STRING_ELT(ans, i, STRING_ELT(val, 0)); break;
case VECSXP: SET_VECTOR_ELT(ans, i, VECTOR_ELT(val, 0)); break;
}
} else { // commonLen > 1 (typically, or == 0) :
switch (commonType) {
case REALSXP:
memcpy(REAL(ans) + common_len_offset,
REAL(val), commonLen * sizeof(double)); break;
case INTSXP:
memcpy(INTEGER(ans) + common_len_offset,
INTEGER(val), commonLen * sizeof(int)); break;
case LGLSXP:
memcpy(LOGICAL(ans) + common_len_offset,
LOGICAL(val), commonLen * sizeof(int)); break;
case RAWSXP:
memcpy(RAW(ans) + common_len_offset,
RAW(val), commonLen * sizeof(Rbyte)); break;
case CPLXSXP:
memcpy(COMPLEX(ans) + common_len_offset,
COMPLEX(val), commonLen * sizeof(Rcomplex)); break;
case STRSXP:
for (int j = 0; j < commonLen; j++)
SET_STRING_ELT(ans, common_len_offset + j, STRING_ELT(val, j));
break;
case VECSXP:
for (int j = 0; j < commonLen; j++)
SET_VECTOR_ELT(ans, common_len_offset + j, VECTOR_ELT(val, j));
break;
}
common_len_offset += commonLen;
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = (int) n; // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
/* rep_len(x, len), also used for rep.int() with scalar 'times' */
static SEXP rep3(SEXP s, R_xlen_t ns, R_xlen_t na)
{
R_xlen_t i, j;
SEXP a;
PROTECT(a = allocVector(TYPEOF(s), na));
// i % ns is slow, especially with long R_xlen_t
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
LOGICAL(a)[i++] = LOGICAL(s)[j++];
}
break;
case INTSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
INTEGER(a)[i++] = INTEGER(s)[j++];
}
break;
case REALSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
REAL(a)[i++] = REAL(s)[j++];
}
break;
case CPLXSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
COMPLEX(a)[i++] = COMPLEX(s)[j++];
}
break;
case RAWSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
RAW(a)[i++] = RAW(s)[j++];
}
break;
case STRSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
SET_STRING_ELT(a, i++, STRING_ELT(s, j++));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
SET_VECTOR_ELT(a, i++, lazy_duplicate(VECTOR_ELT(s, j++)));
}
break;
default:
UNIMPLEMENTED_TYPE("rep3", s);
}
UNPROTECT(1);
return a;
}
/* rep.int(x, times) for a vector times */
static SEXP rep2(SEXP s, SEXP ncopy)
{
R_xlen_t i, na, nc, n;
int j;
SEXP a, t;
PROTECT(t = coerceVector(ncopy, INTSXP));
nc = xlength(ncopy);
na = 0;
for (i = 0; i < nc; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i] < 0)
error(_("invalid '%s' value"), "times");
na += INTEGER(t)[i];
}
/* R_xlen_t ni = NINTERRUPT, ratio;
if(nc > 0) {
ratio = na/nc; // average no of replications
if (ratio > 1000U) ni = 1000U;
} */
PROTECT(a = allocVector(TYPEOF(s), na));
n = 0;
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
LOGICAL(a)[n++] = LOGICAL(s)[i];
}
break;
case INTSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
INTEGER(a)[n++] = INTEGER(s)[i];
}
break;
case REALSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
REAL(a)[n++] = REAL(s)[i];
}
break;
case CPLXSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
COMPLEX(a)[n++] = COMPLEX(s)[i];
}
break;
case STRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
SET_STRING_ELT(a, n++, STRING_ELT(s, i));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
SEXP elt = lazy_duplicate(VECTOR_ELT(s, i));
for (j = 0; j < INTEGER(t)[i]; j++)
SET_VECTOR_ELT(a, n++, elt);
if (j > 1) SET_NAMED(elt, 2);
}
break;
case RAWSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
RAW(a)[n++] = RAW(s)[i];
}
break;
default:
UNIMPLEMENTED_TYPE("rep2", s);
}
UNPROTECT(2);
return a;
}
static SEXP duplicate_child(SEXP s, Rboolean deep) {
if (deep)
return duplicate1(s, TRUE);
else
return lazy_duplicate(s);
}
