x["a"] <- val should not end up calling EnlargeVector() and hence losing dim+dimnames

git-svn-id: https://svn.r-project.org/R/trunk@89130 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: maechler

doc/NEWS.Rd

@@ -444,6 +444,10 @@
       \PR{18304}.  Its behaviour remains back compatible for now, but can
       be switched to future behaviour via enviroment variable
       \env{R_sequence_recycle}, or explicit \code{recycle = TRUE}.
+
+      \item Subassignment, \code{x[ind] <- val}, to 1-dimensional
+      \code{array}s no longer \dQuote{drops} them to simple vectors when
+      \code{ind} is a name, fixing \PR{18973}, reported by \I{Thomas Soeiro}.
     }
   }
 }

src/main/subassign.c

@@ -192,7 +192,7 @@ static SEXP EnlargeVector(SEXP x, R_xlen_t newlen)
     }
 
     if (newlen > len) {
-	double expanded_nlen = newlen * expand;
+	double expanded_nlen = (double)newlen * expand;
 	if (expanded_nlen <= R_XLEN_T_MAX)
 	    newtruelen = (R_xlen_t) expanded_nlen;
 	else
@@ -322,8 +322,8 @@ static bool dispatch_asvector(SEXP *x, SEXP call, SEXP rho) {
    Level 2 is used in do_subassign2_dflt.
    This does not coerce when assigning into a list.
 */
-
-static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch, int level,
+static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch,
+			    int level,
 			    SEXP call, SEXP rho)
 {
     /* A rather pointless optimization, but level 2 used to be handled
@@ -494,11 +494,11 @@ static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch, int level,
     default:
 	error(_("incompatible types (from %s to %s) in subassignment type fix"),
 	      R_typeToChar(*x), R_typeToChar(*y));
-    }
+    } //--- end switch(which)
 
     if (stretch) {
 	PROTECT(*y);
-	*x = EnlargeVector(*x, stretch);
+	*x = EnlargeVector(*x, stretch); // FIXME: 1d-array w/ {dim,dimnames} |--> vector w/ names
 	UNPROTECT(1);
     }
     SET_OBJECT(*x, x_is_object);
@@ -507,7 +507,7 @@ static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch, int level,
 	return(100 * TYPEOF(*x) + TYPEOF(*y));
     else
 	return(which);
-}
+} // SubassignTypeFix
 
 #ifdef LONG_VECTOR_SUPPORT
 static R_INLINE R_xlen_t gi(SEXP indx, R_xlen_t i)
@@ -642,7 +642,6 @@ static SEXP VectorAssign(SEXP call, SEXP rho, SEXP x, SEXP s, SEXP y)
 
     /* Check to see if we have special matrix subscripting. */
     /* If so, we manufacture a real subscript vector. */
-
     PROTECT(s);
     if (ATTRIB(s) != R_NilValue) { /* pretest to speed up simple case */
 	SEXP dim = getAttrib(x, R_DimSymbol);
@@ -1612,13 +1611,11 @@ NORET static void errorMissingSubscript(SEXP x)
 
 attribute_hidden SEXP do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
-    SEXP subs, x, y;
-    int nsubs, oldtype;
-
     PROTECT(args);
 
-    nsubs = SubAssignArgs(args, &x, &subs, &y);
-    PROTECT(y); /* gets cut loose in SubAssignArs */
+    SEXP subs, x, y;
+    int nsubs = SubAssignArgs(args, &x, &subs, &y);
+    PROTECT(y); /* gets cut loose in SubAssignArgs */
 
     /* make sure the LHS is duplicated if it matches one of the indices */
     /* otherwise this gets the wrong answer:
@@ -1642,7 +1639,7 @@ attribute_hidden SEXP do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
 	x = SETCAR(args, shallow_duplicate(CAR(args)));
 
     bool S4 = IS_S4_OBJECT(x); // {before it is changed}
-    oldtype = 0;
+    int oldtype = 0;
     if (TYPEOF(x) == LISTSXP || TYPEOF(x) == LANGSXP) {
 	oldtype = TYPEOF(x);
 	x = PairToVectorList(x);
@@ -1770,12 +1767,12 @@ attribute_hidden SEXP
 do_subassign2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
     SEXP dims, indx, names, newname, subs, x, xtop, xup, y, thesub = R_NilValue, xOrig = R_NilValue;
-    int i, ndims, nsubs, which, len = 0 /* -Wall */;
+    int i, ndims, which, len = 0 /* -Wall */;
     R_xlen_t  stretch, offset, off = -1; /* -Wall */
 
     PROTECT(args);
 
-    nsubs = SubAssignArgs(args, &x, &subs, &y);
+    int nsubs = SubAssignArgs(args, &x, &subs, &y);
     PROTECT(y); /* gets cut loose in SubAssignArgs */
 
     /* Handle NULL left-hand sides.  If the right-hand side */

src/main/subscript.c

@@ -586,16 +586,16 @@ static SEXP nullSubscript(R_xlen_t n)
 static SEXP
 logicalSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch, SEXP call)
 {
-    R_xlen_t count, i, nmax, i1, i2;
-    int canstretch;
-    SEXP indx;
-    canstretch = *stretch > 0;
+    bool canstretch = *stretch > 0;
     if (!canstretch && ns > nx) {
 	ECALL(call, _("(subscript) logical subscript too long"));
     }
-    nmax = (ns > nx) ? ns : nx;
     *stretch = (ns > nx) ? ns : 0;
     if (ns == 0) return(allocVector(INTSXP, 0));
+    R_xlen_t count, i, i1, i2,
+	nmax = (ns > nx) ? ns : nx;
+    SEXP indx; // result
+
     const int *ps = LOGICAL_RO(s);    /* Calling LOCICAL_RO here may force a
 					 large allocation, but no larger than
 					 the one made by R_alloc below. This
@@ -709,11 +709,9 @@ logicalSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch, SEXP call)
 
 static SEXP negativeSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP call)
 {
-    SEXP indx;
-    R_xlen_t stretch = 0;
-    R_xlen_t i;
-    PROTECT(indx = allocVector(LGLSXP, nx));
+    SEXP indx = PROTECT(allocVector(LGLSXP, nx));
     int *pindx = LOGICAL(indx);
+    R_xlen_t i;
     for (i = 0; i < nx; i++)
 	pindx[i] = 1;
     const int *ps = INTEGER_RO(s);
@@ -722,19 +720,19 @@ static SEXP negativeSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP call)
 	if (ix != 0 && ix != NA_INTEGER && -ix <= nx)
 	    pindx[-ix - 1] = 0;
     }
+    R_xlen_t stretch = 0;
     s = logicalSubscript(indx, nx, nx, &stretch, call);
     UNPROTECT(1);
     return s;
 }
 
 static SEXP positiveSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx)
 {
-    SEXP indx;
     R_xlen_t i, zct = 0;
     const int *ps = INTEGER_RO(s);
     for (i = 0; i < ns; i++) if (ps[i] == 0) zct++;
     if (zct) {
-	indx = allocVector(INTSXP, (ns - zct));
+	SEXP indx = allocVector(INTSXP, (ns - zct));
 	int *pindx = INTEGER(indx);
 	for (i = 0, zct = 0; i < ns; i++)
 	    if (ps[i] != 0)
@@ -748,15 +746,13 @@ static SEXP
 integerSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch,
 		 SEXP call, SEXP x)
 {
-    R_xlen_t i;
-    int ii, max, canstretch;
-    bool isna = false, neg = false;
-    canstretch = *stretch > 0;
+    bool isna = false, neg = false,
+	canstretch = *stretch > 0;
     *stretch = 0;
-    max = 0;
+    int max = 0;
     const int *ps = INTEGER_RO(s);
-    for (i = 0; i < ns; i++) {
-	ii = ps[i];
+    for (R_xlen_t i = 0; i < ns; i++) {
+	int ii = ps[i];
 	if (ii < 0) {
 	    if (ii == NA_INTEGER)
 		isna = true;
@@ -786,7 +782,7 @@ static SEXP
 realSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch,
 	      SEXP call, SEXP x)
 {
-    int canstretch = *stretch > 0;
+    bool canstretch = *stretch > 0;
     *stretch = 0;
     double min = 0, max = 0;
     const double *ps = REAL_RO(s);
@@ -886,21 +882,23 @@ realSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch,
  */
 
 static SEXP
-stringSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP names,
+stringSubscript(SEXP s, R_xlen_t ns /* = xlength(s) */, R_xlen_t nx /* = xlength(x) */,
+		SEXP names,
 		R_xlen_t *stretch, SEXP call, SEXP x, int dim)
 {
-    SEXP indx, indexnames = R_NilValue;
-    R_xlen_t i, j, nnames, extra, sub;
-    int canstretch = *stretch > 0;
     /* product may overflow, so check factors as well. */
     bool usehashing = ( ((ns > 1000 && nx) || (nx > 1000 && ns)) || (ns * nx > 15*nx + ns) );
     int nprotect = 0;
-
     PROTECT(s);
     PROTECT(names);
     nprotect += 2;
-    nnames = nx;
-    extra = nnames;
+
+    SEXP indx, indexnames = R_NilValue;
+    bool canstretch = *stretch > 0;
+    *stretch = 0;
+    R_xlen_t i, sub,
+	nnames = nx,
+	extra = nnames;
 
     /* Process each of the subscripts. First we compare with the names
      * on the vector and then (if there is no match) with each of the
@@ -927,7 +925,7 @@ stringSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP names,
 	for (i = 0; i < ns; i++) {
 	    sub = 0;
 	    if (names != R_NilValue) {
-		for (j = 0; j < nnames; j++) {
+		for (R_xlen_t j = 0; j < nnames; j++) {
 		    SEXP names_j = STRING_ELT(names, j);
 		    if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {
 			sub = j + 1;
@@ -969,10 +967,11 @@ stringSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP names,
     }
     /* We return the new names as the names attribute of the returned
        subscript vector. */
-    if (extra != nnames)
+    if (extra != nnames) {
 	setAttrib(indx, R_UseNamesSymbol, indexnames);
-    if (canstretch)
-	*stretch = extra;
+	if (canstretch)
+	    *stretch = extra;
+    }
     UNPROTECT(nprotect);
     return indx;
 }
@@ -1090,7 +1089,6 @@ makeSubscript(SEXP x, SEXP s, R_xlen_t *stretch, SEXP call)
     case STRSXP:
     {
 	SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));
-	/* *stretch = 0; */
 	ans = stringSubscript(s, ns, nx, names, stretch, call, x, -1);
 	UNPROTECT(1); /* names */
 	break;

tests/reg-tests-1e.R

@@ -2449,6 +2449,19 @@ for(recycl in c(FALSE, TRUE)) withAutoprint({
 })
 
 
+## <1d-arrary>[<name>] <- <val>  -- dropped dim & dimnames in transforming to atomic vector -- PR#18973
+mk1d <- function(N) {
+    stopifnot(length(N) == 1, N >= 1, is.integer(n <- 1:N))
+    array(n, dimnames = list(letters[n]))
+}
+chk1d <- function(a)
+    stopifnot(is.array(a), length(d <- dim(a)) == 1L, is.list(dn <- dimnames(a)), length(dn) == 1L)
+str(x <- mk1d(3)); chk1d(x)
+x[1]   <- 99 ; chk1d(x)
+x["a"] <- 100; chk1d(x)
+## x["a"] <- .. did drop dim() & dimnames() {getting names() instead}.
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,