Nothing
R/RTestCase.R
In RTest: A XML-Based Testing Framework for Automated Component Tests of R Packages
Defines functions
RTestCase
Documented in
RTestCase
###################################################################################################
# RTest #
###################################################################################################
# #
# Class Definition of 'RTestCase' #
# #
# Date: 25 - Jan - 2016 #
# Author: Matthias Pfeifer (matthias.pfeifer@roche.com) #
# #
###################################################################################################
#' The 'RTestCase' Class
#'
#' Objects of the \code{RTestCase} class specify and implement the general behavoir of the
#' XML-based test cases (TC).
#'
#' On basis of Based on a XML definition file (see \code{'RTestCase.xsd'}), test cases are defined
#' for the individual packages / projects to be tested. Thereby, this class definition provides
#' the general outline of the individual test case classes (i.e. test case adapters), which have
#' to implement the project- and package-specific requirements and test logic.
#'
#' The slot '\code{tests}' represents the execution environment for a test case and stores all
#' information about the execution including test case metainformation, test result (success or
#' failed), the testthat reporter and the test cache. It has the following format:\cr
#' \code{XML: tests:}\cr
#' \code{tests}\cr
#' \code{ |- Pkg_1 [Pkg_1][1]}\cr
#' \code{ | - funct_01 [Pkg_1][1][funct_01][1] = list( ... )}\cr
#' \code{ |- Pkg_1 [Pkg_1][2]}\cr
#' \code{ | |- funct_01 [Pkg_1][2][funct_01][1] = list( ... )}\cr
#' \code{ | |- funct_01 [Pkg_1][2][funct_01][2] = list( ... )}\cr
#' \code{ | - funct_02 [Pkg_1][2][funct_02][1] = list( ... )}\cr
#' \code{ - Pkg_2 [Pkg_2][1]}\cr
#' \code{ - funct_01 [Pkg_2][1][funct_01][1] = list( ... )}\cr
#'
#' @slot ID (\code{character}) ID of the TC.
#' @slot tc.type (\code{character}) Type of the TC (i.e. the class name).
#' @slot synopsis (\code{list}) Synopsis information of the TC (as defined in the XSD
#' ComplexType 'RTestSynopis').
#' @slot xml.fPath (\code{character}) Path to XML definition file of the TC.
#' @slot xml.root (\code{XMLNode}) The imported TC definition as \code{XMLNode}-class
#' object.
#' @slot input.data (\code{list}) The input data of the test case, which will be filled
#' using the method \code{\link{readXMLInputData}}.
#' @slot tests (\code{list}) A list with the test results or NULL, if the test case
#' has not been executed (see 'Details').
#' @slot test.for (\code{character}) Names of the packages, which were tested in the last
#' execution of the test case. NULL, if the test case has not been
#' executed.
#' @slot test.result (\code{character}) Result of the last test case execution ('SUCCESS' or
#' 'FAILURE'). NULL, if the test case has not been executed.
#'
#' @author Matthias Pfeifer \email{matthiaspfeifer@@gmx.net}
setClass(
Class = "RTestCase",
representation = representation(
ID = "character",
tc.type = "character",
synopsis = "list",
xml.fPath = "character",
xml.root = "XMLNode",
input.data = "ANY",
tests = "environment",
test.for = "ANY",
test.result = "ANY"
),
prototype = list(
test.for = NULL,
test.result = NULL)
)
#' Constructor for RTestCase
#' @param ID (\code{character}) ID of the TC.
#' @param tc.type (\code{character}) Type of the TC (i.e. the class name).
#' @param synopsis (\code{list}) Synopsis information of the TC (as defined in the XSD
#' ComplexType 'RTestSynopis').
#' @param xml.fPath (\code{character}) Path to XML definition file of the TC.
#' @param xml.root (\code{XMLNode}) The imported TC definition as \code{XMLNode}-class
#' object.
#' @param input.data (\code{list}) The input data of the test case, which will be filled
#' using the method \code{\link{readXMLInputData}}.
#' @param tests (\code{list}) A list with the test results or NULL, if the test case
#' has not been executed (see 'Details').
#' @param test.for (\code{character}) Names of the packages, which were tested in the last
#' execution of the test case. NULL, if the test case has not been
#' executed.
#' @param test.result (\code{character}) Result of the last test case execution ('SUCCESS' or
#' 'FAILURE'). NULL, if the test case has not been executed.
#' @return (.Object) \link{RTestCase-class} Object
#'
#' @export
#'
#' @examples
#' library(RTest)
#'
#' xml.root <- XML::newXMLNode("func01")
#' RTest::xmlFromList(xml.root,
#' list(
#' params=list(mult=list(attributes=c(value="1",type="numeric"))),
#' testspec=list(
#' execution=list(attributes=c("execution-type"="silent")),
#' "return-value"=list(attributes=c(
#' "compare-type"="equal",
#' "diff-type"="absolute",
#' "tolerance"=0.001
#' ))
#' )
#' )
#' )
#' # Add the reference result to the params and testspec and read it in again
#' xml.root <- XML::xmlRoot(XML::xmlTreeParse(
#' paste0("<root>",
#' capture_output(print(xml.root[[1]])),
#' capture_output(print(xml.root[[2]])),
#' paste(xmlWriteData_data.frame(
#' "reference",
#' data=data.frame(x=c(1,1),y=c(2,2),sum=c(3,3)),
#' printXML=FALSE)
#' ,collapse="\n"),"</root>")
#' ))
#'
#' # Define what to test in the first test
#' # Please check the function test.RTest.funct_01 to see
#' # how it tests the code of the function ("test_fun")
#' tests <- new.env()
#' testEntry <- list(
#' "pkg" = "RTest", # test description
#' "pgk-iter" = "1",
#' "func" = "funct_01",
#' "func-iter" = "1",
#' "test-code" = "RTest::test_fun",
#' "test-adapter" = "RTestCase",
#' "test-func" = "test.RTest.funct_01",
#' "pkg-desc" = "no package desc",
#' "func-desc" = "Simple add func",
#' "xpath" = "/root",
#' "reporter" = NA, # field for testthat reporter
#' "result" = NA, # field for test result (failed/success)
#' "cache" = NA, # field for caching test results
#' "execresid" = NA, # field for test execution result id
#' "specid" = "0", # field for test function id
#' "riskid" = "0" # field for test function risk id
#' )
#'
#' # Assign test entry to test environment
#' # pkg-name pkg-iter func-name func-iter
#' tests[["RTest"]][["1"]][["funct_01"]][["1"]] <- testEntry
#'
#' # Create a TestCase Object
#' object <- RTestCase(
#' ID="1",
#' tc.type="RTestCase",
#' synopsis= list(version="v1",author="Sebastian Wolf"),
#' xml.fPath="",
#' xml.root=xml.root,
#' input.data=list("one"=
#' data.frame(x=c(1,1),y=c(2,2))
#' ),
#' tests=tests,
#' test.for="RTest",
#' test.result=NA
#' )
#'
#' # Run the test
#' object <- test(object,test.for="RTest")
#' stopifnot(object@@test.result=="success")
#'
#' # Run a failing test
#'
#' object@@input.data <- list("one"=
#' data.frame(x=c(1,2),y=c(2,1))
#' )
#' object <- test(object,test.for="RTest")
#' stopifnot(object@@test.result=="failed")
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
RTestCase <- function(
ID = NULL,
tc.type = NULL,
synopsis = NULL,
xml.fPath = NULL,
xml.root = NULL,
input.data = NULL,
tests = NULL,
test.for = NULL,
test.result = NULL
){
if(missing(xml.fPath) || xml.fPath==""){
#stop("Argument 'xml.fPath' missing.")
new("RTestCase",
ID = ID,
tc.type = tc.type ,
synopsis = synopsis,
xml.fPath = xml.fPath,
xml.root = xml.root,
input.data = input.data,
tests = tests,
test.for = test.for,
test.result = test.result
)
}else{
if(!file.exists(xml.fPath))
stop("Input file '",xml.fPath,"' not exists.")
# Open and read xml ---------------------------------------------------------------------------
#xml.doc <- xmlTreeParse(xml.fPath, getDTD = F)
xml.doc <- xmlTreeParse(xml.fPath, getDTD = F,
handlers = list("comment"=function(x,...){NULL}), asTree = TRUE)
xml.root <- xmlRoot(xml.doc)
# Initialize slots ----------------------------------------------------------------------------
# XML information - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
xml.fPath <- xml.fPath
xml.root <- xml.root
# TC information (synopsis) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ID <- xmlValue(xml.root[["ID"]])
tc.type <- xmlName(xml.root)
synopsis <- list(
"version" = xmlValue(xml.root[["synopsis"]][["version"]]),
"author" =
paste(
sapply(
xmlElementsByTagName(xml.root[["synopsis"]], "author"),
function(e) xmlValue(e)
), collapse = ", "),
"short-description" =
if(!is.null(xml.root[["synopsis"]][["short-description"]])){
xmlValue(xml.root[["synopsis"]][["short-description"]])
}else{
""
},
"description" =
if(!is.null(xml.root[["synopsis"]][["description"]])){
xmlValue(xml.root[["synopsis"]][["description"]])
}
else{
""
} ,
"label" =
if(!is.null(xml.root[["synopsis"]][["label"]])) {
xmlValue(xml.root[["synopsis"]][["label"]])
}
else{""},
"creation-date" =
if(!is.null(xml.root[["synopsis"]][["creation-date"]])) {
xmlValue(xml.root[["synopsis"]][["creation-date"]])
}else{""},
"change-history" =
if(!is.null(xml.root[["synopsis"]][["change-history"]])){
lapply(
xmlElementsByTagName(xml.root[["synopsis"]][["change-history"]], "change"),
function(e)
c(
author = xmlAttrs(e)[["author"]],
date = xmlAttrs(e)[["date"]],
change = xmlValue(e)
)
)
}else{
list()
}
)
# Set Input data
.Object <- new("RTestCase",
ID = ID,
tc.type = tc.type ,
synopsis = synopsis,
xml.fPath = xml.fPath,
xml.root = xml.root,
input.data = data.frame(),
tests = new.env(),
test.for = NA,
test.result = NA
)
# TC execution details and test results - - - - - - - - - - - - - - - - - - - - - - - - - - - -
.Object@input.data <- readXMLInputData(.Object)
.Object <- initializeTests(.Object)
# Return initialized object -------------------------------------------------------------------
return(.Object)
}
}
# initializeTests #################################################################################
setGeneric("initializeTests",
function(object) standardGeneric("initializeTests"))
#' Initialize the Test Slot for a Test Case.
#'
#' This method initializes the slots '\code{tests}', '\code{test.for}' and '\code{test.result}' of
#' a object of class '\code{RTestCase}'. See description of \code{\link{RTestCase-class}} for
#' further information.
#'@name initializeTests
#' @aliases initializeTests,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("initializeTests",
signature = "RTestCase",
definition = function (object) {
# Create a new empty environment for the results ----------------------------------------------
tests <- new.env()
# Create and initialize test structure --------------------------------------------------------
# Run through all tests and create the execution structure (see class documentation for
# detailed structure)
xmlApply(
object@xml.root[["tests"]],
function(xmlPkgItem) {
# Get infos about current package test definition - - - - - - - - - - - - - - - - - - - - -
# Name of test package
tf.pkg <- xmlName(xmlPkgItem)
# First iteration: Initialize empty list for package test
if(is.null(tests[[tf.pkg]]))
tests[[tf.pkg]] <<- list()
# Increase counter (no. of package tests defined in XML)
tf.pkg.i <- length(tests[[tf.pkg]]) + 1
# Get description (if specified in XML)
tf.pkg.testDesc <-
if(!is.null(xmlAttrs(xmlPkgItem)[["test-desc"]])) xmlAttrs(xmlPkgItem)[["test-desc"]]
else ""
# Get test functions of this package test - - - - - - - - - - - - - - - - - - - - - - - - -
# Initialize list for function tests
tests[[tf.pkg]][[tf.pkg.i]] <<- list()
# Get test functions of this package test
xmlApply(
xmlPkgItem,
function(xmlFuncItem) {
# Name of test function
tf.func <- xmlName(xmlFuncItem)
# First iteration: Initialize empty list for function test
if(is.null(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]]))
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]] <<- list()
# Increase counter (no. of function tests defined in XML)
tf.func.i <- length(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]]) + 1
# Get description (if specified)
tf.func.testDesc <-
if("test-desc" %in% names(xmlAttrs(xmlFuncItem)))
xmlAttrs(xmlFuncItem)[["test-desc"]]
else
""
# Get specid (if specified)
tf.func.specid <-
if("spec-id" %in% names(xmlAttrs(xmlFuncItem)))
xmlAttrs(xmlFuncItem)[["spec-id"]]
else
""
# Get riskid (if specified)
tf.func.riskid <-
if("risk-id" %in% names(xmlAttrs(xmlFuncItem)))
xmlAttrs(xmlFuncItem)[["risk-id"]]
else
""
# Initialize test entry
testEntry <- list(
"pkg" = tf.pkg, # test description
"pgk-iter" = tf.pkg.i,
"func" = tf.func,
"func-iter" = tf.func.i,
"test-code" = paste0(tf.pkg,"::",tf.func),
"test-adapter" = xmlName(object@xml.root),
"test-func" = paste0("test.",tf.pkg,".",tf.func),
"pkg-desc" = tf.pkg.testDesc,
"func-desc" = tf.func.testDesc,
"xpath" =
paste("/",
xmlName(object@xml.root),
"tests",
paste0(tf.pkg,"[",tf.pkg.i,"]"),
paste0(tf.func,"[",tf.func.i,"]"), sep = "/"),
"reporter" = NA, # field for testthat reporter
"result" = NA, # field for test result (failed/success)
"cache" = NA, # field for caching test results
"execresid" = NA, # field for test execution result id
"specid" = tf.func.specid, # field for test function id
"riskid" = tf.func.riskid # field for test function risk id
)
# Assign test entry to test environment
# pkg-name pkg-iter func-name func-iter
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]] <<- testEntry
})
})
# Set slots -----------------------------------------------------------------------------------
# Slot 'test'
object@tests <- tests
# Slot reset 'test.for' and 'test.status' (status: not executed)
object@test.for <- NA
object@test.result <- NA
# Return object -------------------------------------------------------------------------------
return(object)
}
)
# show ############################################################################################
#' Print Summary of the Test Case to Console
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @aliases show,RTestCase-method
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("show",
signature = "RTestCase",
definition = function (object) {
cat("Test Case\n")
cat(" Object of class '",class(object),"'\n")
cat(" @ID : ",object@ID,"\n")
cat(" @tc.type : ",object@tc.type,"\n")
cat(" @synopsis :\n")
for(i in names(object@synopsis)) {
if(i != "change-history") {
cat(" ",paste0("$",i),": ",object@synopsis[[i]],"\n")
} else {
cat(" $change-history :\n")
for(c in object@synopsis[[i]]) {
cat(" ",c["date"],", ",c["author"],":\n")
cat(" ",c["change"],"\n")
}
}
}
cat("\n")
cat(" @xml.fPath : ",object@xml.fPath,"\n")
cat(" @xml.root : ",class(object@xml.root)[1],"\n")
cat("\n")
cat(" @input.data : \n")
print(ls.str(object@input.data), max.level = 1)
cat("\n")
cat(" @test.for : ",
(if(!is.null(object@test.for)) object@test.for else "NULL (test not executed)"),"\n")
cat(" @test.result : ",
(if(!is.null(object@test.result)) object@test.result else "NULL (test not executed)"),"\n")
cat("\n")
cat(" @tests :\n")
print(ls.str(object@tests), max.level=4)
cat("\n")
}
)
# getID ###########################################################################################
setGeneric("getID",
function(object) standardGeneric("getID"))
#' Get ID of the Test Case
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @name getID
#' @aliases getID,RTestCase-method
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getID",
signature = "RTestCase",
definition = function (object) {
object@ID
}
)
# getType #########################################################################################
setGeneric("getType",
function(object) standardGeneric("getType"))
#' Get Type of the Test Case
#'
#' @name getType
#' @aliases getType,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getType",
signature = "RTestCase",
definition = function (object) {
object@tc.type
}
)
# getSynopsis #####################################################################################
setGeneric("getSynopsis",
function(object) standardGeneric("getSynopsis"))
#' Get Synopsis of the Test Case
#'
#' @name getSynopsis
#' @aliases getSynopsis,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getSynopsis",
signature = "RTestCase",
definition = function (object) {
object@synopsis
}
)
# getXMLSourcePath ################################################################################
setGeneric("getXMLSourcePath",
function(object) standardGeneric("getXMLSourcePath"))
#' Get Path to the XML Input File of the Test Case
#' @name getXMLSourcePath
#' @aliases getXMLSourcePath,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getXMLSourcePath",
signature = "RTestCase",
definition = function (object) {
object@xml.fPath
}
)
# getXMLSourceFileName ############################################################################
setGeneric("getXMLSourceFileName",
function(object) standardGeneric("getXMLSourceFileName"))
#' Get File Name of the XML Input File of the Test Case
#'
#' @name getXMLSourceFileName
#' @aliases getXMLSourceFileName,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getXMLSourceFileName",
signature = "RTestCase",
definition = function (object) {
s <- strsplit(object@xml.fPath, "/")[[1]]
return(s[length(s)])
}
)
# getXMLRoot ######################################################################################
setGeneric("getXMLRoot",
function(object) standardGeneric("getXMLRoot"))
#' Get the XML Root of the Test Case
#'
#' @name getXMLRoot
#' @aliases getXMLRoot,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{XMLNode})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getXMLRoot",
signature = "RTestCase",
definition = function (object) {
object@xml.root
}
)
# getTestFor ######################################################################################
setGeneric("getTestFor",
function(object) standardGeneric("getTestFor"))
#' Get For of Last Execution of the Test Case
#'
#' @name getTestFor
#' @aliases getTestFor,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{ANY})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getTestFor",
signature = "RTestCase",
definition = function (object) {
object@test.for
}
)
# getTestResult ###################################################################################
setGeneric("getTestResult",
function(object) standardGeneric("getTestResult"))
#' Get Result of Last Execution of the Test Case
#'
#' @name getTestResult
#' @aliases getTestResult,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{ANY})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getTestResult",
signature = "RTestCase",
definition = function (object) {
object@test.result
}
)
# clearTest #######################################################################################
setGeneric("clearTest",
function(object) standardGeneric("clearTest"))
#' Clear Test Reporter and Test Cache of Last Test Case Execution
#'
#' This method resets the test information of the current test case including slots
#' \code{'test.for'}, \code{'test.result'} and the cache in the \code{'tests'} test case
#' environment.
#' @name clearTest
#' @aliases clearTest,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{\link{RTestCase-class}})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("clearTest",
signature = "RTestCase",
definition = function (object) {
# Clear global test execution information -----------------------------------------------------
object@test.for <- NA
object@test.result <- NA
# Clear test environment ----------------------------------------------------------------------
tests <- object@tests
for(tf.pkg in ls(tests)) {
# Level 1: packages
for(tf.pkg.i in 1:length(tests[[tf.pkg]])) {
# Level 2: package-iterations
for(tf.func in names(tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
for(tf.func.i in 1:length(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 3: iteration of a function
# Clear test reporter
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["reporter"]] <- NA
# Clear test execution status
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["result"]] <- NA
# Clear test cache
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["cache"]] <- NA
# Clear test exec result id
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["execresid"]]<- NA
}
}
}
}
object@tests <- tests
# Return
return(object)
}
)
# readXMLInputData ################################################################################
setGeneric("readXMLInputData",
function(object) standardGeneric("readXMLInputData"))
#' Read Input Data of Test Case for Default XML Definitions
#'
#' This functions reads the XML definitions for default RTest objects.
#'
#' Input datasets are contained below the XML element '\code{input-data}' and can be used by any
#' test packages and functions of the respective test case adapter (i.e. by the functions of the
#' objects inheriting the class '\code{RTestCase}'). By default major R data types are predefined
#' under the node and can be read by this method. Thereby, the type of the imported datasets is
#' determined by the XML element names. This method runs through all XML items, parses the
#' item and converts it into the respective R object.\cr
#' The following element types are supported:\cr
#' \itemize{
#' \item{variable}{\code{XML: variable, XSD: RTestData_variable, RTest: xmlReadData_variable}}
#' \item{vector}{\code{XML: vector, XSD: RTestData_vector, RTest: xmlReadData_vector}}
#' \item{data.frame}{\code{XML: data.frame, XSD: RTestData_data.frame, RTest: xmlReadData_data.frame}}
#' \item{list}{\code{XML: list, XSD: RTestData_list, RTest: xmlReadData_list}}
#' }
#'
#'
#' @name readXMLInputData
#' @aliases readXMLInputData,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object
#'
#' @return (\code{ANY}) If multiple datasets are defined a \code{list} will be returned
#' containing all datasets with the same order as in the XML file. Else, if only a single
#' is defined, the dataset itself will be returned.
#'
#' @seealso \code{RTestCase-class}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("readXMLInputData",
signature = "RTestCase",
definition = function(object) {
input.data <- xmlRead.default(object@xml.root[["input-data"]])
input.data
}
)
# test ############################################################################################
setGeneric("test",
function(object, test.for = NULL, out.fPathPre = NULL, ...) standardGeneric("test"))
#' Execute Test Logic of the Test Case
#'
#' This method executes the test logic for a test case in a \code{testthat} reporter environment.
#'
#' This method performs the test logic by iterating through all testgroups as defined in the TC XML
#' definition file. For each test group it starts a seperate '\code{ListReporter}', which is
#' defined in the \code{testthat} package. Then, the different functions of a testgroup are
#' executed. Therefore, this function calls the method \code{execTCAdapter}, which needs to be
#' defined for each TestCase type separatly (e.g. for DSTAT, VCA, Calib, etc.). This method is the
#' adapter function and knows how to read the test case and how to execute the functions, which
#' should be tested. Thereby, all test results generated using \code{\link[testthat]{test_that}}
#' and the \code{expect_*} of the \code{testthat} package are recorded by the previously started
#' reporter object. The generated test results are stored (slot \code{test.result}) and the test
#' execution status set (slot \code{test.status}).
#'
#' @name test
#' @aliases test,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#' @param test.for (\code{vector(character)}) Specification for which elements to test,
#' NULL to test for all elements
#' @param out.fPathPre (\code{character}) Prefix incl. path to output files generated during
#' tetest
#' @param ... Additional arguments passed to the check function.
#'
#' @return (\code{\link{RTestCase-class}})
#'
#' @seealso \code{\link{RTestCase-class}}
#' @examples
#'
#' location <- find.package("RTest")
#'
#' TestCase <- RTestCase(xml.fPath =
#' file.path(location,"xml-templates","RTest_TC-01.xml"))
#'
#' result <- test(TestCase)
#'
#' stopifnot(result@@test.result == "success")
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("test",
signature = "RTestCase",
definition = function (object, test.for = NULL, ...) {
RTest.cat("##### TEST CASE '",object@ID,"'\n\n")
# Check test.for argument ---------------------------------------------------------------------
# If NULL, test for all elements specified for this TC
if(is.null(test.for))
test.for <- XML::xmlSApply(object@xml.root[["tests"]], xmlName)
# Use caching for multiple iterations, say, allow to say, which tests to should re-run
# Check, if execution details changed (test.for)
#if(!is.null(object@test.for) && !identical(test.for, object@test.for)) {
# object <- clearTest(object)
#}
# Re-Set cache and of the test environment
object <- clearTest(object)
# Re-Set 'test.for' class slot for current execution
object@test.for <- test.for
# Re-Set 'test.result' class slot for current execution
object@test.result <- NA
RTest.cat("Test for: ",paste(paste0("'",test.for,"'"), collapse=", "),"\n\n")
# Execute tests / call test adapters / set test status ----------------------------------------
# Get test environment - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
tests <- object@tests
# Execute all defined tests - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for(tf.pkg in ls(tests)) {
# Level 1: packages
if(is.element(tf.pkg, test.for)) {
# If the current package should be tested, execute all defined function test
RTest.cat("Run test(s) for '",tf.pkg,"'\n")
for(tf.pkg.i in 1:length(tests[[tf.pkg]])) {
# Level 2: package-iterations
for(tf.func in names(tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
for(tf.func.i in 1:length(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 4: iteration of a function
tf.test <- tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
RTest.cat(" Test '",tf.test[["test-code"]],"' ...")
# Open and start testthat reporter
reporter <- ListReporter$new()
set_reporter(reporter)
reporter$start_reporter()
# Set testthat context
context(tf.test[["test-code"]])
# Execute the wrapper function
tmpExec <- NULL
with_reporter(reporter,
tmpExec <- execAdapter(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i,
out.fPathPre = out.fPathPre, ...)
#tf.test[["cache"]] <- execAdapter(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i)
#execAdapter(object, tf.test[["test-func"]], tf.test[["xpath"]])
)
tf.test[["cache"]] <- tmpExec[["result"]]
tf.test[["execresid"]] <- tmpExec[["execresid"]]
tf.test[["test-func"]] <- tmpExec[["function_name"]]
`%:::%` = function(pkg, fun) get(fun, envir = asNamespace(pkg),
inherits = FALSE)
end_context <- "testthat" %:::% "end_context"
# Close testthat reporter
end_context()
reporter$end_reporter()
# Set test name to reporter
#unlockBinding("test", reporter)
#reporter$test <- paste0(tf.func)
#print(str(ls(reporter)))
# reporter.results <- as.data.frame(reporter$get_results())
# reporter.failed <- length(which(reporter.results$failed > 0))
#
# message("\n----------\n")
# print(str(reporter$results$as_list()))
# message("\n----------\n")
if(length(reporter$results$as_list())>0){
reporter.failed <- sum(sapply(reporter$results$as_list(),
function(repores) length(which(sapply(repores$results,
function(e) !"expectation_success" %in% class(e))))))
}else{
reporter.failed <- 0
}
# stop()
# message("-")
# print(str(reporter$get_results()[[1]][["results"]]))
# message("--")
# print(attributes(reporter$get_results()[[1]][["results"]][[1]]))
# message("---")
# print(reporter$failed)
# #print(reporter$results)
# stop()
# Set test reporter
tf.test[["reporter"]] <- reporter
# Set test result based on reporter status
tf.test[["result"]] <-
#ifelse(length(reporter$results) == 0 || !reporter$failed, "failed", "success")
#ifelse(length(reporter$results) == 0, "failed", ifelse(reporter$failed, "failed", "success"))
ifelse(reporter.failed == 0, "success", "failed")
RTest.cat(" ",tf.test[["result"]],"\n")
# Set global test result for this test case
if(is.na(object@test.result))
# If it has not been set, use current result
object@test.result <- tf.test[["result"]]
else
if(object@test.result != "failed")
# As soon as failed has been set once, never change it again
object@test.result <- tf.test[["result"]]
# Change test entry in object@test slot (i.e. in test environment)
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]] <- tf.test
}
}
}
}
}
RTest.cat("\n")
# Return
return(object)
}
)
# execAdapter #####################################################################################
setGeneric("execAdapter",
function(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i, out.fPathPre = NULL, ...)
standardGeneric("execAdapter"))
#' Execute the Adapter Function of the Test Case
#'
#' This is an abstract method definition and specifies the adapter function of the individual
#' test case adapter, which understand the test case and knows how to execute it. It has to be
#' implemented in the specialized test classes separetly for each test project.
#'
#' @name execAdapter
#' @aliases execAdapter,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object
#' @param tf.pkg (\code{character}) The package name of the currently executed test
#' function.
#' @param tf.pkg.i (\code{integer}) The package iteration number of the currently executed
#' test function.
#' @param tf.func (\code{character}) The function name of the currently executed test
#' function.
#' @param tf.func.i (\code{character}) The function iteration number of the currently
#' executed test function.
#' @param out.fPathPre (\code{character}) Prefix incl. path to output files generated during
#' tests
#' @param ... Additional arguments passed to the check function.
#'
#' @return (\code{ANY}) The cached result of the executed test function.
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("execAdapter",
signature = "RTestCase",
definition = function (object, tf.pkg, tf.pkg.i, tf.func, tf.func.i, out.fPathPre = NULL, ...) {
# Initialize test case execution --------------------------------------------------------------
# Get test environment
tf.test <- object@tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
# Get test function
tf.testFunc <- tf.test[["test-func"]]
# Get XML xpath for current test function
tf.xpath <- tf.test[["xpath"]]
# Get the execution cache
tf.execCache <- execCache(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i)
tf.cacheid <- paste0(tf.pkg,"-",tf.pkg.i,"-",tf.func,"-",tf.func.i)
# Check test function -------------------------------------------------------------------------
use_generic <- FALSE
if(!exists(tf.testFunc)){
message("Using generic test interpreter function")
use_generic <- TRUE
}
# stop("No default test function '",tf.testFunc,"' defined for '",class(object),"'!")
# Get XML definition --------------------------------------------------------------------------
# Use the passed xpath to get XML definition of the test item
# Try to access the XML definition and use the return xml node set
tf.xmlItem <- suppressWarnings(getNodeSet(object@xml.root, path = tf.xpath)[[1]])
# In R-3.4.0 it always produces warnings due to a change in the sturcture functions :(
# Warnings, trough stop message (be very conservative)
# warning = function(w) {
#
# stop("Warning occured during access of XML test element '",tf.xpath,"'.")
# },
# Execute test function -----------------------------------------------------------------------
# Call the test function and pass the TC's input data and current XML function definition
if(use_generic){
tf.testFunc <- "'generic' test function"
tf.result <- do.call("generic",
list(object, object@input.data, tf.execCache, tf.xmlItem, cacheid = tf.cacheid,
paste0(out.fPathPre,"_",tf.cacheid), package = tf.pkg, ...))
}else{
tf.result <- do.call(tf.testFunc,
list(object, object@input.data, tf.execCache, tf.xmlItem, cacheid = tf.cacheid,
paste0(out.fPathPre,"_",tf.cacheid), ...))
}
# Return test function result -----------------------------------------------------------------
# The returned value will be stored in the cache for this execution
tf.return <- list()
tf.return$result <- tf.result
tf.return$execresid <-
if("exec-res-id" %in% names(xmlAttrs(tf.xmlItem))) xmlAttrs(tf.xmlItem)[["exec-res-id"]]
else NA
tf.return$function_name <- tf.testFunc
return(tf.return)
}
)
# execCache #####################################################################################
setGeneric("execCache",
function(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i) standardGeneric("execCache"))
#' Execution Cache for Test Function
#'
#' Creates the execution cache for the the currently executed test function.
#'
#' The execution cache includes all cached results of test functions that are part of the same
#' package iteration and were executed prior to the current test function. The cached results will
#' be stored in as a list() object with the following format:\cr
#' \code{XML: execCache:}\cr
#' \code{<pkg_01>}\cr
#' \code{ <func_01> ... </func_01> $funct_01}\cr
#' \code{ <func_01> ... </func_01> $funct_01[[1]] -> result}\cr
#' \code{ <func_01> ... </func_01> $funct_01[[2]] -> result}\cr
#' \code{ <func_02> ... </func_02> <- current tf -> $funct_02 -> result}\cr
#' \code{ <func_03> ... </func_03> --- not included ---}\cr
#' \code{</pkg_01>}
#' @name execCache
#' @aliases execCache,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object
#' @param tf.pkg (\code{character}) The package name of the currently executed test
#' function.
#' @param tf.pkg.i (\code{integer}) The package iteration number of the currently executed
#' test function.
#' @param tf.func (\code{character}) The function name of the currently executed test
#' function.
#' @param tf.func.i (\code{character}) The function iteration number of the currently
#' executed test function.
#'
#' @return (\code{list})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("execCache",
signature = "RTestCase",
definition = function (object, tf.pkg, tf.pkg.i, tf.func, tf.func.i) {
# Get current test entivornment
tf.tests <- object@tests
# Get index of the current test function
tf.funcIndex <- which(tf.func == names(tf.tests[[tf.pkg]][[tf.pkg.i]]))
if(length(tf.funcIndex)<1){
stop(paste0("no cache created due to unkown '",tf.func,"'"))
}
# Initialize execution cache
tf.execCache <- NULL
# Create execution cache
if(tf.funcIndex == 1 && tf.func.i == 1) {
# If first function and first iteration, initialize empty list
tf.execCache <- list()
} else {
# Else, built a list with the cached results
tf.execCache <- list()
# Get index of the last function to be included in the cache ...
maxFuncUseIndex <- if(tf.func.i == 1) tf.funcIndex - 1 else tf.funcIndex
# ... and the cache of these
for(f in names(tf.tests[[tf.pkg]][[tf.pkg.i]])[1:maxFuncUseIndex]) {
# Get the index of the last function interation to be included ...
maxIterUseIndex <-
if(f == tf.func) tf.func.i-1 else length(tf.tests[[tf.pkg]][[tf.pkg.i]][[f]])
# ... and collect the cache
tf.execCache[[f]] <- list()
for(i in 1:maxIterUseIndex) {
i.index <-
if(is.na(tf.tests[[tf.pkg]][[tf.pkg.i]][[f]][[i]][["execresid"]])) i
else tf.tests[[tf.pkg]][[tf.pkg.i]][[f]][[i]][["execresid"]]
tf.execCache[[f]][[i.index]] <- tf.tests[[tf.pkg]][[tf.pkg.i]][[f]][[i]][["cache"]]
}
# # If only one iteration is used, not return as single list
# if(maxIterUseIndex == 1)
# tf.execCache[[f]] <- tf.execCache[[f]][[1]]
}
}
return(tf.execCache)
})
# getExecSummary ################################################################################
setGeneric("getExecSummary",
function(object) standardGeneric("getExecSummary"))
#' Summary of the Last Execution of the Test Case
#'
#' @name getExecSummary
#' @aliases getExecSummary,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{list})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getExecSummary",
signature = "RTestCase",
definition = function (object) {
if(is.na(object@test.result))
stop("This test case has not been executed!")
print(ls.str(object@tests), max.level=4)
}
)
# getExecSummary.html #############################################################################
setGeneric("getExecSummary.html",
function(object) standardGeneric("getExecSummary.html"))
#' Create HTML Summary of the Last Execution of the Test Case
#'
#' Generates a summary of the last test case execution for the overall test report.
#' @name getExecSummary.html
#' @aliases getExecSummary.html,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getExecSummary.html",
signature = "RTestCase",
definition = function (object) {
if(is.na(object@test.result))
return(c())
#stop("This test case has not been executed!")
out <- c()
out.append <- function(...) { out <<- c(out, paste0(...)) }
tc.tests <- object@tests
tc.status <- if(length(tc.tests) == 0) "NO-TESTS" else toupper(object@test.result)
out.append("<table width=\"100%\" class=\"TCSummary\">")
out.append(" <tr>")
out.append(" <th width=\"100\">TC</th>")
out.append(" <th width=\"70\">Version</th>")
out.append(" <th width=\"100\">Type</th>")
out.append(" <th width=\"100\">Label</th>")
out.append(" <th>Description</th>")
out.append(" <th width=\"150\">No. of Testgroups</th>")
out.append(" <th width=\"250\">Input</th>")
out.append(" <th width=\"150\">Status</th>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td align=\"center\">")
out.append(" <a href=\"#TC-",getID(object),"\">",getID(object),"</a>")
out.append(" </td>")
out.append(" <td align=\"center\">",getSynopsis(object)[["version"]],"</td>")
out.append(" <td align=\"center\">",getType(object),"</td>")
out.append(" <td align=\"center\">",getSynopsis(object)[["label"]],"</td>")
out.append(" <td>",getSynopsis(object)[["short-description"]],"</td>")
out.append(" <td align=\"center\">",length(tc.tests),"</td>")
out.append(" <td align=\"center\">",getXMLSourceFileName(object),"</td>")
out.append(" <td align=\"center\" class=\"",tc.status,"\">",tc.status,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td colspan=\"8\">")
out.append(" <table width=\"100%\" class=\"TCExpecSummary\">")
out.append(" <tr>")
out.append(" <th width=\"100\">Package</th>")
out.append(" <th width=\"40\">#</th>")
out.append(" <th width=\"200\">Description</th>")
out.append(" <th width=\"100\">Function</th>")
out.append(" <th width=\"40\">SpecID</th>")
out.append(" <th width=\"40\">RiskID</th>")
out.append(" <th width=\"40\">#</th>")
out.append(" <th>Description</th>")
out.append(" <th width=\"200\">No. of Tests</th>")
out.append(" <th width=\"150\">Status</th>")
out.append(" </tr>")
#print(object@test.for)
for(tf.pkg in unique(object@test.for)) {
# Level 1: packages (write only those which were tested in the last execution)
for(tf.pkg.i in 1:length(tc.tests[[tf.pkg]])) {
# Level 2: package-iterations
tf.pkg.info <- FALSE
for(tf.func in names(tc.tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
tf.func.info <- FALSE
for(tf.func.i in 1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 4: iteration of a function
tf.test <- tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
tf.tests <- nrow(as.matrix(tf.test$reporter$get_results()))
tf.status <-
if(tf.tests == 0) "NO-TESTS"
else toupper(tf.test$result)
out.append(" <tr>")
if(!tf.pkg.info) {
out.append(" <td>")
out.append(" <a href=\"#TC-",getID(object),"-",tf.pkg,"_",tf.pkg.i,"\">")
out.append(" ",tf.pkg,"")
out.append(" </a>")
out.append(" </td>")
out.append(" <td align=\"center\">",tf.pkg.i,"</td>")
out.append(" <td>",tf.test[["pkg-desc"]],"</td>")
tf.pkg.info <- TRUE
} else {
out.append(" <td colspan=\"3\"></td>")
}
if(!tf.func.info) {
out.append(" <td>")
out.append(" <a href=\"#TC-",getID(object),"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"\">")
out.append(" ",tf.func,"")
out.append(" </a>")
out.append(" </td>")
out.append(" <td align=\"center\">",tf.test[["specid"]],"</td>")
out.append(" <td align=\"center\">",tf.test[["riskid"]],"</td>")
tf.func.info <- TRUE
} else {
out.append(" <td></td>")
out.append(" <td></td>")
out.append(" <td></td>")
}
out.append(" <td align=\"center\">")
out.append(" <a href=\"#TC-",getID(object),"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"_",tf.func.i,"\">")
out.append( tf.func.i)
out.append(" </a>")
out.append(" </td>")
out.append(" <td>",tf.test[["func-desc"]],"</td>")
out.append(" <td align=\"center\">",tf.tests,"</td>")
out.append(" <td align=\"center\" class=\"",tf.status,"\">",tf.status,"</td>")
out.append(" </tr>")
}
}
}
}
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
out.append("</table>")
out.append("</br>")
return(out)
}
)
# execDetails.html ################################################################################
setGeneric("getExecDetails.html",
function(object, report.onlyFailed = FALSE) standardGeneric("getExecDetails.html"))
#' Create Detailed HTML Summary of the Last Execution of the Test Case
#'
#' Generates a detailed summary of the last test case execution for the overall test report
#' including all tested expectations.
#'
#'
#' @name getExecDetails.html
#' @aliases getExecDetails.html,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#' @param report.onlyFailed (\code{logical}) Report only failed exceptions (TRUE) or
#' all exceptions (FALSE, default).
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getExecDetails.html",
signature = "RTestCase",
definition = function (object, report.onlyFailed = FALSE) {
tc.ID <- getID(object)
if(is.null(object@test.result) || is.na(object@test.result))
return(c())
#stop("This test case has not been executed!")
out <- c()
out.append <- function(...) { out <<- c(out, paste0(...)) }
tc.tests <- object@tests
tc.status <- if(length(tc.tests) == 0) "NO-TESTS" else toupper(object@test.result)
out.append("<a name=\"TC-",tc.ID,"\"></a>")
out.append("<h2>",tc.ID,"</h2>")
out.append("")
out.append("<div class=\"abstract\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"50%\" valign=\"top\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Version:</b></td>")
out.append(" <td>",getSynopsis(object)[["version"]],"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Type:</b></td>")
out.append(" <td>",getType(object),"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" <td width=\"50%\" valign=\"top\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Author(s):</b></td>")
out.append(" <td>",getSynopsis(object)[["author"]],"</td>")
out.append(" </tr>")
if(getSynopsis(object)[["creation-date"]] != "") {
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Creation Date:</b></td>")
out.append(" <td>",getSynopsis(object)[["creation-date"]],"</td>")
out.append(" </tr>")
}
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
if(getSynopsis(object)[["label"]] != "") {
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\" valign=\"top\"><b>Label:</b></td>")
out.append(" <td>",getSynopsis(object)[["label"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
}
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\" valign=\"top\"><b>Short Description:</b></td>")
out.append(" <td>",getSynopsis(object)[["short-description"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
if(length(getSynopsis(object)[["description"]]) > 0 && getSynopsis(object)[["description"]] != "") {
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\" valign=\"top\"><b>Description:</b></td>")
out.append(" <td>",getSynopsis(object)[["description"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
}
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Input File:</b></td>")
out.append(" <td>",getXMLSourcePath(object),"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
out.append("</div>")
out.append("<br />")
out.append("")
out.tempfiles <- c()
#for(tf.pkg in object@test.for) {
lapply(unique(object@test.for), function(tf.pkg) {
# Level 1: packages (write only those which were tested in the last execution)
out.append("<a name=\"TC-",tc.ID,"-",tf.pkg,"\"></a>")
out.append("<table width=\"100%\" class=\"TC-Level1\" style=\"margin-bottom: 15px\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level1-left\"></td>")
out.append(" <td class=\"TC-Level1-head\">",tf.pkg,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level1-left\"></td>")
out.append(" <td class=\"TC-Level1-content\">")
#for(tf.pkg.i in 1:length(tc.tests[[tf.pkg]])) {
lapply(1:length(tc.tests[[tf.pkg]]), function(tf.pkg.i) {
# Level 2: package-iterations
out.append(" <table width=\"100%\" class=\"TC-Level2\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level2-left\"></td>")
out.append(" <td class=\"TC-Level2-head\">")
out.append(" <a name=\"TC-",tc.ID,"-",tf.pkg,"_",tf.pkg.i,"\"></a>")
out.append(" ",tf.pkg.i,"")
out.append(" </td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level2-left\"></td>")
out.append(" <td class=\"TC-Level2-content\">")
#for(tf.func in names(tc.tests[[tf.pkg]][[tf.pkg.i]])) {
lapply(names(tc.tests[[tf.pkg]][[tf.pkg.i]]), function(tf.func) {
# Level 3: functions of package
out.append(" <a name=\"TC-",tc.ID,"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"\"></a>")
out.append(" <table width=\"100%\" class=\"TC-Level3\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level3-left\"></td>")
out.append(" <td class=\"TC-Level3-head\">",tf.func,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level3-left\"></td>")
out.append(" <td class=\"TC-Level3-content\">")
#for(tf.func.i in 1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
lapply(1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]]), function(tf.func.i) {
# Level 4: iteration of a function
tf.test <- tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
tf.reporter <- tf.test$reporter$results$as_list()
tf.nTests <- length(tf.reporter)
tf.reporter.results <- as.data.frame(tf.test$reporter$get_results())
tf.nTests <- nrow(tf.reporter.results)
# print(tf.reporter.results)
RTest.cat("Write details for '",tf.pkg,"::",tf.func,"'\n")
if(tf.nTests>0){
tf.exceptions.passed <- sum(sapply(tf.reporter,
function(repores) length(which(sapply(repores$results, function(e) "expectation_success" %in% class(e))))))
tf.expections.failed <- sum(sapply(tf.reporter,
function(repores) length(which(sapply(repores$results, function(e) !"expectation_success" %in% class(e))))))
tf.exceptions <- tf.exceptions.passed + tf.expections.failed
}else{
tf.exceptions <- tf.expections.failed <- tf.exceptions.passed <- 0
}
tf.status <- if(tf.nTests == 0) "NO-TESTS" else toupper(tf.test$result)
tf.desc <- c()
if(tf.test[["pkg-desc"]] != "") tf.desc <- c(tf.desc, tf.test[["pkg-desc"]])
if(tf.test[["func-desc"]] != "") tf.desc <- c(tf.desc, tf.test[["func-desc"]])
tf.desc <- paste(tf.desc, collapse = "; ")
out.append(" <table width=\"100%\" class=\"TC-Level4\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level4-left\"></td>")
out.append(" <td class=\"TC-Level4-head\">")
out.append(" <a name=\"TC-",tc.ID,"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"_",tf.func.i,"\">")
out.append(" #",tf.func.i)
out.append(" </a>")
out.append(" </td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level4-left\"></td>")
out.append(" <td class=\"TC-Level4-content\">")
out.append(" <div class=\"abstract-",tf.status,"\">")
out.append(" <table width=\"100%\" style=\"margin-bottom: 5px;\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Test</b></td>")
out.append(" <td>",tf.test[["test-code"]],"</td>")
out.append(" <td width=\"150\"><b>Description</b></td>")
out.append(" <td>",tf.desc,"</td>")
out.append(" <td width=\"150\" rowspan=\"4\" align=\"center\" valign=\"top\"></td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>RTest Adapter</b></td>")
out.append(" <td>",tf.test[["test-adapter"]],"</td>")
out.append(" <td><b>No. of Tests</b></td>")
out.append(" <td>",tf.nTests,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>RTest Function</b></td>")
out.append(" <td>",tf.test[["test-func"]],"</td>")
out.append(" <td><b>No. of Exceptions</b></td>")
out.append(" <td>",tf.exceptions," (",
tf.expections.failed," failed / ",tf.exceptions.passed," passed)</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>XML Test Definition</b></td>")
out.append(" <td colspan=\"3\">",tf.test[["xpath"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </div>")
if(tf.nTests == 0) {
out.append(" <table width=\"100%\" class=\"TCSummary\">")
out.append(" <tr>")
out.append(" <td align=\"center\">NO TESTS</td>")
out.append(" </tr>")
out.append(" </table>")
} else {
#for(repores.i in 1:length(tf.reporter$results)) {
lapply(1:tf.nTests, function(repores.i) {
repores <- tf.reporter[[repores.i]]
repores.results.length <- length(repores$results)
RTest.cat(" ",repores$test,"\n")
# message("\n* repores\n")
# print(ls(repores))
# message("\n***\n")
repores.status <-
ifelse(length(which(sapply(repores$results, function(e) !"expectation_success" %in% class(e)))) > 0,
"FAILED", "SUCCESS")
out.append(" <table width=\"100%\" class=\"TCSummary\" style=\"margin-bottom: 5px\">")
out.append(" <tr>")
out.append(" <th>Test</th>")
out.append(" <th width=\"150\">No. of Exectations</th>")
out.append(" <th width=\"70\">User</th>")
out.append(" <th width=\"70\">System</th>")
out.append(" <th width=\"70\">Real</th>")
out.append(" <th width=\"150\">Status</th>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>",repores$test,"</b></td>")
out.append(" <td align=\"center\"><b>",repores.results.length,"</b></td>")
out.append(" <td align=\"center\"><b>",round(repores$user, 6),"</b></td>")
out.append(" <td align=\"center\"><b>",round(repores$system, 6),"</b></td>")
out.append(" <td align=\"center\"><b>",round(repores$real, 6),"</b></td>")
out.append(" <td align=\"center\" class=\"",repores.status,"\"><b>",repores.status,"</b></td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td colspan=\"6\">")
expec.info.pre <- c()
infostepsize <- max(250, round(repores.results.length/20))
RTest.cat(" 0% ")
i.expec <- 1
i.expec.written <- 1
lapply(repores$results, function(expec) {
out.test <- ""
if(i.expec %% 50 == 0) {
RTest.cat(".")
}
if(i.expec %% infostepsize == 0) {
gc()
RTest.cat("\n ",round(i.expec/repores.results.length*100),"% ")
}
# message("\n* expec\n")
# print(class(expec))
# print(str(expec))
# message("\n***\n")
expec.status <-
ifelse("expectation_success" %in% class(expec), "SUCCESS", "FAILED")
if(report.onlyFailed == FALSE ||
(report.onlyFailed && expec.status == "FAILED"))
{
expec.msg <- expec$message #ifelse(expec$passed, expec$success_msg, expec$failure_msg)
# message("\n* expec.msg\n")
# print(expec.msg)
# message("\n***\n")
expec.msg.array <- strsplit(expec.msg,"\\n")[[1]]
expec.msg.others <- c()
# message("\n* expec.msg.array\n")
# print(expec.msg.array)
# message("\n***\n")
if(length(expec.msg.array) <= 1) {
expec.msg.main <- expec.msg
expec.msg.info <- c(
"Test" = "Test Expected Behaviour",
"Success" = "expectation_success" %in% class(expec),
"Failure" = !"expectation_success" %in% class(expec))
} else {
expec.msg.main <- expec.msg.array[1]
if(length(expec.msg.array) > 2) {
expec.msg.others <- expec.msg.array[2:(length(expec.msg.array))]
} else {
expec.msg.others <- expec.msg.array[length(expec.msg.array)]
}
`%:::%` = function(pkg, fun) get(fun, envir = asNamespace(pkg),
inherits = FALSE)
fromJSON_string <- "jsonlite" %:::% "fromJSON_string"
if(grepl("\\{.*\\}", expec.msg.array[length(expec.msg.array)])) {
expec.msg.info <- stringr::str_extract(expec.msg.array[length(expec.msg.array)],"\\{.*\\}")
expec.msg.info <- fromJSON_string(expec.msg.info)
expec.msg.others <- expec.msg.others[1:(length(expec.msg.others)-1)]
} else {
expec.msg.info <- c(noinfo="")
}
}
# print(str(expec))
# message("array")
# print(expec.msg.array)
# message("main")
# print(expec.msg.main)
# message("info")
# print(expec.msg.info)
# message("others")
# print(expec.msg.others)
# message("***")
expec.msg.info.names <- names(expec.msg.info)
expec.msg.info.length <- length(expec.msg.info)
if(!identical(expec.info.pre, expec.msg.info.names)) {
if(i.expec.written > 1) {
out.test <- paste0(out.test, " </table>")
}
out.test <- paste0(out.test, " <table width=\"100%\" class=\"TCExpecSummary\">")
out.test <- paste0(out.test, " <tr>")
out.test <- paste0(out.test, " <th width=\"25\">#</th>")
if(expec.msg.info.length > 0 && expec.msg.info.names[1]!="noinfo") {
lapply(1:expec.msg.info.length, function(i.info) {
if(i.info == 1)
out.test <<- paste0(out.test, " <th width=\"200\">",expec.msg.info.names[i.info],"</th>")
else
out.test <<- paste0(out.test, " <th>",expec.msg.info.names[i.info],"</th>")
})
#lapply(expec.msg.info.names, function(info)
# paste0(out.test, " <th>",info,"</th>"))
} else {
out.test <- paste0(out.test, " <th>-</th>")
}
out.test <- paste0(out.test, " <th width=\"250\">Info</th>")
out.test <- paste0(out.test, " <th width=\"150\">Status</th>")
out.test <- paste0(out.test, " </tr>")
expec.info.pre <<- expec.msg.info.names
}
out.test <- paste0(out.test, " <tr>")
out.test <- paste0(out.test, " <td align=\"center\">",i.expec.written,"</td>")
if(expec.msg.info.length > 0 && expec.msg.info.names[1]!="noinfo") {
lapply(expec.msg.info,
function(info)
out.test <<- paste0(out.test, " <td align=\"center\">",info,"</td>"))
} else {
out.test <- paste0(out.test, " <td align=\"center\"></td>")
}
out.test <- paste0(out.test, " <td>")
if(expec.status == "SUCCESS")
out.test <- paste0(out.test, " ")
else
out.test <- paste0(out.test, " ",expec.msg.main)
out.test <- paste0(out.test, " </td>")
out.test <- paste0(out.test, " <td align=\"center\" class=\"",expec.status,"\">")
out.test <- paste0(out.test, " ",expec.status)
out.test <- paste0(out.test, " </td>")
out.test <- paste0(out.test, " </tr>")
if(expec.status == "FAILED" && length(expec.msg.others) > 0) {
out.test <- paste0(out.test, " <tr>")
out.test <- paste0(out.test, " <td></td>")
if(expec.msg.info.length > 0) {
lapply(expec.msg.info,
function(info)
out.test <<- paste0(out.test, " <td></td>"))
} else {
out.test <- paste0(out.test, " <td></td>")
}
out.test <- paste0(out.test, " <td class=\"FAILURE-msg\">")
out.test <- paste0(out.test, " ",paste0(expec.msg.others, collapse="<br/>"))
out.test <- paste0(out.test, " </td>")
out.test <- paste0(out.test, " <td align=\"center\" class=\"",expec.status,"\"></td>")
out.test <- paste0(out.test, " </tr>")
}
out.append(out.test)
i.expec.written <<- i.expec.written + 1
}
i.expec <<- i.expec + 1
})
# End of lapply(repores$results)
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
RTest.cat("\n")
})
}
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" <a href=\"#pagetop\" class=\"backlink\">back to page top</a>")
})
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
})
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
})
out.append(" </td>")
out.append(" </tr>")
out.append("</table>")
})
RTest.cat("\n")
return(out)
}
)
# getRTMInfos ##########################################################################################
setGeneric("getRTMInfos",
function(object, test.for = NULL, cols = c("Version", "Type", "sDesc"))
standardGeneric("getRTMInfos"))
#' Create RTM from executed test cases
#'
#' Creates the requirement traceability matrix for this test case.
#'
#' @name getRTMInfos
#' @aliases getRTMInfos,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#' @param test.for (\code{character}) Vector with package names that should be tested or
#' NULL to get all packages available from the test case.
#' @param cols (\code{character}) Defines which information columns are shown for
#' the TCs in the RTM. The ordering in the vector is also the ordering
#' in the output ('Version','Type','Label','sDesc','lDesc').
#'
#' @return (\code{list}) Listing of test case details (ID, Version, Type, sDesc) and
#' assigned specification IDs (SpecIDs) and risk IDs (RiskIDs).
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getRTMInfos",
signature = "RTestCase",
definition = function (object, test.for = NULL, cols = c("Version", "Type", "sDesc")) {
if(is.null(test.for))
test.for <- ls(object@tests)
tc.tests <- object@tests
tc.status <- if(length(tc.tests) == 0) "NO-TESTS" else toupper(object@test.result)
cols.contents <- list(
Version = getSynopsis(object)[["version"]],
Type = getType(object),
sDesc = getSynopsis(object)[["short-description"]],
lDesc = getSynopsis(object)[["description"]],
Label = getSynopsis(object)[["label"]])
RTM <- list(
ID = getID(object)
)
if(!is.null(cols) && length(cols) > 0) {
for(col in cols) {
RTM[[col]] <- cols.contents[[col]]
}
}
tf.SpecIDs <- tf.RiskIDs <- c()
for(tf.pkg in test.for) {
# Level 1: packages (write only those which were tested in the last execution)
tf.pkg.SpecIDs <- tf.pkg.RiskIDs <- c()
for(tf.pkg.i in 1:length(tc.tests[[tf.pkg]])) {
# Level 2: package-iterations
tf.pkg.info <- FALSE
for(tf.func in names(tc.tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
tf.func.info <- FALSE
for(tf.func.i in 1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 4: iteration of a function
tf.test <- tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
specid <- tf.test[["specid"]]
specid <- unlist(strsplit(specid, ","))
specid <- gsub("\\ ","",specid)
riskid <- tf.test[["riskid"]]
riskid <- unlist(strsplit(riskid, ","))
riskid <- gsub("\\ ","",riskid)
tf.pkg.SpecIDs <- unique(c(tf.pkg.SpecIDs, specid))
tf.pkg.RiskIDs <- unique(c(tf.pkg.RiskIDs, riskid))
}
}
}
tf.pkg.SpecIDs <- paste(tf.pkg.SpecIDs, collapse = ", ")
tf.pkg.RiskIDs <- paste(tf.pkg.RiskIDs, collapse = ", ")
if(length(test.for) > 1) {
tf.SpecIDs <- c(tf.SpecIDs,paste0(tf.pkg,": ",tf.pkg.SpecIDs))
tf.RiskIDs <- c(tf.RiskIDs,paste0(tf.pkg,": ",tf.pkg.RiskIDs))
}else{
tf.SpecIDs <- c(tf.SpecIDs,tf.pkg.SpecIDs)
tf.RiskIDs <- c(tf.RiskIDs,tf.pkg.RiskIDs)
}
}
RTM$SpecIDs <- paste(tf.SpecIDs, collapse = "; ")
RTM$RiskIDs <- paste(tf.RiskIDs, collapse = "; ")
return(RTM)
}
)
Try the RTest package in your browser
Any scripts or data that you put into this service are public.
RTest documentation built on Dec. 4, 2019, 5:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions RTestCase
Documented in RTestCase
###################################################################################################
# RTest #
###################################################################################################
# #
# Class Definition of 'RTestCase' #
# #
# Date: 25 - Jan - 2016 #
# Author: Matthias Pfeifer (matthias.pfeifer@roche.com) #
# #
###################################################################################################
#' The 'RTestCase' Class
#'
#' Objects of the \code{RTestCase} class specify and implement the general behavoir of the
#' XML-based test cases (TC).
#'
#' On basis of Based on a XML definition file (see \code{'RTestCase.xsd'}), test cases are defined
#' for the individual packages / projects to be tested. Thereby, this class definition provides
#' the general outline of the individual test case classes (i.e. test case adapters), which have
#' to implement the project- and package-specific requirements and test logic.
#'
#' The slot '\code{tests}' represents the execution environment for a test case and stores all
#' information about the execution including test case metainformation, test result (success or
#' failed), the testthat reporter and the test cache. It has the following format:\cr
#' \code{XML: tests:}\cr
#' \code{tests}\cr
#' \code{ |- Pkg_1 [Pkg_1][1]}\cr
#' \code{ | - funct_01 [Pkg_1][1][funct_01][1] = list( ... )}\cr
#' \code{ |- Pkg_1 [Pkg_1][2]}\cr
#' \code{ | |- funct_01 [Pkg_1][2][funct_01][1] = list( ... )}\cr
#' \code{ | |- funct_01 [Pkg_1][2][funct_01][2] = list( ... )}\cr
#' \code{ | - funct_02 [Pkg_1][2][funct_02][1] = list( ... )}\cr
#' \code{ - Pkg_2 [Pkg_2][1]}\cr
#' \code{ - funct_01 [Pkg_2][1][funct_01][1] = list( ... )}\cr
#'
#' @slot ID (\code{character}) ID of the TC.
#' @slot tc.type (\code{character}) Type of the TC (i.e. the class name).
#' @slot synopsis (\code{list}) Synopsis information of the TC (as defined in the XSD
#' ComplexType 'RTestSynopis').
#' @slot xml.fPath (\code{character}) Path to XML definition file of the TC.
#' @slot xml.root (\code{XMLNode}) The imported TC definition as \code{XMLNode}-class
#' object.
#' @slot input.data (\code{list}) The input data of the test case, which will be filled
#' using the method \code{\link{readXMLInputData}}.
#' @slot tests (\code{list}) A list with the test results or NULL, if the test case
#' has not been executed (see 'Details').
#' @slot test.for (\code{character}) Names of the packages, which were tested in the last
#' execution of the test case. NULL, if the test case has not been
#' executed.
#' @slot test.result (\code{character}) Result of the last test case execution ('SUCCESS' or
#' 'FAILURE'). NULL, if the test case has not been executed.
#'
#' @author Matthias Pfeifer \email{matthiaspfeifer@@gmx.net}
setClass(
Class = "RTestCase",
representation = representation(
ID = "character",
tc.type = "character",
synopsis = "list",
xml.fPath = "character",
xml.root = "XMLNode",
input.data = "ANY",
tests = "environment",
test.for = "ANY",
test.result = "ANY"
),
prototype = list(
test.for = NULL,
test.result = NULL)
)
#' Constructor for RTestCase
#' @param ID (\code{character}) ID of the TC.
#' @param tc.type (\code{character}) Type of the TC (i.e. the class name).
#' @param synopsis (\code{list}) Synopsis information of the TC (as defined in the XSD
#' ComplexType 'RTestSynopis').
#' @param xml.fPath (\code{character}) Path to XML definition file of the TC.
#' @param xml.root (\code{XMLNode}) The imported TC definition as \code{XMLNode}-class
#' object.
#' @param input.data (\code{list}) The input data of the test case, which will be filled
#' using the method \code{\link{readXMLInputData}}.
#' @param tests (\code{list}) A list with the test results or NULL, if the test case
#' has not been executed (see 'Details').
#' @param test.for (\code{character}) Names of the packages, which were tested in the last
#' execution of the test case. NULL, if the test case has not been
#' executed.
#' @param test.result (\code{character}) Result of the last test case execution ('SUCCESS' or
#' 'FAILURE'). NULL, if the test case has not been executed.
#' @return (.Object) \link{RTestCase-class} Object
#'
#' @export
#'
#' @examples
#' library(RTest)
#'
#' xml.root <- XML::newXMLNode("func01")
#' RTest::xmlFromList(xml.root,
#' list(
#' params=list(mult=list(attributes=c(value="1",type="numeric"))),
#' testspec=list(
#' execution=list(attributes=c("execution-type"="silent")),
#' "return-value"=list(attributes=c(
#' "compare-type"="equal",
#' "diff-type"="absolute",
#' "tolerance"=0.001
#' ))
#' )
#' )
#' )
#' # Add the reference result to the params and testspec and read it in again
#' xml.root <- XML::xmlRoot(XML::xmlTreeParse(
#' paste0("<root>",
#' capture_output(print(xml.root[[1]])),
#' capture_output(print(xml.root[[2]])),
#' paste(xmlWriteData_data.frame(
#' "reference",
#' data=data.frame(x=c(1,1),y=c(2,2),sum=c(3,3)),
#' printXML=FALSE)
#' ,collapse="\n"),"</root>")
#' ))
#'
#' # Define what to test in the first test
#' # Please check the function test.RTest.funct_01 to see
#' # how it tests the code of the function ("test_fun")
#' tests <- new.env()
#' testEntry <- list(
#' "pkg" = "RTest", # test description
#' "pgk-iter" = "1",
#' "func" = "funct_01",
#' "func-iter" = "1",
#' "test-code" = "RTest::test_fun",
#' "test-adapter" = "RTestCase",
#' "test-func" = "test.RTest.funct_01",
#' "pkg-desc" = "no package desc",
#' "func-desc" = "Simple add func",
#' "xpath" = "/root",
#' "reporter" = NA, # field for testthat reporter
#' "result" = NA, # field for test result (failed/success)
#' "cache" = NA, # field for caching test results
#' "execresid" = NA, # field for test execution result id
#' "specid" = "0", # field for test function id
#' "riskid" = "0" # field for test function risk id
#' )
#'
#' # Assign test entry to test environment
#' # pkg-name pkg-iter func-name func-iter
#' tests[["RTest"]][["1"]][["funct_01"]][["1"]] <- testEntry
#'
#' # Create a TestCase Object
#' object <- RTestCase(
#' ID="1",
#' tc.type="RTestCase",
#' synopsis= list(version="v1",author="Sebastian Wolf"),
#' xml.fPath="",
#' xml.root=xml.root,
#' input.data=list("one"=
#' data.frame(x=c(1,1),y=c(2,2))
#' ),
#' tests=tests,
#' test.for="RTest",
#' test.result=NA
#' )
#'
#' # Run the test
#' object <- test(object,test.for="RTest")
#' stopifnot(object@@test.result=="success")
#'
#' # Run a failing test
#'
#' object@@input.data <- list("one"=
#' data.frame(x=c(1,2),y=c(2,1))
#' )
#' object <- test(object,test.for="RTest")
#' stopifnot(object@@test.result=="failed")
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
RTestCase <- function(
ID = NULL,
tc.type = NULL,
synopsis = NULL,
xml.fPath = NULL,
xml.root = NULL,
input.data = NULL,
tests = NULL,
test.for = NULL,
test.result = NULL
){
if(missing(xml.fPath) || xml.fPath==""){
#stop("Argument 'xml.fPath' missing.")
new("RTestCase",
ID = ID,
tc.type = tc.type ,
synopsis = synopsis,
xml.fPath = xml.fPath,
xml.root = xml.root,
input.data = input.data,
tests = tests,
test.for = test.for,
test.result = test.result
)
}else{
if(!file.exists(xml.fPath))
stop("Input file '",xml.fPath,"' not exists.")
# Open and read xml ---------------------------------------------------------------------------
#xml.doc <- xmlTreeParse(xml.fPath, getDTD = F)
xml.doc <- xmlTreeParse(xml.fPath, getDTD = F,
handlers = list("comment"=function(x,...){NULL}), asTree = TRUE)
xml.root <- xmlRoot(xml.doc)
# Initialize slots ----------------------------------------------------------------------------
# XML information - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
xml.fPath <- xml.fPath
xml.root <- xml.root
# TC information (synopsis) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ID <- xmlValue(xml.root[["ID"]])
tc.type <- xmlName(xml.root)
synopsis <- list(
"version" = xmlValue(xml.root[["synopsis"]][["version"]]),
"author" =
paste(
sapply(
xmlElementsByTagName(xml.root[["synopsis"]], "author"),
function(e) xmlValue(e)
), collapse = ", "),
"short-description" =
if(!is.null(xml.root[["synopsis"]][["short-description"]])){
xmlValue(xml.root[["synopsis"]][["short-description"]])
}else{
""
},
"description" =
if(!is.null(xml.root[["synopsis"]][["description"]])){
xmlValue(xml.root[["synopsis"]][["description"]])
}
else{
""
} ,
"label" =
if(!is.null(xml.root[["synopsis"]][["label"]])) {
xmlValue(xml.root[["synopsis"]][["label"]])
}
else{""},
"creation-date" =
if(!is.null(xml.root[["synopsis"]][["creation-date"]])) {
xmlValue(xml.root[["synopsis"]][["creation-date"]])
}else{""},
"change-history" =
if(!is.null(xml.root[["synopsis"]][["change-history"]])){
lapply(
xmlElementsByTagName(xml.root[["synopsis"]][["change-history"]], "change"),
function(e)
c(
author = xmlAttrs(e)[["author"]],
date = xmlAttrs(e)[["date"]],
change = xmlValue(e)
)
)
}else{
list()
}
)
# Set Input data
.Object <- new("RTestCase",
ID = ID,
tc.type = tc.type ,
synopsis = synopsis,
xml.fPath = xml.fPath,
xml.root = xml.root,
input.data = data.frame(),
tests = new.env(),
test.for = NA,
test.result = NA
)
# TC execution details and test results - - - - - - - - - - - - - - - - - - - - - - - - - - - -
.Object@input.data <- readXMLInputData(.Object)
.Object <- initializeTests(.Object)
# Return initialized object -------------------------------------------------------------------
return(.Object)
}
}
# initializeTests #################################################################################
setGeneric("initializeTests",
function(object) standardGeneric("initializeTests"))
#' Initialize the Test Slot for a Test Case.
#'
#' This method initializes the slots '\code{tests}', '\code{test.for}' and '\code{test.result}' of
#' a object of class '\code{RTestCase}'. See description of \code{\link{RTestCase-class}} for
#' further information.
#'@name initializeTests
#' @aliases initializeTests,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("initializeTests",
signature = "RTestCase",
definition = function (object) {
# Create a new empty environment for the results ----------------------------------------------
tests <- new.env()
# Create and initialize test structure --------------------------------------------------------
# Run through all tests and create the execution structure (see class documentation for
# detailed structure)
xmlApply(
object@xml.root[["tests"]],
function(xmlPkgItem) {
# Get infos about current package test definition - - - - - - - - - - - - - - - - - - - - -
# Name of test package
tf.pkg <- xmlName(xmlPkgItem)
# First iteration: Initialize empty list for package test
if(is.null(tests[[tf.pkg]]))
tests[[tf.pkg]] <<- list()
# Increase counter (no. of package tests defined in XML)
tf.pkg.i <- length(tests[[tf.pkg]]) + 1
# Get description (if specified in XML)
tf.pkg.testDesc <-
if(!is.null(xmlAttrs(xmlPkgItem)[["test-desc"]])) xmlAttrs(xmlPkgItem)[["test-desc"]]
else ""
# Get test functions of this package test - - - - - - - - - - - - - - - - - - - - - - - - -
# Initialize list for function tests
tests[[tf.pkg]][[tf.pkg.i]] <<- list()
# Get test functions of this package test
xmlApply(
xmlPkgItem,
function(xmlFuncItem) {
# Name of test function
tf.func <- xmlName(xmlFuncItem)
# First iteration: Initialize empty list for function test
if(is.null(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]]))
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]] <<- list()
# Increase counter (no. of function tests defined in XML)
tf.func.i <- length(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]]) + 1
# Get description (if specified)
tf.func.testDesc <-
if("test-desc" %in% names(xmlAttrs(xmlFuncItem)))
xmlAttrs(xmlFuncItem)[["test-desc"]]
else
""
# Get specid (if specified)
tf.func.specid <-
if("spec-id" %in% names(xmlAttrs(xmlFuncItem)))
xmlAttrs(xmlFuncItem)[["spec-id"]]
else
""
# Get riskid (if specified)
tf.func.riskid <-
if("risk-id" %in% names(xmlAttrs(xmlFuncItem)))
xmlAttrs(xmlFuncItem)[["risk-id"]]
else
""
# Initialize test entry
testEntry <- list(
"pkg" = tf.pkg, # test description
"pgk-iter" = tf.pkg.i,
"func" = tf.func,
"func-iter" = tf.func.i,
"test-code" = paste0(tf.pkg,"::",tf.func),
"test-adapter" = xmlName(object@xml.root),
"test-func" = paste0("test.",tf.pkg,".",tf.func),
"pkg-desc" = tf.pkg.testDesc,
"func-desc" = tf.func.testDesc,
"xpath" =
paste("/",
xmlName(object@xml.root),
"tests",
paste0(tf.pkg,"[",tf.pkg.i,"]"),
paste0(tf.func,"[",tf.func.i,"]"), sep = "/"),
"reporter" = NA, # field for testthat reporter
"result" = NA, # field for test result (failed/success)
"cache" = NA, # field for caching test results
"execresid" = NA, # field for test execution result id
"specid" = tf.func.specid, # field for test function id
"riskid" = tf.func.riskid # field for test function risk id
)
# Assign test entry to test environment
# pkg-name pkg-iter func-name func-iter
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]] <<- testEntry
})
})
# Set slots -----------------------------------------------------------------------------------
# Slot 'test'
object@tests <- tests
# Slot reset 'test.for' and 'test.status' (status: not executed)
object@test.for <- NA
object@test.result <- NA
# Return object -------------------------------------------------------------------------------
return(object)
}
)
# show ############################################################################################
#' Print Summary of the Test Case to Console
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @aliases show,RTestCase-method
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("show",
signature = "RTestCase",
definition = function (object) {
cat("Test Case\n")
cat(" Object of class '",class(object),"'\n")
cat(" @ID : ",object@ID,"\n")
cat(" @tc.type : ",object@tc.type,"\n")
cat(" @synopsis :\n")
for(i in names(object@synopsis)) {
if(i != "change-history") {
cat(" ",paste0("$",i),": ",object@synopsis[[i]],"\n")
} else {
cat(" $change-history :\n")
for(c in object@synopsis[[i]]) {
cat(" ",c["date"],", ",c["author"],":\n")
cat(" ",c["change"],"\n")
}
}
}
cat("\n")
cat(" @xml.fPath : ",object@xml.fPath,"\n")
cat(" @xml.root : ",class(object@xml.root)[1],"\n")
cat("\n")
cat(" @input.data : \n")
print(ls.str(object@input.data), max.level = 1)
cat("\n")
cat(" @test.for : ",
(if(!is.null(object@test.for)) object@test.for else "NULL (test not executed)"),"\n")
cat(" @test.result : ",
(if(!is.null(object@test.result)) object@test.result else "NULL (test not executed)"),"\n")
cat("\n")
cat(" @tests :\n")
print(ls.str(object@tests), max.level=4)
cat("\n")
}
)
# getID ###########################################################################################
setGeneric("getID",
function(object) standardGeneric("getID"))
#' Get ID of the Test Case
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @name getID
#' @aliases getID,RTestCase-method
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getID",
signature = "RTestCase",
definition = function (object) {
object@ID
}
)
# getType #########################################################################################
setGeneric("getType",
function(object) standardGeneric("getType"))
#' Get Type of the Test Case
#'
#' @name getType
#' @aliases getType,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getType",
signature = "RTestCase",
definition = function (object) {
object@tc.type
}
)
# getSynopsis #####################################################################################
setGeneric("getSynopsis",
function(object) standardGeneric("getSynopsis"))
#' Get Synopsis of the Test Case
#'
#' @name getSynopsis
#' @aliases getSynopsis,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getSynopsis",
signature = "RTestCase",
definition = function (object) {
object@synopsis
}
)
# getXMLSourcePath ################################################################################
setGeneric("getXMLSourcePath",
function(object) standardGeneric("getXMLSourcePath"))
#' Get Path to the XML Input File of the Test Case
#' @name getXMLSourcePath
#' @aliases getXMLSourcePath,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getXMLSourcePath",
signature = "RTestCase",
definition = function (object) {
object@xml.fPath
}
)
# getXMLSourceFileName ############################################################################
setGeneric("getXMLSourceFileName",
function(object) standardGeneric("getXMLSourceFileName"))
#' Get File Name of the XML Input File of the Test Case
#'
#' @name getXMLSourceFileName
#' @aliases getXMLSourceFileName,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getXMLSourceFileName",
signature = "RTestCase",
definition = function (object) {
s <- strsplit(object@xml.fPath, "/")[[1]]
return(s[length(s)])
}
)
# getXMLRoot ######################################################################################
setGeneric("getXMLRoot",
function(object) standardGeneric("getXMLRoot"))
#' Get the XML Root of the Test Case
#'
#' @name getXMLRoot
#' @aliases getXMLRoot,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{XMLNode})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getXMLRoot",
signature = "RTestCase",
definition = function (object) {
object@xml.root
}
)
# getTestFor ######################################################################################
setGeneric("getTestFor",
function(object) standardGeneric("getTestFor"))
#' Get For of Last Execution of the Test Case
#'
#' @name getTestFor
#' @aliases getTestFor,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{ANY})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getTestFor",
signature = "RTestCase",
definition = function (object) {
object@test.for
}
)
# getTestResult ###################################################################################
setGeneric("getTestResult",
function(object) standardGeneric("getTestResult"))
#' Get Result of Last Execution of the Test Case
#'
#' @name getTestResult
#' @aliases getTestResult,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{ANY})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getTestResult",
signature = "RTestCase",
definition = function (object) {
object@test.result
}
)
# clearTest #######################################################################################
setGeneric("clearTest",
function(object) standardGeneric("clearTest"))
#' Clear Test Reporter and Test Cache of Last Test Case Execution
#'
#' This method resets the test information of the current test case including slots
#' \code{'test.for'}, \code{'test.result'} and the cache in the \code{'tests'} test case
#' environment.
#' @name clearTest
#' @aliases clearTest,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{\link{RTestCase-class}})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("clearTest",
signature = "RTestCase",
definition = function (object) {
# Clear global test execution information -----------------------------------------------------
object@test.for <- NA
object@test.result <- NA
# Clear test environment ----------------------------------------------------------------------
tests <- object@tests
for(tf.pkg in ls(tests)) {
# Level 1: packages
for(tf.pkg.i in 1:length(tests[[tf.pkg]])) {
# Level 2: package-iterations
for(tf.func in names(tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
for(tf.func.i in 1:length(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 3: iteration of a function
# Clear test reporter
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["reporter"]] <- NA
# Clear test execution status
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["result"]] <- NA
# Clear test cache
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["cache"]] <- NA
# Clear test exec result id
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]][["execresid"]]<- NA
}
}
}
}
object@tests <- tests
# Return
return(object)
}
)
# readXMLInputData ################################################################################
setGeneric("readXMLInputData",
function(object) standardGeneric("readXMLInputData"))
#' Read Input Data of Test Case for Default XML Definitions
#'
#' This functions reads the XML definitions for default RTest objects.
#'
#' Input datasets are contained below the XML element '\code{input-data}' and can be used by any
#' test packages and functions of the respective test case adapter (i.e. by the functions of the
#' objects inheriting the class '\code{RTestCase}'). By default major R data types are predefined
#' under the node and can be read by this method. Thereby, the type of the imported datasets is
#' determined by the XML element names. This method runs through all XML items, parses the
#' item and converts it into the respective R object.\cr
#' The following element types are supported:\cr
#' \itemize{
#' \item{variable}{\code{XML: variable, XSD: RTestData_variable, RTest: xmlReadData_variable}}
#' \item{vector}{\code{XML: vector, XSD: RTestData_vector, RTest: xmlReadData_vector}}
#' \item{data.frame}{\code{XML: data.frame, XSD: RTestData_data.frame, RTest: xmlReadData_data.frame}}
#' \item{list}{\code{XML: list, XSD: RTestData_list, RTest: xmlReadData_list}}
#' }
#'
#'
#' @name readXMLInputData
#' @aliases readXMLInputData,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object
#'
#' @return (\code{ANY}) If multiple datasets are defined a \code{list} will be returned
#' containing all datasets with the same order as in the XML file. Else, if only a single
#' is defined, the dataset itself will be returned.
#'
#' @seealso \code{RTestCase-class}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("readXMLInputData",
signature = "RTestCase",
definition = function(object) {
input.data <- xmlRead.default(object@xml.root[["input-data"]])
input.data
}
)
# test ############################################################################################
setGeneric("test",
function(object, test.for = NULL, out.fPathPre = NULL, ...) standardGeneric("test"))
#' Execute Test Logic of the Test Case
#'
#' This method executes the test logic for a test case in a \code{testthat} reporter environment.
#'
#' This method performs the test logic by iterating through all testgroups as defined in the TC XML
#' definition file. For each test group it starts a seperate '\code{ListReporter}', which is
#' defined in the \code{testthat} package. Then, the different functions of a testgroup are
#' executed. Therefore, this function calls the method \code{execTCAdapter}, which needs to be
#' defined for each TestCase type separatly (e.g. for DSTAT, VCA, Calib, etc.). This method is the
#' adapter function and knows how to read the test case and how to execute the functions, which
#' should be tested. Thereby, all test results generated using \code{\link[testthat]{test_that}}
#' and the \code{expect_*} of the \code{testthat} package are recorded by the previously started
#' reporter object. The generated test results are stored (slot \code{test.result}) and the test
#' execution status set (slot \code{test.status}).
#'
#' @name test
#' @aliases test,RTestCase-method
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#' @param test.for (\code{vector(character)}) Specification for which elements to test,
#' NULL to test for all elements
#' @param out.fPathPre (\code{character}) Prefix incl. path to output files generated during
#' tetest
#' @param ... Additional arguments passed to the check function.
#'
#' @return (\code{\link{RTestCase-class}})
#'
#' @seealso \code{\link{RTestCase-class}}
#' @examples
#'
#' location <- find.package("RTest")
#'
#' TestCase <- RTestCase(xml.fPath =
#' file.path(location,"xml-templates","RTest_TC-01.xml"))
#'
#' result <- test(TestCase)
#'
#' stopifnot(result@@test.result == "success")
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("test",
signature = "RTestCase",
definition = function (object, test.for = NULL, ...) {
RTest.cat("##### TEST CASE '",object@ID,"'\n\n")
# Check test.for argument ---------------------------------------------------------------------
# If NULL, test for all elements specified for this TC
if(is.null(test.for))
test.for <- XML::xmlSApply(object@xml.root[["tests"]], xmlName)
# Use caching for multiple iterations, say, allow to say, which tests to should re-run
# Check, if execution details changed (test.for)
#if(!is.null(object@test.for) && !identical(test.for, object@test.for)) {
# object <- clearTest(object)
#}
# Re-Set cache and of the test environment
object <- clearTest(object)
# Re-Set 'test.for' class slot for current execution
object@test.for <- test.for
# Re-Set 'test.result' class slot for current execution
object@test.result <- NA
RTest.cat("Test for: ",paste(paste0("'",test.for,"'"), collapse=", "),"\n\n")
# Execute tests / call test adapters / set test status ----------------------------------------
# Get test environment - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
tests <- object@tests
# Execute all defined tests - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
for(tf.pkg in ls(tests)) {
# Level 1: packages
if(is.element(tf.pkg, test.for)) {
# If the current package should be tested, execute all defined function test
RTest.cat("Run test(s) for '",tf.pkg,"'\n")
for(tf.pkg.i in 1:length(tests[[tf.pkg]])) {
# Level 2: package-iterations
for(tf.func in names(tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
for(tf.func.i in 1:length(tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 4: iteration of a function
tf.test <- tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
RTest.cat(" Test '",tf.test[["test-code"]],"' ...")
# Open and start testthat reporter
reporter <- ListReporter$new()
set_reporter(reporter)
reporter$start_reporter()
# Set testthat context
context(tf.test[["test-code"]])
# Execute the wrapper function
tmpExec <- NULL
with_reporter(reporter,
tmpExec <- execAdapter(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i,
out.fPathPre = out.fPathPre, ...)
#tf.test[["cache"]] <- execAdapter(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i)
#execAdapter(object, tf.test[["test-func"]], tf.test[["xpath"]])
)
tf.test[["cache"]] <- tmpExec[["result"]]
tf.test[["execresid"]] <- tmpExec[["execresid"]]
tf.test[["test-func"]] <- tmpExec[["function_name"]]
`%:::%` = function(pkg, fun) get(fun, envir = asNamespace(pkg),
inherits = FALSE)
end_context <- "testthat" %:::% "end_context"
# Close testthat reporter
end_context()
reporter$end_reporter()
# Set test name to reporter
#unlockBinding("test", reporter)
#reporter$test <- paste0(tf.func)
#print(str(ls(reporter)))
# reporter.results <- as.data.frame(reporter$get_results())
# reporter.failed <- length(which(reporter.results$failed > 0))
#
# message("\n----------\n")
# print(str(reporter$results$as_list()))
# message("\n----------\n")
if(length(reporter$results$as_list())>0){
reporter.failed <- sum(sapply(reporter$results$as_list(),
function(repores) length(which(sapply(repores$results,
function(e) !"expectation_success" %in% class(e))))))
}else{
reporter.failed <- 0
}
# stop()
# message("-")
# print(str(reporter$get_results()[[1]][["results"]]))
# message("--")
# print(attributes(reporter$get_results()[[1]][["results"]][[1]]))
# message("---")
# print(reporter$failed)
# #print(reporter$results)
# stop()
# Set test reporter
tf.test[["reporter"]] <- reporter
# Set test result based on reporter status
tf.test[["result"]] <-
#ifelse(length(reporter$results) == 0 || !reporter$failed, "failed", "success")
#ifelse(length(reporter$results) == 0, "failed", ifelse(reporter$failed, "failed", "success"))
ifelse(reporter.failed == 0, "success", "failed")
RTest.cat(" ",tf.test[["result"]],"\n")
# Set global test result for this test case
if(is.na(object@test.result))
# If it has not been set, use current result
object@test.result <- tf.test[["result"]]
else
if(object@test.result != "failed")
# As soon as failed has been set once, never change it again
object@test.result <- tf.test[["result"]]
# Change test entry in object@test slot (i.e. in test environment)
tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]] <- tf.test
}
}
}
}
}
RTest.cat("\n")
# Return
return(object)
}
)
# execAdapter #####################################################################################
setGeneric("execAdapter",
function(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i, out.fPathPre = NULL, ...)
standardGeneric("execAdapter"))
#' Execute the Adapter Function of the Test Case
#'
#' This is an abstract method definition and specifies the adapter function of the individual
#' test case adapter, which understand the test case and knows how to execute it. It has to be
#' implemented in the specialized test classes separetly for each test project.
#'
#' @name execAdapter
#' @aliases execAdapter,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object
#' @param tf.pkg (\code{character}) The package name of the currently executed test
#' function.
#' @param tf.pkg.i (\code{integer}) The package iteration number of the currently executed
#' test function.
#' @param tf.func (\code{character}) The function name of the currently executed test
#' function.
#' @param tf.func.i (\code{character}) The function iteration number of the currently
#' executed test function.
#' @param out.fPathPre (\code{character}) Prefix incl. path to output files generated during
#' tests
#' @param ... Additional arguments passed to the check function.
#'
#' @return (\code{ANY}) The cached result of the executed test function.
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("execAdapter",
signature = "RTestCase",
definition = function (object, tf.pkg, tf.pkg.i, tf.func, tf.func.i, out.fPathPre = NULL, ...) {
# Initialize test case execution --------------------------------------------------------------
# Get test environment
tf.test <- object@tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
# Get test function
tf.testFunc <- tf.test[["test-func"]]
# Get XML xpath for current test function
tf.xpath <- tf.test[["xpath"]]
# Get the execution cache
tf.execCache <- execCache(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i)
tf.cacheid <- paste0(tf.pkg,"-",tf.pkg.i,"-",tf.func,"-",tf.func.i)
# Check test function -------------------------------------------------------------------------
use_generic <- FALSE
if(!exists(tf.testFunc)){
message("Using generic test interpreter function")
use_generic <- TRUE
}
# stop("No default test function '",tf.testFunc,"' defined for '",class(object),"'!")
# Get XML definition --------------------------------------------------------------------------
# Use the passed xpath to get XML definition of the test item
# Try to access the XML definition and use the return xml node set
tf.xmlItem <- suppressWarnings(getNodeSet(object@xml.root, path = tf.xpath)[[1]])
# In R-3.4.0 it always produces warnings due to a change in the sturcture functions :(
# Warnings, trough stop message (be very conservative)
# warning = function(w) {
#
# stop("Warning occured during access of XML test element '",tf.xpath,"'.")
# },
# Execute test function -----------------------------------------------------------------------
# Call the test function and pass the TC's input data and current XML function definition
if(use_generic){
tf.testFunc <- "'generic' test function"
tf.result <- do.call("generic",
list(object, object@input.data, tf.execCache, tf.xmlItem, cacheid = tf.cacheid,
paste0(out.fPathPre,"_",tf.cacheid), package = tf.pkg, ...))
}else{
tf.result <- do.call(tf.testFunc,
list(object, object@input.data, tf.execCache, tf.xmlItem, cacheid = tf.cacheid,
paste0(out.fPathPre,"_",tf.cacheid), ...))
}
# Return test function result -----------------------------------------------------------------
# The returned value will be stored in the cache for this execution
tf.return <- list()
tf.return$result <- tf.result
tf.return$execresid <-
if("exec-res-id" %in% names(xmlAttrs(tf.xmlItem))) xmlAttrs(tf.xmlItem)[["exec-res-id"]]
else NA
tf.return$function_name <- tf.testFunc
return(tf.return)
}
)
# execCache #####################################################################################
setGeneric("execCache",
function(object, tf.pkg, tf.pkg.i, tf.func, tf.func.i) standardGeneric("execCache"))
#' Execution Cache for Test Function
#'
#' Creates the execution cache for the the currently executed test function.
#'
#' The execution cache includes all cached results of test functions that are part of the same
#' package iteration and were executed prior to the current test function. The cached results will
#' be stored in as a list() object with the following format:\cr
#' \code{XML: execCache:}\cr
#' \code{<pkg_01>}\cr
#' \code{ <func_01> ... </func_01> $funct_01}\cr
#' \code{ <func_01> ... </func_01> $funct_01[[1]] -> result}\cr
#' \code{ <func_01> ... </func_01> $funct_01[[2]] -> result}\cr
#' \code{ <func_02> ... </func_02> <- current tf -> $funct_02 -> result}\cr
#' \code{ <func_03> ... </func_03> --- not included ---}\cr
#' \code{</pkg_01>}
#' @name execCache
#' @aliases execCache,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object
#' @param tf.pkg (\code{character}) The package name of the currently executed test
#' function.
#' @param tf.pkg.i (\code{integer}) The package iteration number of the currently executed
#' test function.
#' @param tf.func (\code{character}) The function name of the currently executed test
#' function.
#' @param tf.func.i (\code{character}) The function iteration number of the currently
#' executed test function.
#'
#' @return (\code{list})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("execCache",
signature = "RTestCase",
definition = function (object, tf.pkg, tf.pkg.i, tf.func, tf.func.i) {
# Get current test entivornment
tf.tests <- object@tests
# Get index of the current test function
tf.funcIndex <- which(tf.func == names(tf.tests[[tf.pkg]][[tf.pkg.i]]))
if(length(tf.funcIndex)<1){
stop(paste0("no cache created due to unkown '",tf.func,"'"))
}
# Initialize execution cache
tf.execCache <- NULL
# Create execution cache
if(tf.funcIndex == 1 && tf.func.i == 1) {
# If first function and first iteration, initialize empty list
tf.execCache <- list()
} else {
# Else, built a list with the cached results
tf.execCache <- list()
# Get index of the last function to be included in the cache ...
maxFuncUseIndex <- if(tf.func.i == 1) tf.funcIndex - 1 else tf.funcIndex
# ... and the cache of these
for(f in names(tf.tests[[tf.pkg]][[tf.pkg.i]])[1:maxFuncUseIndex]) {
# Get the index of the last function interation to be included ...
maxIterUseIndex <-
if(f == tf.func) tf.func.i-1 else length(tf.tests[[tf.pkg]][[tf.pkg.i]][[f]])
# ... and collect the cache
tf.execCache[[f]] <- list()
for(i in 1:maxIterUseIndex) {
i.index <-
if(is.na(tf.tests[[tf.pkg]][[tf.pkg.i]][[f]][[i]][["execresid"]])) i
else tf.tests[[tf.pkg]][[tf.pkg.i]][[f]][[i]][["execresid"]]
tf.execCache[[f]][[i.index]] <- tf.tests[[tf.pkg]][[tf.pkg.i]][[f]][[i]][["cache"]]
}
# # If only one iteration is used, not return as single list
# if(maxIterUseIndex == 1)
# tf.execCache[[f]] <- tf.execCache[[f]][[1]]
}
}
return(tf.execCache)
})
# getExecSummary ################################################################################
setGeneric("getExecSummary",
function(object) standardGeneric("getExecSummary"))
#' Summary of the Last Execution of the Test Case
#'
#' @name getExecSummary
#' @aliases getExecSummary,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{list})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getExecSummary",
signature = "RTestCase",
definition = function (object) {
if(is.na(object@test.result))
stop("This test case has not been executed!")
print(ls.str(object@tests), max.level=4)
}
)
# getExecSummary.html #############################################################################
setGeneric("getExecSummary.html",
function(object) standardGeneric("getExecSummary.html"))
#' Create HTML Summary of the Last Execution of the Test Case
#'
#' Generates a summary of the last test case execution for the overall test report.
#' @name getExecSummary.html
#' @aliases getExecSummary.html,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getExecSummary.html",
signature = "RTestCase",
definition = function (object) {
if(is.na(object@test.result))
return(c())
#stop("This test case has not been executed!")
out <- c()
out.append <- function(...) { out <<- c(out, paste0(...)) }
tc.tests <- object@tests
tc.status <- if(length(tc.tests) == 0) "NO-TESTS" else toupper(object@test.result)
out.append("<table width=\"100%\" class=\"TCSummary\">")
out.append(" <tr>")
out.append(" <th width=\"100\">TC</th>")
out.append(" <th width=\"70\">Version</th>")
out.append(" <th width=\"100\">Type</th>")
out.append(" <th width=\"100\">Label</th>")
out.append(" <th>Description</th>")
out.append(" <th width=\"150\">No. of Testgroups</th>")
out.append(" <th width=\"250\">Input</th>")
out.append(" <th width=\"150\">Status</th>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td align=\"center\">")
out.append(" <a href=\"#TC-",getID(object),"\">",getID(object),"</a>")
out.append(" </td>")
out.append(" <td align=\"center\">",getSynopsis(object)[["version"]],"</td>")
out.append(" <td align=\"center\">",getType(object),"</td>")
out.append(" <td align=\"center\">",getSynopsis(object)[["label"]],"</td>")
out.append(" <td>",getSynopsis(object)[["short-description"]],"</td>")
out.append(" <td align=\"center\">",length(tc.tests),"</td>")
out.append(" <td align=\"center\">",getXMLSourceFileName(object),"</td>")
out.append(" <td align=\"center\" class=\"",tc.status,"\">",tc.status,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td colspan=\"8\">")
out.append(" <table width=\"100%\" class=\"TCExpecSummary\">")
out.append(" <tr>")
out.append(" <th width=\"100\">Package</th>")
out.append(" <th width=\"40\">#</th>")
out.append(" <th width=\"200\">Description</th>")
out.append(" <th width=\"100\">Function</th>")
out.append(" <th width=\"40\">SpecID</th>")
out.append(" <th width=\"40\">RiskID</th>")
out.append(" <th width=\"40\">#</th>")
out.append(" <th>Description</th>")
out.append(" <th width=\"200\">No. of Tests</th>")
out.append(" <th width=\"150\">Status</th>")
out.append(" </tr>")
#print(object@test.for)
for(tf.pkg in unique(object@test.for)) {
# Level 1: packages (write only those which were tested in the last execution)
for(tf.pkg.i in 1:length(tc.tests[[tf.pkg]])) {
# Level 2: package-iterations
tf.pkg.info <- FALSE
for(tf.func in names(tc.tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
tf.func.info <- FALSE
for(tf.func.i in 1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 4: iteration of a function
tf.test <- tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
tf.tests <- nrow(as.matrix(tf.test$reporter$get_results()))
tf.status <-
if(tf.tests == 0) "NO-TESTS"
else toupper(tf.test$result)
out.append(" <tr>")
if(!tf.pkg.info) {
out.append(" <td>")
out.append(" <a href=\"#TC-",getID(object),"-",tf.pkg,"_",tf.pkg.i,"\">")
out.append(" ",tf.pkg,"")
out.append(" </a>")
out.append(" </td>")
out.append(" <td align=\"center\">",tf.pkg.i,"</td>")
out.append(" <td>",tf.test[["pkg-desc"]],"</td>")
tf.pkg.info <- TRUE
} else {
out.append(" <td colspan=\"3\"></td>")
}
if(!tf.func.info) {
out.append(" <td>")
out.append(" <a href=\"#TC-",getID(object),"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"\">")
out.append(" ",tf.func,"")
out.append(" </a>")
out.append(" </td>")
out.append(" <td align=\"center\">",tf.test[["specid"]],"</td>")
out.append(" <td align=\"center\">",tf.test[["riskid"]],"</td>")
tf.func.info <- TRUE
} else {
out.append(" <td></td>")
out.append(" <td></td>")
out.append(" <td></td>")
}
out.append(" <td align=\"center\">")
out.append(" <a href=\"#TC-",getID(object),"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"_",tf.func.i,"\">")
out.append( tf.func.i)
out.append(" </a>")
out.append(" </td>")
out.append(" <td>",tf.test[["func-desc"]],"</td>")
out.append(" <td align=\"center\">",tf.tests,"</td>")
out.append(" <td align=\"center\" class=\"",tf.status,"\">",tf.status,"</td>")
out.append(" </tr>")
}
}
}
}
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
out.append("</table>")
out.append("</br>")
return(out)
}
)
# execDetails.html ################################################################################
setGeneric("getExecDetails.html",
function(object, report.onlyFailed = FALSE) standardGeneric("getExecDetails.html"))
#' Create Detailed HTML Summary of the Last Execution of the Test Case
#'
#' Generates a detailed summary of the last test case execution for the overall test report
#' including all tested expectations.
#'
#'
#' @name getExecDetails.html
#' @aliases getExecDetails.html,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#' @param report.onlyFailed (\code{logical}) Report only failed exceptions (TRUE) or
#' all exceptions (FALSE, default).
#'
#' @return (\code{character})
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getExecDetails.html",
signature = "RTestCase",
definition = function (object, report.onlyFailed = FALSE) {
tc.ID <- getID(object)
if(is.null(object@test.result) || is.na(object@test.result))
return(c())
#stop("This test case has not been executed!")
out <- c()
out.append <- function(...) { out <<- c(out, paste0(...)) }
tc.tests <- object@tests
tc.status <- if(length(tc.tests) == 0) "NO-TESTS" else toupper(object@test.result)
out.append("<a name=\"TC-",tc.ID,"\"></a>")
out.append("<h2>",tc.ID,"</h2>")
out.append("")
out.append("<div class=\"abstract\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"50%\" valign=\"top\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Version:</b></td>")
out.append(" <td>",getSynopsis(object)[["version"]],"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Type:</b></td>")
out.append(" <td>",getType(object),"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" <td width=\"50%\" valign=\"top\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Author(s):</b></td>")
out.append(" <td>",getSynopsis(object)[["author"]],"</td>")
out.append(" </tr>")
if(getSynopsis(object)[["creation-date"]] != "") {
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Creation Date:</b></td>")
out.append(" <td>",getSynopsis(object)[["creation-date"]],"</td>")
out.append(" </tr>")
}
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
if(getSynopsis(object)[["label"]] != "") {
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\" valign=\"top\"><b>Label:</b></td>")
out.append(" <td>",getSynopsis(object)[["label"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
}
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\" valign=\"top\"><b>Short Description:</b></td>")
out.append(" <td>",getSynopsis(object)[["short-description"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
if(length(getSynopsis(object)[["description"]]) > 0 && getSynopsis(object)[["description"]] != "") {
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\" valign=\"top\"><b>Description:</b></td>")
out.append(" <td>",getSynopsis(object)[["description"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
}
out.append(" <tr>")
out.append(" <td colspan=\"2%\">")
out.append(" <table width=\"100%\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Input File:</b></td>")
out.append(" <td>",getXMLSourcePath(object),"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
out.append("</div>")
out.append("<br />")
out.append("")
out.tempfiles <- c()
#for(tf.pkg in object@test.for) {
lapply(unique(object@test.for), function(tf.pkg) {
# Level 1: packages (write only those which were tested in the last execution)
out.append("<a name=\"TC-",tc.ID,"-",tf.pkg,"\"></a>")
out.append("<table width=\"100%\" class=\"TC-Level1\" style=\"margin-bottom: 15px\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level1-left\"></td>")
out.append(" <td class=\"TC-Level1-head\">",tf.pkg,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level1-left\"></td>")
out.append(" <td class=\"TC-Level1-content\">")
#for(tf.pkg.i in 1:length(tc.tests[[tf.pkg]])) {
lapply(1:length(tc.tests[[tf.pkg]]), function(tf.pkg.i) {
# Level 2: package-iterations
out.append(" <table width=\"100%\" class=\"TC-Level2\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level2-left\"></td>")
out.append(" <td class=\"TC-Level2-head\">")
out.append(" <a name=\"TC-",tc.ID,"-",tf.pkg,"_",tf.pkg.i,"\"></a>")
out.append(" ",tf.pkg.i,"")
out.append(" </td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level2-left\"></td>")
out.append(" <td class=\"TC-Level2-content\">")
#for(tf.func in names(tc.tests[[tf.pkg]][[tf.pkg.i]])) {
lapply(names(tc.tests[[tf.pkg]][[tf.pkg.i]]), function(tf.func) {
# Level 3: functions of package
out.append(" <a name=\"TC-",tc.ID,"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"\"></a>")
out.append(" <table width=\"100%\" class=\"TC-Level3\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level3-left\"></td>")
out.append(" <td class=\"TC-Level3-head\">",tf.func,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level3-left\"></td>")
out.append(" <td class=\"TC-Level3-content\">")
#for(tf.func.i in 1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
lapply(1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]]), function(tf.func.i) {
# Level 4: iteration of a function
tf.test <- tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
tf.reporter <- tf.test$reporter$results$as_list()
tf.nTests <- length(tf.reporter)
tf.reporter.results <- as.data.frame(tf.test$reporter$get_results())
tf.nTests <- nrow(tf.reporter.results)
# print(tf.reporter.results)
RTest.cat("Write details for '",tf.pkg,"::",tf.func,"'\n")
if(tf.nTests>0){
tf.exceptions.passed <- sum(sapply(tf.reporter,
function(repores) length(which(sapply(repores$results, function(e) "expectation_success" %in% class(e))))))
tf.expections.failed <- sum(sapply(tf.reporter,
function(repores) length(which(sapply(repores$results, function(e) !"expectation_success" %in% class(e))))))
tf.exceptions <- tf.exceptions.passed + tf.expections.failed
}else{
tf.exceptions <- tf.expections.failed <- tf.exceptions.passed <- 0
}
tf.status <- if(tf.nTests == 0) "NO-TESTS" else toupper(tf.test$result)
tf.desc <- c()
if(tf.test[["pkg-desc"]] != "") tf.desc <- c(tf.desc, tf.test[["pkg-desc"]])
if(tf.test[["func-desc"]] != "") tf.desc <- c(tf.desc, tf.test[["func-desc"]])
tf.desc <- paste(tf.desc, collapse = "; ")
out.append(" <table width=\"100%\" class=\"TC-Level4\">")
out.append(" <tr>")
out.append(" <td class=\"TC-Level4-left\"></td>")
out.append(" <td class=\"TC-Level4-head\">")
out.append(" <a name=\"TC-",tc.ID,"-",tf.pkg,"_",tf.pkg.i,"-",tf.func,"_",tf.func.i,"\">")
out.append(" #",tf.func.i)
out.append(" </a>")
out.append(" </td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td class=\"TC-Level4-left\"></td>")
out.append(" <td class=\"TC-Level4-content\">")
out.append(" <div class=\"abstract-",tf.status,"\">")
out.append(" <table width=\"100%\" style=\"margin-bottom: 5px;\">")
out.append(" <tr>")
out.append(" <td width=\"150\"><b>Test</b></td>")
out.append(" <td>",tf.test[["test-code"]],"</td>")
out.append(" <td width=\"150\"><b>Description</b></td>")
out.append(" <td>",tf.desc,"</td>")
out.append(" <td width=\"150\" rowspan=\"4\" align=\"center\" valign=\"top\"></td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>RTest Adapter</b></td>")
out.append(" <td>",tf.test[["test-adapter"]],"</td>")
out.append(" <td><b>No. of Tests</b></td>")
out.append(" <td>",tf.nTests,"</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>RTest Function</b></td>")
out.append(" <td>",tf.test[["test-func"]],"</td>")
out.append(" <td><b>No. of Exceptions</b></td>")
out.append(" <td>",tf.exceptions," (",
tf.expections.failed," failed / ",tf.exceptions.passed," passed)</td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>XML Test Definition</b></td>")
out.append(" <td colspan=\"3\">",tf.test[["xpath"]],"</td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" </div>")
if(tf.nTests == 0) {
out.append(" <table width=\"100%\" class=\"TCSummary\">")
out.append(" <tr>")
out.append(" <td align=\"center\">NO TESTS</td>")
out.append(" </tr>")
out.append(" </table>")
} else {
#for(repores.i in 1:length(tf.reporter$results)) {
lapply(1:tf.nTests, function(repores.i) {
repores <- tf.reporter[[repores.i]]
repores.results.length <- length(repores$results)
RTest.cat(" ",repores$test,"\n")
# message("\n* repores\n")
# print(ls(repores))
# message("\n***\n")
repores.status <-
ifelse(length(which(sapply(repores$results, function(e) !"expectation_success" %in% class(e)))) > 0,
"FAILED", "SUCCESS")
out.append(" <table width=\"100%\" class=\"TCSummary\" style=\"margin-bottom: 5px\">")
out.append(" <tr>")
out.append(" <th>Test</th>")
out.append(" <th width=\"150\">No. of Exectations</th>")
out.append(" <th width=\"70\">User</th>")
out.append(" <th width=\"70\">System</th>")
out.append(" <th width=\"70\">Real</th>")
out.append(" <th width=\"150\">Status</th>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td><b>",repores$test,"</b></td>")
out.append(" <td align=\"center\"><b>",repores.results.length,"</b></td>")
out.append(" <td align=\"center\"><b>",round(repores$user, 6),"</b></td>")
out.append(" <td align=\"center\"><b>",round(repores$system, 6),"</b></td>")
out.append(" <td align=\"center\"><b>",round(repores$real, 6),"</b></td>")
out.append(" <td align=\"center\" class=\"",repores.status,"\"><b>",repores.status,"</b></td>")
out.append(" </tr>")
out.append(" <tr>")
out.append(" <td colspan=\"6\">")
expec.info.pre <- c()
infostepsize <- max(250, round(repores.results.length/20))
RTest.cat(" 0% ")
i.expec <- 1
i.expec.written <- 1
lapply(repores$results, function(expec) {
out.test <- ""
if(i.expec %% 50 == 0) {
RTest.cat(".")
}
if(i.expec %% infostepsize == 0) {
gc()
RTest.cat("\n ",round(i.expec/repores.results.length*100),"% ")
}
# message("\n* expec\n")
# print(class(expec))
# print(str(expec))
# message("\n***\n")
expec.status <-
ifelse("expectation_success" %in% class(expec), "SUCCESS", "FAILED")
if(report.onlyFailed == FALSE ||
(report.onlyFailed && expec.status == "FAILED"))
{
expec.msg <- expec$message #ifelse(expec$passed, expec$success_msg, expec$failure_msg)
# message("\n* expec.msg\n")
# print(expec.msg)
# message("\n***\n")
expec.msg.array <- strsplit(expec.msg,"\\n")[[1]]
expec.msg.others <- c()
# message("\n* expec.msg.array\n")
# print(expec.msg.array)
# message("\n***\n")
if(length(expec.msg.array) <= 1) {
expec.msg.main <- expec.msg
expec.msg.info <- c(
"Test" = "Test Expected Behaviour",
"Success" = "expectation_success" %in% class(expec),
"Failure" = !"expectation_success" %in% class(expec))
} else {
expec.msg.main <- expec.msg.array[1]
if(length(expec.msg.array) > 2) {
expec.msg.others <- expec.msg.array[2:(length(expec.msg.array))]
} else {
expec.msg.others <- expec.msg.array[length(expec.msg.array)]
}
`%:::%` = function(pkg, fun) get(fun, envir = asNamespace(pkg),
inherits = FALSE)
fromJSON_string <- "jsonlite" %:::% "fromJSON_string"
if(grepl("\\{.*\\}", expec.msg.array[length(expec.msg.array)])) {
expec.msg.info <- stringr::str_extract(expec.msg.array[length(expec.msg.array)],"\\{.*\\}")
expec.msg.info <- fromJSON_string(expec.msg.info)
expec.msg.others <- expec.msg.others[1:(length(expec.msg.others)-1)]
} else {
expec.msg.info <- c(noinfo="")
}
}
# print(str(expec))
# message("array")
# print(expec.msg.array)
# message("main")
# print(expec.msg.main)
# message("info")
# print(expec.msg.info)
# message("others")
# print(expec.msg.others)
# message("***")
expec.msg.info.names <- names(expec.msg.info)
expec.msg.info.length <- length(expec.msg.info)
if(!identical(expec.info.pre, expec.msg.info.names)) {
if(i.expec.written > 1) {
out.test <- paste0(out.test, " </table>")
}
out.test <- paste0(out.test, " <table width=\"100%\" class=\"TCExpecSummary\">")
out.test <- paste0(out.test, " <tr>")
out.test <- paste0(out.test, " <th width=\"25\">#</th>")
if(expec.msg.info.length > 0 && expec.msg.info.names[1]!="noinfo") {
lapply(1:expec.msg.info.length, function(i.info) {
if(i.info == 1)
out.test <<- paste0(out.test, " <th width=\"200\">",expec.msg.info.names[i.info],"</th>")
else
out.test <<- paste0(out.test, " <th>",expec.msg.info.names[i.info],"</th>")
})
#lapply(expec.msg.info.names, function(info)
# paste0(out.test, " <th>",info,"</th>"))
} else {
out.test <- paste0(out.test, " <th>-</th>")
}
out.test <- paste0(out.test, " <th width=\"250\">Info</th>")
out.test <- paste0(out.test, " <th width=\"150\">Status</th>")
out.test <- paste0(out.test, " </tr>")
expec.info.pre <<- expec.msg.info.names
}
out.test <- paste0(out.test, " <tr>")
out.test <- paste0(out.test, " <td align=\"center\">",i.expec.written,"</td>")
if(expec.msg.info.length > 0 && expec.msg.info.names[1]!="noinfo") {
lapply(expec.msg.info,
function(info)
out.test <<- paste0(out.test, " <td align=\"center\">",info,"</td>"))
} else {
out.test <- paste0(out.test, " <td align=\"center\"></td>")
}
out.test <- paste0(out.test, " <td>")
if(expec.status == "SUCCESS")
out.test <- paste0(out.test, " ")
else
out.test <- paste0(out.test, " ",expec.msg.main)
out.test <- paste0(out.test, " </td>")
out.test <- paste0(out.test, " <td align=\"center\" class=\"",expec.status,"\">")
out.test <- paste0(out.test, " ",expec.status)
out.test <- paste0(out.test, " </td>")
out.test <- paste0(out.test, " </tr>")
if(expec.status == "FAILED" && length(expec.msg.others) > 0) {
out.test <- paste0(out.test, " <tr>")
out.test <- paste0(out.test, " <td></td>")
if(expec.msg.info.length > 0) {
lapply(expec.msg.info,
function(info)
out.test <<- paste0(out.test, " <td></td>"))
} else {
out.test <- paste0(out.test, " <td></td>")
}
out.test <- paste0(out.test, " <td class=\"FAILURE-msg\">")
out.test <- paste0(out.test, " ",paste0(expec.msg.others, collapse="<br/>"))
out.test <- paste0(out.test, " </td>")
out.test <- paste0(out.test, " <td align=\"center\" class=\"",expec.status,"\"></td>")
out.test <- paste0(out.test, " </tr>")
}
out.append(out.test)
i.expec.written <<- i.expec.written + 1
}
i.expec <<- i.expec + 1
})
# End of lapply(repores$results)
out.append(" </table>")
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
RTest.cat("\n")
})
}
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
out.append(" <a href=\"#pagetop\" class=\"backlink\">back to page top</a>")
})
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
})
out.append(" </td>")
out.append(" </tr>")
out.append(" </table>")
})
out.append(" </td>")
out.append(" </tr>")
out.append("</table>")
})
RTest.cat("\n")
return(out)
}
)
# getRTMInfos ##########################################################################################
setGeneric("getRTMInfos",
function(object, test.for = NULL, cols = c("Version", "Type", "sDesc"))
standardGeneric("getRTMInfos"))
#' Create RTM from executed test cases
#'
#' Creates the requirement traceability matrix for this test case.
#'
#' @name getRTMInfos
#' @aliases getRTMInfos,RTestCase-method
#'
#' @param object (\code{object}) The \code{\link{RTestCase-class}} object.
#' @param test.for (\code{character}) Vector with package names that should be tested or
#' NULL to get all packages available from the test case.
#' @param cols (\code{character}) Defines which information columns are shown for
#' the TCs in the RTM. The ordering in the vector is also the ordering
#' in the output ('Version','Type','Label','sDesc','lDesc').
#'
#' @return (\code{list}) Listing of test case details (ID, Version, Type, sDesc) and
#' assigned specification IDs (SpecIDs) and risk IDs (RiskIDs).
#'
#' @seealso \code{\link{RTestCase-class}}
#'
#' @author Matthias Pfeifer \email{matthias.pfeifer@@roche.com}
setMethod("getRTMInfos",
signature = "RTestCase",
definition = function (object, test.for = NULL, cols = c("Version", "Type", "sDesc")) {
if(is.null(test.for))
test.for <- ls(object@tests)
tc.tests <- object@tests
tc.status <- if(length(tc.tests) == 0) "NO-TESTS" else toupper(object@test.result)
cols.contents <- list(
Version = getSynopsis(object)[["version"]],
Type = getType(object),
sDesc = getSynopsis(object)[["short-description"]],
lDesc = getSynopsis(object)[["description"]],
Label = getSynopsis(object)[["label"]])
RTM <- list(
ID = getID(object)
)
if(!is.null(cols) && length(cols) > 0) {
for(col in cols) {
RTM[[col]] <- cols.contents[[col]]
}
}
tf.SpecIDs <- tf.RiskIDs <- c()
for(tf.pkg in test.for) {
# Level 1: packages (write only those which were tested in the last execution)
tf.pkg.SpecIDs <- tf.pkg.RiskIDs <- c()
for(tf.pkg.i in 1:length(tc.tests[[tf.pkg]])) {
# Level 2: package-iterations
tf.pkg.info <- FALSE
for(tf.func in names(tc.tests[[tf.pkg]][[tf.pkg.i]])) {
# Level 3: functions of package
tf.func.info <- FALSE
for(tf.func.i in 1:length(tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]])) {
# Level 4: iteration of a function
tf.test <- tc.tests[[tf.pkg]][[tf.pkg.i]][[tf.func]][[tf.func.i]]
specid <- tf.test[["specid"]]
specid <- unlist(strsplit(specid, ","))
specid <- gsub("\\ ","",specid)
riskid <- tf.test[["riskid"]]
riskid <- unlist(strsplit(riskid, ","))
riskid <- gsub("\\ ","",riskid)
tf.pkg.SpecIDs <- unique(c(tf.pkg.SpecIDs, specid))
tf.pkg.RiskIDs <- unique(c(tf.pkg.RiskIDs, riskid))
}
}
}
tf.pkg.SpecIDs <- paste(tf.pkg.SpecIDs, collapse = ", ")
tf.pkg.RiskIDs <- paste(tf.pkg.RiskIDs, collapse = ", ")
if(length(test.for) > 1) {
tf.SpecIDs <- c(tf.SpecIDs,paste0(tf.pkg,": ",tf.pkg.SpecIDs))
tf.RiskIDs <- c(tf.RiskIDs,paste0(tf.pkg,": ",tf.pkg.RiskIDs))
}else{
tf.SpecIDs <- c(tf.SpecIDs,tf.pkg.SpecIDs)
tf.RiskIDs <- c(tf.RiskIDs,tf.pkg.RiskIDs)
}
}
RTM$SpecIDs <- paste(tf.SpecIDs, collapse = "; ")
RTM$RiskIDs <- paste(tf.RiskIDs, collapse = "; ")
return(RTM)
}
)
Try the RTest package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.