/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, arg1, arg2;
int argc;
if (args == R_NilValue)
argc = 0;
else if (CDR(args) == R_NilValue)
argc = 1;
else if (CDDR(args) == R_NilValue)
argc = 2;
else
argc = length(args);
arg1 = CAR(args);
arg2 = CADR(args);
if (ATTRIB(arg1) != R_NilValue || ATTRIB(arg2) != R_NilValue) {
if (DispatchGroup("Ops",call, op, args, env, &ans))
return ans;
}
else if (argc == 1 && IS_SCALAR(arg1, LGLSXP)) {
/* directly handle '!' operator for simple logical scalars. */
int v = LOGICAL(arg1)[0];
return ScalarLogical(v == NA_LOGICAL ? v : ! v);
}
if (argc == 1)
return lunary(call, op, arg1);
else if (argc == 2)
return lbinary(call, op, args);
else
error(_("binary operations require two arguments"));
return R_NilValue; /* for -Wall */
}
/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP arg1 = CAR(args); //, arg2 = CADR(args)
Rboolean attr1 = ATTRIB(arg1) != R_NilValue;
if (attr1 || ATTRIB(CADR(args)) != R_NilValue) {
SEXP ans;
if (DispatchGroup("Ops", call, op, args, env, &ans))
return ans;
}
/* The above did dispatch to valid S3/S4 methods, including those with
* "wrong" number of arguments.
* Now require binary calls to `&` and `|` or unary calls to `!` : */
checkArity(op, args);
if (CDR(args) == R_NilValue) { // one argument <==> !(arg1)
if (!attr1 && IS_SCALAR(arg1, LGLSXP)) {
/* directly handle '!' operator for simple logical scalars. */
int v = LOGICAL(arg1)[0];
return ScalarLogical(v == NA_LOGICAL ? v : ! v);
}
return lunary(call, op, arg1);
}
// else : two arguments
return lbinary(call, op, args);
}
SEXP attribute_hidden do_relop(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
if (DispatchGroup("Ops", call, op, args, env, &ans))
return ans;
checkArity(op, args);
return do_relop_dflt(call, op, CAR(args), CADR(args));
}
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 */
}
/* 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_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
if (DispatchGroup("Ops",call, op, args, env, &ans))
return ans;
switch (length(args)) {
case 1:
return lunary(call, op, CAR(args));
case 2:
return lbinary(call, op, args);
default:
error(_("binary operations require two arguments"));
return R_NilValue; /* for -Wall */
}
}
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;
}
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 */
}
