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;
}
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;
}
