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

 /* attribute.  Note that this function mutates x. */
 /* Duplication should occur before this is called. */
 SEXP DropDims(SEXP x)
+{
-    SEXP q, dims, dimnames, newnames = R_NilValue;
+    SEXP dims, dimnames, newnames = R_NilValue;
     int i, n, ndims;
     PROTECT(x);
     dims = getAttrib(x, R_DimSymbol);
     dimnames = getAttrib(x, R_DimNamesSymbol);
 	UNPROTECT(1);
 	return x;
+    }
     if (n <= 1) {
-	/* We have reduced to a vector result. */
+	/* We have reduced to a vector result.
+	   If that has length one, it is ambiguous which dimnames to use,
+	   so use it if there is only one (as from R 2.7.0).
+	 */
 	if (dimnames != R_NilValue) {
-	    n = length(dims);
-	    if (TYPEOF(dimnames) == VECSXP) {
+	    if(LENGTH(x) != 1) {
-		for (i = 0; i < n; i++) {
+		for (i = 0; i < LENGTH(dims); i++) {
 		    if (INTEGER(dims)[i] != 1) {
 			newnames = VECTOR_ELT(dimnames, i);
 			break;
+		    }
+		}
+	    } else { /* drop all dims: keep names if unambiguous */
-	    }
+		int cnt;
-	    else {
+		for(i = 0, cnt = 0; i < LENGTH(dims); i++)
+		    if(VECTOR_ELT(dimnames, i) != R_NilValue) cnt++;
-		q = dimnames;
+		if(cnt == 1)
-		for (i = 0; i < n; i++) {
+		    for (i = 0; i < LENGTH(dims); i++) {
-		    if (INTEGER(dims)[i] != 1) {
+			newnames = VECTOR_ELT(dimnames, i);
-			newnames = CAR(q);
+			if(newnames != R_NilValue) break;
-			break;
+		    }
-		    q = CDR(q);
-		}
+	    }
+	}
 	PROTECT(newnames);
 	setAttrib(x, R_DimNamesSymbol, R_NilValue);
 	setAttrib(x, R_DimSymbol, R_NilValue);
 	setAttrib(x, R_NamesSymbol, newnames);
 	UNPROTECT(1);
-    }
-    else {
+    } else {
 	/* We have a lower dimensional array. */
 	SEXP newdims, dnn, newnamesnames = R_NilValue;
 	dnn = getAttrib(dimnames, R_NamesSymbol);
 	PROTECT(newdims = allocVector(INTSXP, n));
 	for (i = 0, n = 0; i < ndims; i++)

The R Project SVN R

(root)/branches/R-classInheritance/src/main/array.c @ 63243 – Rev 43024 → 43878