inst/unitTests/runTests.R

In cloudcell/blotter: Tools for Transaction-Oriented Trading Systems Development

# Cleanup Functions ---------------------------------------------------------- -
# TODO: create these functions properly in blotter
rm_portfolios <- function(x)
{
    if(inherits(x, what="character")) {
        rm(list=paste0("portfolio.",x),pos=.blotter)
    } else {
        stop("portfolio name(s) must be supplied")
    }
}

rm_accounts <- function(x)
{
    if(inherits(x, what="character")) {
        rm(list=paste0("account.",x),pos=.blotter)
    } else {
        stop("account name(s) must be supplied")
    }
}

ls_portfolios <- function()
{
    ls(pattern=glob2rx("portfolio.*"),pos=.blotter)
}

ls_accounts <- function()
{
    ls(pattern=glob2rx("account.*"),pos=.blotter)
}
# ---------------------------------------------------------------------------- -

############################################################################## #
# The testing template was borrowed from RcppGSL package
# https://github.com/eddelbuettel/rcppgsl
# with minor modifications
############################################################################## #

# This seemingly redundant second assignment to "pkg" in the test is
# done in case this particular file is launched independently from doRUnit.R
pkg <- "blotter"  # set package name here

if(require("RUnit", quietly = TRUE)) {

    is_local <- function(){
    	if( exists( "argv", globalenv() ) && "--local" %in% argv ) return(TRUE)
    	if( "--local" %in% commandArgs(TRUE) ) return(TRUE)
    	FALSE
    }
    if( is_local() ) path <- getwd()

    library(package=pkg, character.only = TRUE)
    if(!(exists("path") && file.exists(path)))
        path <- system.file("unitTests", package = pkg)

    ## --- Testing ---

    ## Define tests
    testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), dirs = path)

    if(interactive()) {
        cat("Now have RUnit Test Suite 'testSuite' for package '", pkg,
            "' :\n", sep='')
        str(testSuite)
        cat('', "Consider doing",
            "\t  tests <- runTestSuite(testSuite)", "\nand later",
            "\t  printTextProtocol(tests)", '', sep="\n")
    } else { ## run from shell / Rscript / R CMD Batch / ...
        ## Run
        tests <- runTestSuite(testSuite)

        output <- NULL

        process_args <- function(argv){
        	if( !is.null(argv) && length(argv) > 0 ){
        		rx <- "^--output=(.*)$"
        		g  <- grep( rx, argv, value = TRUE )
        		if( length(g) ){
        			sub( rx, "\\1", g[1L] )
        		}
        	}
        }

        # R CMD check uses this
        if( exists( "Unit.test.output.dir", globalenv() ) ){
            output <- Unit.test.output.dir
        } else {

            ## give a chance to the user to customize where he/she wants
            ## the unit tests results to be stored with the --output= command
            ## line argument
            if( exists( "argv",  globalenv() ) ){# littler
                output <- process_args(argv)
            } else {				# Rscript
                output <- process_args(commandArgs(TRUE))
            }
        }

        if( is.null(output) ) {         # if it did not work, use parent dir
            output <- ".."              # as BDR does not want /tmp to be used
        }

        ## Print results
        output.txt  <- file.path( output, sprintf("%s-unitTests.txt", pkg))
        output.html <- file.path( output, sprintf("%s-unitTests.html", pkg))

        printTextProtocol(tests, fileName=output.txt)
        message( sprintf( "saving txt unit test report to '%s'", output.txt ) )

        ## Print HTML version to a file
        ## printHTMLProtocol has problems on Mac OS X
        if (Sys.info()["sysname"] != "Darwin"){
            message(sprintf("saving html unit test report to '%s'", output.html))
            printHTMLProtocol(tests, fileName=output.html)
        }

        ##  stop() if there are any failures i.e. FALSE to unit test.
        ## This will cause R CMD check to return error and stop
        err <- getErrors(tests)
        if( (err$nFail + err$nErr) > 0) {
            stop(sprintf("unit test problems: %d failures, %d errors", err$nFail, err$nErr) )
        } else{
            success <- err$nTestFunc - err$nFail - err$nErr - err$nDeactivated
            cat( sprintf( "%d / %d\n", success, err$nTestFunc ) )
        }
    }
} else {
    cat("R package 'RUnit' cannot be loaded -- no unit tests run\n",
    "for package", pkg,"\n")
}