command line tool for RUnit, which is a unit test framework for R

Runit

#!/usr/bin/env Rscript
#---------------------------------------------------------------------------
# command line tool for RUnit, which is a unit test framework for R
#
# Copyright 2012- Takeshi Arabiki
# License: MIT License (http://opensource.org/licenses/MIT)
#
# See also: http://d.hatena.ne.jp/a_bicky/20120109/1326074730 [in Japanese]
#---------------------------------------------------------------------------

library(methods)
.sandbox <- new.env()
library(RUnit)

.die <- function(msg = "") {
    if (msg != "") {
        cat(sprintf("Error: %s\n", msg))
    }
    quit(status = 1, runLast = FALSE)
}

.getAbsPath <- function(dir) {
    old.pwd <- setwd(dir)
    setwd(old.pwd)
}

.showUsage <- function() {
    cat("usage: Runit [--make-skeleton] R_script\n")
    .die()
}

showDiff <- function(received, expected, msg = "") {
    con <- textConnection("result", "w")
    sink(con)
    cat(sprintf("\n%s", msg))
    cat("\nactual:\n")
    print(received)
    cat("\nexpected:\n")
    print(expected)
    cat("\n")
    sink()
    msg <- paste(result, collapse = "\n")
    close(con)
    msg
}

.checkRes <-function(res, test.func) {
    if (inherits(res, "try-error")) {
        if (exists(".errmsg", test.func)) {
            errmsg <- get(".errmsg", test.func)
        } else {
            errmsg <- ""
        }
        errmsg <- paste(errmsg, geterrmessage(), sep = "\n")
        assign(".errmsg", errmsg, envir = test.func)
    }
}

checkFailure <- function() {
    test.func <- parent.frame()
    if (exists(".errmsg", test.func)) {
        errmsg <- get(".errmsg", test.func)
        stop("received below error messages\n-- error messages --", errmsg)
    }
}

checkEquals <- function(...) {
    res <- try(RUnit::checkEquals(...))
    .checkRes(res, parent.frame())
}

checkEqualsNumeric <- function(...) {
    res <- try(RUnit::checkEqualsNumeric(...))
    .checkRes(res, parent.frame())
}

checkEqualsNumeric <- function(...) {
    res <- try(RUnit::checkException(...))
    .checkRes(res, parent.frame())
}

checkIdentical <- function(...) {
    res <- try(RUnit::checkIdentical(...))
    .checkRes(res, parent.frame())
}

checkTrue <- function(...) {
    res <- try(RUnit::checkTrue(...))
    .checkRes(res, parent.frame())
}

.checkOverwrite <- function(filename) {
    if (file.exists(filename)) {
        ans <- NULL
        while(is.null(ans)) {
            cat(sprintf("%s is already exists. Overwite it? (y/n): ", filename))
            ans <- readLines(file("stdin"), 1)
            if (ans == "y") {
                break
            } else if (ans == "n") {
                .die(sprintf("%s is already exists!", filename))
            } else {
                cat("Please answer 'y' or 'n'.\n")
                ans <- NULL
            }
        }
    }
}

.loadFile <- function(filename, env) {
    tmpfile <- file()
    sink(tmpfile, type = "message")
    res <- try(suppressWarnings(sys.source(filename, env)))
    sink(type = "message")
    if (inherits(res, "try-error")) {
        msg <- readLines(tmpfile)
        cat(sprintf("Error occurred while loading %s!\n", basename(filename)))
        cat("-- error messages --\n")
        .die(msg)
    }
    close(tmpfile)
    env
}

.makeTestFile <- function(rscript, testfile, env) {
    fh <- file(testfile, "w")
    write(.makeHeader(rscript), fh)
    write(.makeSetUp(), fh)
    write(.makeTearDown(), fh)
    .fetchFunctions(env, fh)
    close(fh)
}

.fetchFunctions <- function(env, fh, prefix = NULL) {
    for (var in ls(envir = env, all.names = TRUE)) {
        obj <- get(var, envir = env)
        if (is.function(obj)) {
            write(.makeFuncTest(var, prefix), fh)
        } else if (is.list(obj)) {
            .fetchFunctions(as.environment(obj), fh, paste(c(prefix, var), collapse = "$"))
        }
    }
}


.makeHeader <- function(rscript) {
    sprintf('#-----------------------------------------------------------
# Test script for %s
# Generated by Runit command on %s
# cf. https://gist.github.com/1580439
#-----------------------------------------------------------
source("%s")
', basename(rscript), format(Sys.time(), "%Y-%m-%d at %H:%M:%S"), rscript)
}

.makeSetUp <- function() {
'# This function is executed directly before each test function execution
.setUp <- function() {
}
'
}

.makeTearDown <- function() {
'# This function is executed directly after each test function execution
.tearDown <- function() {
}
'
}

.makeFuncTest <- function(func.name, prefix = NULL) {
    sprintf('`test.%s` <- function() {
    # Remove the following line when you implement this test.
    DEACTIVATED("This test has not been implemented yet.")

    # next code is executed if this test script is executed using Runit command
    if (exists("checkFailure") && is.function(checkFailure)) {
        checkFailure()
    }
}
', paste(c(prefix, func.name), collapse = "$"))
}

.runTest <- function(testfile) {
    sink(file(), type = "message")
    res <- runTestFile(testfile)
    sink()
    printTextProtocol(res, separateFailureList = FALSE)
}

.runitMain <- function(env) {
    opts <- commandArgs(trailingOnly = TRUE)
    if (any(opts %in% c("-h", "--help"))) {
        .showUsage()
    }

    is.skeleton <- which(opts == "--make-skeleton")
    if (length(is.skeleton)) {
        opts <- opts[-is.skeleton]
    }
    if (length(opts) == 1) {
        rscript <- opts
        if (!file.exists(rscript)) {
            .die(sprintf("%s is not found!", rscript))
        }

        dir <- dirname(rscript)
        rscript <- file.path(.getAbsPath(dir), basename(rscript))
        if (length(is.skeleton) > 0) {
            cat("Making skeleton...\n")

            env <- .loadFile(rscript, env)
            testfile <- sprintf("%s/test.%s", dirname(rscript), basename(rscript))
            .checkOverwrite(testfile)
            .makeTestFile(rscript, testfile, env)

            cat(sprintf("Wrote skeleton for '%s' to '%s'.\n", basename(rscript), testfile))
        } else {
            .runTest(rscript)
        }
    } else if (length(opts) == 0) {
        .die("R script is not specified!")
    } else {
        cat("Error: Invalid options are specified!\n")
        .showUsage()
    }
}
.runitMain(.sandbox)