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

+{
     int canstretch, count, i, nmax;
     SEXP indx;
     canstretch = *stretch;
     if (!canstretch && ns > nx)
-	error("(subscript) logical subscript too long");
+        error("(subscript) logical subscript too long");
     nmax = (ns > nx) ? ns : nx;
     *stretch = (ns > nx) ? ns : 0;
     if (ns == 0)
-	return(allocVector(INTSXP, 0));
+        return(allocVector(INTSXP, 0));
     count = 0;
     for (i = 0; i < nmax; i++)
-	if (LOGICAL(s)[i%ns])
+        if (LOGICAL(s)[i%ns] != FALSE)
-	    count++;
+            count++;
     indx = allocVector(INTSXP, count);
     count = 0;
-    for (i = 0; i < nmax; i++)
+    for (i = 0; i < nmax; i++) {
-	if (LOGICAL(s)[i%ns]) {
+        int tmp = LOGICAL(s)[i%ns];
-	    if (LOGICAL(s)[i%ns] == NA_LOGICAL)
+        if (tmp == NA_LOGICAL)
-		INTEGER(indx)[count++] = NA_INTEGER;
+            INTEGER(indx)[count++] = NA_INTEGER;
-	    else
-		INTEGER(indx)[count++] = i + 1;
+        else if (tmp == TRUE) INTEGER(indx)[count++] = i + 1;
-	}
+    }
     return indx;
+}
 static SEXP negativeSubscript(SEXP s, int ns, int nx)
+{
-    SEXP indx;
-    int stretch = 0;
+    int count, i;
-    int i;
-    PROTECT(indx = allocVector(INTSXP, nx));
+    SEXP indx = PROTECT(allocVector(LGLSXP, nx));
     for (i = 0; i < nx; i++)
-	INTEGER(indx)[i] = 1;
+        LOGICAL(indx)[i] = TRUE;
+    count = nx;
     for (i = 0; i < ns; i++)
-	if (INTEGER(s)[i] != 0)
+        if (INTEGER(s)[i] != 0) {
-	    INTEGER(indx)[-INTEGER(s)[i] - 1] = 0;
+            LOGICAL(indx)[-INTEGER(s)[i] - 1] = FALSE;
+            count--;
+        }
-    s = logicalSubscript(indx, nx, nx, &stretch);
+    s = allocVector(INTSXP, count);
+    count = 0;
+    for (i = 0; i < nx; i++)
+        if (LOGICAL(indx)[i])
+            INTEGER(s)[count++] = i + 1;
     UNPROTECT(1);
     return s;
+}
 static SEXP positiveSubscript(SEXP s, int ns, int nx)
+{
     SEXP indx;
     int i, zct = 0;
     for (i = 0; i < ns; i++) {
-	if (INTEGER(s)[i] == 0)
+        if (INTEGER(s)[i] == 0)
-	    zct++;
+            zct++;
+    }
     if (zct) {
-	indx = allocVector(INTSXP, (ns - zct));
+        indx = allocVector(INTSXP, (ns - zct));
-	for (i = 0, zct = 0; i < ns; i++)
+        for (i = 0, zct = 0; i < ns; i++)
-	    if (INTEGER(s)[i] != 0)
+            if (INTEGER(s)[i] != 0)
-		INTEGER(indx)[zct++] = INTEGER(s)[i];
+                INTEGER(indx)[zct++] = INTEGER(s)[i];
-	return indx;
+        return indx;
-    }
-    else
-	return s;
+    } else return s;
+}
 static SEXP integerSubscript(SEXP s, int ns, int nx, int *stretch)
+{
     int i, ii, min, max, canstretch;
+    int have_na = 0;
     canstretch = *stretch;
     *stretch = 0;
-    min = 0;
+    min = 1;
     max = 0;
     for (i = 0; i < ns; i++) {
-	ii = INTEGER(s)[i];
+        ii = INTEGER(s)[i];
-	if (ii != NA_INTEGER) {
+        if (ii == NA_INTEGER) {
+            have_na = 1;
+        } else {
-	    if (ii < min)
+            if (ii < min)
-		min = ii;
+                min = ii;
-	    if (ii > max)
+            if (ii > max)
-		max = ii;
+                max = ii;
-	}
+        }
+    }
     if (min < -nx)
-	error("subscript out of bounds");
+        error("subscript out of bounds");
     if (max > nx) {
-	if(canstretch) *stretch = max;
+        if(canstretch) *stretch = max;
-	else error("subscript out of bounds");
+        else error("subscript out of bounds");
+    }
     if (min < 0) {
-	if (max == 0) return negativeSubscript(s, ns, nx);
+        if (max != 0 || have_na)
-	else error("only 0's may mix with negative subscripts");
+            error("only 0's may mix with negative subscripts");
+        return negativeSubscript(s, ns, nx);
     }
+    if (have_na || min == 0)
-    else return positiveSubscript(s, ns, nx);
+        return positiveSubscript(s, ns, nx);
-    return R_NilValue;
+    else return s;
+}
+typedef SEXP (*StringEltGetter)(SEXP x, int i);
-static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names, int *stretch)
+static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names,
+                            StringEltGetter strg,
+                            int *stretch)
+{
     SEXP indx, indexnames;
     int i, j, nnames, sub, extra;
     int canstretch = *stretch;
     PROTECT(s);
     /* the previous subscripts. */
     for (i = 0; i < ns; i++) {
 	sub = 0;
 	if (names != R_NilValue) {
-	    for (j = 0; j < nnames; j++)
+	    for (j = 0; j < nnames; j++) {
+        SEXP name_j = strg(names, j);
+        if (TYPEOF(name_j) != CHARSXP)
+            error("character vector element does not have type CHARSXP");
-		if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(names, j))) {
+		if (NonNullStringMatch(STRING_ELT(s, i), name_j)) {
 		    sub = j + 1;
 		    SET_STRING_ELT(indexnames, i, R_NilValue);
 		    break;
+		}
+        }
+	}
 	if (sub == 0) {
 	    for (j = 0 ; j < i ; j++)
 		if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {
 		    sub = INTEGER(indx)[j];
     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.
+   strg extracts elements of a string vector, either obtained by using
+   dng(x, R_NamesSymbol) or from one of the elements of an VECSXP
+   obtained from dng(x, R_DimNamesSymbol).
 */
-typedef SEXP AttrGetter(SEXP x, SEXP data);
+typedef SEXP (*AttrGetter)(SEXP x, SEXP data);
-SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng, SEXP x)
+SEXP arraySubscript(int dim, SEXP s, SEXP dims,
+                    AttrGetter dng, StringEltGetter strg, SEXP x)
+{
     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, &stretch);
+	return stringSubscript(s, ns, nd, dnames, strg,
+                           &stretch);
     case SYMSXP:
 	if (s == R_MissingArg)
 	    return nullSubscript(nd);
     default:
 	error("invalid subscript");
     ans = R_NilValue;
     if (isVector(x) || isList(x) || isLanguage(x)) {
 	nx = length(x);
-	ans = vectorSubscript(nx, s, stretch, getAttrib, x);
+	ans = vectorSubscript(nx, s, stretch, getAttrib,
+                          (STRING_ELT), x);
+    }
     else error("subscripting on non-vector");
     return ans;
+}
 /* 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,
+   strg extracts elements of a string vector, either obtained by using
+   dng(x, R_NamesSymbol) or from one of the elements of an VECSXP
+   obtained from dng(x, R_DimNamesSymbol).
 */
-SEXP vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
+SEXP vectorSubscript(int nx, SEXP s, int *stretch,
-		     SEXP x)
+                     AttrGetter dng, StringEltGetter strg, SEXP x)
+{
     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, stretch);
+	ans = stringSubscript(s, ns, nx, names, strg,
+                          stretch);
+    }
     break;
     case SYMSXP:
 	*stretch = 0;
 	if (s == R_MissingArg) {
 	error("invalid subscript type");
+    }
     UNPROTECT(1);
     return ans;
+}

The R Project SVN R

(root)/trunk/src/main/subscript.c @ 28362 – Rev 24735 → 27365