[Sciviews-commits] r394 - in pkg/svUnit: R inst/unitTests inst/unitTests/VirtualClass man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Sep 19 10:15:56 CEST 2011
Author: mariotomo
Date: 2011-09-19 10:15:56 +0200 (Mon, 19 Sep 2011)
New Revision: 394
Added:
pkg/svUnit/R/runExamples.R
Modified:
pkg/svUnit/R/Log.R
pkg/svUnit/R/check.R
pkg/svUnit/R/guiTestReport.R
pkg/svUnit/R/koUnit.R
pkg/svUnit/R/svSuite.R
pkg/svUnit/R/svSuiteData.R
pkg/svUnit/R/svTest.R
pkg/svUnit/R/svTestData.R
pkg/svUnit/R/svUnit-internal.R
pkg/svUnit/inst/unitTests/VirtualClass/runitVirtualClass.R
pkg/svUnit/inst/unitTests/runitsvSuite.R
pkg/svUnit/inst/unitTests/runitsvTest.R
pkg/svUnit/man/Log.Rd
pkg/svUnit/man/check.Rd
pkg/svUnit/man/guiTestReport.Rd
pkg/svUnit/man/koUnit.Rd
pkg/svUnit/man/svSuite.Rd
pkg/svUnit/man/svSuiteData.Rd
pkg/svUnit/man/svTest.Rd
pkg/svUnit/man/svTestData.Rd
pkg/svUnit/man/svUnit-package.Rd
pkg/svUnit/man/unitTests.svUnit.Rd
Log:
ticket:1575
Modified: pkg/svUnit/R/Log.R
===================================================================
--- pkg/svUnit/R/Log.R 2011-09-03 13:58:30 UTC (rev 393)
+++ pkg/svUnit/R/Log.R 2011-09-19 08:15:56 UTC (rev 394)
@@ -1,74 +1,74 @@
-Log <- function (description = NULL)
-{
- if (!exists(".Log", envir = .GlobalEnv, inherits = FALSE))
- createLog(description = description)
- return(get(".Log", envir = .GlobalEnv, inherits = FALSE))
-}
-
-createLog <- function (description = NULL, deleteExisting = FALSE)
-{
- ## Create a log consisting in an environment with class svSuiteData
- if (isTRUE(deleteExisting) && exists(".Log", envir = .GlobalEnv,
- inherits = FALSE)) rm(.Log, envir = .GlobalEnv)
- if (!exists(".Log", envir = .GlobalEnv, inherits = FALSE)) {
- .Log <<- structure(new.env(parent = .GlobalEnv),
- class = c("svSuiteData", "environment"))
- ## Add general informations and variables to it
- .Log$.time <- Sys.time() # Creation time of the log
- .Log$.R.version <- R.version # R version
- .Log$.sessionInfo <- sessionInfo() # Information about current session
- .Log$.description <- description # Optional description of this log
- ## Create ..xxx variables used for test context
- ## Note: never delete or put NULL in these variables, use "" instead
- .Log$..Unit <- ""
- .Log$..Msg <- ""
- .Log$..Obj <- ""
- .Log$..File <- ""
- .Log$..Tag <- ""
- ## Create .lastTest that contains details from last check...()
- naChr <- as.character(NA)
- .Log$.lastTest <- structure(
- data.frame(msg = naChr, call = naChr,
- timing = as.numeric(NA), kind = .kind(NA), res = naChr,
- obj = naChr, file = naChr, tag = naChr,
- stringsAsFactors = FALSE),
- class = c("svTestData", "data.frame"))
- ## Create .lastSuite with an empty list of test units to run
- .Log$.lastSuite <- list()
- }
-}
-
-clearLog <- function ()
-{
- if (exists(".Log", envir = .GlobalEnv, inherits = FALSE)) {
- rm(list = ".Log", envir = .GlobalEnv)
- return(invisible(TRUE))
- } else return(invisible(FALSE))
-}
-
-errorLog <- function (stopit = TRUE, summarize = TRUE)
-{
- .Log <- Log()
- Res <- table(stats(.Log)$kind)
- if (isTRUE(stopit) && any(Res[2:3] > 0)) {
- if (isTRUE(summarize)) summary(.Log)
- msg <- paste(Res[2], "failure(s) and", Res[3], "error(s)")
- stop(msg)
- } else if (interactive()) {
- cat("Summary statistics on all tests run:\n")
- print(Res)
- }
- return(invisible(Res))
-}
-
-lastTest <- function ()
-{
- ## Return a svTestData object with data from last recorded test
- Log()$.lastTest
-}
-
-lastSuite <- function ()
-{
- ## Return data about last suite run
- Log()$.lastSuite
-}
+Log <- function (description = NULL)
+{
+ if (!exists(".Log", envir = .GlobalEnv, inherits = FALSE))
+ createLog(description = description)
+ return(get(".Log", envir = .GlobalEnv, inherits = FALSE))
+}
+
+createLog <- function (description = NULL, deleteExisting = FALSE)
+{
+ ## Create a log consisting in an environment with class svSuiteData
+ if (isTRUE(deleteExisting) && exists(".Log", envir = .GlobalEnv,
+ inherits = FALSE)) rm(.Log, envir = .GlobalEnv)
+ if (!exists(".Log", envir = .GlobalEnv, inherits = FALSE)) {
+ .Log <<- structure(new.env(parent = .GlobalEnv),
+ class = c("svSuiteData", "environment"))
+ ## Add general informations and variables to it
+ .Log$.time <- Sys.time() # Creation time of the log
+ .Log$.R.version <- R.version # R version
+ .Log$.sessionInfo <- sessionInfo() # Information about current session
+ .Log$.description <- description # Optional description of this log
+ ## Create ..xxx variables used for test context
+ ## Note: never delete or put NULL in these variables, use "" instead
+ .Log$..Unit <- ""
+ .Log$..Msg <- ""
+ .Log$..Obj <- ""
+ .Log$..File <- ""
+ .Log$..Tag <- ""
+ ## Create .lastTest that contains details from last check...()
+ naChr <- as.character(NA)
+ .Log$.lastTest <- structure(
+ data.frame(msg = naChr, call = naChr,
+ timing = as.numeric(NA), kind = .kind(NA), res = naChr,
+ obj = naChr, file = naChr, tag = naChr,
+ stringsAsFactors = FALSE),
+ class = c("svTestData", "data.frame"))
+ ## Create .lastSuite with an empty list of test units to run
+ .Log$.lastSuite <- list()
+ }
+}
+
+clearLog <- function ()
+{
+ if (exists(".Log", envir = .GlobalEnv, inherits = FALSE)) {
+ rm(list = ".Log", envir = .GlobalEnv)
+ return(invisible(TRUE))
+ } else return(invisible(FALSE))
+}
+
+errorLog <- function (stopit = TRUE, summarize = TRUE)
+{
+ .Log <- Log()
+ Res <- table(stats(.Log)$kind)
+ if (isTRUE(stopit) && any(Res[2:3] > 0)) {
+ if (isTRUE(summarize)) summary(.Log)
+ msg <- paste(Res[2], "failure(s) and", Res[3], "error(s)")
+ stop(msg)
+ } else if (interactive()) {
+ cat("Summary statistics on all tests run:\n")
+ print(Res)
+ }
+ return(invisible(Res))
+}
+
+lastTest <- function ()
+{
+ ## Return a svTestData object with data from last recorded test
+ Log()$.lastTest
+}
+
+lastSuite <- function ()
+{
+ ## Return data about last suite run
+ Log()$.lastSuite
+}
Property changes on: pkg/svUnit/R/Log.R
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: pkg/svUnit/R/check.R
===================================================================
--- pkg/svUnit/R/check.R 2011-09-03 13:58:30 UTC (rev 393)
+++ pkg/svUnit/R/check.R 2011-09-19 08:15:56 UTC (rev 394)
@@ -1,184 +1,184 @@
-## Define check...() functions in a way they are compatible with same functions
-## in the 'RUnit' package (these functions are directly inspired from those
-## in RUnit). Make version that are more compatible with Komodo/SciViews-K Unit)
-
-checkEquals <- function (target, current, msg = "",
-tolerance = .Machine$double.eps^0.5, checkNames = TRUE, ...)
-{
- val <- FALSE
- timing <- as.numeric(system.time({
- ret <- try({
- ## Run the test
- if (isTRUE(checkNames)) {
- cn <- "" # Since this is the default value
- } else {
- cn <- ", checkNames = FALSE"
- names(target) <- NULL
- names(current) <- NULL
- }
- if (!is.numeric(tolerance))
- stop("tolerance has to be a numeric value")
- if (length(tolerance) != 1)
- stop("tolerance has to be a scalar")
- res <- all.equal(target, current, tolerance = tolerance, ...)
- val <- isTRUE(res)
- }, silent = TRUE)
- }, gcFirst = FALSE)[3])
- ## Log this test
- test <- .logTest(timing)
- ## Decide if recording more info or not
- minTiming <- getOption("svUnit.minTiming")
- if (is.null(minTiming)) minTiming <- 0.1
- if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
- && val) return(invisible(TRUE))
- ## Check for error
- if (inherits(ret, "try-error")) {
- val <- NA
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:3], nlines = 1), timing = timing, val = -1,
- res = as.character(ret))
- } else {
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:3], nlines = 1), timing = timing, val = val,
- res = if (val) "" else paste(c(res, .formatResult(current)),
- collapse = "\n"))
- }
- return(invisible(val))
-}
-
-checkEqualsNumeric <- function (target, current, msg = "",
-tolerance = .Machine$double.eps^0.5, ...)
-{
- val <- FALSE
- timing <- as.numeric(system.time({
- ret <- try({
- ## Run the test
- if (!is.numeric(tolerance))
- stop("tolerance has to be a numeric value")
- if (length(tolerance) != 1)
- stop("tolerance has to be a scalar")
- res <- all.equal.numeric(as.vector(target), as.vector(current),
- tolerance = tolerance, ...)
- val <- isTRUE(res)
- }, silent = TRUE)
- }, gcFirst = FALSE)[3])
- ## Log this test
- test <- .logTest(timing)
- ## Decide if recording more info or not
- minTiming <- getOption("svUnit.minTiming")
- if (is.null(minTiming)) minTiming <- 0.1
- if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
- && val) return(invisible(TRUE))
- ## Check for error
- if (inherits(ret, "try-error")) {
- val <- NA
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:3], nlines = 1), timing = timing, val = -1,
- res = as.character(ret))
- } else {
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:3], nlines = 1), timing = timing, val = val,
- res = if (val) "" else paste(c(res, .formatResult(current)),
- collapse = "\n"))
- }
- return(invisible(val))
-}
-
-checkIdentical <- function (target, current, msg = "")
-{
- val <- FALSE
- timing <- as.numeric(system.time({
- ret <- try({
- ## Run the test
- val <- identical(target, current)
- }, silent = TRUE)
- }, gcFirst = FALSE)[3])
- ## Log this test
- test <- .logTest(timing)
- ## Decide if recording more info or not
- minTiming <- getOption("svUnit.minTiming")
- if (is.null(minTiming)) minTiming <- 0.1
- if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
- && val) return(invisible(TRUE))
- ## Check for error
- if (inherits(ret, "try-error")) {
- val <- NA
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:3], nlines = 1), timing = timing, val = -1,
- res = as.character(ret))
- } else {
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:3], nlines = 1), timing = timing, val = val,
- res = .formatResult(current))
- }
- return(invisible(val))
-}
-
-checkTrue <- function (expr, msg = "")
-{
- val <- FALSE
- timing <- as.numeric(system.time({
- ret <- try({
- ## Run the test
- val <- isTRUE(all(expr == TRUE))
- }, silent = TRUE)
- }, gcFirst = FALSE)[3])
- ## Log this test
- test <- .logTest(timing)
- ## Decide if recording more info or not
- minTiming <- getOption("svUnit.minTiming")
- if (is.null(minTiming)) minTiming <- 0.1
- if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
- && val) return(invisible(TRUE))
- ## Get call, without msg
- call <- sys.call()
- call <- deparse(call[names(call) != "msg"])
- ## Check for error
- if (inherits(ret, "try-error")) {
- val <- NA
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:2], nlines = 1), timing = timing, val = -1,
- res = as.character(ret))
- } else {
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:2], nlines = 1), timing = timing, val = val,
- res = .formatResult(expr))
- }
- return(invisible(val))
-}
-
-checkException <- function (expr, msg = "",
-silent = getOption("svUnit.silentException"))
-{
- val <- FALSE
- timing <- as.numeric(system.time({
- ret <- try({
- ## Run the test
- silent <- (is.null(silent) || isTRUE(silent))
- val <- inherits(res <- try(expr, silent = silent), "try-error")
- }, silent = TRUE)
- }, gcFirst = FALSE)[3])
- ## Log this test
- test <- .logTest(timing)
- ## Decide if recording more info or not
- minTiming <- getOption("svUnit.minTiming")
- if (is.null(minTiming)) minTiming <- 0.1
- if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
- && val) return(invisible(TRUE))
- ## Check for error
- if (inherits(ret, "try-error")) {
- val <- NA
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:2], nlines = 1), timing = timing, val = -1,
- res = as.character(ret))
- } else {
- .logTestData(test, msg = msg, call =
- deparse(sys.call()[1:2], nlines = 1), timing = timing, val = val,
- res = if (val) paste(res, collapse = "\n") else
- "No exception generated!\n")
- }
- return(invisible(val))
-}
-
-DEACTIVATED <- function (msg = "")
- stop(msg)
+## Define check...() functions in a way they are compatible with same functions
+## in the 'RUnit' package (these functions are directly inspired from those
+## in RUnit). Make version that are more compatible with Komodo/SciViews-K Unit)
+
+checkEquals <- function (target, current, msg = "",
+tolerance = .Machine$double.eps^0.5, checkNames = TRUE, ...)
+{
+ val <- FALSE
+ timing <- as.numeric(system.time({
+ ret <- try({
+ ## Run the test
+ if (isTRUE(checkNames)) {
+ cn <- "" # Since this is the default value
+ } else {
+ cn <- ", checkNames = FALSE"
+ names(target) <- NULL
+ names(current) <- NULL
+ }
+ if (!is.numeric(tolerance))
+ stop("tolerance has to be a numeric value")
+ if (length(tolerance) != 1)
+ stop("tolerance has to be a scalar")
+ res <- all.equal(target, current, tolerance = tolerance, ...)
+ val <- isTRUE(res)
+ }, silent = TRUE)
+ }, gcFirst = FALSE)[3])
+ ## Log this test
+ test <- .logTest(timing)
+ ## Decide if recording more info or not
+ minTiming <- getOption("svUnit.minTiming")
+ if (is.null(minTiming)) minTiming <- 0.1
+ if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
+ && val) return(invisible(TRUE))
+ ## Check for error
+ if (inherits(ret, "try-error")) {
+ val <- NA
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:3], nlines = 1), timing = timing, val = -1,
+ res = as.character(ret))
+ } else {
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:3], nlines = 1), timing = timing, val = val,
+ res = if (val) "" else paste(c(res, .formatResult(current)),
+ collapse = "\n"))
+ }
+ return(invisible(val))
+}
+
+checkEqualsNumeric <- function (target, current, msg = "",
+tolerance = .Machine$double.eps^0.5, ...)
+{
+ val <- FALSE
+ timing <- as.numeric(system.time({
+ ret <- try({
+ ## Run the test
+ if (!is.numeric(tolerance))
+ stop("tolerance has to be a numeric value")
+ if (length(tolerance) != 1)
+ stop("tolerance has to be a scalar")
+ res <- all.equal.numeric(as.vector(target), as.vector(current),
+ tolerance = tolerance, ...)
+ val <- isTRUE(res)
+ }, silent = TRUE)
+ }, gcFirst = FALSE)[3])
+ ## Log this test
+ test <- .logTest(timing)
+ ## Decide if recording more info or not
+ minTiming <- getOption("svUnit.minTiming")
+ if (is.null(minTiming)) minTiming <- 0.1
+ if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
+ && val) return(invisible(TRUE))
+ ## Check for error
+ if (inherits(ret, "try-error")) {
+ val <- NA
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:3], nlines = 1), timing = timing, val = -1,
+ res = as.character(ret))
+ } else {
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:3], nlines = 1), timing = timing, val = val,
+ res = if (val) "" else paste(c(res, .formatResult(current)),
+ collapse = "\n"))
+ }
+ return(invisible(val))
+}
+
+checkIdentical <- function (target, current, msg = "")
+{
+ val <- FALSE
+ timing <- as.numeric(system.time({
+ ret <- try({
+ ## Run the test
+ val <- identical(target, current)
+ }, silent = TRUE)
+ }, gcFirst = FALSE)[3])
+ ## Log this test
+ test <- .logTest(timing)
+ ## Decide if recording more info or not
+ minTiming <- getOption("svUnit.minTiming")
+ if (is.null(minTiming)) minTiming <- 0.1
+ if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
+ && val) return(invisible(TRUE))
+ ## Check for error
+ if (inherits(ret, "try-error")) {
+ val <- NA
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:3], nlines = 1), timing = timing, val = -1,
+ res = as.character(ret))
+ } else {
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:3], nlines = 1), timing = timing, val = val,
+ res = .formatResult(current))
+ }
+ return(invisible(val))
+}
+
+checkTrue <- function (expr, msg = "")
+{
+ val <- FALSE
+ timing <- as.numeric(system.time({
+ ret <- try({
+ ## Run the test
+ val <- isTRUE(all(expr == TRUE))
+ }, silent = TRUE)
+ }, gcFirst = FALSE)[3])
+ ## Log this test
+ test <- .logTest(timing)
+ ## Decide if recording more info or not
+ minTiming <- getOption("svUnit.minTiming")
+ if (is.null(minTiming)) minTiming <- 0.1
+ if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
+ && val) return(invisible(TRUE))
+ ## Get call, without msg
+ call <- sys.call()
+ call <- deparse(call[names(call) != "msg"])
+ ## Check for error
+ if (inherits(ret, "try-error")) {
+ val <- NA
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:2], nlines = 1), timing = timing, val = -1,
+ res = as.character(ret))
+ } else {
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:2], nlines = 1), timing = timing, val = val,
+ res = .formatResult(expr))
+ }
+ return(invisible(val))
+}
+
+checkException <- function (expr, msg = "",
+silent = getOption("svUnit.silentException"))
+{
+ val <- FALSE
+ timing <- as.numeric(system.time({
+ ret <- try({
+ ## Run the test
+ silent <- (is.null(silent) || isTRUE(silent))
+ val <- inherits(res <- try(expr, silent = silent), "try-error")
+ }, silent = TRUE)
+ }, gcFirst = FALSE)[3])
+ ## Log this test
+ test <- .logTest(timing)
+ ## Decide if recording more info or not
+ minTiming <- getOption("svUnit.minTiming")
+ if (is.null(minTiming)) minTiming <- 0.1
+ if (!isTRUE(getOption("svUnit.recordAll")) && isTRUE(timing < minTiming)
+ && val) return(invisible(TRUE))
+ ## Check for error
+ if (inherits(ret, "try-error")) {
+ val <- NA
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:2], nlines = 1), timing = timing, val = -1,
+ res = as.character(ret))
+ } else {
+ .logTestData(test, msg = msg, call =
+ deparse(sys.call()[1:2], nlines = 1), timing = timing, val = val,
+ res = if (val) paste(res, collapse = "\n") else
+ "No exception generated!\n")
+ }
+ return(invisible(val))
+}
+
+DEACTIVATED <- function (msg = "")
+ stop(msg)
Property changes on: pkg/svUnit/R/check.R
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: pkg/svUnit/R/guiTestReport.R
===================================================================
--- pkg/svUnit/R/guiTestReport.R 2011-09-03 13:58:30 UTC (rev 393)
+++ pkg/svUnit/R/guiTestReport.R 2011-09-19 08:15:56 UTC (rev 394)
@@ -1,137 +1,137 @@
-guiSuiteList <- function (sep = "\t", path = NULL, compare = TRUE)
-{
- Suites <- svSuiteList()
- if (compare) {
- oldSuites <- .getTemp(".guiSuiteListCache", default = "")
- ## Compare both versions
- if (!identical(Suites, oldSuites)) {
- ## Keep a copy of the last version in TempEnv
- .assignTemp(".guiSuiteListCache", Suites)
- Changed <- TRUE
- } else Changed <- FALSE
- } else {
- Changed <- TRUE
- .assignTemp(".guiSuiteListCache", Suites)
- }
- if (is.null(path)) { # Return result, as a single character string with sep
- if (Changed) {
- if (!is.null(sep)) Suites <- paste(Suites, collapse = sep)
- return(Suites)
- } else return(NULL)
- } else { # Write to a file called 'Suites.txt' in this path
- file <- file.path(path, "Suites.txt")
- if (Changed) {
- if (is.null(sep)) sep <- "\n"
- cat(Suites, sep = sep, file = file)
- }
- return(invisible(Changed))
- }
-}
-
-guiSuiteAutoList <- function (...)
-{
- ## Is koCmd() available?
- if (!exists("koCmd", mode = "function")) return(TRUE)
- ## Is it something changed in the unit list?
- res <- guiSuiteList(sep = ",", path = NULL, compare = TRUE)
- if (!is.null(res))
- ret <- get("koCmd")('sv.r.unit.getRUnitList_Callback("<<<data>>>");',
- data = res)
- return(TRUE)
-}
-
-guiTestFeedback <- function (object, path = NULL, ...)
-{
- ## Give feedback to client about the currently running tests
- ## TODO: feedback about test run
-}
-
-guiTestReport <- function (object, sep = "\t", path = NULL, ...)
-{
- ## Report the results of a test to the GUI client
- if (!is.svSuiteData(object))
- stop("'object' must be a 'svSuiteData' object")
-
- ## For all 'svTestData' objects, create a table with test results for the GUI
- ## Indicate global results of the Unit Test
- Tests <- ls(object)
- if (length(Tests) == 0) {
- Res <- "<<<svUnitSummary>>>|||0|||0|||0|||0"
- } else {
- ## Get general information about the tests
- Stats <- stats(object)
- Tests <- rownames(Stats) # To make sure we use the same!
- Stats$label <- paste(">", sub("^test", "", Tests), " (",
- round(Stats$timing, 3), " sec)", sep = "")
- State <- table(Stats$kind)
- Res <- paste("<<<svUnitSummary>>>|||", State[1], "|||", State[2],
- "|||", State[3], "|||", State[4], sep = "")
- Kinds <- as.numeric(Stats$kind)
- Kinds[Kinds == 4] <- 0 # Use 0 instead of 4 for deactivated tests
- Stats$kind <- Kinds
- ## Get the type for the objects
- Units <- Stats$unit
- Types <- rep("units in packages", length(Units))
- Types[Units == ""] <- "other objects"
- ## TODO: include also dirs!
- Dir1 <- gsub("\\\\", "/", dirname(Units))
- Dir2 <- dirname(Dir1)
- Dir3 <- dirname(Dir2)
- TempDir <- gsub("\\\\", "/", tempdir())
- Types[Dir1 == TempDir] <- "objects in .GlobalEnv"
- Types[tolower(basename(Dir2)) == "inst" ||
- tolower(basename(Dir3)) == "inst"] <- "units in sources"
- ## Keep only "*" in Units
- Units <- basename(Units)
- Units[regexpr("^runit.+\\.[rR]$", Units) == -1] <- ""
- Units[Dir1 == TempDir] <- "" # No second level for objects in .GlobalEnv
- Units <- sub("^runit(.+)\\.[rR]$", "\\1", Units)
- change <- Units != ""
- Units[change] <- paste(">unit", Units[change])
- ## Complete label is Type<Unit<Test (x.xxx sec)
- Stats$label <- paste(Types, Units, Stats$label, sep = "")
- ## Sort Tests and Stats according to label alphabetically
- ord <- order(Stats$label)
- Stats <- Stats[ord, ]
- Tests <- Tests[ord]
- ## Get detailed information about each test
- lastUnit <- ""
- for (Test in Tests) {
- Data <- Stats[Test, ]
- ## Calculate Info
- tData <- Log()[[Test]]
- tStats <- stats(tData)
- Info <- paste(c("Pass:", "Fail:", "Errors:"), tStats$kind[1:3],
- collapse = " ")
- ## Don't print tests that succeed if !all
- tData <- tData[tData$kind != "OK", ]
- ## Get info about each individual filtered test
- if (nrow(tData) > 0) {
- Result <- ifelse(tData$res == "", "",
- paste("\n", tData$res, sep = ""))
- Info <- paste(Info, "\n", paste("* ", tData$msg, ": ",
- tData$call, .formatTime(tData$timing, secDigits = 3),
- " ... ", as.character(tData$kind), Result, sep = "",
- collapse = "\n"), sep = "")
- }
- ## Calculate URI (currently, the name of the unit file
- ## and the name of the test function)
- if (Data$unit == "") URI <- Data$unit else
- URI <- paste(Data$unit, Test, sep = "#")
- if (Data$unit != lastUnit) {
- lastUnit <- Data$unit
- Res <- c(Res, paste("<<<svUnitFile>>>|||", Data$unit,
- "|||||||||", sep = ""))
- }
- Res <- c(Res, paste("<<<svUnitTest>>>|||", Data$label, "|||",
- Data$kind, "|||", Info, "|||", URI, sep = ""))
- }
- }
- Res <- paste(gsub("\t", " ", Res), collapse = sep)
- if (is.null(path)) {
- return(Res)
- } else {
- cat(Res, file = path)
- }
- return(path)
-}
+guiSuiteList <- function (sep = "\t", path = NULL, compare = TRUE)
+{
+ Suites <- svSuiteList()
+ if (compare) {
+ oldSuites <- .getTemp(".guiSuiteListCache", default = "")
+ ## Compare both versions
+ if (!identical(Suites, oldSuites)) {
+ ## Keep a copy of the last version in TempEnv
+ .assignTemp(".guiSuiteListCache", Suites)
+ Changed <- TRUE
+ } else Changed <- FALSE
+ } else {
+ Changed <- TRUE
+ .assignTemp(".guiSuiteListCache", Suites)
+ }
+ if (is.null(path)) { # Return result, as a single character string with sep
+ if (Changed) {
+ if (!is.null(sep)) Suites <- paste(Suites, collapse = sep)
+ return(Suites)
+ } else return(NULL)
+ } else { # Write to a file called 'Suites.txt' in this path
+ file <- file.path(path, "Suites.txt")
+ if (Changed) {
+ if (is.null(sep)) sep <- "\n"
+ cat(Suites, sep = sep, file = file)
+ }
+ return(invisible(Changed))
+ }
+}
+
+guiSuiteAutoList <- function (...)
+{
+ ## Is koCmd() available?
+ if (!exists("koCmd", mode = "function")) return(TRUE)
+ ## Is it something changed in the unit list?
+ res <- guiSuiteList(sep = ",", path = NULL, compare = TRUE)
+ if (!is.null(res))
+ ret <- get("koCmd")('sv.r.unit.getRUnitList_Callback("<<<data>>>");',
+ data = res)
+ return(TRUE)
+}
+
+guiTestFeedback <- function (object, path = NULL, ...)
+{
+ ## Give feedback to client about the currently running tests
+ ## TODO: feedback about test run
+}
+
+guiTestReport <- function (object, sep = "\t", path = NULL, ...)
+{
+ ## Report the results of a test to the GUI client
+ if (!is.svSuiteData(object))
+ stop("'object' must be a 'svSuiteData' object")
+
+ ## For all 'svTestData' objects, create a table with test results for the GUI
+ ## Indicate global results of the Unit Test
+ Tests <- ls(object)
+ if (length(Tests) == 0) {
+ Res <- "<<<svUnitSummary>>>|||0|||0|||0|||0"
+ } else {
+ ## Get general information about the tests
+ Stats <- stats(object)
+ Tests <- rownames(Stats) # To make sure we use the same!
+ Stats$label <- paste(">", sub("^test", "", Tests), " (",
+ round(Stats$timing, 3), " sec)", sep = "")
+ State <- table(Stats$kind)
+ Res <- paste("<<<svUnitSummary>>>|||", State[1], "|||", State[2],
+ "|||", State[3], "|||", State[4], sep = "")
+ Kinds <- as.numeric(Stats$kind)
+ Kinds[Kinds == 4] <- 0 # Use 0 instead of 4 for deactivated tests
+ Stats$kind <- Kinds
+ ## Get the type for the objects
+ Units <- Stats$unit
+ Types <- rep("units in packages", length(Units))
+ Types[Units == ""] <- "other objects"
+ ## TODO: include also dirs!
+ Dir1 <- gsub("\\\\", "/", dirname(Units))
+ Dir2 <- dirname(Dir1)
+ Dir3 <- dirname(Dir2)
+ TempDir <- gsub("\\\\", "/", tempdir())
+ Types[Dir1 == TempDir] <- "objects in .GlobalEnv"
+ Types[tolower(basename(Dir2)) == "inst" ||
+ tolower(basename(Dir3)) == "inst"] <- "units in sources"
+ ## Keep only "*" in Units
+ Units <- basename(Units)
+ Units[regexpr("^runit.+\\.[rR]$", Units) == -1] <- ""
+ Units[Dir1 == TempDir] <- "" # No second level for objects in .GlobalEnv
+ Units <- sub("^runit(.+)\\.[rR]$", "\\1", Units)
+ change <- Units != ""
+ Units[change] <- paste(">unit", Units[change])
+ ## Complete label is Type<Unit<Test (x.xxx sec)
+ Stats$label <- paste(Types, Units, Stats$label, sep = "")
+ ## Sort Tests and Stats according to label alphabetically
+ ord <- order(Stats$label)
+ Stats <- Stats[ord, ]
+ Tests <- Tests[ord]
+ ## Get detailed information about each test
+ lastUnit <- ""
+ for (Test in Tests) {
+ Data <- Stats[Test, ]
+ ## Calculate Info
+ tData <- Log()[[Test]]
+ tStats <- stats(tData)
+ Info <- paste(c("Pass:", "Fail:", "Errors:"), tStats$kind[1:3],
+ collapse = " ")
+ ## Don't print tests that succeed if !all
+ tData <- tData[tData$kind != "OK", ]
+ ## Get info about each individual filtered test
+ if (nrow(tData) > 0) {
+ Result <- ifelse(tData$res == "", "",
+ paste("\n", tData$res, sep = ""))
+ Info <- paste(Info, "\n", paste("* ", tData$msg, ": ",
+ tData$call, .formatTime(tData$timing, secDigits = 3),
+ " ... ", as.character(tData$kind), Result, sep = "",
+ collapse = "\n"), sep = "")
+ }
+ ## Calculate URI (currently, the name of the unit file
+ ## and the name of the test function)
+ if (Data$unit == "") URI <- Data$unit else
+ URI <- paste(Data$unit, Test, sep = "#")
+ if (Data$unit != lastUnit) {
+ lastUnit <- Data$unit
+ Res <- c(Res, paste("<<<svUnitFile>>>|||", Data$unit,
+ "|||||||||", sep = ""))
+ }
+ Res <- c(Res, paste("<<<svUnitTest>>>|||", Data$label, "|||",
+ Data$kind, "|||", Info, "|||", URI, sep = ""))
+ }
+ }
+ Res <- paste(gsub("\t", " ", Res), collapse = sep)
+ if (is.null(path)) {
+ return(Res)
+ } else {
+ cat(Res, file = path)
+ }
+ return(path)
+}
Property changes on: pkg/svUnit/R/guiTestReport.R
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: pkg/svUnit/R/koUnit.R
===================================================================
--- pkg/svUnit/R/koUnit.R 2011-09-03 13:58:30 UTC (rev 393)
+++ pkg/svUnit/R/koUnit.R 2011-09-19 08:15:56 UTC (rev 394)
@@ -1,41 +1,41 @@
-.koUnit <- function (cmd, warn = FALSE, ...)
-{
- ## Look if koCmd() exists, otherwise, we are probably not connected to Komodo
- if (exists("koCmd", mode = "function")) {
- res <- get("koCmd")(cmd, ...)
- if (isTRUE(warn) & inherits(res, "try-error"))
- warning("Komodo is not available or did not process this command correctly")
- return(res)
- } else {
- if (isTRUE(warn))
- warning("You must establish a connection with Komodo/SciViews-K to use this function")
- }
-}
-
-koUnit_isAutoTest <- function ()
-{
- res <- .koUnit('sv.socket.serverWrite(sv.r.unit.isAutoTest());')
- return(res == "true")
-}
-
-koUnit_setAutoTest <- function (state)
-{
- if (isTRUE(state)) state <- "true" else state <- "false"
- res <- .koUnit('sv.r.unit.setAutoTest(<<<data>>>);', data = state)
-}
-
-koUnit_runTest <- function ()
- res <- .koUnit('sv.r.unit.runTest();')
-
-koUnit_showRUnitPane <- function (state)
-{
- if (missing(state)) state <- ""
- else if (isTRUE(state)) state <- "true" else state <- "false"
- res <- .koUnit('sv.r.unit.showRUnitPane(<<<data>>>);', data = state)
-}
-
-koUnit_version <- function ()
-{
- res <- .koUnit('sv.socket.serverWrite(sv.r.unit.version + "." + sv.r.unit.release);')
- return(res)
-}
+.koUnit <- function (cmd, warn = FALSE, ...)
+{
+ ## Look if koCmd() exists, otherwise, we are probably not connected to Komodo
+ if (exists("koCmd", mode = "function")) {
+ res <- get("koCmd")(cmd, ...)
+ if (isTRUE(warn) & inherits(res, "try-error"))
+ warning("Komodo is not available or did not process this command correctly")
+ return(res)
+ } else {
+ if (isTRUE(warn))
+ warning("You must establish a connection with Komodo/SciViews-K to use this function")
+ }
+}
+
+koUnit_isAutoTest <- function ()
+{
+ res <- .koUnit('sv.socket.serverWrite(sv.r.unit.isAutoTest());')
+ return(res == "true")
+}
+
+koUnit_setAutoTest <- function (state)
+{
+ if (isTRUE(state)) state <- "true" else state <- "false"
+ res <- .koUnit('sv.r.unit.setAutoTest(<<<data>>>);', data = state)
+}
+
+koUnit_runTest <- function ()
+ res <- .koUnit('sv.r.unit.runTest();')
+
+koUnit_showRUnitPane <- function (state)
+{
+ if (missing(state)) state <- ""
+ else if (isTRUE(state)) state <- "true" else state <- "false"
+ res <- .koUnit('sv.r.unit.showRUnitPane(<<<data>>>);', data = state)
+}
+
+koUnit_version <- function ()
+{
+ res <- .koUnit('sv.socket.serverWrite(sv.r.unit.version + "." + sv.r.unit.release);')
+ return(res)
+}
Property changes on: pkg/svUnit/R/koUnit.R
___________________________________________________________________
Added: svn:eol-style
+ native
Added: pkg/svUnit/R/runExamples.R
===================================================================
--- pkg/svUnit/R/runExamples.R (rev 0)
+++ pkg/svUnit/R/runExamples.R 2011-09-19 08:15:56 UTC (rev 394)
@@ -0,0 +1,26 @@
+## This file is part of sciViews.
+##
+## sciViews is free software: you can redistribute it and/or modify
+## it under the terms of the GNU General Public License as published by
+## the Free Software Foundation, either version 3 of the License, or
+## (at your option) any later version.
+##
+## sciViews 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 for more details.
+##
+## You should have received a copy of the GNU General Public License
+## along with sciViews. If not, see <http://www.gnu.org/licenses/>.
+##
+
+makeTestListFromExamples <- function(packageName, manFilesDir) {
+ manPageFiles <- list.files(manFilesDir, pattern="\\.Rd$")
+ manPages <- substr(manPageFiles, 1, nchar(manPageFiles) - 3)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 394
More information about the Sciviews-commits
mailing list