/* & | ! */ 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 */ }