[rkward-cvs] SF.net SVN: rkward:[2549] trunk/rkward
tfry at users.sourceforge.net
tfry at users.sourceforge.net
Wed Jun 24 20:37:50 UTC 2009
Revision: 2549
http://rkward.svn.sourceforge.net/rkward/?rev=2549&view=rev
Author: tfry
Date: 2009-06-24 20:37:50 +0000 (Wed, 24 Jun 2009)
Log Message:
-----------
Some more touch-ups to the test framework. The basic features work, now.
Modified Paths:
--------------
trunk/rkward/rkward/misc/rksaveobjectchooser.cpp
trunk/rkward/tests/CMakeLists.txt
trunk/rkward/tests/import_export_plugins.R
Added Paths:
-----------
trunk/rkward/tests/all_tests.R
trunk/rkward/tests/test_framework.R
Removed Paths:
-------------
trunk/rkward/tests/test.R
Modified: trunk/rkward/rkward/misc/rksaveobjectchooser.cpp
===================================================================
--- trunk/rkward/rkward/misc/rksaveobjectchooser.cpp 2009-06-24 17:19:38 UTC (rev 2548)
+++ trunk/rkward/rkward/misc/rksaveobjectchooser.cpp 2009-06-24 20:37:50 UTC (rev 2549)
@@ -81,7 +81,6 @@
RObject *object = RObjectList::getGlobalEnv ()->findObject (validizedSelectedObjectName ());
if (object) {
-qDebug ("exists: %s", qPrintable (object->getFullName ()));
object_exists = true;
overwrite_confirm->setText (i18n ("Overwrite? (The given object name already exists)"));
overwrite_confirm->setEnabled (true);
Modified: trunk/rkward/tests/CMakeLists.txt
===================================================================
--- trunk/rkward/tests/CMakeLists.txt 2009-06-24 17:19:38 UTC (rev 2548)
+++ trunk/rkward/tests/CMakeLists.txt 2009-06-24 20:37:50 UTC (rev 2549)
@@ -1,3 +1,3 @@
ADD_CUSTOM_TARGET (plugintests
- COMMAND ${CMAKE_CURRENT_BINARY_DIR}/../rkward/rkward --evaluate 'source (\"import_export_plugins.R\")'
+ COMMAND ${CMAKE_CURRENT_BINARY_DIR}/../rkward/rkward --evaluate 'source (\"all_tests.R\")'
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
\ No newline at end of file
Added: trunk/rkward/tests/all_tests.R
===================================================================
--- trunk/rkward/tests/all_tests.R (rev 0)
+++ trunk/rkward/tests/all_tests.R 2009-06-24 20:37:50 UTC (rev 2549)
@@ -0,0 +1,14 @@
+if (!isClass ("RKTestSuite")) source ("test_framework.R")
+
+## add your test suite files, to this vector:
+testsuites <- c ("import_export_plugins.R")
+
+allresults <- new ("RKTestResult")
+for (testsuite in testsuites) {
+ source (testsuite)
+ allresults <- rktest.appendTestResults (allresults, results)
+ rm ("results")
+}
+
+print ("Overall results:")
+print (allresults)
Modified: trunk/rkward/tests/import_export_plugins.R
===================================================================
--- trunk/rkward/tests/import_export_plugins.R 2009-06-24 17:19:38 UTC (rev 2548)
+++ trunk/rkward/tests/import_export_plugins.R 2009-06-24 20:37:50 UTC (rev 2549)
@@ -1,8 +1,12 @@
+## intro
# This should be the first line in each test suite file: Include the
-# test framework, multiple inclusion should do no harm
-source ("test.R")
+# test framework, unless already included (multiple inclusion would not
+# really do any harm either, though
+if (!isClass ("RKTestSuite")) source ("test_framework.R")
+## definition of the test suite
suite <- new ("RKTestSuite", id="import_export_plugins",
+ # initCalls are run *before* any tests. Use this to set up the environment
initCalls = list (
function () {
library ("R2HTML")
@@ -16,6 +20,7 @@
suppressWarnings (rm ("women"))
}
+ ## the tests
), tests = list (
new ("RKTest", id="load_r_object", call=function () {
rk.call.plugin ("rkward::load_r_object", file.selection="women.RData", other_env.state="0", submit.mode="submit")
@@ -34,9 +39,9 @@
# this one is expected to fail, as it would overwrite the existing "women" in globalenv()
rk.call.plugin ("rkward::import_csv", file.selection="women.csv", name.selection="women", submit.mode="submit")
}, expect_error=TRUE)
- ), postCalls = list ()
+ ), postCalls = list () # like initCalls: run after all tests to clean up. Empty in this case.
)
-y <- rktest.runRKTestSuite (suite)
-
-print (y)
+## always store the result in "results" and print it
+results <- rktest.runRKTestSuite (suite)
+print (results)
Deleted: trunk/rkward/tests/test.R
===================================================================
--- trunk/rkward/tests/test.R 2009-06-24 17:19:38 UTC (rev 2548)
+++ trunk/rkward/tests/test.R 2009-06-24 20:37:50 UTC (rev 2549)
@@ -1,224 +0,0 @@
-setClass ("RKTestSuite",
- representation (id="character", initCalls="list", tests="list", postCalls="list"),
- prototype(character(0), id=NULL, initCalls=list(), tests=list(), postCalls=list ()),
- validity=function (object) {
- if (length (object at id) != 1) return (FALSE)
- if (length (object at tests) < 1) return (FALSE)
- return (TRUE)
- }
- )
-
-setClass ("RKTest",
- representation (id="character", call="function", fuzzy_output="logical", expect_error="logical"),
- prototype(character(0), id=NULL, call=function () { stop () }, fuzzy_output=FALSE, expect_error=FALSE),
- validity=function (object) {
- if (is.null (object at id)) return (FALSE)
- return (TRUE)
- }
- )
-
-setClass ("RKTestResult",
- representation (id = "character", code_match = "logical", output_match = "logical", message_match = "logical", error="logical", passed="logical"),
- prototype(character(0), id = character (0), code_match = NA, output_match = NA, message_match = NA, error = NA, passed=FALSE),
- validity=function (object) {
- return (all.equal (length (object at id), length (object at code_match), length (object at output_match), length (object at message_match), length (object at error), length (object at passed)))
- }
- )
-
-setMethod ("show", "RKTestResult", function (object) {
- stopifnot (inherits (object, "RKTestResult"))
-
- cat (format ("ID", width=20))
- cat (format ("code match", width=15))
- cat (format ("output match", width=15))
- cat (format ("message match", width=15))
- cat (format ("error", width=15))
- cat (format ("result", width=15))
- cat ("\n")
-
- for (i in 1:length (object at id)) {
- cat (format (object at id[i], width=20))
- cat (format (if (object at code_match[i]) "true" else "FALSE", width=15))
- cat (format (if (object at output_match[i]) "true" else "FALSE", width=15))
- cat (format (if (object at message_match[i]) "true" else "FALSE", width=15))
- cat (format (if (object at error[i]) "TRUE" else "false", width=15))
- cat (format (if (object at passed[i]) "pass" else "FAIL", width=15))
- cat ("\n")
- }
-})
-
-rktest.appendTestResults <- function (objecta, objectb) {
- stopifnot (inherits (objecta, "RKTestResult") && validObject (objecta))
- stopifnot (inherits (objectb, "RKTestResult") && validObject (objectb))
-
- index <- length (objecta at id)
- for (i in 1:length (objectb at id)) {
- objecta at id[index+i] = objectb at id[i]
- objecta at code_match[index+i] = objectb at code_match[i]
- objecta at output_match[index+i] = objectb at output_match[i]
- objecta at message_match[index+i] = objectb at message_match[i]
- objecta at error[index+i] = objectb at error[i]
- objecta at passed[index+i] = objectb at passed[i]
- }
-
- objecta
-}
-
-rktest.file <- function (id, extension) {
- file.path(getwd(), paste (id, extension, sep=""))
-}
-
-# returns true, if file corresponds to standard.
-rktest.compare.against.standard <- function (file) {
- standard_file <- paste (file, ".standard", sep="")
- if (!file.exists (file)) {
- # if neither exists, that means both files are empty
- if (!file.exists (standard_file)) return (TRUE)
- }
-
- output.diff <- system(paste("diff", shQuote(file), shQuote(standard_file), "2>&1"), intern=TRUE)
- if (!length (output.diff)) return (TRUE)
- if ((length (output.diff) == 1) && (!nzchar (output.diff))) return (TRUE)
-
- print (paste ("Differences between", file, "and", standard_file, ":"))
- print (output.diff)
- return (FALSE)
-}
-
-rktest.runRKTest.internal <- function (test, output_file, code_file, message_file) {
- # save / restore old output file
- old_output <- rk.get.output.html.file ()
- rk.set.output.html.file (output_file)
- on.exit (rk.set.output.html.file (old_output), add=TRUE)
-
- message_file_handle <- file (message_file, open="w+")
- sink(message_file_handle, type="message")
- on.exit ({
- sink (NULL, type="message")
- close (message_file_handle)
- }, add=TRUE)
-
- rk.record.commands (code_file)
- on.exit (rk.record.commands (NULL), add=TRUE)
-
- old.symbols <- ls (envir=globalenv (), all.names=TRUE)
- on.exit ({
- # clean up any new objects created by the test
- new.symbols <- ls (envir=globalenv (), all.names=TRUE)
- new.symbols <- new.symbols[!(new.symbols %in% old.symbols)]
- rm (list=new.symbols, envir=globalenv ())
- rk.sync.global ()
- }, add=TRUE)
-
- failed <- TRUE
- try ({
- test at call ()
- failed <- FALSE
- })
-
- return (failed)
-}
-
-rktest.runRKTest <- function (test) {
- result <- new ("RKTestResult") # FALSE by default
-
- if (!inherits (test, "RKTest")) return (result)
- result at id <- test at id
- if (!validObject (test)) return (result)
-
- output_file <- rktest.file (test at id, ".rkout")
- code_file <- rktest.file (test at id, ".rkcom")
- message_file <- rktest.file (test at id, ".rkwarn")
-
- # the essence of the test:
- result at error <- rktest.runRKTest.internal (test, output_file, code_file, message_file)
-
- result at output_match = rktest.compare.against.standard (output_file)
- result at message_match = rktest.compare.against.standard (message_file)
- result at code_match = rktest.compare.against.standard (code_file)
-
- if ((result at error == test at expect_error) && (result at output_match || test at fuzzy_output) && result at code_match && result at message_match) result at passed = TRUE
-
- result
-}
-
-rktest.cleanRKTestSuite <- function (suite, basedir=getwd ()) {
- oldwd = getwd ()
- on.exit (setwd (oldwd))
- setwd (paste (basedir, suite at id, sep="/"))
-
- files <- list.files ()
- # do not delete the standards!
- files <- grep (".*\\.standard$", files, value=TRUE, invert=TRUE)
-
- file.remove (files)
-
- invisible (NULL)
-}
-
-rktest.runRKTestSuite <- function (suite, basedir=getwd ()) {
- result <- new ("RKTestResult") # FALSE by default
-
- if (!inherits (suite, "RKTestSuite")) return (result)
- if (!validObject (suite)) return (result)
-
- # clean any old results
- rktest.cleanRKTestSuite (suite, basedir)
-
- oldwd = getwd ()
- on.exit (setwd (oldwd))
- setwd (paste (basedir, suite at id, sep="/"))
-
- if (length (suite at initCalls) > 0) {
- for (i in 1:length (suite at initCalls)) try (suite at initCalls[[i]]())
- }
-
- for (i in 1:length (suite at tests)) {
- try (res <- rktest.runRKTest(suite at tests[[i]]))
- result <- rktest.appendTestResults (result, res)
- }
-
- if (length (suite at postCalls) > 0) {
- for (i in 1:length (suite at postCalls)) try (suite at postCalls[[i]]())
- }
-
- result
-}
-
-rktest.setSuiteStandards <- function (suite, basedir=getwd ()) {
- if (!inherits (suite, "RKTestSuite")) return (result)
- if (!validObject (suite)) return (result)
-
- ok <- readline ("You are about to set new standards for this suite. This means you are certain that ALL tests in this suite have produced the expected/correct result on the last run. If you are absolutely sure, enter \"I am sure\" to proceed.");
- if (ok != "I am sure") stop ("Aborted")
-
- oldwd = getwd ()
- on.exit (setwd (oldwd))
- setwd (paste (basedir, suite at id, sep="/"))
-
- files <- list.files ()
- files <- grep (".*\\.(rkwarn|rkcom|rkout)$", files, value=TRUE)
- file.copy (files, paste (files, ".standard", sep=""), overwrite=TRUE)
-
- # clean anything that is *not* a standard file
- rktest.cleanRKTestSuite (suite, basedir)
-}
-
-# You can use this to temporarily replace .rk.rerun.plugin.link.
-# This way, after running a plugin, you are shown the call needed to run this
-# plugin with those settings, instead of the link.
-.rk.rerun.plugin.link.replacement <- function (plugin, settings, label) {
- .rk.cat.output ("<h3>Rerun code:</h3>")
- .rk.cat.output ("<pre>")
- .rk.cat.output ("rk.call.plugin (\"")
- .rk.cat.output (plugin)
- .rk.cat.output ("\", ")
- .rk.cat.output (gsub ("^\"", "", gsub ("=", "=\"", gsub ("\n", "\", ", settings))))
- .rk.cat.output ("\", submit.mode=\"submit\")</pre>")
-}
-
-# HACK: Override date, so we don't get a difference for each call of rk.header ()
-# TODO: implement a clean solution inside rk.header()
-date <- function () {
- return ("DATE")
-}
Copied: trunk/rkward/tests/test_framework.R (from rev 2548, trunk/rkward/tests/test.R)
===================================================================
--- trunk/rkward/tests/test_framework.R (rev 0)
+++ trunk/rkward/tests/test_framework.R 2009-06-24 20:37:50 UTC (rev 2549)
@@ -0,0 +1,224 @@
+setClass ("RKTestSuite",
+ representation (id="character", initCalls="list", tests="list", postCalls="list"),
+ prototype(character(0), id=NULL, initCalls=list(), tests=list(), postCalls=list ()),
+ validity=function (object) {
+ if (length (object at id) != 1) return (FALSE)
+ if (length (object at tests) < 1) return (FALSE)
+ return (TRUE)
+ }
+ )
+
+setClass ("RKTest",
+ representation (id="character", call="function", fuzzy_output="logical", expect_error="logical"),
+ prototype(character(0), id=NULL, call=function () { stop () }, fuzzy_output=FALSE, expect_error=FALSE),
+ validity=function (object) {
+ if (is.null (object at id)) return (FALSE)
+ return (TRUE)
+ }
+ )
+
+setClass ("RKTestResult",
+ representation (id = "character", code_match = "logical", output_match = "logical", message_match = "logical", error="logical", passed="logical"),
+ prototype(character(0), id = character (0), code_match = NA, output_match = NA, message_match = NA, error = NA, passed=FALSE),
+ validity=function (object) {
+ return (all.equal (length (object at id), length (object at code_match), length (object at output_match), length (object at message_match), length (object at error), length (object at passed)))
+ }
+ )
+
+setMethod ("show", "RKTestResult", function (object) {
+ stopifnot (inherits (object, "RKTestResult"))
+
+ cat (format ("ID", width=20))
+ cat (format ("code match", width=15))
+ cat (format ("output match", width=15))
+ cat (format ("message match", width=15))
+ cat (format ("error", width=15))
+ cat (format ("result", width=15))
+ cat ("\n")
+
+ for (i in 1:length (object at id)) {
+ cat (format (object at id[i], width=20))
+ cat (format (if (object at code_match[i]) "true" else "FALSE", width=15))
+ cat (format (if (object at output_match[i]) "true" else "FALSE", width=15))
+ cat (format (if (object at message_match[i]) "true" else "FALSE", width=15))
+ cat (format (if (object at error[i]) "TRUE" else "false", width=15))
+ cat (format (if (object at passed[i]) "pass" else "FAIL", width=15))
+ cat ("\n")
+ }
+})
+
+rktest.appendTestResults <- function (objecta, objectb) {
+ stopifnot (inherits (objecta, "RKTestResult") && validObject (objecta))
+ stopifnot (inherits (objectb, "RKTestResult") && validObject (objectb))
+
+ index <- length (objecta at id)
+ for (i in 1:length (objectb at id)) {
+ objecta at id[index+i] = objectb at id[i]
+ objecta at code_match[index+i] = objectb at code_match[i]
+ objecta at output_match[index+i] = objectb at output_match[i]
+ objecta at message_match[index+i] = objectb at message_match[i]
+ objecta at error[index+i] = objectb at error[i]
+ objecta at passed[index+i] = objectb at passed[i]
+ }
+
+ objecta
+}
+
+rktest.file <- function (id, extension) {
+ file.path(getwd(), paste (id, extension, sep=""))
+}
+
+# returns true, if file corresponds to standard.
+rktest.compare.against.standard <- function (file) {
+ standard_file <- paste (file, ".standard", sep="")
+ if (!file.exists (file)) {
+ # if neither exists, that means both files are empty
+ if (!file.exists (standard_file)) return (TRUE)
+ }
+
+ output.diff <- system(paste("diff", shQuote(file), shQuote(standard_file), "2>&1"), intern=TRUE)
+ if (!length (output.diff)) return (TRUE)
+ if ((length (output.diff) == 1) && (!nzchar (output.diff))) return (TRUE)
+
+ print (paste ("Differences between", file, "and", standard_file, ":"))
+ print (output.diff)
+ return (FALSE)
+}
+
+rktest.runRKTest.internal <- function (test, output_file, code_file, message_file) {
+ # save / restore old output file
+ old_output <- rk.get.output.html.file ()
+ rk.set.output.html.file (output_file)
+ on.exit (rk.set.output.html.file (old_output), add=TRUE)
+
+ message_file_handle <- file (message_file, open="w+")
+ sink(message_file_handle, type="message")
+ on.exit ({
+ sink (NULL, type="message")
+ close (message_file_handle)
+ }, add=TRUE)
+
+ rk.record.commands (code_file)
+ on.exit (rk.record.commands (NULL), add=TRUE)
+
+ old.symbols <- ls (envir=globalenv (), all.names=TRUE)
+ on.exit ({
+ # clean up any new objects created by the test
+ new.symbols <- ls (envir=globalenv (), all.names=TRUE)
+ new.symbols <- new.symbols[!(new.symbols %in% old.symbols)]
+ rm (list=new.symbols, envir=globalenv ())
+ rk.sync.global ()
+ }, add=TRUE)
+
+ failed <- TRUE
+ try ({
+ test at call ()
+ failed <- FALSE
+ })
+
+ return (failed)
+}
+
+rktest.runRKTest <- function (test) {
+ result <- new ("RKTestResult") # FALSE by default
+
+ if (!inherits (test, "RKTest")) return (result)
+ result at id <- test at id
+ if (!validObject (test)) return (result)
+
+ output_file <- rktest.file (test at id, ".rkout")
+ code_file <- rktest.file (test at id, ".rkcom")
+ message_file <- rktest.file (test at id, ".rkwarn")
+
+ # the essence of the test:
+ result at error <- rktest.runRKTest.internal (test, output_file, code_file, message_file)
+
+ result at output_match = rktest.compare.against.standard (output_file)
+ result at message_match = rktest.compare.against.standard (message_file)
+ result at code_match = rktest.compare.against.standard (code_file)
+
+ if ((result at error == test at expect_error) && (result at output_match || test at fuzzy_output) && result at code_match && result at message_match) result at passed = TRUE
+
+ result
+}
+
+rktest.cleanRKTestSuite <- function (suite, basedir=getwd ()) {
+ oldwd = getwd ()
+ on.exit (setwd (oldwd))
+ setwd (paste (basedir, suite at id, sep="/"))
+
+ files <- list.files ()
+ # do not delete the standards!
+ files <- grep (".*\\.standard$", files, value=TRUE, invert=TRUE)
+
+ file.remove (files)
+
+ invisible (NULL)
+}
+
+rktest.runRKTestSuite <- function (suite, basedir=getwd ()) {
+ result <- new ("RKTestResult") # FALSE by default
+
+ if (!inherits (suite, "RKTestSuite")) return (result)
+ if (!validObject (suite)) return (result)
+
+ # clean any old results
+ rktest.cleanRKTestSuite (suite, basedir)
+
+ oldwd = getwd ()
+ on.exit (setwd (oldwd))
+ setwd (paste (basedir, suite at id, sep="/"))
+
+ if (length (suite at initCalls) > 0) {
+ for (i in 1:length (suite at initCalls)) try (suite at initCalls[[i]]())
+ }
+
+ for (i in 1:length (suite at tests)) {
+ try (res <- rktest.runRKTest(suite at tests[[i]]))
+ result <- rktest.appendTestResults (result, res)
+ }
+
+ if (length (suite at postCalls) > 0) {
+ for (i in 1:length (suite at postCalls)) try (suite at postCalls[[i]]())
+ }
+
+ result
+}
+
+rktest.setSuiteStandards <- function (suite, basedir=getwd ()) {
+ if (!inherits (suite, "RKTestSuite")) return (result)
+ if (!validObject (suite)) return (result)
+
+ ok <- readline ("You are about to set new standards for this suite. This means you are certain that ALL tests in this suite have produced the expected/correct result on the last run. If you are absolutely sure, enter \"I am sure\" to proceed.");
+ if (ok != "I am sure") stop ("Aborted")
+
+ oldwd = getwd ()
+ on.exit (setwd (oldwd))
+ setwd (paste (basedir, suite at id, sep="/"))
+
+ files <- list.files ()
+ files <- grep (".*\\.(rkwarn|rkcom|rkout)$", files, value=TRUE)
+ file.copy (files, paste (files, ".standard", sep=""), overwrite=TRUE)
+
+ # clean anything that is *not* a standard file
+ rktest.cleanRKTestSuite (suite, basedir)
+}
+
+# You can use this to temporarily replace .rk.rerun.plugin.link.
+# This way, after running a plugin, you are shown the call needed to run this
+# plugin with those settings, instead of the link.
+.rk.rerun.plugin.link.replacement <- function (plugin, settings, label) {
+ .rk.cat.output ("<h3>Rerun code:</h3>")
+ .rk.cat.output ("<pre>")
+ .rk.cat.output ("rk.call.plugin (\"")
+ .rk.cat.output (plugin)
+ .rk.cat.output ("\", ")
+ .rk.cat.output (gsub ("^\"", "", gsub ("=", "=\"", gsub ("\n", "\", ", settings))))
+ .rk.cat.output ("\", submit.mode=\"submit\")</pre>")
+}
+
+# HACK: Override date, so we don't get a difference for each call of rk.header ()
+# TODO: implement a clean solution inside rk.header()
+date <- function () {
+ return ("DATE")
+}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
More information about the rkward-tracker
mailing list