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

     if (pos < 0 && length(s) != 1) {
 	if (length(s) > 1)
 	    error("attempt to select more than one element");
 	else
 	    error("attempt to select less than one element");
     } else
 	if(pos >= length(s))
 	    error("internal error in use of recursive indexing");
     if(pos < 0) pos = 0;
     indx = -1;
     switch (TYPEOF(s)) {
 	    indx = integerOneIndex((int)dblind, len);
 	break;
     case STRSXP:
 	/* Try for exact match */
 	for (i = 0; i < length(names); i++)
 	    if (streql(CHAR(STRING_ELT(names, i)),
 		       CHAR(STRING_ELT(s, pos)))) {
 		indx = i;
 		break;
+	    }
 	/* Try for partial match */
     int i, ix;
     PROTECT(indx = allocVector(INTSXP, nx));
     for (i = 0; i < nx; i++)
 	INTEGER(indx)[i] = 1;
     for (i = 0; i < ns; i++) {
 	ix = INTEGER(s)[i];
 	if (ix != 0 && ix != NA_INTEGER && -ix <= nx)
 	    INTEGER(indx)[-ix - 1] = 0;
+    }
     s = logicalSubscript(indx, nx, nx, &stretch);
     UNPROTECT(1);
     return R_NilValue;
+}
 typedef SEXP (*StringEltGetter)(SEXP x, int i);
+/* This uses a couple of horrible hacks in conjunction with
+ * VectorAssign (in subassign.c).  If subscripting is used for
+ * assignment, it is possible to extend a vector by supplying new
+ * names, and we want to give the extended vector those names, so they
+ * are returned as the attribute. Also, unset elements of the vector
+ * of new names (places where a match was found) are indicated by
+ * setting the element of the newnames vector to NULL, even though it
+ * is a character vector.
+*/
+/* The original code (pre 2.0.0) used a ns x nx loop that was too
+ * slow.  So now we hash.  Hashing is expensive on memory (up to 32nx
+ * bytes) so it is only worth doing if ns * nx is large.  If nx is
+ * large, then it will be too slow unless ns is very small.
+ */
+#define USE_HASHING 1
 static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names,
-			    StringEltGetter strg, int *stretch)
+			    StringEltGetter strg, int *stretch, Rboolean in)
+{
     SEXP indx, indexnames;
     int i, j, nnames, sub, extra;
     int canstretch = *stretch;
+#ifdef USE_HASHING
+    Rboolean usehashing = in && (ns * nx > 1000);
+#else
+    Rboolean usehashing = FALSE;
+#endif
     PROTECT(s);
     PROTECT(names);
-    PROTECT(indx = allocVector(INTSXP, ns));
     PROTECT(indexnames = allocVector(STRSXP, ns));
     nnames = nx;
     extra = nnames;
-    /* Process each of the subscripts */
+    /* Process each of the subscripts. First we compare with the names
-    /* First we compare with the names on the vector */
+     * on the vector and then (if there is no match) with each of the
+     * previous subscripts, since (if assigning) we may have already
-    /* and then (if there is no match) with each of */
+     * added an element of that name. (If we are not assigning, any
-    /* the previous subscripts. */
+     * nonmatch will have given an error.)
+     */
+#ifdef USE_HASHING
+    if(usehashing) {
+	/* must be internal, so names contains a character vector */
+	PROTECT(indx = match(names, s, 0));
+	for (i = 0; i < ns; i++) SET_STRING_ELT(indexnames, i, R_NilValue);
+    } else {
+#endif
+	PROTECT(indx = allocVector(INTSXP, ns));
-    for (i = 0; i < ns; i++) {
+	for (i = 0; i < ns; i++) {
-	sub = 0;
+	    sub = 0;
-	if (names != R_NilValue) {
+	    if (names != R_NilValue) {
-	    for (j = 0; j < nnames; j++) {
+		for (j = 0; j < nnames; j++) {
-	        SEXP names_j = strg(names, j);
+		    SEXP names_j = strg(names, j);
-		if (TYPEOF(names_j) != CHARSXP)
+		    if (!in && TYPEOF(names_j) != CHARSXP)
-		    error("character vector element does not have type CHARSXP");
+			error("character vector element does not have type CHARSXP");
-		if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {
+		    if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {
-		    sub = j + 1;
+			sub = j + 1;
-		    SET_STRING_ELT(indexnames, i, R_NilValue);
+			SET_STRING_ELT(indexnames, i, R_NilValue);
-		    break;
+			break;
+		    }
+		}
+	    }
+	    INTEGER(indx)[i] = sub;
+	}
+#ifdef USE_HASHING
+    }
+#endif
+    for (i = 0; i < ns; i++) {
+	sub = INTEGER(indx)[i];
 	if (sub == 0) {
 	    for (j = 0 ; j < i ; j++)
 		if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {
 		    sub = INTEGER(indx)[j];
-/*		    SET_STRING_ELT(indexnames, i, STRING_ELT(indexnames, sub - 1));*/
 		    SET_STRING_ELT(indexnames, i, STRING_ELT(s, j));
 		    break;
+		}
+	}
 	if (sub == 0) {
+	}
 	INTEGER(indx)[i] = sub;
+    }
     /* Ghastly hack!  We attach the new names to the attribute */
     /* slot on the returned subscript vector. */
-    if (extra != nnames) {
+    if (extra != nnames)
 	SET_ATTRIB(indx, indexnames);
-    }
     if (canstretch)
 	*stretch = extra;
     UNPROTECT(4);
     return indx;
+}
 /* Array Subscripts.
     dim is the dimension (0 to k-1)
     s is the subscript list,
     dims is the dimensions of x
     dng is a function (usually getAttrib) that obtains the dimnames
     x is the array to be subscripted.
 */
 typedef SEXP AttrGetter(SEXP x, SEXP data);
+static SEXP
-SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
+int_arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
-		    StringEltGetter strg, SEXP x)
+		   StringEltGetter strg, SEXP x, Rboolean in)
+{
     int nd, ns, stretch = 0;
     SEXP dnames, tmp;
     ns = length(s);
     nd = INTEGER(dims)[dim];
     case STRSXP:
 	dnames = dng(x, R_DimNamesSymbol);
 	if (dnames == R_NilValue)
 	    error("no dimnames attribute for array");
 	dnames = VECTOR_ELT(dnames, dim);
-	return stringSubscript(s, ns, nd, dnames, strg, &stretch);
+	return stringSubscript(s, ns, nd, dnames, strg, &stretch, in);
     case SYMSXP:
 	if (s == R_MissingArg)
 	    return nullSubscript(nd);
     default:
 	error("invalid subscript");
+    }
     return R_NilValue;
+}
+SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
+		    StringEltGetter strg, SEXP x)
+{
+    return int_arraySubscript(dim, s, dims, dng, strg, x, TRUE);
+}
 /* Subscript creation.  The first thing we do is check to see */
 /* if there are any user supplied NULL's, these result in */
 /* returning a vector of length 0. */
 /* if stretch is zero on entry then the vector x cannot be
    "stretched",
 /* nx is the length of the object being subscripted,
    s is the R subscript value,
    dng gets a given attrib for x, which is the object we are
    subsetting,
 */
+static SEXP
-SEXP vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
+int_vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
-		     StringEltGetter strg, SEXP x)
+		    StringEltGetter strg, SEXP x, Rboolean in)
+{
     int ns;
     SEXP ans=R_NilValue, tmp;
     ns = length(s);
 	break;
     case STRSXP:
+    {
 	SEXP names = dng(x, R_NamesSymbol);
 	/* *stretch = 0; */
-	ans = stringSubscript(s, ns, nx, names, strg, stretch);
+	ans = stringSubscript(s, ns, nx, names, strg, stretch, in);
+    }
     break;
     case SYMSXP:
 	*stretch = 0;
 	if (s == R_MissingArg) {
     UNPROTECT(1);
     return ans;
+}
+SEXP vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
+		     StringEltGetter strg, SEXP x)
+{
+    return int_vectorSubscript(nx, s, stretch, dng, strg, x, TRUE);
+}

The R Project SVN R

(root)/trunk/src/main/subscript.c @ 28362 – Rev 28766 → 29363