diff --git a/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/model.R b/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/model.R
index e0ebabafddce019be410544ca68bb4ccc6a5cf70..c3b62475f676a8d386a147e273b64f69e1201fa9 100644
--- a/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/model.R
+++ b/com.oracle.truffle.r.library/src/com/oracle/truffle/r/library/stats/model.R
@@ -494,21 +494,29 @@ TermCode <- function(formula, callIdx, varIndex) {
}
# gets the formula as parameter and returns the same formula, where
-# dot symbol is replaced with (a+b+c+...) where a,b,c.. are framenames.
-ExpandDots <- function(x) {
+# the dot symbol is replaced with the 'replacement'
+replaceDots <- function(x, replacement) {
if (is.symbol(x)) {
if (identical(x, quote(`.`))) {
- return(parse(text=paste(framenames, collapse="+"))[[1]])
+ return(replacement)
}
return(x)
}
for (i in seq_along(x)) {
- x[[i]] <- ExpandDots(x[[i]]);
+ x[[i]] <- replaceDots(x[[i]], replacement);
}
x
}
+# gets the formula as parameter and returns the same formula, where
+# the dot symbol is replaced with (a+b+c+...) where a,b,c.. are framenames.
+# Note: this version is not equivalent of the GnuR C version as it expects
+# variable names as the second argument. replaceDots is closer to the GnuR C version.
+ExpandDots <- function(x, framenames) {
+ replaceDots(x, parse(text=paste(framenames, collapse="+"))[[1]]);
+}
+
# PUBLIC: termsform
#
@@ -666,7 +674,7 @@ termsform <- function (x, specials, data, keep.order, allowDotAsName) {
# Step 6: Fix up the formula by substituting for dot, which should be
# the framenames joined by +
if (haveDot) {
- x <- ExpandDots(x)
+ x <- ExpandDots(x, framenames)
}
attr(x, "order") <- ord
@@ -1247,6 +1255,43 @@ modelmatrix <- function(formula, modelframe) {
x
}
+# =============================================================
+# Implementation of updateform
+# PUBLIC updateform
+#
+# Replaces all occurences of dot symbol '.' in the lsh/rhs of 'new' formula with
+# lhs/rhs of the 'old' formula. The result is stripped off of all attributes and
+# gets .Environment attribute from the 'old' formula.
+updateform <- function(old, new) {
+ is.formula <- function (x) is.language(x) && x[[1L]] == quote(`~`);
+ if (!is.formula(old) || !is.formula(new)) {
+ error("formula expected")
+ }
+ if (length(old) == 3) {
+ lhs <- old[[2L]]
+ rhs <- old[[3L]]
+ # We now check that new formula has a valid lhs. If it doesn't,
+ # we add one and set it to the rhs of the old formula.
+ if (length(new) == 2) {
+ tmp <- new[[2L]]
+ new[[2L]] <- lhs
+ new[[3L]] <- tmp
+ }
+ # Note: we are probably getting away with not parenthesizing thanks to R
+ new[[2L]] <- replaceDots(new[[2L]], lhs)
+ new[[3L]] <- replaceDots(new[[3L]], rhs)
+ } else {
+ # the old formula has no lhs, we only expand rhs
+ if (length(new) == 3) {
+ new[[3L]] <- replaceDots(new[[3L]], old[[2L]])
+ } else {
+ new[[2L]] <- replaceDots(new[[2L]], old[[2L]])
+ }
+ }
+ attributes(new) <- NULL
+ attr(new, '.Environment') <- attr(old, '.Environment')
+ new
+}
diff --git a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java
index 58e6992ce24d022fa4076ff2641d538567d5afba..4452a2d5b3060ece2953d3eabba624407d443a33 100644
--- a/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java
+++ b/com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/foreign/ForeignFunctions.java
@@ -404,7 +404,6 @@ public class ForeignFunctions {
case "binomial_dev_resids":
case "rWishart":
case "Cdist":
- case "updateform":
case "mvfft":
case "nextn":
case "r2dtable":
@@ -446,8 +445,12 @@ public class ForeignFunctions {
case "d2x2xk":
return new UnimplementedExternal(name);
+ case "updateform":
+ return getExternalModelBuiltinNode("updateform");
+
case "Cdqrls":
return new RInternalCodeBuiltinNode(RContext.getInstance(), "stats", RInternalCode.loadSourceRelativeTo(StatsUtil.class, "lm.R"), "Cdqrls");
+
case "dnorm":
return StatsFunctionsFactory.Function3_1NodeGen.create(new Dnorm4());
diff --git a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/builtin/RInternalCodeBuiltinNode.java b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/builtin/RInternalCodeBuiltinNode.java
index cf4cdca50cb5a10f779dbdcbcef25a57ed40dda5..f1b6e6148446abd8e77b68c416aebae36269d46e 100644
--- a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/builtin/RInternalCodeBuiltinNode.java
+++ b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/builtin/RInternalCodeBuiltinNode.java
@@ -61,6 +61,9 @@ public final class RInternalCodeBuiltinNode extends RExternalBuiltinNode {
CompilerDirectives.transferToInterpreterAndInvalidate();
RInternalCode internalCode = RInternalCode.lookup(context, basePackage, code);
this.function = internalCode.lookupFunction(functionName);
+ if (this.function == null) {
+ throw RInternalError.shouldNotReachHere("Could not load RInternalCodeBuiltin function '" + functionName + "'.");
+ }
}
return call.execute(frame, actualArgs.getSignature(), actualArgs.getArguments(), function, functionName, null);
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
index 2f39c38c369eff2a241461fe81b3f3058fc9b96e..4ac9392678c23e2ee8dd10d7292da68a79e0d4a5 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
@@ -111569,6 +111569,42 @@ In qnorm(c(0.1, 0.9, 0.5, 1.00001, 0.99999), 100, c(20, 1)) : NaNs produced
#{ round(100*sd(c(1,2))^2) }
[1] 50
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(. ~ u+v, log(.) ~ .:q)
+log(.) ~ u:q + v:q
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(. ~ u+v, x + . ~ y:. + log(.))
+x + . ~ log(u + v) + y:u + y:v
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(. ~ u+v, ~ . + x2)
+. ~ u + v + x2
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(x ~ u+v, log(.) ~ .:q)
+log(x) ~ u:q + v:q
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(x ~ u+v, x + . ~ y:. + log(.))
+x + x ~ log(u + v) + y:u + y:v
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(x ~ u+v, ~ . + x2)
+x ~ u + v + x2
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(x ~ y, log(.) ~ .:q)
+log(x) ~ y:q
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(x ~ y, x + . ~ y:. + log(.))
+x + x ~ y + log(y)
+
+##com.oracle.truffle.r.test.library.stats.TestUpdateForm.basicTests
+#update.formula(x ~ y, ~ . + x2)
+x ~ y + x2
+
##com.oracle.truffle.r.test.library.utils.TestInteractiveDebug.testInvalidName
#f <- function(x) {<<<NEWLINE>>> `123t` <- x + 1<<<NEWLINE>>> print(`123t`)<<<NEWLINE>>> `123t`}<<<NEWLINE>>>debug(f)<<<NEWLINE>>>f(5)<<<NEWLINE>>>x<<<NEWLINE>>>n<<<NEWLINE>>>n<<<NEWLINE>>>`123t`<<<NEWLINE>>>n<<<NEWLINE>>>n
debugging in: f(5)
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/TestUpdateForm.java b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/TestUpdateForm.java
new file mode 100644
index 0000000000000000000000000000000000000000..03fc6a7f434da9914635d112ba88fa96a7193891
--- /dev/null
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/TestUpdateForm.java
@@ -0,0 +1,43 @@
+/*
+ * Copyright (c) 2014, 2016, Oracle and/or its affiliates. All rights reserved.
+ * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+ *
+ * This code is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License version 2 only, as
+ * published by the Free Software Foundation.
+ *
+ * This code is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * version 2 for more details (a copy is included in the LICENSE file that
+ * accompanied this code).
+ *
+ * You should have received a copy of the GNU General Public License version
+ * 2 along with this work; if not, write to the Free Software Foundation,
+ * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+ *
+ * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+ * or visit www.oracle.com if you need additional information or have any
+ * questions.
+ */
+package com.oracle.truffle.r.test.library.stats;
+
+import org.junit.Test;
+
+import com.oracle.truffle.r.test.TestBase;
+
+/**
+ * Tests the updateform external function called from R function update.formula, in FastR this
+ * function is implemented in R code. See file modelTests.R in the same directory for pure R tests
+ * testing only the FastR R code without the R wrappers from GnuR. When adding new test cases here,
+ * consider adding them to modelTests.R too.
+ */
+public class TestUpdateForm extends TestBase {
+ private static final String[] OLD_FORMULAE = new String[]{"x ~ y", ". ~ u+v", "x ~ u+v"};
+ private static final String[] NEW_FORMULAE = new String[]{"~ . + x2", "log(.) ~ .:q", "x + . ~ y:. + log(.)"};
+
+ @Test
+ public void basicTests() {
+ assertEval(template("update.formula(%0, %1)", OLD_FORMULAE, NEW_FORMULAE));
+ }
+}
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/modelTests.R b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/modelTests.R
index 6fad3bc8dbd278793259a4daa352a4f4e6a0e757..b53b5e876fb411fe0535773b6b2e3d9a19afad4e 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/modelTests.R
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/library/stats/modelTests.R
@@ -47,10 +47,11 @@ modelmatrixdefault <- eval(parse(text=body))
# check function compares the results
check <- function(expected, actual, name) {
if (try(identical(expected, actual)) != TRUE) {
- cat(name, ": FAIL\n")
+ cat(name, ": FAIL expected:\n\n")
print(expected)
cat("\n>>>>>>>>>actual:\n\n")
print(actual)
+ cat("\n-------------\n")
}
else { cat(name, ": OK\n") }
}
@@ -120,3 +121,27 @@ check(terms.formula(t, data=mtcars), termsform(t, NULL, mtcars, FALSE, FALSE), "
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")
+
+
+# ------------------------------------
+# tests for update formula
+
+body <- deparse(update.formula)
+idx <- which(grepl(".Call", body))
+body[[idx]] <- gsub("C_updateform,", "", gsub(".Call", "updateform", body[[idx]]))
+updateformula <- eval(parse(text=body))
+
+test.update.formula <- function(old, new) {
+ print(old);
+ print(new);
+ check(update.formula(old, new), updateformula(old, new), "update.formula test")
+}
+
+test.update.formula(y ~ x, ~ . + x2)
+test.update.formula(y ~ x, log(.) ~ . )
+test.update.formula(. ~ u+v, res ~ . )
+test.update.formula(~ u+v, res ~ . )
+test.update.formula(~ u+v, ~ . )
+test.update.formula(~ u+v, . ~ . )
+test.update.formula(~ u+v, ~ x*. )
+test.update.formula(~ u+v, ~ x:. )