SEXP attribute_hidden do_rowscols(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, ans;
int i, j, nr, nc;
checkArity(op, args);
/* This is the dimensions vector */
x = CAR(args);
if (!isInteger(x) || LENGTH(x) != 2)
error(_("a matrix-like object is required as argument to '%s'"),
(PRIMVAL(op) == 2) ? "col" : "row");
nr = INTEGER(x)[0];
nc = INTEGER(x)[1];
ans = allocMatrix(INTSXP, nr, nc);
R_xlen_t NR = nr;
switch (PRIMVAL(op)) {
case 1:
for (i = 0; i < nr; i++)
for (j = 0; j < nc; j++)
INTEGER(ans)[i + j * NR] = i + 1;
break;
case 2:
for (i = 0; i < nr; i++)
for (j = 0; j < nc; j++)
INTEGER(ans)[i + j * NR] = j + 1;
break;
}
return ans;
}
SEXP attribute_hidden do_sysbrowser(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP rval=R_NilValue;
RCNTXT *cptr;
int n;
checkArity(op, args);
n = asInteger(CAR(args));
if(n < 1 ) error(_("number of contexts must be positive"));
/* first find the closest browser context */
cptr = R_GlobalContext;
while (cptr != R_ToplevelContext) {
if (cptr->callflag == CTXT_BROWSER) {
break;
}
cptr = cptr->nextcontext;
}
/* error if not a browser context */
if( !(cptr->callflag == CTXT_BROWSER) )
error(_("no browser context to query"));
switch (PRIMVAL(op)) {
case 1: /* text */
case 2: /* condition */
/* first rewind to the right place if needed */
/* note we want n>1, as we have already */
/* rewound to the first context */
if( n > 1 ) {
while (cptr != R_ToplevelContext && n > 0 ) {
if (cptr->callflag == CTXT_BROWSER) {
n--;
break;
}
cptr = cptr->nextcontext;
}
}
if( !(cptr->callflag == CTXT_BROWSER) )
error(_("not that many calls to browser are active"));
if( PRIMVAL(op) == 1 )
rval = CAR(cptr->promargs);
else
rval = CADR(cptr->promargs);
break;
case 3: /* turn on debugging n levels up */
while ( (cptr != R_ToplevelContext) && n > 0 ) {
if (cptr->callflag & CTXT_FUNCTION)
n--;
cptr = cptr->nextcontext;
}
if( !(cptr->callflag & CTXT_FUNCTION) )
error(_("not that many functions on the call stack"));
else
SET_RDEBUG(cptr->cloenv, 1);
break;
}
return(rval);
}
SEXP do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
int i;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
s = allocVector(CPLXSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for (i = 0 ; i < length(t) ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
case 4: /* cummin */
errorcall(call, _("min/max not defined for complex numbers"));
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
else { /* Non-Complex: here, (sh|c)ould differentiate real / int */
PROTECT(t = coerceVector(CAR(args), REALSXP));
s = allocVector(REALSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for(i = 0 ; i < length(t) ; i++)
REAL(s)[i] = NA_REAL;
UNPROTECT(1);
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
/* && || */
SEXP attribute_hidden do_logic2(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* && and || */
SEXP s1, s2;
int x1, x2;
SEXP ans;
if (length(args) != 2)
error(_("'%s' operator requires 2 arguments"),
PRIMVAL(op) == 1 ? "&&" : "||");
s1 = CAR(args);
s2 = CADR(args);
PROTECT(ans = allocVector(LGLSXP, 1));
s1 = eval(s1, env);
if (!isNumber(s1))
errorcall(call, _("invalid 'x' type in 'x %s y'"),
PRIMVAL(op) == 1 ? "&&" : "||");
x1 = asLogical(s1);
#define get_2nd \
s2 = eval(s2, env); \
if (!isNumber(s2)) \
errorcall(call, _("invalid 'y' type in 'x %s y'"), \
PRIMVAL(op) == 1 ? "&&" : "||"); \
x2 = asLogical(s2);
switch (PRIMVAL(op)) {
case 1: /* && */
if (x1 == FALSE)
LOGICAL(ans)[0] = FALSE;
else {
get_2nd;
if (x1 == NA_LOGICAL)
LOGICAL(ans)[0] = (x2 == NA_LOGICAL || x2) ? NA_LOGICAL : x2;
else /* x1 == TRUE */
LOGICAL(ans)[0] = x2;
}
break;
case 2: /* || */
if (x1 == TRUE)
LOGICAL(ans)[0] = TRUE;
else {
get_2nd;
if (x1 == NA_LOGICAL)
LOGICAL(ans)[0] = (x2 == NA_LOGICAL || !x2) ? NA_LOGICAL : x2;
else /* x1 == FALSE */
LOGICAL(ans)[0] = x2;
}
}
UNPROTECT(1);
return ans;
}
/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, s, t, call2;
int narm, has_na = 0;
/* initialize for behavior on empty vector
all(logical(0)) -> TRUE
any(logical(0)) -> FALSE
*/
Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;
PROTECT(args = fixup_NaRm(args));
PROTECT(call2 = duplicate(call));
SETCDR(call2, args);
if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
UNPROTECT(2);
return(ans);
}
ans = matchArgExact(R_NaRmSymbol, &args);
narm = asLogical(ans);
for (s = args; s != R_NilValue; s = CDR(s)) {
t = CAR(s);
/* Avoid memory waste from coercing empty inputs, and also
avoid warnings with empty lists coming from sapply */
if(xlength(t) == 0) continue;
/* coerceVector protects its argument so this actually works
just fine */
if (TYPEOF(t) != LGLSXP) {
/* Coercion of integers seems reasonably safe, but for
other types it is more often than not an error.
One exception is perhaps the result of lapply, but
then sapply was often what was intended. */
if(TYPEOF(t) != INTSXP)
warningcall(call,
_("coercing argument of type '%s' to logical"),
type2char(TYPEOF(t)));
t = coerceVector(t, LGLSXP);
}
val = checkValues(PRIMVAL(op), narm, LOGICAL(t), XLENGTH(t));
if (val != NA_LOGICAL) {
if ((PRIMVAL(op) == _OP_ANY && val)
|| (PRIMVAL(op) == _OP_ALL && !val)) {
has_na = 0;
break;
}
} else has_na = 1;
}
UNPROTECT(2);
return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
SEXP attribute_hidden do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue;
checkArity(op,args);
#define find_char_fun \
if (isValidString(CAR(args))) { \
SEXP s; \
PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0))); \
SETCAR(args, findFun(s, rho)); \
UNPROTECT(1); \
}
find_char_fun
if (TYPEOF(CAR(args)) != CLOSXP && TYPEOF(CAR(args)) != SPECIALSXP
&& TYPEOF(CAR(args)) != BUILTINSXP )
errorcall(call, _("argument must be a closure"));
switch(PRIMVAL(op)) {
case 0:
SET_RDEBUG(CAR(args), 1);
break;
case 1:
if( RDEBUG(CAR(args)) != 1 )
warningcall(call, "argument is not being debugged");
SET_RDEBUG(CAR(args), 0);
break;
case 2:
ans = ScalarLogical(RDEBUG(CAR(args)));
break;
case 3:
SET_RSTEP(CAR(args), 1);
break;
}
return ans;
}
/*
Set a particular element of the converter list to be active or inactive.
The element is identified by index (starting at 1) or by the description
string. This returns the original setting.
This is also used to remove an element. The op contains a different value
to indicate this.
*/
SEXP attribute_hidden
do_setToCConverterActiveStatus(SEXP call, SEXP op, SEXP args, SEXP env)
{
R_toCConverter *el;
SEXP id, status;
checkArity(op, args);
id = CAR(args);
if(isString(id)) {
el = R_getToCConverterByDescription(translateChar(STRING_ELT(id, 0)));
} else {
el = R_getToCConverterByIndex(asInteger(id) - 1);
}
if(el == NULL) {
error(_("no R-to-C converter found corresponding to identifier"));
}
PROTECT(status = allocVector(LGLSXP, 1));
if(PRIMVAL(op) == 0) {
LOGICAL(status)[0] = el->active;
el->active = LOGICAL(CADR(args))[0];
} else {
R_removeToCConverter(el);
LOGICAL(status)[0] = TRUE;
}
UNPROTECT(1);
return(status);
}
SEXP attribute_hidden complex_math2(SEXP call, SEXP op, SEXP args, SEXP env)
{
R_xlen_t i, n, na, nb;
Rcomplex ai, bi, *a, *b, *y;
SEXP sa, sb, sy;
Rboolean naflag = FALSE;
cm2_fun f;
switch (PRIMVAL(op)) {
case 0: /* atan2 */
f = z_atan2; break;
case 10001: /* round */
f = z_rround; break;
case 2: /* passed from do_log1arg */
case 10:
case 10003: /* passed from do_log */
f = z_logbase; break;
case 10004: /* signif */
f = z_prec; break;
default:
errorcall_return(call, _("unimplemented complex function"));
}
PROTECT(sa = coerceVector(CAR(args), CPLXSXP));
PROTECT(sb = coerceVector(CADR(args), CPLXSXP));
na = XLENGTH(sa); nb = XLENGTH(sb);
if ((na == 0) || (nb == 0)) {
UNPROTECT(2);
return(allocVector(CPLXSXP, 0));
}
n = (na < nb) ? nb : na;
PROTECT(sy = allocVector(CPLXSXP, n));
a = COMPLEX(sa); b = COMPLEX(sb); y = COMPLEX(sy);
for (i = 0; i < n; i++) {
ai = a[i % na]; bi = b[i % nb];
if(ISNA(ai.r) && ISNA(ai.i) &&
ISNA(bi.r) && ISNA(bi.i)) {
y[i].r = NA_REAL; y[i].i = NA_REAL;
} else {
f(&y[i], &ai, &bi);
if ( (ISNAN(y[i].r) || ISNAN(y[i].i)) &&
!(ISNAN(ai.r) || ISNAN(ai.i) || ISNAN(bi.r) || ISNAN(bi.i)) )
naflag = TRUE;
}
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
if(n == na) {
DUPLICATE_ATTRIB(sy, sa);
} else if(n == nb) {
DUPLICATE_ATTRIB(sy, sb);
}
UNPROTECT(3);
return sy;
}
SEXP attribute_hidden do_traceOnOff(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP onOff = CAR(args);
Rboolean trace = (PRIMVAL(op) == 0),
prev = trace ? GET_TRACE_STATE : GET_DEBUG_STATE;
if(length(onOff) > 0) {
Rboolean _new = asLogical(onOff);
if(_new == TRUE || _new == FALSE)
if(trace) SET_TRACE_STATE(_new);
else SET_DEBUG_STATE(_new);
else
error(_("Value for '%s' must be TRUE or FALSE"),
trace ? "tracingState" : "debuggingState");
}
return ScalarLogical(prev);
}
SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho) {
if (PRIMVAL(op) != 0) { /* crossprod or tcrossprod */
RETURN_EARG2(do_earg_matprod, call, op, args, rho);
}
/* %*% */
SEXP x = CAR(args), y = CADR(args);
/* %*% is primitive, the others are .Internal() */
if ((IS_S4_OBJECT(x) || IS_S4_OBJECT(y)) && R_has_methods(op)) {
SEXP s, value;
/* Remove argument names to ensure positional matching */
for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
value = R_possible_dispatch(call, op, args, rho, FALSE);
if (value) return value;
}
return do_earg_matprod(call, op, x, y, rho);
}
/* primitives .primTrace() and .primUntrace() */
SEXP attribute_hidden do_trace(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
find_char_fun
if (TYPEOF(CAR(args)) != CLOSXP &&
TYPEOF(CAR(args)) != SPECIALSXP &&
TYPEOF(CAR(args)) != BUILTINSXP)
errorcall(call, _("argument must be a function"));
switch(PRIMVAL(op)) {
case 0:
SET_RTRACE(CAR(args), 1);
break;
case 1:
SET_RTRACE(CAR(args), 0);
break;
}
return R_NilValue;
}
SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, ans;
checkArity(op, args);
check1arg(args, call, "x");
x = CAR(args);
if (PRIMVAL(op)) { /* xlength<- */
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
return xlengthgets(x, len);
}
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
if (len < 0) error(_("invalid value"));
if (len > R_LEN_T_MAX) {
#ifdef LONG_VECTOR_SUPPORT
return xlengthgets(x, len);
#else
error(_("vector size specified is too large"));
return x; /* -Wall */
#endif
}
return lengthgets(x, (R_len_t) len);
}
SEXP attribute_hidden complex_math1(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y;
R_xlen_t n;
Rboolean naflag = FALSE;
PROTECT(x = CAR(args));
n = xlength(x);
PROTECT(y = allocVector(CPLXSXP, n));
switch (PRIMVAL(op)) {
case 10003: naflag = cmath1(clog, COMPLEX(x), COMPLEX(y), n); break;
case 3: naflag = cmath1(csqrt, COMPLEX(x), COMPLEX(y), n); break;
case 10: naflag = cmath1(cexp, COMPLEX(x), COMPLEX(y), n); break;
case 20: naflag = cmath1(ccos, COMPLEX(x), COMPLEX(y), n); break;
case 21: naflag = cmath1(csin, COMPLEX(x), COMPLEX(y), n); break;
case 22: naflag = cmath1(z_tan, COMPLEX(x), COMPLEX(y), n); break;
case 23: naflag = cmath1(z_acos, COMPLEX(x), COMPLEX(y), n); break;
case 24: naflag = cmath1(z_asin, COMPLEX(x), COMPLEX(y), n); break;
case 25: naflag = cmath1(z_atan, COMPLEX(x), COMPLEX(y), n); break;
case 30: naflag = cmath1(ccosh, COMPLEX(x), COMPLEX(y), n); break;
case 31: naflag = cmath1(csinh, COMPLEX(x), COMPLEX(y), n); break;
case 32: naflag = cmath1(ctanh, COMPLEX(x), COMPLEX(y), n); break;
case 33: naflag = cmath1(z_acosh, COMPLEX(x), COMPLEX(y), n); break;
case 34: naflag = cmath1(z_asinh, COMPLEX(x), COMPLEX(y), n); break;
case 35: naflag = cmath1(z_atanh, COMPLEX(x), COMPLEX(y), n); break;
default:
/* such as sign, gamma */
errorcall(call, _("unimplemented complex function"));
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
return y;
}
SEXP attribute_hidden do_sys(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, n = -1, nframe;
SEXP rval, t;
RCNTXT *cptr;
checkArity(op, args);
/* first find the context that sys.xxx needs to be evaluated in */
cptr = R_GlobalContext;
t = cptr->sysparent;
while (cptr != R_ToplevelContext) {
if (cptr->callflag & CTXT_FUNCTION )
if (cptr->cloenv == t)
break;
cptr = cptr->nextcontext;
}
if (length(args) == 1) n = asInteger(CAR(args));
switch (PRIMVAL(op)) {
case 1: /* parent */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "n");
i = nframe = framedepth(cptr);
/* This is a pretty awful kludge, but the alternative would be
a major redesign of everything... -pd */
while (n-- > 0)
i = R_sysparent(nframe - i + 1, cptr);
return ScalarInteger(i);
case 2: /* call */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_syscall(n, cptr);
case 3: /* frame */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_sysframe(n, cptr);
case 4: /* sys.nframe */
return ScalarInteger(framedepth(cptr));
case 5: /* sys.calls */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t=rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_syscall(i, cptr));
UNPROTECT(1);
return rval;
case 6: /* sys.frames */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t = rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_sysframe(i, cptr));
UNPROTECT(1);
return rval;
case 7: /* sys.on.exit */
if( R_GlobalContext->nextcontext != NULL)
return R_GlobalContext->nextcontext->conexit;
else
return R_NilValue;
case 8: /* sys.parents */
nframe = framedepth(cptr);
rval = allocVector(INTSXP, nframe);
for(i = 0; i < nframe; i++)
INTEGER(rval)[i] = R_sysparent(nframe - i, cptr);
return rval;
case 9: /* sys.function */
if(n == NA_INTEGER)
error(_("invalid '%s' value"), "which");
return(R_sysfunction(n, cptr));
default:
error(_("internal error in 'do_sys'"));
return R_NilValue;/* just for -Wall */
}
}
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
int nx, ny, xarray, yarray, xts, yts;
Rboolean mismatch = FALSE, iS;
PROTECT_INDEX xpi, ypi;
PROTECT_WITH_INDEX(x, &xpi);
PROTECT_WITH_INDEX(y, &ypi);
nx = length(x);
ny = length(y);
/* pre-test to handle the most common case quickly.
Used to skip warning too ....
*/
if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
LENGTH(x) > 0 && LENGTH(y) > 0) {
SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (mismatch) {
PROTECT(ans);
warningcall(call, _("longer object length is not a multiple of shorter object length"));
UNPROTECT(1);
}
UNPROTECT(2);
return ans;
}
/* That symbols and calls were allowed was undocumented prior to
R 2.5.0. We deparse them as deparse() would, minus attributes */
if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
REPROTECT(x = tmp, xpi);
UNPROTECT(1);
}
if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
REPROTECT(y = tmp, ypi);
UNPROTECT(1);
}
if (!isVector(x) || !isVector(y)) {
if (isNull(x) || isNull(y)) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
errorcall(call,
_("comparison (%d) is possible only for atomic and list types"),
PRIMVAL(op));
}
if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
errorcall(call, _("comparison is not allowed for expressions"));
/* ELSE : x and y are both atomic or list */
if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
mismatch = FALSE;
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}
SEXP attribute_hidden do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
R_xlen_t i, n;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
n = XLENGTH(t);
PROTECT(s = allocVector(CPLXSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
UNPROTECT(1);
if(n == 0) return s;
for (i = 0 ; i < n ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
errorcall(call, _("'cummax' not defined for complex numbers"));
break;
case 4: /* cummin */
errorcall(call, _("'cummin' not defined for complex numbers"));
break;
default:
errorcall(call, "unknown cumxxx function");
}
} else if( ( isInteger(CAR(args)) || isLogical(CAR(args)) ) &&
PRIMVAL(op) != 2) {
PROTECT(t = coerceVector(CAR(args), INTSXP));
n = XLENGTH(t);
PROTECT(s = allocVector(INTSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
if(n == 0) {
UNPROTECT(2); /* t, s */
return s;
}
for(i = 0 ; i < n ; i++) INTEGER(s)[i] = NA_INTEGER;
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
ans = icumsum(t,s);
break;
case 3: /* cummax */
ans = icummax(t,s);
break;
case 4: /* cummin */
ans = icummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
ans = R_NilValue;
}
UNPROTECT(2); /* t, s */
return ans;
} else {
PROTECT(t = coerceVector(CAR(args), REALSXP));
n = XLENGTH(t);
PROTECT(s = allocVector(REALSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
UNPROTECT(2);
if(n == 0) return s;
for(i = 0 ; i < n ; i++) REAL(s)[i] = NA_REAL;
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
SEXP
x = CAR(args),
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if ( !(isNull(x) || isNumber(x)) ||
!(isNull(y) || isNumber(y)) )
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
R_xlen_t
nx = xlength(x),
ny = xlength(y);
Rboolean
xarray = isArray(x),
yarray = isArray(y),
xts = isTs(x),
yts = isTs(y);
SEXP dims, xnames, ynames;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray && (ny != 0 || nx == 0)) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (yarray && (nx != 0 || ny == 0)) {
PROTECT(dims = getAttrib(y, R_DimSymbol));
} else
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
SEXP klass = NULL, tsp = NULL; // -Wall
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (nx < ny)
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (ny < nx)
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (nx > 0 && ny > 0) {
if(((nx > ny) ? nx % ny : ny % nx) != 0) // mismatch
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
x = binaryLogic2(PRIMVAL(op), x, y);
}
else {
if(isNull(x))
x = SETCAR(args, allocVector(LGLSXP, 0));
else // isNumeric(x)
x = SETCAR(args, coerceVector(x, LGLSXP));
if(isNull(y))
y = SETCAR(args, allocVector(LGLSXP, 0));
else // isNumeric(y)
y = SETCADR(args, coerceVector(y, LGLSXP));
x = binaryLogic(PRIMVAL(op), x, y);
}
} else { // nx == 0 || ny == 0
x = allocVector(LGLSXP, 0);
}
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if(xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if(ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if(xnames != R_NilValue && XLENGTH(x) == XLENGTH(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if(ynames != R_NilValue && XLENGTH(x) == XLENGTH(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(4);
return x;
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y = R_NilValue; /* -Wall*/
R_xlen_t i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = XLENGTH(x);
switch(PRIMVAL(op)) {
case 1: /* Re */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].r;
break;
case 2: /* Im */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].i;
break;
case 3: /* Mod */
case 6: /* abs */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CABS
REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
break;
case 4: /* Arg */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CARG
REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
break;
case 5: /* Conj */
y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
for(i = 0 ; i < n ; i++) {
COMPLEX(y)[i].r = COMPLEX(x)[i].r;
COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
}
break;
}
}
else if(isNumeric(x)) { /* so no complex numbers involved */
n = XLENGTH(x);
if(isReal(x)) PROTECT(x);
else PROTECT(x = coerceVector(x, REALSXP));
y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);
switch(PRIMVAL(op)) {
case 1: /* Re */
case 5: /* Conj */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = REAL(x)[i];
break;
case 2: /* Im */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = 0.0;
break;
case 4: /* Arg */
for(i = 0 ; i < n ; i++)
if(ISNAN(REAL(x)[i]))
REAL(y)[i] = REAL(x)[i];
else if (REAL(x)[i] >= 0)
REAL(y)[i] = 0;
else
REAL(y)[i] = M_PI;
break;
case 3: /* Mod */
case 6: /* abs */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = fabs(REAL(x)[i]);
break;
}
UNPROTECT(1);
}
else errorcall(call, _("non-numeric argument to function"));
if (x != y && ATTRIB(x) != R_NilValue) {
PROTECT(x);
PROTECT(y);
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
}
return y;
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_earg_matprod(SEXP call, SEXP op, SEXP arg_x, SEXP arg_y, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = arg_x, y = arg_y, xdims, ydims, ans;
Rboolean sym;
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getDimAttrib(x);
ydims = getDimAttrib(y);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
}
else {
nrx = LENGTH(x);
ncx = 1;
}
nry = LENGTH(y);
ncy = 1;
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
}
}
else { /* tcrossprod -- y is a col vector */
nry = LENGTH(y);
ncy = 1;
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(x) || isComplex(y))
mode = CPLXSXP;
else
mode = REALSXP;
x = coerceVector(x, mode);
y = coerceVector(y, mode);
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else
matprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
PROTECT(xdims = getDimNamesAttrib(x));
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getNamesAttrib(ydims); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getNamesAttrib(ydims); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(x), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(x), nrx, ncx, REAL(ans));
else
crossprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
}
PROTECT(xdims = getDimNamesAttrib(x));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(x), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(x), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
}
PROTECT(xdims = getDimNamesAttrib(x));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getNamesAttrib(ydims);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
return ans;
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;
Rboolean sym;
if (PRIMVAL(op) == 0 && /* %*% is primitive, the others are .Internal() */
(IS_S4_OBJECT(x) || IS_S4_OBJECT(y))
&& R_has_methods(op)) {
SEXP s, value;
/* Remove argument names to ensure positional matching */
for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
value = R_possible_dispatch(call, op, args, rho, FALSE);
if (value) return value;
}
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getAttrib(x, R_DimSymbol);
ydims = getAttrib(y, R_DimSymbol);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
// for crossprod, allow two cases: n x n ==> (1,n) x (n,1); 1 x n = (n, 1) x (1, n)
if (PRIMVAL(op) == 1 && LENGTH(x) == 1) {
nrx = ncx = nry = 1;
ncy = LENGTH(y);
}
else {
nry = LENGTH(y);
ncy = 1;
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
if(ncx == 1) { // y as row vector
ncy = nry;
nry = 1;
}
}
else {
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
} else if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
}
else { // tcrossprod
if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
else { // y is a col vector
nry = LENGTH(y);
ncy = 1;
}
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(CAR(args)) || isComplex(CADR(args)))
mode = CPLXSXP;
else
mode = REALSXP;
SETCAR(args, coerceVector(CAR(args), mode));
SETCADR(args, coerceVector(CADR(args), mode));
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else
matprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
crossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getAttrib(ydims, R_NamesSymbol);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
return ans;
}
/* Note that NA_STRING is not handled separately here. This is
deliberate -- see ?paste -- and implicitly coerces it to "NA"
*/
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, collapse, sep, x;
int sepw, u_sepw, ienc;
R_xlen_t i, j, k, maxlen, nx, pwidth;
const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
char *buf;
Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
use_sep = (PRIMVAL(op) == 0);
const void *vmax;
checkArity(op, args);
/* We use formatting and so we must initialize printing. */
PrintDefaults();
/* Check the arguments */
x = CAR(args);
if (!isVectorList(x))
error(_("invalid first argument"));
nx = xlength(x);
if(use_sep) { /* paste(..., sep, .) */
sep = CADR(args);
if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
error(_("invalid separator"));
sep = STRING_ELT(sep, 0);
csep = translateChar(sep);
u_sepw = sepw = (int) strlen(csep); // will be short
sepASCII = strIsASCII(csep);
sepKnown = ENC_KNOWN(sep) > 0;
sepUTF8 = IS_UTF8(sep);
sepBytes = IS_BYTES(sep);
collapse = CADDR(args);
} else { /* paste0(..., .) */
u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
collapse = CADR(args);
}
if (!isNull(collapse))
if(!isString(collapse) || LENGTH(collapse) <= 0 ||
STRING_ELT(collapse, 0) == NA_STRING)
error(_("invalid '%s' argument"), "collapse");
if(nx == 0)
return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
/* Maximum argument length, coerce if needed */
maxlen = 0;
for (j = 0; j < nx; j++) {
if (!isString(VECTOR_ELT(x, j))) {
/* formerly in R code: moved to C for speed */
SEXP call, xj = VECTOR_ELT(x, j);
if(OBJECT(xj)) { /* method dispatch */
PROTECT(call = lang2(install("as.character"), xj));
SET_VECTOR_ELT(x, j, eval(call, env));
UNPROTECT(1);
} else if (isSymbol(xj))
SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
else
SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
if (!isString(VECTOR_ELT(x, j)))
error(_("non-string argument to internal 'paste'"));
}
if(xlength(VECTOR_ELT(x, j)) > maxlen)
maxlen = xlength(VECTOR_ELT(x, j));
}
if(maxlen == 0)
return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
PROTECT(ans = allocVector(STRSXP, maxlen));
for (i = 0; i < maxlen; i++) {
/* Strategy for marking the encoding: if all inputs (including
* the separator) are ASCII, so is the output and we don't
* need to mark. Otherwise if all non-ASCII inputs are of
* declared encoding, we should mark.
* Need to be careful only to include separator if it is used.
*/
anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
if(nx > 1) {
allKnown = sepKnown || sepASCII;
anyKnown = sepKnown;
use_UTF8 = sepUTF8;
use_Bytes = sepBytes;
}
pwidth = 0;
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
if(IS_UTF8(cs)) use_UTF8 = TRUE;
if(IS_BYTES(cs)) use_Bytes = TRUE;
}
}
if (use_Bytes) use_UTF8 = FALSE;
vmax = vmaxget();
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
if(use_Bytes)
pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
else if(use_UTF8)
pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
else
pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
vmaxset(vmax);
}
}
if(use_sep) {
if (use_UTF8 && !u_csep) {
u_csep = translateCharUTF8(sep);
u_sepw = (int) strlen(u_csep); // will be short
}
pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
}
if (pwidth > INT_MAX)
error(_("result would exceed 2^31-1 bytes"));
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
vmax = vmaxget();
for (j = 0; j < nx; j++) {
k = xlength(VECTOR_ELT(x, j));
if (k > 0) {
SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
if (use_UTF8) {
s = translateCharUTF8(cs);
strcpy(buf, s);
buf += strlen(s);
} else {
s = use_Bytes ? CHAR(cs) : translateChar(cs);
strcpy(buf, s);
buf += strlen(s);
allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
}
}
if (sepw != 0 && j != nx - 1) {
if (use_UTF8) {
strcpy(buf, u_csep);
buf += u_sepw;
} else {
strcpy(buf, csep);
buf += sepw;
}
}
vmax = vmaxget();
}
ienc = 0;
if(use_UTF8) ienc = CE_UTF8;
else if(use_Bytes) ienc = CE_BYTES;
else if(anyKnown && allKnown) {
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
}
SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
}
/* Now collapse, if required. */
if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
sep = STRING_ELT(collapse, 0);
use_UTF8 = IS_UTF8(sep);
use_Bytes = IS_BYTES(sep);
for (i = 0; i < nx; i++) {
if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;
}
if(use_Bytes) {
csep = CHAR(sep);
use_UTF8 = FALSE;
} else if(use_UTF8)
csep = translateCharUTF8(sep);
else
csep = translateChar(sep);
sepw = (int) strlen(csep);
anyKnown = ENC_KNOWN(sep) > 0;
allKnown = anyKnown || strIsASCII(csep);
pwidth = 0;
vmax = vmaxget();
for (i = 0; i < nx; i++)
if(use_UTF8) {
pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
vmaxset(vmax);
} else /* already translated */
pwidth += strlen(CHAR(STRING_ELT(ans, i)));
pwidth += (nx - 1) * sepw;
if (pwidth > INT_MAX)
error(_("result would exceed 2^31-1 bytes"));
cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
vmax = vmaxget();
for (i = 0; i < nx; i++) {
if(i > 0) {
strcpy(buf, csep);
buf += sepw;
}
if(use_UTF8)
s = translateCharUTF8(STRING_ELT(ans, i));
else /* already translated */
s = CHAR(STRING_ELT(ans, i));
strcpy(buf, s);
while (*buf)
buf++;
allKnown = allKnown &&
(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0));
anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0);
if(use_UTF8) vmaxset(vmax);
}
UNPROTECT(1);
ienc = CE_NATIVE;
if(use_UTF8) ienc = CE_UTF8;
else if(use_Bytes) ienc = CE_BYTES;
else if(anyKnown && allKnown) {
if(known_to_be_latin1) ienc = CE_LATIN1;
if(known_to_be_utf8) ienc = CE_UTF8;
}
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
}
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return ans;
}
SEXP do_rgb(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, r, g, b, a, nam;
int OP, i, l_max, nr, ng, nb, na;
Rboolean max_1 = FALSE;
double mV = 0.0; /* -Wall */
checkArity(op, args);
OP = PRIMVAL(op);
if(OP) {/* op == 1: rgb256() :*/
PROTECT(r = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(g = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(b = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args), INTSXP)); args = CDR(args);
}
else {
PROTECT(r = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(g = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(b = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args), REALSXP)); args = CDR(args);
mV = asReal(CAR(args)); args = CDR(args);
max_1 = (mV == 1.);
}
nr = LENGTH(r); ng = LENGTH(g); nb = LENGTH(b); na = LENGTH(a);
if (nr <= 0 || ng <= 0 || nb <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
l_max = nr;
if (l_max < ng) l_max = ng;
if (l_max < nb) l_max = nb;
if (l_max < na) l_max = na;
PROTECT(nam = coerceVector(CAR(args), STRSXP)); args = CDR(args);
if (length(nam) != 0 && length(nam) != l_max)
errorcall(call, _("invalid names vector"));
PROTECT(c = allocVector(STRSXP, l_max));
#define _R_set_c_RGBA(_R,_G,_B,_A) \
for (i = 0; i < l_max; i++) \
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(_R,_G,_B,_A)))
if(OP) { /* OP == 1: rgb256() :*/
_R_set_c_RGBA(CheckColor(INTEGER(r)[i%nr]),
CheckColor(INTEGER(g)[i%ng]),
CheckColor(INTEGER(b)[i%nb]),
CheckAlpha(INTEGER(a)[i%na]));
}
else if(max_1) {
_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr]),
ScaleColor(REAL(g)[i%ng]),
ScaleColor(REAL(b)[i%nb]),
ScaleAlpha(REAL(a)[i%na]));
}
else { /* maxColorVal not in {1, 255} */
_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr] / mV),
ScaleColor(REAL(g)[i%ng] / mV),
ScaleColor(REAL(b)[i%nb] / mV),
ScaleAlpha(REAL(a)[i%na] / mV));
}
if (length(nam) != 0)
setAttrib(c, R_NamesSymbol, nam);
UNPROTECT(6);
return c;
}
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
SEXP x, y, dims, tsp, klass, xnames, ynames;
R_xlen_t mismatch, nx, ny;
int xarray, yarray, xts, yts;
mismatch = 0;
x = CAR(args);
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if (!isNumber(x) || !isNumber(y))
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
tsp = R_NilValue; /* -Wall */
klass = R_NilValue; /* -Wall */
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
error(_("binary operation on non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
nx = XLENGTH(x);
ny = XLENGTH(y);
if(nx > 0 && ny > 0) {
if(nx > ny) mismatch = nx % ny;
else mismatch = ny % nx;
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (XLENGTH(x) < XLENGTH(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (XLENGTH(y) < XLENGTH(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if(mismatch)
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
PROTECT(x = binaryLogic2(PRIMVAL(op), x, y));
} else {
if (!isNumber(x) || !isNumber(y))
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
x = SETCAR(args, coerceVector(x, LGLSXP));
y = SETCADR(args, coerceVector(y, LGLSXP));
PROTECT(x = binaryLogic(PRIMVAL(op), x, y));
}
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if(xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if(ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if(XLENGTH(x) == XLENGTH(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if(XLENGTH(x) == XLENGTH(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(4);
return x;
}
