[education/rkward] /: Add test for new object modification mechanism
Thomas Friedrichsmeier
null at kde.org
Thu May 26 10:06:45 BST 2022
Git commit 7a436a4361d4eb826418d3aadd9f027fe2c84121 by Thomas Friedrichsmeier.
Committed on 26/05/2022 at 07:34.
Pushed by tfry into branch 'master'.
Add test for new object modification mechanism
M +5 -7 rkward/rbackend/rkrbackend.cpp
M +15 -2 rkward/rbackend/rkrsupport.cpp
M +2 -1 rkward/rbackend/rkrsupport.h
M +1 -1 rkward/rbackend/rpackages/rkward/DESCRIPTION
M +9 -1 rkward/rbackend/rpackages/rkward/R/internal.R
M +2 -2 rkward/rbackend/rpackages/rkward/R/rk.sync-functions.R
M +22 -2 tests/rkward_application_tests.R
A +100 -0 tests/rkward_application_tests/object_modifications.rkout
https://invent.kde.org/education/rkward/commit/7a436a4361d4eb826418d3aadd9f027fe2c84121
diff --git a/rkward/rbackend/rkrbackend.cpp b/rkward/rbackend/rkrbackend.cpp
index 9934a800..3ded40f5 100644
--- a/rkward/rbackend/rkrbackend.cpp
+++ b/rkward/rbackend/rkrbackend.cpp
@@ -916,13 +916,12 @@ void doError (const QString &callstring) {
}
}
-SEXP doSubstackCall (SEXP call) {
+SEXP doSubstackCall (SEXP _call, SEXP _args) {
RK_TRACE (RBACKEND);
R_CheckUserInterrupt ();
- QStringList list = RKRSupport::SEXPToStringList (call);
-
+ QString call = RKRSupport::SEXPToStringList(_call).value(0);
/* // this is a useful place to sneak in test code for profiling
if (list.value (0) == "testit") {
for (int i = 10000; i >= 1; --i) {
@@ -931,9 +930,8 @@ SEXP doSubstackCall (SEXP call) {
return R_NilValue;
} */
- QStringList args;
- if (list.size() > 1) args = list.mid(1);
- auto ret = RKRBackend::this_pointer->handleRequestWithSubcommands(list.value(0), args);
+ // For now, for simplicity, assume args are always strings, although possibly nested in lists
+ auto ret = RKRBackend::this_pointer->handleRequestWithSubcommands(call, RKRSupport::SEXPToNestedStrings(_args));
if (!ret.warning.isEmpty()) Rf_warning(RKRBackend::fromUtf8(ret.warning)); // print warnings, first, as errors will cause a stop
if (!ret.error.isEmpty()) Rf_error(RKRBackend::fromUtf8(ret.error));
@@ -1138,7 +1136,7 @@ bool RKRBackend::startR () {
// NOTE: Intermediate cast to void* to avoid compiler warning
{ "rk.check.env", (DL_FUNC) (void*) &checkEnv, 1 },
{ "rk.simple", (DL_FUNC) (void*) &doSimpleBackendCall, 1},
- { "rk.do.command", (DL_FUNC) (void*) &doSubstackCall, 1 },
+ { "rk.do.command", (DL_FUNC) (void*) &doSubstackCall, 2 },
{ "rk.do.generic.request", (DL_FUNC) (void*) &doPlainGenericRequest, 2 },
{ "rk.get.structure", (DL_FUNC) (void*) &doGetStructure, 4 },
{ "rk.get.structure.global", (DL_FUNC) (void*) &doGetGlobalEnvStructure, 3 },
diff --git a/rkward/rbackend/rkrsupport.cpp b/rkward/rbackend/rkrsupport.cpp
index 467685f7..69abc1b8 100644
--- a/rkward/rbackend/rkrsupport.cpp
+++ b/rkward/rbackend/rkrsupport.cpp
@@ -1,6 +1,6 @@
/*
rkrsupport - This file is part of RKWard (https://rkward.kde.org). Created: Mon Oct 25 2010
-SPDX-FileCopyrightText: 2010-2020 by Thomas Friedrichsmeier <thomas.friedrichsmeier at kdemail.net>
+SPDX-FileCopyrightText: 2010-2022 by Thomas Friedrichsmeier <thomas.friedrichsmeier at kdemail.net>
SPDX-FileContributor: The RKWard Team <rkward-devel at kde.org>
SPDX-License-Identifier: GPL-2.0-or-later
*/
@@ -163,6 +163,19 @@ SEXP RKRSupport::QVariantToSEXP(const QVariant& var) {
return ret;
}
+QVariant RKRSupport::SEXPToNestedStrings(SEXP from_exp) {
+ RK_TRACE (RBACKEND);
+ if (Rf_isList(from_exp)) {
+ QVariantList ret;
+ for(SEXP cons = from_exp; cons != R_NilValue; cons = CDR(cons)) {
+ SEXP el = CAR(cons);
+ ret.append(SEXPToNestedStrings(el));
+ }
+ return ret;
+ }
+ return QVariant(SEXPToStringList(from_exp));
+}
+
RData::IntStorage RKRSupport::SEXPToIntArray (SEXP from_exp) {
RK_TRACE (RBACKEND);
@@ -361,7 +374,7 @@ RKRShadowEnvironment::Result RKRShadowEnvironment::diffAndUpdate() {
if (main == R_UnboundValue) {
res.removed.append(RKRSupport::SEXPToString(name));
R_removeVarFromFrame(name, shadowenvir);
- if (++count >= count2) break;
+ if (++count >= count2) i = count2; // end loop
}
UNPROTECT(1);
}
diff --git a/rkward/rbackend/rkrsupport.h b/rkward/rbackend/rkrsupport.h
index 84090727..bd203c67 100644
--- a/rkward/rbackend/rkrsupport.h
+++ b/rkward/rbackend/rkrsupport.h
@@ -1,6 +1,6 @@
/*
rkrsupport - This file is part of the RKWard project. Created: Mon Oct 25 2010
-SPDX-FileCopyrightText: 2010-2020 by Thomas Friedrichsmeier <thomas.friedrichsmeier at kdemail.net>
+SPDX-FileCopyrightText: 2010-2022 by Thomas Friedrichsmeier <thomas.friedrichsmeier at kdemail.net>
SPDX-FileContributor: The RKWard Team <rkward-devel at kde.org>
SPDX-License-Identifier: GPL-2.0-or-later
*/
@@ -28,6 +28,7 @@ namespace RKRSupport {
QStringList SEXPToStringList (SEXP from_exp);
SEXP StringListToSEXP (const QStringList &list);
SEXP QVariantToSEXP(const QVariant &val);
+ QVariant SEXPToNestedStrings(SEXP from_exp);
QString SEXPToString (SEXP from_exp);
RData::IntStorage SEXPToIntArray (SEXP from_exp);
int SEXPToInt (SEXP from_exp, int def_value = INT_MIN);
diff --git a/rkward/rbackend/rpackages/rkward/DESCRIPTION b/rkward/rbackend/rpackages/rkward/DESCRIPTION
index 5cdb6c31..8f8dbfa8 100755
--- a/rkward/rbackend/rpackages/rkward/DESCRIPTION
+++ b/rkward/rbackend/rpackages/rkward/DESCRIPTION
@@ -18,7 +18,7 @@ Authors at R: c(person(given="Thomas", family="Friedrichsmeier",
role=c("aut")), person(given="the RKWard team",
email="rkward-devel at kde.org", role=c("cre","ctb")))
Version: 0.7.5
-Date: 2022-05-22
+Date: 2022-05-26
RoxygenNote: 7.1.2
Collate:
'base_overrides.R'
diff --git a/rkward/rbackend/rpackages/rkward/R/internal.R b/rkward/rbackend/rpackages/rkward/R/internal.R
index b7d264f9..236d6efe 100755
--- a/rkward/rbackend/rpackages/rkward/R/internal.R
+++ b/rkward/rbackend/rpackages/rkward/R/internal.R
@@ -122,7 +122,7 @@
}
".rk.do.call" <- function (x, args=NULL) {
- x <- .Call ("rk.do.command", c (x, args), PACKAGE="(embedding)");
+ x <- .Call ("rk.do.command", x, args, PACKAGE="(embedding)");
if (is.null(x)) invisible(NULL)
else x
}
@@ -351,3 +351,11 @@ assign(".rk.shadow.envs", new.env(parent=emptyenv()), envir=.rk.variables)
# call separate assignments functions:
if (exists (".rk.fix.assignments.graphics")) eval (body (.rk.fix.assignments.graphics)) # internal_graphics.R
}
+
+# Checks which objects have been added, removed, or changed since the last time, this function was called on the given environment.
+# This is mostly provided for testing purposes (and not currently exported), but speak up, if you think it is useful beyond internal use.
+"rk.check.env.changes" <- function(env) {
+ ret <- .Call("rk.check.env", env, PACKAGE="(embedding)")
+ names(ret) <- c("added", "removed", "changed")
+ ret
+}
diff --git a/rkward/rbackend/rpackages/rkward/R/rk.sync-functions.R b/rkward/rbackend/rpackages/rkward/R/rk.sync-functions.R
index 2e38d6bf..6ebcb138 100644
--- a/rkward/rbackend/rpackages/rkward/R/rk.sync-functions.R
+++ b/rkward/rbackend/rpackages/rkward/R/rk.sync-functions.R
@@ -29,12 +29,12 @@
#' @export
"rk.sync" <- function (x) {
object <- deparse (substitute (x))
- .rk.do.call ("sync", object)
+ .rk.do.call("sync", list(NULL, NULL, object))
}
# should this really be public?
#' @export
#' @rdname rk.sync
"rk.sync.global" <- function () {
- .rk.do.call("syncglobal", ls (envir=globalenv (), all.names=TRUE))
+ .rk.do.call("sync", rk.check.env.changes(globalenv()))
}
diff --git a/tests/rkward_application_tests.R b/tests/rkward_application_tests.R
index d4d2e077..a013c467 100644
--- a/tests/rkward_application_tests.R
+++ b/tests/rkward_application_tests.R
@@ -21,10 +21,30 @@ suite <- new ("RKTestSuite", id="rkward_application_tests",
.GlobalEnv$active.binding.value <- 123
stopifnot (.GlobalEnv$active.binding == 123)
- stopifnot (isTRUE(rkward:::.rk.watched.symbols$active.binding))
-
# NOTE: the message "active.binding" should be displayed in the message output
}),
+ new ("RKTest", id="object_modifications", call=function () {
+ env <- new.env()
+ for (a in letters) {
+ for (b in letters) {
+ for (c in letters) {
+ assign(paste0(a, b, c), 1, pos=env);
+ }
+ }
+ }
+ assign(paste0("lll", 0), 1, pos=env);
+ rkward:::rk.check.env.changes(env)
+ res <- system.time({
+ for (i in 1:5) {
+ env$lll <- env$lll + 1
+ assign(paste0("lll", i), 1, pos=env);
+ rm(list=paste0("lll", i-1), pos=env);
+ rk.print(rkward:::rk.check.env.changes(env))
+ }
+ })
+ # this is really crude, and might give false positives, but the idea is trying to catch potential performance regressions
+ stopifnot(res[1] < 0.5)
+ }),
new ("RKTest", id="promise_in_globalenv", call=function () {
.GlobalEnv$promised.value <- 1
delayedAssign ("promise.symbol", { message ("delayed assign"); promised.value }, eval.env=.GlobalEnv, assign.env=.GlobalEnv)
diff --git a/tests/rkward_application_tests/object_modifications.rkout b/tests/rkward_application_tests/object_modifications.rkout
new file mode 100644
index 00000000..410c0ae3
--- /dev/null
+++ b/tests/rkward_application_tests/object_modifications.rkout
@@ -0,0 +1,100 @@
+
+
+<p class='character'><hr class='hr'></p>
+<ul>
+</center><li>
+
+<p class='character'>lll1</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll0</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll</p>
+</ul>
+
+<br><hr class='hr'>
+
+
+<p class='character'><hr class='hr'></p>
+<ul>
+</center><li>
+
+<p class='character'>lll2</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll1</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll</p>
+</ul>
+
+<br><hr class='hr'>
+
+
+<p class='character'><hr class='hr'></p>
+<ul>
+</center><li>
+
+<p class='character'>lll3</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll2</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll</p>
+</ul>
+
+<br><hr class='hr'>
+
+
+<p class='character'><hr class='hr'></p>
+<ul>
+</center><li>
+
+<p class='character'>lll4</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll3</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll</p>
+</ul>
+
+<br><hr class='hr'>
+
+
+<p class='character'><hr class='hr'></p>
+<ul>
+</center><li>
+
+<p class='character'>lll5</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll4</p>
+</ul>
+<ul>
+</center><li>
+
+<p class='character'>lll</p>
+</ul>
+
+<br><hr class='hr'>
More information about the rkward-tracker
mailing list