[rkward-cvs] SF.net SVN: rkward:[2540] trunk/rkward

[tfry at users.sourceforge.net]

Revision: 2540
          http://rkward.svn.sourceforge.net/rkward/?rev=2540&view=rev
Author:   tfry
Date:     2009-06-21 21:24:19 +0000 (Sun, 21 Jun 2009)

Log Message:
-----------
Add an initial (not quite complete) version of the testing framework

Added Paths:
-----------
    trunk/rkward/tests/
    trunk/rkward/tests/test.R

Added: trunk/rkward/tests/test.R
===================================================================
--- trunk/rkward/tests/test.R	                        (rev 0)
+++ trunk/rkward/tests/test.R	2009-06-21 21:24:19 UTC (rev 2540)
@@ -0,0 +1,191 @@
+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", compare_code="logical", compare_output="logical", fuzzy_output="logical", expect_error="logical"),
+		prototype(character(0), id=NULL, call=function () { stop () }, compare_code=TRUE, compare_output=TRUE, fuzzy_output=FALSE, expect_error=FALSE),
+		validity=function (object) {
+			if (is.null (object at id)) return (FALSE)
+			return (TRUE)
+		}
+	)
+
+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 (as.character (object at code_match[i]), width=15))
+		cat (format (as.character (object at output_match[i]), width=15))
+		cat (format (as.character (object at message_match[i]), width=15))
+		cat (format (as.character (object at error[i]), width=15))
+		cat (format (if (object at passed[i]) "PASS" else "FAIL", width=15))
+		cat ("\n")
+	}
+})
+
+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)))
+		}
+	)
+
+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)
+	return (!nzchar (output.diff))
+}
+
+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)
+
+	# save / restore old output file
+	old_output <- rk.get.output.html.file ()
+	rk.set.output.html.file (rk.testrun.file (test at id, ".rkout"))
+	on.exit (rk.set.output.html.file (old_output), add=TRUE)
+
+	message_file <- rktest.file (test at id, ".rkwarn")
+	#sink(message_file, type="message")
+	#on.exit (sink (NULL, type="message"))
+
+	#code_file <- rk.testrun.file (test at id, ".rkcom")
+	#rk.record.user.commands (code_file)
+	#on.exit (rk.record.user.commands (NULL))
+
+	result at error <- TRUE
+	try ({
+		test at call ()
+		result at error <- FALSE
+	})
+
+	result at output_match = rktest.compare.against.standard (rk.get.output.html.file ())
+	result at message_match = rktest.compare.against.standard (message_file)
+	#result at code_match = rktest.compare.against.standard (code_file)
+	result at code_match = TRUE		# TODO: only for now!
+
+	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.runRKTestSuite <- function (suite, basedir=getwd ()) {
+	result <- new ("RKTestResult")		# FALSE by default
+
+	if (!inherits (suite, "RKTestSuite")) return (result)
+	if (!validObject (suite)) return (result)
+
+	system (paste ("tar -xf", suite at id, ".tar", sep=""))
+	oldwd = getwd ()
+	on.exit (setwd (oldwd))
+
+	# clean any old files
+	setwd (paste (basedir, suite at id, sep="/"))
+	system ("find . -name '*.standard' -o -exec rm {} \\;")#
+
+	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.packageSuiteStandards <- function (suite, basedir=getwd ()) {
+	if (!inherits (suite, "RKTestSuite")) return (result)
+	if (!validObject (suite)) return (result)
+
+	oldwd = getwd ()
+	on.exit (setwd (oldwd))
+
+	# create package
+	setwd (basedir)
+	system (paste ("tar -cf ", suite at id, ".tar ", suite at id, sep=""))
+}
+
+rktest.setSuiteStandards <- function (suite, basedir=getwd ()) {
+	if (!inherits (suite, "RKTestSuite")) return (result)
+	if (!validObject (suite)) return (result)
+
+	oldwd = getwd ()
+	on.exit (setwd (oldwd))
+	setwd (paste (basedir, suite at id, sep="/"))
+
+	system ("find . -name '*.standard' -o -exec cp {} {}.standard \\;")#
+}
+
+x <- new ("RKTest", id="firsttest", call=function () rk.print (1))
+
+suite <- new ("RKTestSuite", id="testsuite",
+	initCalls = list (
+		function () {
+			library ("R2HTML")
+		}
+	), tests = list (
+		new ("RKTest", id="firsttestb", call=function () rk.print (1)),
+		new ("RKTest", id="secondtest", call=function () rk.print (2)),
+		x
+	), postCalls = list ()
+)
+
+y <- rktest.runRKTestSuite (suite)
+
+y


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.