tests/scheduled_tests/regression.R

In airGR: Suite of GR Hydrological Models for Precipitation-Runoff Modelling

# Helper functions for regression

StoreStableExampleResults <- function(
  package = "airGR",
  path = file.path("tests/tmp", Sys.getenv("R_VERSION"), "stable"),
  ...
) {
  install.packages(package, repos = "http://cran.r-project.org")
  StoreExampleResults(package = package, path = path, ...)
}

StoreDevExampleResults <- function(
  package = "airGR",
  path = file.path("tests/tmp", Sys.getenv("R_VERSION"), "dev"),
  ...
) {
  StoreExampleResults(package = package, path = path, ...)
}

#' Run examples of a package and store the output variables in RDS files for further testing.
#'
#' @param package Name of the package from which examples are tested.
#' @param path Path where to record the files.
#' @param run.dontrun See \code{\link{example}}.
#' @param run.donttest See \code{\link{example}}.
#'
#' @return
#' @export
#'
#' @examples
StoreExampleResults <- function(
  package,
  path,
  run.dontrun = FALSE,
  run.donttest = TRUE
) {
  # Install and load stable version of the package
  library(package, character.only = TRUE)

  # Get the list of documentation pages
  rd <- unique(readRDS(system.file("help", "aliases.rds", package = package)))

  unlink(path, recursive = TRUE)
  dir.create(path, recursive = TRUE)

  lapply(
    rd,
    StoreTopicResults,
    package,
    path,
    run.dontrun = run.dontrun,
    run.donttest = run.donttest
  )
}

StoreTopicResults <- function(
  topic,
  package,
  path,
  run.dontrun = TRUE,
  run.donttest = TRUE,
  items_ignored = "FUN_.*",
  max_item_depth = 4
) {
  cat("*******************************\n")
  cat("*", topic, "\n")
  cat("*******************************\n")

  par(ask = FALSE) #https://stackoverflow.com/questions/34756905/how-to-turn-off-the-hit-return-to-see-next-plot-prompt-plot3d

  varBefore <- c()
  varBefore <- ls(envir = globalenv())

  start_time = Sys.time()

  example(
    topic,
    package = package,
    character.only = TRUE,
    echo = FALSE,
    ask = FALSE,
    local = FALSE,
    setRNG = TRUE,
    run.dontrun = run.dontrun,
    run.donttest = run.donttest
  )

  end_time <- Sys.time()
  dev.off()

  write.table(
    data.frame(topic = topic, time = end_time - start_time),
    file.path(path, "timing.tsv"),
    row.names = FALSE,
    col.names = FALSE,
    quote = FALSE,
    sep = "\t",
    append = TRUE
  )

  varAfter <- ls(envir = globalenv())

  varToSave <- setdiff(varAfter, varBefore)

  if (length(varToSave) > 0) {
    path <- file.path(path, topic)
    dir.create(path, showWarnings = FALSE, recursive = TRUE)
    lapply(varToSave, function(x) {
      v <- get(x)
      if (is.function(v)) {
        return(NULL)
      }
      # If v is a list, remove ignored items recursively
      remove_ignored_items <- function(
        x,
        depth = 0,
        max_depth = max_item_depth
      ) {
        if (depth > max_depth) {
          return(x)
        }

        # Only recurse into plain lists (avoid breaking data.frames)
        if (is.list(x) && !inherits(x, "data.frame")) {
          # Recurse first
          x <- lapply(x, function(item) remove_ignored_items(item, depth + 1))
          # Drop named elements matching the pattern
          nm <- names(x)
          if (!is.null(nm)) {
            keep <- !grepl(items_ignored, nm)
            x <- x[keep]
          }
        }
        x
      }
      v <- remove_ignored_items(v)
      saveRDS(v, file = file.path(path, paste0(x, ".rds")))
    })
  }

  rm(list = varToSave, envir = globalenv())
}

CompareStableDev <- function() {
  Sys.setenv(RUN_REGRESSION_TESTS = "true")
  res <- testthat::test_file("tests/testthat/test-regression.R")
  dRes <- as.data.frame(res)
  if (any(dRes[, "failed"] > 0) | any(dRes[, "error"])) {
    quit(status = 1)
  }
}

###############
# MAIN SCRIPT #
###############

# Execute Regression test by comparing RD files stored in folders /tests/tmp/ref and /tests/tmp/test
Args <- commandArgs(trailingOnly = TRUE)

lActions <- list(
  stable = StoreStableExampleResults,
  dev = StoreDevExampleResults,
  compare = CompareStableDev
)

if (length(Args) == 1 && Args %in% names(lActions)) {
  invisible(lActions[[Args]]())
} else {
  stop(
    "This script should be run with one argument in the command line:\n",
    "`Rscript tests/regression_tests.R [stable|dev|compare]`.\n",
    "Available arguments are:\n",
    "- stable: install stable version from CRAN, run and store examples\n",
    "- dev: install dev version from current directory, run and store examples\n",
    "- compare: stored results of both versions"
  )
}