tests/testthat/test-module-deps-methods.R

In SpaDES.core: Core Utilities for Developing and Running Spatially Explicit Discrete Event Models

test_that("defineModule correctly handles different inputs", {
  testInit("terra", smcc = FALSE)

  tmp <- simInit()
  tmp1 <- simInit()

  # check empty metadata
  x0 <- list()
  expect_warning(defineModule(tmp, x0))
  expect_equivalent(suppressWarnings(defineModule(tmp, x0)),
                   suppressWarnings(defineModule(tmp1, .emptyMetadata())))

  # check each element in metadata
  x1 <- list(
    name = "testModule",
    description = "this is a test.",
    keywords = c("test"),
    childModules = character(),
    authors = c(person(c("Alex", "M"), "Chubaty",
                       email = "alex.chubaty@gmail.com",
                       role = c("aut", "cre"))),
    version = list(testModule = "0.0.0.9000"),
    spatialExtent = terra::ext(rep(0, 4)),
    timeframe = as.POSIXlt(c(NA, NA)),
    timeunit = "year",
    citation = list(),
    documentation = list(),
    reqdPkgs = list("grid", "terra", "sf"),
    parameters = rbind(
      defineParameter("dummyVal", "numeric", 1.0, NA, NA, "vague description
                      with spaces")
    ),
    inputObjects = bindrows(
      expectsInput(objectName = "testInput", objectClass = "list", sourceURL = "", desc = NA_character_),
      expectsInput(objectName = "testInput2", objectClass = "list", sourceURL = "", desc = "another vague
                   description with spaces")
    ),
    outputObjects = bindrows(
      createsOutput(objectName = "testOutput", objectClass = "list", desc = NA_character_),
      createsOutput(objectName = "testOutput", objectClass = "list", desc = "another vague
                    description with spaces for outputs   another space")
    )
  )

  # This is now corrected automatically
  expect_false(any(unlist(lapply(x1, function(v)
    grepl("  |\n", v)))))
  x1 <- rmExtraSpacesEOLList(x1)
  expect_false(any(unlist(lapply(x1, function(v)
    grepl("  |\n", v)))))

  ## check name
  x2 <- x1
  x2$name <- list("testModule") # not a character
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check description
  x2 <- x1
  x2$description <- list("this is a test.") # not a character vector
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check keywords
  x2 <- x1
  x2$keywords <- list("test") # not a character vector
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check authors
  x2 <- x1
  x2$authors <- "not a person class"
  expect_true({defineModule(tmp, x2); TRUE}) # if error, then TRUE not eval'ed

  ## check version
  x2 <- x1
  x2$version <- "0.0.0.9000"
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check spatialExtent
  x2 <- x1
  x2$spatialExtent <- NA
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check timeframe
  x2 <- x1
  x2$timeframe <- NA
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check timeunit
  x2 <- x1
  x2$timeunit <- NA
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check citation
  x2 <- x1
  x2$citation <- character() # not a list
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check reqdPkgs
  x2 <- x1
  x2$reqdPkgs <- c("grid", "terra", "sf") # not a list
  expect_equivalent(defineModule(tmp, x1), defineModule(tmp1, x2))

  ## check parameters
  x2 <- x1
  x2$parameters <- "not a data.frame"
  expect_true({defineModule(tmp, x2); TRUE}) # if error, then TRUE not eval'ed

  ## check inputObjects
  x2 <- x1
  x2$inputObjects <- "not a data.frame"
  expect_true({defineModule(tmp, x2); TRUE}) # if error, then TRUE not eval'ed

  ## check authors
  x2 <- x1
  x2$outputObjects <- "not a person class"
  expect_true({defineModule(tmp, x2); TRUE}) # if error, then TRUE not eval'ed
})

test_that("depsEdgeList and depsGraph work", {
  skip_on_cran() # requires installation of NLMR, from a Git Repo
  testInit(sampleModReqdPkgs)

  origRepos <- getOption("repos")
  print(origRepos)
  if (any(unname(origRepos) == "@CRAN@")) {
    suppressMessages(utils::chooseCRANmirror(ind = 1))
    on.exit({
      options(repos = origRepos)
      print(getOption("repos"))
    } , add = TRUE)
  }
  times <- list(start = 0.0, end = 10)
  params <- list(
    .globals = list(burnStats = "npixelsburned", stackName = "landscape"),
    randomLandscapes = list(.plotInitialTime = NA, .plotInterval = NA),
    caribouMovement = list(.plotInitialTime = NA, .plotInterval = NA),
    fireSpread = list(.plotInitialTime = NA, .plotInterval = NA)
  )
  modules <- list("randomLandscapes", "caribouMovement", "fireSpread")
  paths <- list(modulePath = getSampleModules(tmpdir))

  mySim <- simInit(times, params, modules, paths = paths)

  # depsEdgeList
  el <- depsEdgeList(mySim)
  el_from <- c("caribouMovement", "fireSpread", "fireSpread",
               "fireSpread", "randomLandscapes", "randomLandscapes")
  el_to <- c("caribouMovement", "caribouMovement", "fireSpread", "fireSpread",
             "caribouMovement", "fireSpread")
  el_objName <- c("caribou", "landscape", "landscape",
                  "npixelsburned", "landscape", "landscape")
  el_objClass <- c("SpatialPointsDataFrame", "RasterStack", "RasterStack",
                   "numeric", "RasterStack", "RasterStack")

  el_objClass <- c("SpatVector", "SpatRaster", "SpatRaster",
                   "numeric", "SpatRaster", "SpatRaster")

  expect_is(el, "data.table")
  expect_equal(names(el), c("from", "to", "objName", "objClass"))
  expect_equal(el$from, el_from)
  expect_equal(el$to, el_to)
  expect_equal(el$objName, el_objName)
  expect_equal(el$objClass, el_objClass)

  # .depsPruneEdges
  p <- .depsPruneEdges(el)
  p_from <- c("fireSpread", "randomLandscapes", "randomLandscapes")
  p_to <- c("caribouMovement", "caribouMovement", "fireSpread")
  p_objName <- c("landscape", "landscape", "landscape")
  p_objClass <- c("SpatRaster", "SpatRaster", "SpatRaster")
  p_ <- data.table::data.table(
    from = p_from, to = p_to, objName = p_objName, objClass = p_objClass
  )

  expect_is(p, "data.table")
  expect_equivalent(p, p_)

  # depsGraph
  expect_is(depsGraph(mySim), "igraph")
})

test_that("3 levels of parent and child modules load and show correctly", {
  testInit("terra", smcc = FALSE)

  suppressMessages({
    newModule("grandpar1", tmpdir, type = "parent",
              children = c("child1", "child2", "par1", "par2"), open = FALSE)
    newModule("par1", tmpdir, type = "parent", children = c("child4", "child3"), open = FALSE)
    newModule("par2", tmpdir, type = "parent", children = c("child5", "child6"), open = FALSE)
    newModule("child1", tmpdir, open = FALSE)
    newModule("child2", tmpdir, open = FALSE)
    newModule("child3", tmpdir, open = FALSE)
    newModule("child4", tmpdir, open = FALSE)
    newModule("child5", tmpdir, open = FALSE)
    newModule("child6", tmpdir, open = FALSE)
  })

  fileName <- "child2/child2.R"
  xxx <- readLines(fileName)
  xxx1 <- gsub(xxx, pattern = 'timeunit = "year"', replacement = 'timeunit = "day"')
  cat(xxx1, file = fileName, sep = "\n")

  fileName <- "child3/child3.R"
  xxx <- readLines(fileName)
  xxx1 <- gsub(xxx, pattern = 'timeunit = "year"', replacement = 'timeunit = "week"')
  cat(xxx1, file = fileName, sep = "\n")

  fileName <- "child5/child5.R"
  xxx <- readLines(fileName)
  xxx1 <- gsub(xxx, pattern = 'timeunit = "year"', replacement = 'timeunit = "second"')
  cat(xxx1, file = fileName, sep = "\n")

  fileName <- "par1/par1.R"
  xxx <- readLines(fileName)
  xxx1 <- gsub(xxx, pattern = 'timeunit = "year"', replacement = 'timeunit = "month"')
  cat(xxx1, file = fileName, sep = "\n")

  if (Sys.which("glpsol") == "") {
    if (Sys.info()[['sysname']] == "Darwin") {
      skip("GLPK not available on macOS")
    } else if (Sys.info()[['sysname']] == "Linux") {
      skip("GLPK not available on Linux")
    }
  } else {
    mySim <- simInit(modules = list("grandpar1"), paths = list(modulePath = tmpdir))
    mg <- moduleGraph(mySim, FALSE) ## will be list if successful; NULL if not (no igraph GLPK support)
    if (is(mg, "list")) {
      expect_true(is(mg$graph, "igraph"))
      expect_true(is(mg$communities, "communities"))
      expect_true(length(unique(mg$communities$member)) == 3)
      comm <- try(communities(mg$communities)[["1"]])
      if (!is(comm, "try-error")) {
        expect_true(any(grepl("grandpar1", comm)))
        expect_true(identical(basename(comm), c("grandpar1", "par1", "par2", "child1", "child2")))
      }
    }
  }
})


test_that("Test cleaning up of desc in createsOutputs, expectsInputs, defineParameters", {
  testInit("terra", smcc = FALSE)

  aList <- list()
  aList[[1]] <- expectsInput("ROCList", "list", sourceURL = NA,
               "Hi ", "Ho ", "its off
              to work we go", otherCol = "lala")
  aList[[2]] <- createsOutput("ROCList", "list", # sourceURL = NA,
                    "Hi ", "Ho ", "its off
              to work we go", otherCol = "lala")
  aList[[3]] <- defineParameter("ROCList", "list", NA, NA, NA, # sourceURL = NA,
                              "Hi ", "Ho ", "its off
              to work we go", otherCol = "lala")
  tests <- Map(a = aList,
               nam = c("expectsInput", "createsOutput", "defineParameter"),
               function(a, nam) {
                 expect_true(is(a, "data.frame"))
                 cn <- colnames(a)
                 cn <- tolower(gsub("param", "", cn))
                 actuallyIs <- tolower(sort(c("...", cn)))
                 shouldBe <- tolower(sort(c(formalArgs(get(nam)))))
                 if (!grepl("Param", nam))
                   shouldBe <- sort(c(shouldBe, "othercol"))
                 expect_true(identical(actuallyIs, shouldBe))
                 desc <- a[[grep("desc", tolower(colnames(a)))]]
                 expect_false(grepl("  ", desc))
                 expect_false(grepl("\n", desc))
               })


})