The R Project SVN – R – Diff – /branches/R-exp-R5/src/main/array.c

  */
 /* this increments iip and sets j using strides */
 #define CLICKJ						\
-    for (itmp=0; itmp<n; itmp++)			\
+    for (itmp = 0; itmp < n; itmp++)			\
-	if (iip[itmp] == INTEGER(dimsr)[itmp]-1)	\
+	if (iip[itmp] == isr[itmp]-1) iip[itmp] = 0;	\
-	    iip[itmp] = 0;				\
 	else {						\
 	    iip[itmp]++;				\
 	    break;					\
 	}						\
-    for (j=0, itmp=0; itmp<n; itmp++)			\
+    for (j = 0, itmp = 0; itmp < n; itmp++)	       	\
 	j += iip[itmp] * stride[itmp];
 /* aperm (a, perm, resize = TRUE) */
 SEXP attribute_hidden do_aperm(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
-    SEXP a, perm, resize, r, dimsa, dimsr, dna;
+    SEXP a, perm, r, dimsa, dimsr, dna;
     int i, j, n, len, itmp;
-    int *pp, *iip, *stride;
     checkArity(op, args);
     a = CAR(args);
     if (!isArray(a))
 	error(_("invalid first argument, must be an array"));
     PROTECT(dimsa = getAttrib(a, R_DimSymbol));
     n = LENGTH(dimsa);
+    int *isa = INTEGER(dimsa);
     /* check the permutation */
-    PROTECT(perm = coerceVector(CADR(args), INTSXP));
+    int *pp = (int *) R_alloc(n, sizeof(int));
-    pp = (int *) R_alloc(n, sizeof(int));
+    perm = CADR(args);
     if (length(perm) == 0) {
-	for (i=0; i<n; i++)
+	for (i = 0; i < n; i++) pp[i] = n-1-i;
+    } else if (isString(perm)) {
-	    pp[i] = n-1-i;
+    } else {
-    } else if (length(perm) == n) {
+	PROTECT(perm = coerceVector(perm, INTSXP));
-	for (i=0; i<n; i++)
+	if (length(perm) == n) {
-	    pp[i] = INTEGER(perm)[i] - 1; /* no offset! */
+	    for (i = 0; i < n; i++) pp[i] = INTEGER(perm)[i] - 1;
-    } else
+	    UNPROTECT(1);
-	error(_("'perm' is of wrong length"));
+	} else error(_("'perm' is of wrong length"));
+    }
-    iip = (int *) R_alloc(n, sizeof(int));
+    int *iip = (int *) R_alloc(n, sizeof(int));
     for (i = 0; i < n; iip[i++] = 0);
     for (i = 0; i < n; i++)
-	if (pp[i] >= 0 && pp[i] < n)
+	if (pp[i] >= 0 && pp[i] < n) iip[pp[i]]++;
-	    iip[pp[i]]++;
-	else
-	    error(_("value out of range in 'perm'"));
+	else error(_("value out of range in 'perm'"));
     for (i = 0; i < n; i++)
-	if (iip[i] == 0)
-	    error(_("invalid '%s' argument"), "perm");
+	if (iip[i] == 0) error(_("invalid '%s' argument"), "perm");
     /* create the stride object and permute */
-    stride = (int *) R_alloc(n, sizeof(int));
+    int *stride = (int *) R_alloc(n, sizeof(int));
-    for (iip[0] = 1, i = 1; i<n; i++)
+    for (iip[0] = 1, i = 1; i<n; i++) iip[i] = iip[i-1] * isa[i-1];
-	iip[i] = iip[i-1] * INTEGER(dimsa)[i-1];
-    for (i = 0; i < n; i++)
+    for (i = 0; i < n; i++) stride[i] = iip[pp[i]];
-	stride[i] = iip[pp[i]];
     /* also need to have the dimensions of r */
-    PROTECT(dimsr = allocVector(INTSXP,n));
+    PROTECT(dimsr = allocVector(INTSXP, n));
-    for (i = 0; i < n; i++)
+    int *isr = INTEGER(dimsr);
-	INTEGER(dimsr)[i] = INTEGER(dimsa)[pp[i]];
+    for (i = 0; i < n; i++) isr[i] = isa[pp[i]];
     /* and away we go! iip will hold the incrementer */
     len = LENGTH(a);
     len = length(a);
     PROTECT(r = allocVector(TYPEOF(a), len));
-    for (i=0; i<n; iip[i++] = 0);
+    for (i = 0; i < n; iip[i++] = 0);
     switch (TYPEOF(a)) {
     case INTSXP:
 	for (j=0, i=0; i<len; i++) {
     default:
 	UNIMPLEMENTED_TYPE("aperm", a);
+    }
     /* handle the resize */
-    PROTECT(resize = coerceVector(CADDR(args), LGLSXP));
+    int resize = asLogical(CADDR(args));
-    if (LOGICAL(resize)[0])
+    if (resize == NA_LOGICAL) error(_("'resize' must be TRUE or FALSE"));
-	setAttrib(r, R_DimSymbol, dimsr);
-    else
-	setAttrib(r, R_DimSymbol, dimsa);
+    setAttrib(r, R_DimSymbol, resize ? dimsr : dimsa);
-    /* and handle the dimnames */
+    /* and handle the dimnames, if any */
+    if (resize) {
-    PROTECT(dna = getAttrib(a, R_DimNamesSymbol));
+	PROTECT(dna = getAttrib(a, R_DimNamesSymbol));
-    if (LOGICAL(resize)[0] && dna != R_NilValue) {
+	if (dna != R_NilValue) {
-	SEXP dnna, dnr, dnnr;
+	    SEXP dnna, dnr, dnnr;
+	    PROTECT(dnr  = allocVector(VECSXP, n));
-	PROTECT(dnna = getAttrib(dna, R_NamesSymbol));
+	    PROTECT(dnna = getAttrib(dna, R_NamesSymbol));
-	PROTECT(dnnr = allocVector(STRSXP,n));
+	    if (dnna != R_NilValue) {
-	PROTECT(dnr  = allocVector(VECSXP,n));
+		PROTECT(dnnr = allocVector(STRSXP, n));
-	for (i=0; i<n; i++) {
+		for (i = 0; i < n; i++) {
-	    SET_VECTOR_ELT(dnr, i, VECTOR_ELT(dna, pp[i]));
+		    SET_VECTOR_ELT(dnr, i, VECTOR_ELT(dna, pp[i]));
+		    SET_STRING_ELT(dnnr, i, STRING_ELT(dnna, pp[i]));
+		}
+		setAttrib(dnr, R_NamesSymbol, dnnr);
+		UNPROTECT(1);
+	    } else {
-	    if (dnna != R_NilValue)
+		for (i = 0; i < n; i++)
-		SET_STRING_ELT(dnnr, i, STRING_ELT(dnna, pp[i]));
+		    SET_VECTOR_ELT(dnr, i, VECTOR_ELT(dna, pp[i]));
+	    }
+	    setAttrib(r, R_DimNamesSymbol, dnr);
+	    UNPROTECT(2);
+	}
-	if (dnna != R_NilValue)
-	    setAttrib(dnr, R_NamesSymbol, dnnr);
-	setAttrib(r, R_DimNamesSymbol, dnr);
-	UNPROTECT(3); /* dnna, dnr, dnnr */
+	UNPROTECT(1);
+    }
-    UNPROTECT(6); /* dimsa, perm, r, dimsr, resize, dna */
+    UNPROTECT(3); /* dimsa, r, dimsr */
     return r;
+}
 /* colSums(x, n, p, na.rm) and friends */
 SEXP attribute_hidden do_colsum(SEXP call, SEXP op, SEXP args, SEXP rho)

The R Project SVN R

(root)/branches/R-exp-R5/src/main/array.c @ 77458 – Rev 51267 → 52649