The R Project SVN – R – Diff – /trunk/src/main/summary.c

     empty = 1;/*- =1: only zero-length arguments, or NA with na.rm=T */
     iop = PRIMVAL(op);
     switch(iop) {
     case 0:/* sum */
     /* we need to find out if _all_ the arguments are integer in advance,
        as we might overflow before we find out */
 	a = args;
 	int_a = 1;
 	while (a != R_NilValue) {
 	    if(!isInteger(CAR(a))) {
 		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;
 #ifdef IEEE_754
 	zcum.r = R_PosInf;
 #else
 	zcum.r = NA_REAL;
 #endif
 	icum = INT_MAX;
 	break;
     case 3:/* max */
 	DbgP2("do_summary: max(.. na.rm=%d) ", narm);
 	ans_type = INTSXP;
 		break;/* prod() part */
 	    }/* switch(iop) */
 	} else { /*len(a)=0*/
 	    if(TYPEOF(a) == CPLXSXP && (iop == 2 || iop == 3)) goto badmode;
 	    if(ans_type < TYPEOF(a) && ans_type != CPLXSXP) {
 		if(!empty && ans_type == INTSXP)
 		    zcum.r = Int2Real(icum);
 		ans_type = TYPEOF(a);
     /*-------------------------------------------------------*/
     if(empty && (iop == 2 || iop == 3)) {
 	if(iop == 2)
 	    warning("no finite arguments to min; returning Inf");
 	else
 	    warning("no finite arguments to max; returning -Inf");
 	ans_type = REALSXP;
+    }
     ans = allocVector(ans_type, 1);
+}
 /* which.min(x) : The index (starting at 1), of the first min(x) in x */
 SEXP do_first_min(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
+#define Beg_do_first					\
-    SEXP sx, ans;
+    SEXP sx, ans;					\
-    double s;
+    double s;						\
-    int i, n, indx;
+    int i, n, indx;					\
+							\
-    checkArity(op, args);
+    checkArity(op, args);				\
+							\
-    PROTECT(sx = coerceVector(CAR(args), REALSXP));
+    PROTECT(sx = coerceVector(CAR(args), REALSXP));	\
-    if (!isNumeric(sx))
+    if (!isNumeric(sx))					\
-      errorcall(call, "non-numeric argument");
+      errorcall(call, "non-numeric argument");		\
-    n = LENGTH(sx);
+    n = LENGTH(sx);					\
     indx = NA_INTEGER;
+    Beg_do_first
     s = R_PosInf;
     for (i = 0; i < n; i++)
 	if (!ISNAN(REAL(sx)[i]) && REAL(sx)[i] < s) {
 	    s = REAL(sx)[i]; indx = i;
+	}
+#define End_do_first							\
-    UNPROTECT(1);
+    i = (indx != NA_INTEGER);						\
-    ans = allocVector(INTSXP, (i = (indx != NA_INTEGER)) ? 1 : 0);
+    ans = allocVector(INTSXP, i ? 1 : 0);				\
+    if (i) {								\
-    if (i) INTEGER(ans)[0] = indx + 1;
+	INTEGER(ans)[0] = indx + 1;					\
+	if (getAttrib(sx, R_NamesSymbol) != R_NilValue) { /* keep name */\
+	    SEXP ansnam;						\
+	    PROTECT(ansnam = allocVector(STRSXP, 1));			\
+	    SET_STRING_ELT(ansnam, 0,					\
+			   STRING_ELT(getAttrib(sx, R_NamesSymbol), indx));\
+	    setAttrib(ans, R_NamesSymbol, ansnam);			\
+	    UNPROTECT(1);						\
+	}								\
+    }									\
+    UNPROTECT(1);							\
     return ans;
+    End_do_first
+}
 /* which.max(x) : The index (starting at 1), of the first max(x) in x */
 SEXP do_first_max(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
-    SEXP sx, ans;
-    double s;
+    Beg_do_first
-    int i, n, indx;
-    checkArity(op, args);
-    PROTECT(sx = coerceVector(CAR(args), REALSXP));
-    if (!isNumeric(sx))
-      errorcall(call, "non-numeric argument");
-    n = LENGTH(sx);
-    indx = NA_INTEGER;
     s = R_NegInf;
     for (i = 0; i < n; i++)
 	if (!ISNAN(REAL(sx)[i]) && REAL(sx)[i] > s) {
 	    s = REAL(sx)[i]; indx = i;
+	}
-    UNPROTECT(1);
-    ans = allocVector(INTSXP, (i = (indx != NA_INTEGER)) ? 1 : 0);
-    if (i) INTEGER(ans)[0] = indx + 1;
-    return ans;
+    End_do_first
+}
+#undef Beg_do_first
+#undef End_do_first
 /* complete.cases(.) */
 SEXP do_compcases(SEXP call, SEXP op, SEXP args, SEXP rho)
+{

The R Project SVN R

(root)/trunk/src/main/summary.c – Rev 19912 → 24343