terms(<formula>, specials = "<non-syntactic>") now works

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

Author: maechler

doc/NEWS.Rd

@@ -51,7 +51,7 @@
 
   \subsection{BUG FIXES}{
     \itemize{
-      \item Setting \code{\link{attributes}} on primitive functions is an
+      \item Setting \code{attributes} on primitive functions is an
       error now; previously, it modified without copying, as noticed by
       \I{Henrik Bengtsson} on the R-devel mailing list.
     }
@@ -270,6 +270,9 @@
       \item \code{selectMethod(f, ..)} now keeps the function name if the
       function belongs to a group generic and the method is for the
       generic.
+
+      \item \code{terms(<formula>, specials = *)} now treats non-syntactic
+      specials more gracefully, thanks to \I{Mikael Jagan}'s \PR{18568}.
     }
   }
 

src/library/stats/src/model.c

@@ -2092,35 +2092,36 @@ SEXP termsform(SEXP args)
     /* If there are specials stick them in here */
 
     if (specials != R_NilValue) {
-	R_xlen_t j;
+	int j; // R_xlen_t? but  j < i  which is int
 	const void *vmax = vmaxget();
 	int i = length(specials);
-	SEXP t;
-	PROTECT(v = allocList(i));
-	for (j = 0, t = v; j < i; j++, t = CDR(t)) {
+	SEXP t, t_ = PROTECT(allocList(i));
+	for (j = 0, t = t_; j < i; j++, t = CDR(t)) {
 	    const char *ss = translateChar(STRING_ELT(specials, j));
 	    SET_TAG(t, install(ss));
-	    R_xlen_t n = (int) strlen(ss);
 	    SETCAR(t, allocVector(INTSXP, 0));
 	    R_xlen_t k = 0;
-	    for (R_xlen_t l = 0; l < nvar; l++) {
-		if (!strncmp(CHAR(STRING_ELT(varnames, l)), ss, n))
-		    if (CHAR(STRING_ELT(varnames, l))[n] == '(')
-			k++;
+	    for (v = CDR(varlist); v != R_NilValue; v = CDR(v)) {
+		call = CAR(v);
+		if (TYPEOF(call) == LANGSXP && TYPEOF(CAR(call)) == SYMSXP &&
+		    !strcmp(CHAR(PRINTNAME(CAR(call))), ss))
+		    k++;
 	    }
 	    if (k > 0) {
 		SETCAR(t, allocVector(INTSXP, k));
 		k = 0;
-		for (int l = 0; l < nvar; l++) {
-		    if (!strncmp(CHAR(STRING_ELT(varnames, l)), ss, n))
-			if (CHAR(STRING_ELT(varnames, l))[n] == '('){
-			    INTEGER(CAR(t))[k++] = l+1;
-			}
+		int l = 1;
+		for (v = CDR(varlist); v != R_NilValue; v = CDR(v)) {
+			call = CAR(v);
+			if (TYPEOF(call) == LANGSXP && TYPEOF(CAR(call)) == SYMSXP &&
+			    !strcmp(CHAR(PRINTNAME(CAR(call))), ss))
+				INTEGER(CAR(t))[k++] = l;
+			l++;
 		}
 	    }
 	    else SETCAR(t, R_NilValue);
 	}
-	SETCAR(a, v);
+	SETCAR(a, t_);
 	SET_TAG(a, install("specials"));
 	a = CDR(a);
 	UNPROTECT(1);

tests/reg-tests-1e.R

@@ -1922,6 +1922,26 @@ stopifnot(identical(sum, msum), is.null(attributes(msum)))
 ## all 3 examples, the first a special case of the 2nd, did not error, but *modified* the base::sum primitive
 
 
+## terms.formula(*, specials="<non-syntactic>") -- PR#18568
+f1 <- y ~ x1 + `|`(x2, f)
+t1 <- terms(f1, specials = "|")
+(cs <- colSums(attr(t1, "factors")[attr(t1, "specials")[["|"]], , drop=FALSE]))
+(drp <- which(as.logical(cs))) # 2
+(dt1 <- drop.terms(t1, drp, keep.response = TRUE))
+stopifnot(identical(attr(t1, "specials"), pairlist(`|` = 3L)),
+          inherits(dt1, "terms"), dt1 == (y ~ x1))
+f3 <- y ~ x1 + (x2 | f) + (x3 | g)
+t3 <- terms(f3, specials = "|")
+str(t3)
+dropx <- which(as.logical(colSums(attr(t3, "factors")[attr(t3, "specials")[["|"]], ])))
+dt3 <- drop.terms(t3, dropx, keep.response = as.logical(attr(t3, "response")))
+stopifnot(identical(attr(t3, "specials"),
+                    pairlist(`|` = 3:4)),
+          dt3 == (y ~ x1))
+## was unchanged  y ~ x1 + (x2 | f) + (x3 | g)
+
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,