termsform resets attributes of the result

Additionally: the tests against GnuR externals now check the result
of the external call as opposed to checking the result of the wrapper
of the external call. This helps to find even tinier differences.

com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/model.R

@@ -533,6 +533,7 @@ ExpandDots <- function(x, framenames) {
 # "order", "intercept", "response": 1
 termsform <- function (x, specials, data, keep.order, allowDotAsName) {
     
+    attributes(x) <- NULL
     if (!isLanguage(x)
         || !identical(x[[1]], quote(`~`))
         || length(x) != 2L && length(x) != 3L) {
@@ -655,8 +656,8 @@ termsform <- function (x, specials, data, keep.order, allowDotAsName) {
     if (nterm > 0L) {
       dimnames(pattern) <- list(varnames, termlabs)
     }
-    attr(x, "term.labels") <- termlabs
     attr(x, "factors") <- pattern
+    attr(x, "term.labels") <- termlabs
     
     if (!is.null(specials)) {
         specialsAttr <- vector("pairlist", length(specials))
@@ -680,7 +681,7 @@ termsform <- function (x, specials, data, keep.order, allowDotAsName) {
     attr(x, "order") <- ord
     attr(x, "intercept") <- as.integer(intercept)
     attr(x, "response") <- as.integer(response)
-    class(x) <- c("terms", "formula")
+    class(x) <- c("terms")
     return(x)
 }
 

com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/modelTests.R

@@ -32,28 +32,48 @@
 # IMPORTANT: some test cases from this file are used in Java unit tests in TestFormulae
 # class, please update them accordingly when updating this file.
 
-# create patched versions of R stubs for externals:
-# we replace call to .External with call to our implementation
-body <- deparse(model.frame.default)
-idx <- which(grepl(".External2", body))
-body[[idx]] <- gsub("C_modelframe,", "", gsub(".External2", "modelframe", body[[idx]]))
-modelframedefault <- eval(parse(text=body))
-
-body <- deparse(model.matrix.default)
-idx <- which(grepl(".External2", body))
-body[[idx]] <- gsub("C_modelmatrix,", "", gsub(".External2", "modelmatrix", body[[idx]]))
-modelmatrixdefault <- eval(parse(text=body))
+gsubVec <- function(pattern, replace, text) {
+    for (i in seq_along(pattern)) {
+        text <- gsub(pattern[[i]], replace[[i]], text);
+    }
+    text
+}
+
+saved <- list()
+saveArgs <- function(...) {
+    saved <<- list(...)
+}
+
+replaceExternalWithSaveArgs <- function(func, externalType='.External2') {
+    body <- deparse(func)
+    idx <- which(grepl(externalType, body))
+    body[[idx]] <- gsubVec(c('C_[^,]*,', externalType), c("", "saveArgs"), body[[idx]])
+    eval(parse(text=body))
+}
+
+# stubs that save original arguments to .External calls so that we can call them with these args by hand
+# note: there is no logic in terms.formula executed before the .External call
+saveArgs.model.frame.default <- replaceExternalWithSaveArgs(model.frame.default)
+saveArgs.model.matrix.default <- replaceExternalWithSaveArgs(model.matrix.default)
 
 # check function compares the results
+failedTests <- 0
+successTests <- 0
 check <- function(expected, actual, name) {
-	if (try(identical(expected, actual)) != TRUE) {
-		cat(name, ": FAIL  expected:\n\n")
-		print(expected)
-		cat("\n>>>>>>>>>actual:\n\n")
-		print(actual)
-		cat("\n-------------\n")
-	}
-	else { cat(name, ": OK\n") }
+    if (try(identical(expected, actual)) != TRUE) {
+        failedTests <<- failedTests + 1
+        cat(name, ": FAIL  expected:\n\n")
+        print(expected)
+        cat("\n>>>>>>>>>actual:\n\n")
+        print(actual)
+        cat("\n-------------\n")
+        if (failedTests > 10) {
+            stop("Too many failed tests...")
+        }
+    } else {
+        successTests <<- successTests + 1
+        cat(".")
+    }
 }
 
 # tests data: formulae
@@ -66,24 +86,28 @@ tests <- c(tests, ignoremm)
 
 run.tests <- function() {
     for (t in tests) {
-    	print(t)
-    	check(terms.formula(t), termsform(t, NULL, NULL, FALSE, FALSE), "termsform")
-    	
-    	# modelframe
-    	if (!(c(t) %in% ignoremf)) {
-    	    mf <- model.frame.default(t)
-    	    check(mf, modelframedefault(t), "model.frame.default")
-    	} else {
-    	    next
-    	}
-
-    	# modelmatrix
-    	if (!(c(t) %in% ignoremm)) {
-        	our <- modelmatrixdefault(mf)
-        	mode(our) <- "double" # GnuR has always double results, even when not necessary
-        	check(model.matrix.default(mf), our, "model.matrix.default")
-        	# for one off testing: modelmatrixdefault(model.frame.default(t))
-    	}
+        print(t)
+        check(.External(stats:::C_termsform, t, NULL, NULL, FALSE, FALSE), termsform(t, NULL, NULL, FALSE, FALSE), "termsform")
+
+        # modelframe
+        if (!(c(t) %in% ignoremf)) {
+            saveArgs.model.frame.default(t)
+            their <- do.call(.External2, c(list(stats:::C_modelframe), saved))
+            ours <- do.call(modelframe, saved)
+            check(their, ours, "model.frame.default")
+        } else {
+            next
+        }
+
+        # modelmatrix
+        if (!(c(t) %in% ignoremm)) {
+            mf <- model.frame.default(t)
+            saveArgs.model.matrix.default(mf)
+            their <- do.call(.External2, c(list(stats:::C_modelmatrix), saved))
+            ours <- do.call(modelmatrix, saved)
+            mode(ours) <- "double" # GnuR has always double results, even when not necessary
+            check(their, ours, "model.matrix.default")
+        }
     }
 }
 
@@ -104,23 +128,25 @@ run.tests()
 
 # check subsetting
 print(y~z)
-mf <- model.frame.default(y~z, subset=3:7)
-check(mf, modelframedefault(y~z, subset=3:7), "model.frame.default with subset")
+saveArgs.model.frame.default(y~z, subset=3:7)
+their <- do.call(.External2, c(list(stats:::C_modelframe), saved))
+ours <- do.call(modelframe, saved)
+check(their, ours, "model.frame.default with subset")
 
 # check specials
 t <- y~myfun(z)+x
 print(t)
-check(terms.formula(t, c('myfun')), termsform(t, c('myfun'), NULL, FALSE, FALSE), "termsform with specials")
+check(.External(stats:::C_termsform, t, c('myfun'), NULL, FALSE, FALSE), termsform(t, c('myfun'), NULL, FALSE, FALSE), "termsform with specials")
 
 # check expand dots
 t <- cyl~hp*mpg+.
 print(t)
-check(terms.formula(t, data=mtcars), termsform(t, NULL, mtcars, FALSE, FALSE), "termsform with expandDots")
+check(.External(stats:::C_termsform, t, NULL, mtcars, FALSE, FALSE), termsform(t, NULL, mtcars, FALSE, FALSE), "termsform with expandDots")
 
 # check specials and expand dots
 t <- cyl~mufun(mpg)+.
 print(t)
-check(terms.formula(t, specials=c('myfun'), data=mtcars), termsform(t, c('myfun'), mtcars, FALSE, FALSE), "termsform with specials and expandDots")
+check(.External(stats:::C_termsform, t, c('myfun'), mtcars, FALSE, FALSE), termsform(t, c('myfun'), mtcars, FALSE, FALSE), "termsform with specials and expandDots")
 
 
 # ------------------------------------
@@ -145,3 +171,7 @@ test.update.formula(~ u+v, ~ . )
 test.update.formula(~ u+v, . ~ . )
 test.update.formula(~ u+v, ~ x*. )
 test.update.formula(~ u+v, ~ x:. )
+
+
+cat("\n\nFinished\nsuccessful:", successTests, "\nfailed:", failedTests)
+