R/testCoverageWrapper.R

In MangoTheCat/testCoverage: Analyzing coverage of R unit tests

# dev_mode()
getCollate <- function(packagedir) {
  lst <- try(scan(textConnection(read.dcf(file.path(packagedir, 'DESCRIPTION'), 
    'Collate')), character(0), quiet = TRUE), silent = TRUE)
  if (!is(lst, 'try-error') && !is.na(lst) && length(lst)>0){
    return(lst)
  } else {
    return(NULL)
  }
}

getCorePackages <- function(ind = 1) {
  if (file.exists(R.home('share/make/vars.mk'))) {
    fn <- R.home('share/make/vars.mk')
    re <- read.table(fn, sep = '=', as.is = TRUE)
    re <- scan(text = re[ind, 2],  what = 'character', quiet = TRUE)
  } else {
#       If R installation is different, we can only get information from defaultPackages
    re <- options('defaultPackages')[[1]]
  }
  re
}

# Test packages for code coverage.
# 
# A wrapper function providing a convenient way of running reportCoverage 
# against multiple source packages.
# 
# @param package Vector of package paths, "core" or some the name of a package from 
# CRAN and any combination of the above.
# @param clean Boolean. After each iteration should we clean away all variables 
# in .GlobalEnv? Default TRUE.
# @param r.ver R version string eg. "R-3.0.2". Default is the current version 
# of R.
# @param test.dir String contaning a path to the unit test directory. By 
# default the insts/tests folder is used.
# @param ... Any parameters to pass reportCoverage.
# @return A list with two entries. 
#         The first is a vector of the coverage values and the 
#         second is an environment with test coverage reports generated by 
#         \code{reportCoverage} or \code{buildHTMLreport}.
# @details 
# Source packages must be available either as a path to the package folder or 
# as the name of a package which is downloadable from CRAN.
# 
# This is a convenience function that assumes that the tests for all packages 
# are in the "inst/tests" folder. If not \code{\link{reportCoverage}} should be 
# used with individual packages.
# 
# The parameter r.ver is only necessary only if you want to test 
# 'core' and cause this function has to download the R source.
# @seealso \code{\link{reportCoverage}}
# @author Mango Solutions  \email{support@@mango-solutions.com}
# @export
# @examples
# \dontrun{
# testCoverageWrapper(c('plyr', 'stringr'))
# }


testCoverageWrapper <- function(package, clean = TRUE, 
                r.ver = paste("R", getRversion(), sep = "-"), 
                test.dir = "", ...) {
  ind <- which(package == 'core')
  core.pkg.ind <- which( package %in% getCorePackages() )
  if (length(ind)>0 || length(core.pkg.ind)>0) {
    xs0 <- package[-union(ind, core.pkg.ind)]
    in_dir(tempdir(), 
      {
        if (!file.exists(sprintf('%s.tar.gz', r.ver))) {
          download.file(
            sprintf("http://cran.r-project.org/src/base/R-3/%s.tar.gz", r.ver), 
            sprintf('%s.tar.gz', r.ver))
          untar(sprintf('%s.tar.gz', r.ver))
        }
      }
    )
    if (length(ind)>0) {
      package <- c(xs0, file.path(sprintf('%s/%s/src/library', tempdir(), r.ver), 
        getCorePackages()))
    } else {
      package <- c(xs0, file.path(sprintf('%s/%s/src/library', tempdir(), r.ver), 
        package[core.pkg.ind]))
    }
  }
  executionL <- new.env(parent = emptyenv())
  old.Global <- ls(all.names = TRUE, envir = .GlobalEnv)
  clear.Global <- function() {
    lst <- base::ls(all = TRUE, envir = .GlobalEnv)
    base::rm(list = lst[! (lst %in% old.Global)], envir = .GlobalEnv)
  }
  on.exit(clear.Global()) 
  for(i in seq_along(package)) {
    if (clean)
      clear.Global()
    test.result = try(testCoverageWrapper0(package[i], 
        reportfile = sprintf('coverage_report_%s.html', basename(package[i])), 
        outputfile = sprintf('trace_%s.txt', basename(package[i])), 
        unittestdir = test.dir), 
    silent = T, ...)
    assign(basename(package[i]), test.result, envir = executionL)
  }
  Coverage = as.matrix(eapply(executionL, function(x) {
    re = if (is(x, 'try-error')) 0 
    else sum(x$A[-1, ])/sum(x$A[1, ])
    if (is.nan(re)) re = 0
    re
  }))
  colnames(Coverage) = 'Coverage'
  re = list(Coverage = Coverage, env = executionL)
  re
}

## test x either to be path to source or a package name from CRAN
testCoverageWrapper0 <- function(x, unittestdir, reportfile, ...) {
  is.a.dir <- function(x) {
    file.exists(x) && file.info(x)$isdir
  }


  newSkeleton <- function(pkgPath){
    # We must ensure 'a' < 'A'; or the sorted files are not in correct order and will met a error
    oldlc <- Sys.getlocale('LC_COLLATE')
    on.exit(Sys.setlocale('LC_COLLATE', oldlc))
    Sys.setlocale('LC_COLLATE', 'C')
    f <- function(x) {
      l <- list.files(x)
      ind <- grep('\\.[RrqQ]$', l)
      l <- l[ind]
      if (basename(pkgPath) == 'base') {
        l <- l[(basename(l) %in% c(
          'table.R',
          'stop.R',
          'warnings.R',
          'gl.R',
          'outer.R',
          'zapsmall.R',
          'aperm.R'
        ))]
      }
      l <- sort(l)
      l
    }
    f.res <- function(pkg = basename(pkgPath)) {
      l <- list.files(system.file('test.resources', package = 'testCoverage'), 
        full.names = T)
      #ind = grep(sprintf('^test\\.%s.*\\.[Rr]$',pkg),basename(l))
      #l[ind]
    }
    re <- list()
    stopifnot(is.a.dir(R <- file.path(pkgPath, 'R')))
    re$Collate = getCollate(pkgPath)
    if (is.null(re$Collate)) {
      re$R <- f(R)
    } else {
      re$R <- re$Collate
    }
    if (is.a.dir(tests <- file.path(pkgPath, 'tests'))){
      re$tests <- f(tests)
    }
    if (is.a.dir(testthats <- file.path(pkgPath, 'inst/tests'))){
      re$testthats <- f(testthats)
    }
    if (is.a.dir(unittests <- file.path(pkgPath, 'inst/unittests'))){
      re$unittests <- f(unittests)
    }
    if (is.a.dir(additionaltests <- unittestdir)){
      re$additionaltests <- f(additionaltests)
    }
    re$testable <- TRUE
    if (basename(pkgPath) %in% getCorePackages()) {
      re$extern.tests <- f.res()
    } else 
    if (length(c(re$tests, re$testthats, re$unittests, re$additionaltests)) == 0) {
      cat('No test or test that scripts in the package!\n')
      re$testable <- FALSE
    }
    re
  }

  outpath <- getwd()
  on.exit(setwd(outpath))
  if (!is.a.dir(x)) {
    cat(sprintf('Assuming %s is a package from CRAN.\n', x))
    re <- 
    in_dir(tempdir(), {
      if (!is.a.dir(x)) {
        fn <- download.packages(x, '.', type = 'source')
        untar(fn[2])
      } else {
        fn <- c(basename(x), x)
      }
      if (!(s<-newSkeleton(fn[1]))$testable) {
        cat(sprintf(" %s is not a testable package\n", x))
        return(NULL)
      } 
      b = list(...)
      if (!is.null(s$testthats) || !is.null(s$additionaltests)) {
        if (is.null(b$htmlwd)) {
          if (!is.null(s$testthats)) 
            reportCoverage(
              packagename = fn[1], packagedir = fn[1], htmlwd = outpath, 
              reportfile = paste0(gsub(".html$", "", reportfile), 
                "_internal.html"), ...)
          if (!is.null(s$additionaltests)) 
            reportCoverage(
              packagename = fn[1], packagedir = fn[1], htmlwd = outpath, 
              unittestdir = unittestdir,
              reportfile = paste0(gsub(".html$", "", reportfile), 
                "_additional.html"), ...)
        }  else {
          if (!is.null(s$testthats)) 
            reportCoverage(
              packagename = fn[1], packagedir = fn[1], 
              reportfile = paste0(gsub(".html$", "", reportfile), 
                "_internal.html"), ...)
          if (!is.null(s$additionaltests)) 
            reportCoverage(
              packagename = fn[1], packagedir = fn[1], unittestdir = unittestdir, 
              reportfile = paste0(gsub(".html$", "", reportfile), 
                "_additional.html"), ...)
        }
      } else {
        sfs <- file.path(fn[1], 'R', s$R)
        if (!is.null(s$unittests))
          exfs <- file.path(fn[1], 'inst/unittests', s$unittests)
        else 
        if (!is.null(s$extern.tests))
          exfs <- s$extern.tests
        else
          exfs <- file.path(fn[1], 'tests', s$tests)
        if (is.null(b$htmlwd))
          reportCoverage(packagename = fn[1], htmlwd = outpath, 
          sourcefiles = sfs, 
          executionfiles = exfs , 
          unittestdir = unittestdir, ...)
        else
          reportCoverage(packagename = fn[1], 
          sourcefiles = sfs, 
          executionfiles = exfs, 
          unittestdir = unittestdir, ...)
      }
    })
  } else {
    if (!(s<-newSkeleton(x))$testable) {
      cat(sprintf(" %s is not a testable package\n", x))
      return(NULL)
    } 
    in_dir(outpath, { # avoid possible change of working dir, e.g. MASS
      if (!is.null(s$testthats) || !is.null(s$additionaltests)) {
        if (!is.null(s$testthats)) re <- reportCoverage(packagename = basename(x), 
          packagedir = x, reportfile = paste0(gsub(".html$", "", reportfile), 
            "_internal.html"), ...)
        if (!is.null(s$additionaltests)) re <- reportCoverage(
          packagename = basename(x), packagedir = x, unittestdir = unittestdir, 
          reportfile = paste0(gsub(".html$", "", reportfile), 
            "_additional.html"), ...)
      } else {
        sfs <- file.path(x,'R',s$R)
        if (!is.null(s$unittests))
          exfs <- file.path(x,'inst/unittests',s$unittests)
        else 
        if (!is.null(s$extern.tests))
          exfs <- s$extern.tests
        else
          exfs <- file.path(x,'tests',s$tests)
        re <- reportCoverage(packagename = basename(x), 
          sourcefiles = sfs,
          executionfiles = exfs ,
          unittestdir = unittestdir, 
          #This line will make problem, if we want to set isrunit, we should pass it from ...
          #isrunit = TRUE, runitfileregexp = "\\.[rR]$", runitfuncregexp = "^test.+",
          ...)
      }
    })
  }
  invisible(re)
}


is.a.dir <- function(x) {
  file.exists(x) && file.info(x)$isdir
}

newSkeleton <- function(pkgPath, unittestdir = NULL){
  # We must ensure 'a' < 'A'; or the sorted files are not in correct order and will met a error
  oldlc <- Sys.getlocale('LC_COLLATE')
  on.exit(Sys.setlocale('LC_COLLATE', oldlc))
  Sys.setlocale('LC_COLLATE', 'C')
  f <- function(x) {
    l <- list.files(x)
    ind <- grep('\\.[RrqQ]$', l)
    l <- l[ind]
    ind <- grep('^testthat.R$', l, invert = TRUE)
    l <- l[ind]
    
    if (basename(pkgPath) == 'base') {
      l <- l[(basename(l) %in% c(
        'table.R',
        'stop.R',
        'warnings.R',
        'gl.R',
        'outer.R',
        'zapsmall.R',
        'aperm.R'
      ))]
    }
    l <- sort(l)
    
    if(length(l) == 0)
      return(NULL)
    else
      return(l)
  }
  f.res <- function(pkg = basename(pkgPath)) {
    l <- list.files(system.file('test.resources', package = 'testCoverage'), 
                    full.names = T)
    
  }
  re <- list()
  stopifnot(is.a.dir(R <- file.path(pkgPath, 'R')))
  re$Collate = getCollate(pkgPath)
  if (is.null(re$Collate)) {
    re$R <- f(R)
  } else {
    re$R <- re$Collate
  }
  if (is.a.dir(tests <- file.path(pkgPath, 'tests')))
    re$tests <- f(tests)
  
  if (is.a.dir(testthats <- file.path(pkgPath, 'tests/testthat'))) {
    re$testthats <- f(testthats)
    re$testthatdir <- 'tests/testthat'
  } else if (is.a.dir(testthats <- file.path(pkgPath, 'inst/tests'))) {
    re$testthats <- f(testthats)
    re$testthatdir <- 'inst/tests'
  }
  
  if (is.a.dir(unittests <- file.path(pkgPath, 'inst/unittests')))
    re$unittests <- f(unittests)
  
  if (!is.null(unittestdir) && is.a.dir(additionaltests <- file.path(pkgPath, unittestdir)))
    re$additionaltests <- f(additionaltests)
  
  re$testable <- TRUE
  if (basename(pkgPath) %in% getCorePackages()) {
    re$extern.tests <- f.res()
  } else 
    if (length(c(re$tests, re$testthats, re$unittests, re$additionaltests)) == 0) {
      cat('No test or test that scripts in the package!\n')
      re$testable <- FALSE
    }
  re
}