SEXP attribute_hidden do_rapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP X, FUN, classes, deflt, how, ans, names;
int i, n;
Rboolean replace;
checkArity(op, args);
X = CAR(args); args = CDR(args);
FUN = CAR(args); args = CDR(args);
if(!isFunction(FUN)) error(_("invalid '%s' argument"), "f");
classes = CAR(args); args = CDR(args);
if(!isString(classes)) error(_("invalid '%s' argument"), "classes");
deflt = CAR(args); args = CDR(args);
how = CAR(args);
if(!isString(how)) error(_("invalid '%s' argument"), "how");
replace = CXXRCONSTRUCT(Rboolean, strcmp(CHAR(STRING_ELT(how, 0)), "replace") == 0); /* ASCII */
n = length(X);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
/* or copy attributes if replace = TRUE? */
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;
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names, X, XX, FUN;
R_xlen_t i, n;
PROTECT_INDEX px;
checkArity(op, args);
PROTECT_WITH_INDEX(X = CAR(args), &px);
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* 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>]], ...) */
/* 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(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
tmp = eval(R_fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(3);
}
UNPROTECT(3); /* X, XX, ans */
return ans;
}
// used in GScale(), but also grDevices/src/axis_scales.c :
// (usr, log, n_inp) |--> (axp, n_out) :
void GAxisPars(double *min, double *max, int *n, Rboolean log, int axis)
{
#define EPS_FAC_2 100
Rboolean swap = CXXRCONSTRUCT(Rboolean, *min > *max);
double t_, min_o, max_o;
if(swap) { /* Feature: in R, something like xlim = c(100,0) just works */
t_ = *min; *min = *max; *max = t_;
}
/* save only for the extreme case (EPS_FAC_2): */
min_o = *min; max_o = *max;
if(log) {
/* Avoid infinities */
if(*max > 308) *max = 308;
if(*min < -307) *min = -307;
*min = Rexp10(*min);
*max = Rexp10(*max);
GLPretty(min, max, n);
}
else GEPretty(min, max, n);
double tmp2 = EPS_FAC_2 * DBL_EPSILON;/* << prevent overflow in product below */
if(fabs(*max - *min) < (t_ = fmax2(fabs(*max), fabs(*min)))* tmp2) {
/* Treat this case somewhat similar to the (min ~= max) case above */
/* Too much accuracy here just shows machine differences */
warning(_("relative range of values =%4.0f * EPS, is small (axis %d)")
/*"to compute accurately"*/,
fabs(*max - *min) / (t_*DBL_EPSILON), axis);
/* No pretty()ing anymore */
*min = min_o;
*max = max_o;
double eps = .005 * fabs(*max - *min);/* .005: not to go to DBL_MIN/MAX */
*min += eps;
*max -= eps;
if(log) {
*min = Rexp10(*min);
*max = Rexp10(*max);
}
*n = 1;
}
if(swap) {
t_ = *min; *min = *max; *max = t_;
}
}
SEXP attribute_hidden do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP X;
Rboolean lans = TRUE, recursive;
int i, n;
checkArity(op, args);
X = CAR(args);
recursive = CXXRCONSTRUCT(Rboolean, asLogical(CADR(args)));
n = length(X);
if(n == 0 || !isVectorList(X)) {
lans = FALSE;
goto do_ans;
}
if(!recursive) {
for(i = 0; i < LENGTH(X); i++)
if(!isFactor(VECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
} else {
switch(TYPEOF(X)) {
case VECSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(VECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
break;
case EXPRSXP:
for(i = 0; i < LENGTH(X); i++)
if(!islistfactor(XVECTOR_ELT(X, i))) {
lans = FALSE;
break;
}
break;
default:
break;
}
}
do_ans:
return ScalarLogical(lans);
}
/* 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; // -Wall
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 = CXXRCONSTRUCT(Rboolean, 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);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (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>]], ...) */
/* 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(ind = allocVector(INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
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 = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
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) {
bool 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;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
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);
for (int j = 0; j < commonLen; j++) {
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
default:
error(_("type '%s' is not supported"), type2char(commonType));
}
}
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;
}
SEXP attribute_hidden do_sprintf(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;
/* fmt2 is a copy of fmt with '*' expanded.
bit will hold numeric formats and %<w>s, so be quite small. */
char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
*outputString;
const char *formatString;
size_t n, cur, chunk;
SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue;
int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
static R_StringBuffer outbuff = {nullptr, 0, MAXELTSIZE};
Rboolean has_star, use_UTF8;
#define _my_sprintf(_X_) \
{ \
int nc = snprintf(bit, MAXLINE+1, fmtp, _X_); \
if (nc > MAXLINE) \
error(_("required resulting string length %d is greater than maximal %d"), \
nc, MAXLINE); \
}
nargs = num_args;
/* grab the format string */
format = num_args ? args[0] : nullptr;
if (!isString(format))
error(_("'fmt' is not a character vector"));
nfmt = length(format);
if (nfmt == 0) return allocVector(STRSXP, 0);
args = (args + 1); nargs--;
if(nargs >= MAXNARGS)
error(_("only %d arguments are allowed"), MAXNARGS);
/* record the args for possible coercion and later re-ordering */
for(i = 0; i < nargs; i++, args = (args + 1)) {
SEXPTYPE t_ai;
a[i] = args[0];
if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */
error(_("invalid type of argument[%d]: '%s'"),
i+1, CHAR(type2str(t_ai)));
lens[i] = length(a[i]);
if(lens[i] == 0) return allocVector(STRSXP, 0);
}
#define CHECK_maxlen \
maxlen = nfmt; \
for(i = 0; i < nargs; i++) \
if(maxlen < lens[i]) maxlen = lens[i]; \
if(maxlen % nfmt) \
error(_("arguments cannot be recycled to the same length")); \
for(i = 0; i < nargs; i++) \
if(maxlen % lens[i]) \
error(_("arguments cannot be recycled to the same length"))
CHECK_maxlen;
outputString = CXXRCONSTRUCT(static_cast<char*>, R_AllocStringBuffer(0, &outbuff));
/* We do the format analysis a row at a time */
for(ns = 0; ns < maxlen; ns++) {
outputString[0] = '\0';
use_UTF8 = CXXRCONSTRUCT(Rboolean, getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8);
if (!use_UTF8) {
for(i = 0; i < nargs; i++) {
if (!isString(a[i])) continue;
if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) {
use_UTF8 = TRUE; break;
}
}
}
formatString = TRANSLATE_CHAR(format, ns % nfmt);
n = strlen(formatString);
if (n > MAXLINE)
error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
/* process the format string */
for (cur = 0, cnt = 0; cur < n; cur += chunk) {
const char *curFormat = formatString + cur, *ss;
char *starc;
ss = nullptr;
if (formatString[cur] == '%') { /* handle special format command */
if (cur < n - 1 && formatString[cur + 1] == '%') {
/* take care of %% in the format */
chunk = 2;
strcpy(bit, "%");
}
else {
/* recognise selected types from Table B-1 of K&R */
/* NB: we deal with "%%" in branch above. */
/* This is MBCS-OK, as we are in a format spec */
chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2;
if (cur + chunk > n)
error(_("unrecognised format specification '%s'"), curFormat);
strncpy(fmt, curFormat, chunk);
fmt[chunk] = '\0';
nthis = -1;
/* now look for %n$ or %nn$ form */
if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
v = fmt[1] - '0';
if(fmt[2] == '$') {
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nthis = v-1;
memmove(fmt+1, fmt+3, strlen(fmt)-2);
} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
v = 10*v + fmt[2] - '0';
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nthis = v-1;
memmove(fmt+1, fmt+4, strlen(fmt)-3);
}
}
starc = Rf_strchr(fmt, '*');
if (starc) { /* handle * format if present */
nstar = -1;
if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') {
v = starc[1] - '0';
if(starc[2] == '$') {
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nstar = v-1;
memmove(starc+1, starc+3, strlen(starc)-2);
} else if(starc[2] >= '0' && starc[2] <= '9'
&& starc[3] == '$') {
v = 10*v + starc[2] - '0';
if(v > nargs)
error(_("reference to non-existent argument %d"), v);
nstar = v-1;
memmove(starc+1, starc+4, strlen(starc)-3);
}
}
if(nstar < 0) {
if (cnt >= nargs) error(_("too few arguments"));
nstar = cnt++;
}
if (Rf_strchr(starc+1, '*'))
error(_("at most one asterisk '*' is supported in each conversion specification"));
_this = a[nstar];
if(ns == 0 && TYPEOF(_this) == REALSXP) {
_this = coerceVector(_this, INTSXP);
PROTECT(a[nstar] = _this);
nprotect++;
}
if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 ||
INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER)
error(_("argument for '*' conversion specification must be a number"));
star_arg = INTEGER(_this)[ns % LENGTH(_this)];
has_star = TRUE;
}
else
has_star = FALSE;
if (fmt[strlen(fmt) - 1] == '%') {
/* handle % with formatting options */
if (has_star)
snprintf(bit, MAXLINE+1, fmt, star_arg);
else
strcpy(bit, fmt);
/* was sprintf(..) for which some compiler warn */
} else {
Rboolean did_this = FALSE;
if(nthis < 0) {
if (cnt >= nargs) error(_("too few arguments"));
nthis = cnt++;
}
_this = a[nthis];
if (has_star) {
size_t nf; char *p, *q = fmt2;
for (p = fmt; *p; p++)
if (*p == '*') q += sprintf(q, "%d", star_arg);
else *q++ = *p;
*q = '\0';
nf = strlen(fmt2);
if (nf > MAXLINE)
error(_("'fmt' length exceeds maximal format length %d"),
MAXLINE);
fmtp = fmt2;
} else fmtp = fmt;
#define CHECK_this_length \
PROTECT(_this); \
thislen = length(_this); \
if(thislen == 0) \
error(_("coercion has changed vector length to 0"))
/* Now let us see if some minimal coercion
would be sensible, but only do so once, for ns = 0: */
if(ns == 0) {
SEXP tmp; Rboolean do_check;
switch(*findspec(fmtp)) {
case 'd':
case 'i':
case 'o':
case 'x':
case 'X':
if(TYPEOF(_this) == REALSXP) {
double r = REAL(_this)[0];
// qdapTools manages to call this with NaN
if(R_FINITE(r) && (double)((int) r) == r)
_this = coerceVector(_this, INTSXP);
PROTECT(a[nthis] = _this);
nprotect++;
}
break;
case 'a':
case 'A':
case 'e':
case 'f':
case 'g':
case 'E':
case 'G':
if(TYPEOF(_this) != REALSXP &&
/* no automatic as.double(<string>) : */
TYPEOF(_this) != STRSXP) {
PROTECT(tmp = lang2(install("as.double"), _this));
#define COERCE_THIS_TO_A \
_this = eval(tmp, env); \
UNPROTECT(1); \
PROTECT(a[nthis] = _this); \
nprotect++; \
did_this = TRUE; \
CHECK_this_length; \
do_check = (CXXRCONSTRUCT(Rboolean, lens[nthis] == maxlen)); \
lens[nthis] = thislen; /* may have changed! */ \
if(do_check && thislen < maxlen) { \
CHECK_maxlen; \
}
COERCE_THIS_TO_A
}
break;
case 's':
if(TYPEOF(_this) != STRSXP) {
/* as.character method might call sprintf() */
size_t nc = strlen(outputString);
char *z = Calloc(nc+1, char);
strcpy(z, outputString);
PROTECT(tmp = lang2(install("as.character"), _this));
COERCE_THIS_TO_A
strcpy(outputString, z);
Free(z);
}
break;
default:
break;
}
} /* ns == 0 (first-time only) */
if(!did_this)
CHECK_this_length;
switch(TYPEOF(_this)) {
case LGLSXP:
{
int x = LOGICAL(_this)[ns % thislen];
if (checkfmt(fmtp, "di"))
error(_("invalid format '%s'; %s"), fmtp,
_("use format %d or %i for logical objects"));
if (x == NA_LOGICAL) {
fmtp[strlen(fmtp)-1] = 's';
_my_sprintf("NA")
} else {
_my_sprintf(x)
}
break;
}
case INTSXP:
{
int x = INTEGER(_this)[ns % thislen];
if (checkfmt(fmtp, "dioxX"))
error(_("invalid format '%s'; %s"), fmtp,
_("use format %d, %i, %o, %x or %X for integer objects"));
if (x == NA_INTEGER) {
fmtp[strlen(fmtp)-1] = 's';
_my_sprintf("NA")
} else {
_my_sprintf(x)
}
break;
}
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
int m, zero = 0;
R_xlen_t *lengths, *counters, longest = 0;
m = length(varyingArgs);
SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
Rboolean named = CXXRCONSTRUCT(Rboolean, vnames != R_NilValue);
lengths = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
for (int i = 0; i < m; i++) {
SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
lengths[i] = xlength(tmp1);
if (isObject(tmp1)) { // possibly dispatch on length()
/* Cache the .Primitive: unclear caching is worthwhile. */
static SEXP length_op = NULL;
if (length_op == NULL) length_op = R_Primitive("length");
// DispatchOrEval() needs 'args' to be a pairlist
SEXP ans, tmp2 = PROTECT(list1(tmp1));
if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
lengths[i] = R_xlen_t( (TYPEOF(ans) == REALSXP ?
REAL(ans)[0] : asInteger(ans)));
UNPROTECT(1);
}
if (lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("zero-length inputs cannot be mixed with those of non-zero length"));
counters = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
memset(counters, 0, m * sizeof(R_xlen_t));
SEXP mindex = PROTECT(allocVector(VECSXP, m));
SEXP nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
SEXP fcall = R_NilValue; // -Wall
if (constantArgs == R_NilValue)
;
else if (isVectorList(constantArgs))
fcall = VectorToPairList(constantArgs);
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
PROTECT_INDEX fi;
PROTECT_WITH_INDEX(fcall, &fi);
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, longest > INT_MAX);
SEXP Dots = install("dots");
for (int j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
REPROTECT(fcall = CONS(tmp2, fcall), fi);
UNPROTECT(2);
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
}
REPROTECT(fcall = LCONS(f, fcall), fi);
SEXP ans = PROTECT(allocVector(VECSXP, longest));
for (int i = 0; i < longest; i++) {
for (int j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
if (realIndx)
REAL(VECTOR_ELT(nindex, j))[0] = double( counters[j]);
else
INTEGER(VECTOR_ELT(nindex, j))[0] = int( counters[j]);
}
SEXP tmp = eval(fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
for (int j = 0; j < m; j++)
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
UNPROTECT(5);
return ans;
}
SEXP attribute_hidden do_split(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
SEXP x, f, counts, vec, nm, nmj;
Rboolean have_names;
op->checkNumArgs(num_args, call);
x = args[0];
f = args[1];
if (!isVector(x))
error(_("first argument must be a vector"));
if (!isFactor(f))
error(_("second argument must be a factor"));
int nlevs = nlevels(f);
R_xlen_t nfac = XLENGTH(args[1]);
R_xlen_t nobs = XLENGTH(args[0]);
if (nfac <= 0 && nobs > 0)
error(_("group length is 0 but data length > 0"));
if (nfac > 0 && (nobs % nfac) != 0)
warning(_("data length is not a multiple of split variable"));
nm = getAttrib(x, R_NamesSymbol);
have_names = CXXRCONSTRUCT(Rboolean, nm != nullptr);
PROTECT(counts = allocVector(INTSXP, nlevs));
for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
for (R_xlen_t i = 0; i < nobs; i++) {
int j = INTEGER(f)[i % nfac];
if (j != NA_INTEGER) {
/* protect against malformed factors */
if (j > nlevs || j < 1) error(_("factor has bad level"));
INTEGER(counts)[j - 1]++;
}
}
/* Allocate a generic vector to hold the results. */
/* The i-th element will hold the split-out data */
/* for the ith group. */
PROTECT(vec = allocVector(VECSXP, nlevs));
for (R_xlen_t i = 0; i < nlevs; i++) {
SET_VECTOR_ELT(vec, i, allocVector(TYPEOF(x), INTEGER(counts)[i]));
setAttrib(VECTOR_ELT(vec, i), R_LevelsSymbol,
getAttrib(x, R_LevelsSymbol));
if(have_names)
setAttrib(VECTOR_ELT(vec, i), R_NamesSymbol,
allocVector(STRSXP, INTEGER(counts)[i]));
}
for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
for (R_xlen_t i = 0; i < nobs; i++) {
int j = INTEGER(f)[i % nfac];
if (j != NA_INTEGER) {
int k = INTEGER(counts)[j - 1];
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(VECTOR_ELT(vec, j - 1))[k] = INTEGER(x)[i];
break;
case REALSXP:
REAL(VECTOR_ELT(vec, j - 1))[k] = REAL(x)[i];
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(vec, j - 1))[k] = COMPLEX(x)[i];
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(vec, j - 1), k, STRING_ELT(x, i));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(vec, j - 1), k, VECTOR_ELT(x, i));
break;
case RAWSXP:
RAW(VECTOR_ELT(vec, j - 1))[k] = RAW(x)[i];
break;
default:
UNIMPLEMENTED_TYPE("split", x);
}
if(have_names) {
nmj = getAttrib(VECTOR_ELT(vec, j - 1), R_NamesSymbol);
SET_STRING_ELT(nmj, k, STRING_ELT(nm, i));
}
INTEGER(counts)[j - 1] += 1;
}
}
setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
UNPROTECT(2);
return vec;
}
