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] != FALSE)
+	if (LOGICAL(s)[i%ns])
-            count++;
+	    count++;
     indx = allocVector(INTSXP, count);
     count = 0;
-    for (i = 0; i < nmax; i++) {
+    for (i = 0; i < nmax; i++)
-        int tmp = LOGICAL(s)[i%ns];
+	if (LOGICAL(s)[i%ns]) {
-        if (tmp == NA_LOGICAL)
+	    if (LOGICAL(s)[i%ns] == NA_LOGICAL)
-            INTEGER(indx)[count++] = NA_INTEGER;
+		INTEGER(indx)[count++] = NA_INTEGER;
+	    else
-        else if (tmp == TRUE) INTEGER(indx)[count++] = i + 1;
+		INTEGER(indx)[count++] = i + 1;
-    }
+	}
     return indx;
+}
 static SEXP negativeSubscript(SEXP s, int ns, int nx)
+{
+    SEXP indx;
-    int count, i;
+    int stretch = 0;
+    int i;
-    SEXP indx = PROTECT(allocVector(LGLSXP, nx));
+    PROTECT(indx = allocVector(INTSXP, nx));
     for (i = 0; i < nx; i++)
-        LOGICAL(indx)[i] = TRUE;
+	INTEGER(indx)[i] = 1;
-    count = nx;
     for (i = 0; i < ns; i++)
-        if (INTEGER(s)[i] != 0) {
+	if (INTEGER(s)[i] != 0)
-            LOGICAL(indx)[-INTEGER(s)[i] - 1] = FALSE;
+	    INTEGER(indx)[-INTEGER(s)[i] - 1] = 0;
-            count--;
-        }
-    s = allocVector(INTSXP, count);
+    s = logicalSubscript(indx, nx, nx, &stretch);
-    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
-    } else return s;
+	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 = 1;
+    min = 0;
     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 || have_na)
+	if (max == 0) return negativeSubscript(s, ns, nx);
-            error("only 0's may mix with negative subscripts");
+	else error("only 0's may mix with negative subscripts");
-        return negativeSubscript(s, ns, nx);
     }
-    if (have_na || min == 0)
-        return positiveSubscript(s, ns, nx);
+    else return positiveSubscript(s, ns, nx);
-    else return s;
+    return R_NilValue;
+}
 typedef SEXP (*StringEltGetter)(SEXP x, int i);
 static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names,
-                            StringEltGetter strg,
-                            int *stretch)
+			    StringEltGetter strg, int *stretch)
+{
     SEXP indx, indexnames;
     int i, j, nnames, sub, extra;
     int canstretch = *stretch;
     PROTECT(s);
     for (i = 0; i < ns; i++) {
 	sub = 0;
 	if (names != R_NilValue) {
 	    for (j = 0; j < nnames; j++) {
-        SEXP name_j = strg(names, j);
+	        SEXP names_j = strg(names, j);
-        if (TYPEOF(name_j) != CHARSXP)
+		if (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), name_j)) {
+		if (NonNullStringMatch(STRING_ELT(s, i), names_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,
+SEXP arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
-                    AttrGetter dng, StringEltGetter strg, SEXP x)
+		    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, strg,
+	return stringSubscript(s, ns, nd, dnames, strg, &stretch);
-                           &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,
+	ans = vectorSubscript(nx, s, stretch, getAttrib, (STRING_ELT), x);
-                          (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,
+SEXP vectorSubscript(int nx, SEXP s, int *stretch, AttrGetter dng,
-                     AttrGetter dng, StringEltGetter strg, SEXP x)
+		     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, strg,
+	ans = stringSubscript(s, ns, nx, names, strg, stretch);
-                          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 – Rev 27365 → 27383