in source/src/main/summary.c [397:786]
SEXP attribute_hidden do_summary(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, a, stmp = NA_STRING /* -Wall */, scum = NA_STRING, call2;
double tmp = 0.0, s;
Rcomplex z, ztmp, zcum={0.0, 0.0} /* -Wall */;
int itmp = 0, icum = 0, int_a, real_a, empty, warn = 0 /* dummy */;
SEXPTYPE ans_type;/* only INTEGER, REAL, COMPLEX or STRSXP here */
Rboolean narm;
int updated;
/* updated := 1 , as soon as (i)tmp (do_summary),
or *value ([ir]min / max) is assigned */
checkArity(op, args);
if(PRIMVAL(op) == 1) { /* mean */
LDOUBLE s = 0., si = 0., t = 0., ti = 0.;
R_xlen_t i, n = XLENGTH(CAR(args));
SEXP x = CAR(args);
switch(TYPEOF(x)) {
case LGLSXP:
case INTSXP:
PROTECT(ans = allocVector(REALSXP, 1));
for (i = 0; i < n; i++) {
if(INTEGER(x)[i] == NA_INTEGER) {
REAL(ans)[0] = R_NaReal;
UNPROTECT(1); /* ans */
return ans;
}
s += INTEGER(x)[i];
}
REAL(ans)[0] = (double) (s/n);
break;
case REALSXP:
PROTECT(ans = allocVector(REALSXP, 1));
for (i = 0; i < n; i++) s += REAL(x)[i];
s /= n;
if(R_FINITE((double)s)) {
for (i = 0; i < n; i++) t += (REAL(x)[i] - s);
s += t/n;
}
REAL(ans)[0] = (double) s;
break;
case CPLXSXP:
PROTECT(ans = allocVector(CPLXSXP, 1));
for (i = 0; i < n; i++) {
s += COMPLEX(x)[i].r;
si += COMPLEX(x)[i].i;
}
s /= n; si /= n;
if( R_FINITE((double)s) && R_FINITE((double)si) ) {
for (i = 0; i < n; i++) {
t += COMPLEX(x)[i].r - s;
ti += COMPLEX(x)[i].i - si;
}
s += t/n; si += ti/n;
}
COMPLEX(ans)[0].r = (double) s;
COMPLEX(ans)[0].i = (double) si;
break;
default:
error(R_MSG_type, type2char(TYPEOF(x)));
ans = R_NilValue; // -Wall on clang 4.2
}
UNPROTECT(1); /* ans */
return ans;
}
/* match to foo(..., na.rm=FALSE) */
PROTECT(args = fixup_NaRm(args));
PROTECT(call2 = shallow_duplicate(call));
SETCDR(call2, args);
if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
UNPROTECT(2); /* call2, args */
return(ans);
}
UNPROTECT(1); /* call2 */
#ifdef DEBUG_Summary
REprintf("C do_summary(op%s, *): did NOT dispatch\n", PRIMNAME(op));
#endif
ans = matchArgExact(R_NaRmSymbol, &args);
narm = asLogical(ans);
updated = 0;
empty = 1;/*- =1: only zero-length arguments, or NA with na.rm=T */
int iop = PRIMVAL(op);
switch(iop) {
case 0:/* sum */
/* we need to find out if _all_ the arguments are integer or logical
in advance, as we might overflow before we find out. NULL is
documented to be the same as integer(0).
*/
a = args;
int_a = 1;
while (a != R_NilValue) {
if(!isInteger(CAR(a)) && !isLogical(CAR(a)) && !isNull(CAR(a))) {
int_a = 0;
break;
}
a = CDR(a);
}
ans_type = int_a ? INTSXP: REALSXP; /* try to keep if possible.. */
zcum.r = zcum.i = 0.; icum = 0;
break;
case 2:/* min */
DbgP2("do_summary: min(.. na.rm=%d) ", narm);
ans_type = INTSXP;
zcum.r = R_PosInf;
icum = INT_MAX;
break;
case 3:/* max */
DbgP2("do_summary: max(.. na.rm=%d) ", narm);
ans_type = INTSXP;
zcum.r = R_NegInf;;
icum = R_INT_MIN;
break;
case 4:/* prod */
ans_type = REALSXP;
zcum.r = 1.;
zcum.i = 0.;
break;
default:
errorcall(call,
_("internal error ('op = %d' in do_summary).\t Call a Guru"),
iop);
return R_NilValue;/*-Wall */
}
/*-- now loop over all arguments. Do the 'op' switch INSIDE : */
PROTECT(scum);
while (args != R_NilValue) {
a = CAR(args);
int_a = 0;/* int_a = 1 <--> a is INTEGER */
real_a = 0;
if(xlength(a) > 0) {
updated = 0;/*- GLOBAL -*/
switch(iop) {
case 2:/* min */
case 3:/* max */
switch(TYPEOF(a)) {
case LGLSXP:
case INTSXP:
int_a = 1;
if (iop == 2) updated = imin(INTEGER(a), XLENGTH(a), &itmp, narm);
else updated = imax(INTEGER(a), XLENGTH(a), &itmp, narm);
break;
case REALSXP:
real_a = 1;
if(ans_type == INTSXP) {/* change to REAL */
ans_type = REALSXP;
if(!empty) zcum.r = Int2Real(icum);
}
if (iop == 2) updated = rmin(REAL(a), XLENGTH(a), &tmp, narm);
else updated = rmax(REAL(a), XLENGTH(a), &tmp, narm);
break;
case STRSXP:
if(!empty && ans_type == INTSXP) {
scum = StringFromInteger(icum, &warn);
UNPROTECT(1); /* scum */
PROTECT(scum);
} else if(!empty && ans_type == REALSXP) {
scum = StringFromReal(zcum.r, &warn);
UNPROTECT(1); /* scum */
PROTECT(scum);
}
ans_type = STRSXP;
if (iop == 2) updated = smin(a, &stmp, narm);
else updated = smax(a, &stmp, narm);
break;
default:
goto invalid_type;
}
if(updated) {/* 'a' had non-NA elements; --> "add" tmp or itmp*/
DbgP1(" updated:");
if(ans_type == INTSXP) {
DbgP3(" INT: (old)icum= %ld, itmp=%ld\n", icum,itmp);
if (icum == NA_INTEGER); /* NA trumps anything */
else if (itmp == NA_INTEGER ||
(iop == 2 && itmp < icum) || /* min */
(iop == 3 && itmp > icum)) /* max */
icum = itmp;
} else if(ans_type == REALSXP) {
if (int_a) tmp = Int2Real(itmp);
DbgP3(" REAL: (old)cum= %g, tmp=%g\n", zcum.r,tmp);
if (ISNA(zcum.r)); /* NA trumps anything */
else if (ISNAN(tmp)) {
if (ISNA(tmp)) zcum.r = tmp;
else zcum.r += tmp;/* NA or NaN */
} else if(
(iop == 2 && tmp < zcum.r) ||
(iop == 3 && tmp > zcum.r)) zcum.r = tmp;
} else if(ans_type == STRSXP) {
if(int_a)
stmp = StringFromInteger(itmp, &warn);
else if(real_a)
stmp = StringFromReal(tmp, &warn);
if(empty)
scum = stmp;
else if (scum != NA_STRING) {
PROTECT(stmp);
if(stmp == NA_STRING ||
(iop == 2 && stmp != scum && Scollate(stmp, scum) < 0) ||
(iop == 3 && stmp != scum && Scollate(stmp, scum) > 0) )
scum = stmp;
UNPROTECT(1); /* stmp */
}
UNPROTECT(1); /* scum */
PROTECT(scum);
}
}/*updated*/ else {
/*-- in what cases does this happen here at all?
-- if there are no non-missing elements.
*/
DbgP2(" NOT updated [!! RARE !!]: int_a=%d\n", int_a);
}
break;/*--- end of min() / max() ---*/
case 0:/* sum */
switch(TYPEOF(a)) {
case LGLSXP:
case INTSXP:
updated = isum(TYPEOF(a) == LGLSXP ?
LOGICAL(a) :INTEGER(a), XLENGTH(a),
&itmp, narm, call);
if(updated) {
if(itmp == NA_INTEGER) goto na_answer;
if(ans_type == INTSXP) {
s = (double) icum + (double) itmp;
if(s > INT_MAX || s < R_INT_MIN){
warningcall(call,_("Integer overflow - use sum(as.numeric(.))"));
goto na_answer;
}
else icum += itmp;
} else
zcum.r += Int2Real(itmp);
}
break;
case REALSXP:
if(ans_type == INTSXP) {
ans_type = REALSXP;
if(!empty) zcum.r = Int2Real(icum);
}
updated = rsum(REAL(a), XLENGTH(a), &tmp, narm);
if(updated) {
zcum.r += tmp;
}
break;
case CPLXSXP:
if(ans_type == INTSXP) {
ans_type = CPLXSXP;
if(!empty) zcum.r = Int2Real(icum);
} else if (ans_type == REALSXP)
ans_type = CPLXSXP;
updated = csum(COMPLEX(a), XLENGTH(a), &ztmp, narm);
if(updated) {
zcum.r += ztmp.r;
zcum.i += ztmp.i;
}
break;
default:
goto invalid_type;
}
break;/* sum() part */
case 4:/* prod */
switch(TYPEOF(a)) {
case LGLSXP:
case INTSXP:
case REALSXP:
if(TYPEOF(a) == REALSXP)
updated = rprod(REAL(a), XLENGTH(a), &tmp, narm);
else
updated = iprod(INTEGER(a), XLENGTH(a), &tmp, narm);
if(updated) {
zcum.r *= tmp;
zcum.i *= tmp;
}
break;
case CPLXSXP:
ans_type = CPLXSXP;
updated = cprod(COMPLEX(a), XLENGTH(a), &ztmp, narm);
if(updated) {
z.r = zcum.r;
z.i = zcum.i;
zcum.r = z.r * ztmp.r - z.i * ztmp.i;
zcum.i = z.r * ztmp.i + z.i * ztmp.r;
}
break;
default:
goto invalid_type;
}
break;/* prod() part */
} /* switch(iop) */
} else { /* len(a)=0 */
/* Even though this has length zero it can still be invalid,
e.g. list() or raw() */
switch(TYPEOF(a)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case NILSXP: /* OK historically, e.g. PR#1283 */
break;
case CPLXSXP:
if (iop == 2 || iop == 3) goto invalid_type;
break;
case STRSXP:
if (iop == 2 || iop == 3) {
if(!empty && ans_type == INTSXP) {
scum = StringFromInteger(icum, &warn);
UNPROTECT(1); /* scum */
PROTECT(scum);
} else if(!empty && ans_type == REALSXP) {
scum = StringFromReal(zcum.r, &warn);
UNPROTECT(1); /* scum */
PROTECT(scum);
}
ans_type = STRSXP;
break;
}
default:
goto invalid_type;
}
if(ans_type < TYPEOF(a) && ans_type != CPLXSXP) {
if(!empty && ans_type == INTSXP)
zcum.r = Int2Real(icum);
ans_type = TYPEOF(a);
}
}
DbgP3(" .. upd.=%d, empty: old=%d", updated, empty);
if(empty && updated) empty=0;
DbgP2(", new=%d\n", empty);
args = CDR(args);
} /*-- while(..) loop over args */
/*-------------------------------------------------------*/
if(empty && (iop == 2 || iop == 3)) {
if(ans_type == STRSXP) {
warningcall(call, _("no non-missing arguments, returning NA"));
} else {
if(iop == 2)
warningcall(call, _("no non-missing arguments to min; returning Inf"));
else
warningcall(call, _("no non-missing arguments to max; returning -Inf"));
ans_type = REALSXP;
}
}
ans = allocVector(ans_type, 1);
switch(ans_type) {
case INTSXP: INTEGER(ans)[0] = icum;break;
case REALSXP: REAL(ans)[0] = zcum.r; break;
case CPLXSXP: COMPLEX(ans)[0].r = zcum.r; COMPLEX(ans)[0].i = zcum.i;break;
case STRSXP: SET_STRING_ELT(ans, 0, scum); break;
}
UNPROTECT(2); /* scum, args */
return ans;
na_answer: /* only sum(INTSXP, ...) case currently used */
ans = allocVector(ans_type, 1);
switch(ans_type) {
case INTSXP: INTEGER(ans)[0] = NA_INTEGER; break;
case REALSXP: REAL(ans)[0] = NA_REAL; break;
case CPLXSXP: COMPLEX(ans)[0].r = COMPLEX(ans)[0].i = NA_REAL; break;
case STRSXP: SET_STRING_ELT(ans, 0, NA_STRING); break;
}
UNPROTECT(2); /* scum, args */
return ans;
invalid_type:
errorcall(call, R_MSG_type, type2char(TYPEOF(a)));
return R_NilValue;
}/* do_summary */