inst/testScripts/R/launchUtils.R

In HenrikBengtsson/aroma.seq: High-Throughput Sequence Analysis using the Aroma Framework

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Local function
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sourceTestScript <- function(pathname, devel=FALSE, ...) {
  # Argument 'devel':
  devel <- Arguments$getLogical(devel);

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Setup
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Enable support for sibling root paths?
  if (devel) {
    key <- "devel/dropRootPathTags";
    oopts <- setOption(aromaSettings, key, TRUE);
    on.exit({
      setOption(aromaSettings, key, oopts);
    }, add=TRUE);
    # Print settings  
    print(getOption(aromaSettings, key));
  }

  # Use special file cache for testing
  key <- "R.cache::rootPath";
  oopts <- setOption(key, "~/.Rcache,scratch");
  on.exit({
    setOption(key, oopts);
  }, add=TRUE);
  key <- "R.cache::rootPath";
  oopts <- setOption(key, TRUE);
  on.exit({
    setOption(key, oopts);
  }, add=TRUE);


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Process
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  cat("** PATHNAME: ", pathname, "\n", sep="");
  tryCatch({
    pathname <- Arguments$getReadablePathname(pathname);
    source(pathname, echo=TRUE);
    cat("** PATHNAME DONE: ", pathname, "\n", sep="");
  }, error = function(ex) {
    cat("************************************************\n");
    cat("** ", rep(c(" ER", "ROR "), times=6), " **\n", sep="");
    print(ex);
    print(sessionInfo());
    cat("************************************************\n");
    cat("** PATHNAME FAILED: ", pathname, "\n", sep="");
  });
  gc();
} # sourceTestScript()


sourceTestSet <- function(path, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'path':
  path <- Arguments$getReadablePath(path);

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # For each test script...
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  pathnames <- list.files(path=path, pattern="[.]R$", full.names=TRUE);
  cat("TEST SCRIPTS: \n");
  print(pathnames);

  for (pathname in pathnames) {
    if (regexpr("hetero", pathname) != -1)
      next;
    if (regexpr("expectile", pathname) != -1)
      next;
    sourceTestScript(pathname, ...);
  } # for (pathname ...);
} # sourceTestSet()


sourceTestGroups <- function(groups, pattern=".*", order=c("auto", "asis", "reverse", "random"), nbrOfSets=NULL, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'groups':
  groups <- Arguments$getCharacters(groups);

  # Argument 'pattern':
  pattern <- Arguments$getRegularExpression(pattern);

  # Argument 'order':
  order <- match.arg(order);

  # Argument 'nbrOfSets':
  if (!is.null(nbrOfSets)) {
    nbrOfSets <- Arguments$getInteger(nbrOfSets, range=c(1,Inf));
    if (order == "auto") order <- "random";
  }

  if (order == "auto") {
    order <- "asis";
  }

  rootPath <- Arguments$getReadablePath("testScripts/");
  for (group in groups) {
    path <- file.path(rootPath, group);
    path <- Arguments$getReadablePath(path);

    # Find all test sets
    pathnames <- list.files(path=path, recursive=TRUE, full.names=TRUE);
    paths <- dirname(pathnames);
    paths <- unique(paths);
    paths <- paths[sapply(paths, FUN=isDirectory)];

    # Filter
    paths <- grep(pattern, paths, value=TRUE);
    cat("Filtered test sets:\n");
    print(paths);

    if (order == "reverse") {
      paths <- rev(paths);
    } else if (order == "random") {
      paths <- sample(paths);
    }
    cat("All test sets:\n");
    print(paths);

    if (!is.null(nbrOfSets)) {
      cat("Subsetted test sets:\n");
      paths <- paths[1:nbrOfSets];
      print(paths);
    }

    # For each test set...
    for (path in paths) {
      sourceTestSet(path, ...);
    }
  } # for (groups ...);
} # sourceTestGroups()


launchTestGroups <- function(groups="system", ...) {
  sourceTestGroups(groups, ...);
} # launchTestGroups()



############################################################################
# HISTORY:
# 2012-09-14
# o Created.
############################################################################