tests/testthat/test-misc.R

In reproducible: Enhance Reproducibility of R Code

test_that("test miscellaneous fns (part 1)", {
  # ONLY RELEVANT FOR RASTERS
  testInit("raster", tmpFileExt = c(".tif", ".grd"))

  expect_is(searchFullEx(), "list")
  expect_true(length(searchFullEx()) > length(search()))
  expect_true(length(searchFullEx()) == (3 + length(search())))

  expect_true(all(unlist(lapply(searchFull(simplify = FALSE), is.environment))))
  test <- lapply(searchFull(simplify = FALSE), attributes)
  test <- grep("withr_handler", value = TRUE, test, invert = TRUE)
  expect_true(all(is.character(unlist(test))))

  # NO LONGER RELIABLE TEST BECAUSE OF NEW REMOVAL OF PACKAGES fEB 24 2021
  # expect_true(sum(unlist(d1)) < sum(unlist(d)))

  # convertRasterPaths
  filenames <- normalizePath(c("/home/user1/Documents/file.txt", "/Users/user1/Documents/file.txt"),
    winslash = "/", mustWork = FALSE
  )
  oldPaths <- dirname(filenames)
  newPaths <- normalizePath(c("/home/user2/Desktop", "/Users/user2/Desktop"),
    winslash = "/", mustWork = FALSE
  )
  expect_true(grepl(newPaths[1], convertPaths(filenames, oldPaths, newPaths)[1]))

  r1 <- raster::raster(system.file("external/test.grd", package = "raster"))
  r2 <- raster::raster(system.file("external/rlogo.grd", package = "raster"))
  rasters <- list(r1, r2)
  oldPaths <- system.file("external", package = "raster")
  newPaths <- file.path("~/rasters")
  rasters <- convertRasterPaths(rasters, oldPaths, newPaths)

  ## spurious failures non-interactively when not sorting
  expect_true(identical(
    sort(unlist(lapply(rasters, raster::filename))),
    sort(normPath(file.path(newPaths, basename(unlist(lapply(list(r1, r2), raster::filename))))))
  ))

  r3 <- suppressWarnings(writeRaster(r1, tmpfile[1], overwrite = TRUE)) ## TODO: raster needs updating for crs stuff
  r4 <- suppressWarnings(convertRasterPaths(tmpfile[1], dirname(tmpfile[1]), newPaths)) ## TODO: raster needs updating for crs stuff

  expect_true(identical(
    normPath(file.path(newPaths, basename(filename(r4)))),
    normPath(filename(r4))
  ))

  expect_silent({
    b <- retry(quote(rnorm(1)), retries = 1, silent = TRUE)
  })
  expect_error({
    b <- retry(quote(stop()), retries = 1, silent = TRUE)
  })

  expect_true(identical(NULL, basename2(NULL)))
  a <- .formalsNotInCurrentDots(rnorm, n = 1, b = 2)
  b <- .formalsNotInCurrentDots(rnorm, dots = list(n = 1, b = 2))
  expect_identical(a, b)
})

test_that("objSize and objSizeSession", {
  skip_on_cran()
  # objectSize
  a <- 1
  b <- tempfile()
  saveRDS(a, b)
  expect_true(is.numeric(objSize(asPath(b))))
  expect_true(is(objSize(asPath(b)), "lobstr_bytes"))
})

test_that("setting options works correctly", {
  testInit(verbose = 1, ask = TRUE)

  a <- reproducibleOptions()

  # The keep is during terra-migration
  keep <- setdiff(names(a), c(
    "reproducible.rasterRead",
    "reproducible.cachePath",
    "reproducible.overwrite", # This is a bug # TODO... something prior to this test is changing it
    "reproducible.useDBI",
    # "reproducible.cacheSaveFormat",
    "reproducible.shapefileRead"
  ))
  a <- a[keep]

  a1 <- a[sapply(a, function(x) !is.null(x))]
  b <- options()
  # b$reproducible.verbose <- as.numeric(b$reproducible.verbose)
  bbb <- match(names(b), names(a1))
  # expect_true(identical(sort(names(a1)), sort(names(a1[na.omit(bbb)]))))
  expect_true(identical(sort(names(a1)), sort(names(a1[bbb[!is.na(bbb)]]))))
  # omit <- c(names(testInitOut$opts), names(testInitOut$optsAsk),
  #          "reproducible.inputPath", "reproducible.tempPath")
  b1 <- b[names(a1)]
  # b1 <- b1[!names(b1) %in% omit]
  a2 <- a1 # [!names(a1) %in% omit]
  expect_identical(b1, a2)
})

test_that("guessAtTargetAndFun works correctly", {
  testInit("terra")

  # expect_error(.guessAtTargetAndFun(fun = rnorm), "fun must be a")
  expect_message(
    .guessAtTargetAndFun(targetFilePath = NULL, filesExtracted = "", fun = "load"),
    "Don't know which file to load"
  )
  expect_message(
    .guessAtTargetAndFun(targetFilePath = NULL, filesExtracted = "hi.rds", fun = "readRDS"),
    "targetFile was not specified."
  )
  expect_message(
    .guessAtTargetAndFun(targetFilePath = NULL, filesExtracted = c("hi.rds", "hello.rds"), fun = "readRDS"),
    "More than one possible files to load"
  )
})

test_that("unrar is working as expected", {
  testInit("terra", tmpFileExt = c(".tif", ".grd"))

  rarPath <- file.path(tmpdir, "tmp.rar")
  out <- try(utils::zip(zipfile = rarPath, files = tmpfile)) # this should only be relevant if system can unrar
  if (!is(out, "try-error")) {
    unrar <- .whichExtractFn(archive = rarPath, args = "")
    expect_true(identical(unrar$fun, "unrar"))
    suppressWarnings(
      expect_error(.callArchiveExtractFn(unrar$fun, files = "", args = list(exdir = tmpCache)))
    )
  }
})

test_that("test miscellaneous fns (part 2)", {
  testInit("terra",
    tmpFileExt = c(".tif", ".grd"),
    needGoogleDriveAuth = TRUE,
    opts = list("reproducible.cloudFolderID" = NULL)
  )
  on.exit(
    {
      try(googledrive::drive_rm(googledrive::as_id(cloudFolderID)), silent = TRUE)
      try(googledrive::drive_rm(googledrive::as_id(tmpCloudFolderID)), silent = TRUE)
    },
    add = TRUE
  )

  ras <- terra::rast(terra::ext(0, 1, 0, 1), res = 1, vals = 1)
  ras <- terra::writeRaster(ras, file = tmpfile[1], overwrite = TRUE)

  gdriveLs1 <- data.frame(name = "GADM", id = "sdfsd", drive_resource = list(sdfsd = 1))
  tmpCloudFolderID <- checkAndMakeCloudFolderID(create = TRUE)
  gdriveLs <- driveLs(cloudFolderID = NULL, "sdfsdf")
  expect_true(NROW(gdriveLs) == 0)
  expect_true(is(checkAndMakeCloudFolderID("testy"), "dribble") ||
    is(checkAndMakeCloudFolderID("testy"), "character"))
  cloudFolderID <- checkAndMakeCloudFolderID("testy", create = TRUE)
  testthat::with_mock(
    "reproducible::retry" = function(..., retries = 1) TRUE,
    {
      if (useDBI()) {
        # Need to convert to cloudUpload from Cache
        mess1 <- capture_messages(
          capture_warnings( # about cache repo -- not the point here
            expect_error(
              cloudUploadFromCache( # outputToSave = ,
                isInCloud = FALSE, outputHash = "sdfsiodfja",
                # gdriveLs = gdriveLs1,
                cloudFolderID = cloudFolderID,
                cachePath = tmpCache
              )
            )
          )
        )
      }
    }
  )

  a <- cloudUploadRasterBackends(ras, cloudFolderID = cloudFolderID)
  mess1 <- capture_messages(expect_error(expect_warning({
    a <- cloudDownload(
      outputHash = "sdfsd", newFileName = "test.tif",
      gdriveLs = gdriveLs1, cloudFolderID = "testy", cachePath = tmpCache
    )
  })))
  expect_true(grepl("Downloading cloud copy of test\\.tif", mess1))
  testthat::with_mock(
    "reproducible::retry" = function(..., retries = 1) TRUE,
    {
      # cloudFolderID can't be meaningless "character", but retry is TRUE
      warns <- capture_warnings({
        err <- capture_error({
          cloudDownloadRasterBackend(output = ras, cachePath = tmpCache, cloudFolderID = "character")
        })
      })
      expect_true(is.null(err))
    }
  )

  # testthat::with_mock(
  #   "reproducible::retry" = function(..., retries = 1) TRUE,
  #   {
  #     mess1 <- capture_messages({
  #       warn <- capture_warnings(
  #       err <- capture_error({
  #         cloudUploadFromCache(isInCloud = FALSE, outputHash = "sdsdfs", # saved = "life",
  #                              cachePath = tmpCache)
  #       }))
  #     })
  #     expect_true(all(grepl("cloudFolderID.*is missing, with no default", err)))
  #   })

  a <- new.env(parent = emptyenv())
  a$a <- list(ras, ras)
  expect_true(all(unlist(isOrHasRaster(a))))
})

test_that("Filenames for environment", {
  testInit(c("terra"),
    tmpFileExt = c(".tif", ".grd", ".tif", ".tif", ".grd"),
    opts = list("reproducible.ask" = FALSE)
  )

  s <- new.env(parent = emptyenv())
  s$r <- terra::rast(terra::ext(0, 10, 0, 10), vals = 1, res = 1)
  s$r2 <- terra::rast(terra::ext(0, 10, 0, 10), vals = 1, res = 1)
  s$r <- suppressWarningsSpecific(
    terra::writeRaster(s$r, filename = tmpfile[1], overwrite = TRUE),
    "NOT UPDATED FOR PROJ >= 6"
  )
  s$r2 <- suppressWarningsSpecific(
    terra::writeRaster(s$r2, filename = tmpfile[3], overwrite = TRUE),
    "NOT UPDATED FOR PROJ >= 6"
  )
  s$s <- c(s$r, s$r2)
  s$b <- terra::writeRaster(s$s, filename = tmpfile[5], overwrite = TRUE)

  Fns <- Filenames(s)

  fnsGrd <- unlist(normPath(Filenames(s$b)))
  expect_true(identical(c(Fns[["b1"]], Fns[["b2"]]), fnsGrd))
  expect_true(identical(Fns[["r"]], normPath(Filenames(s$r))))
  expect_true(identical(Fns[["r2"]], normPath(Filenames(s$r2))))
  expect_true(identical(
    c(Fns[["s1"]], Fns[["s2"]]),
    sapply(seq_len(nlayers2(s$s)), function(rInd) normPath(Filenames(s$s[[rInd]])))
  ))

  FnsR <- Filenames(s$r)
  expect_true(identical(FnsR, normPath(Filenames(s$r))))

  FnsS <- Filenames(s$s)
  expect_true(identical(FnsS, sapply(
    seq_len(nlayers2(s$s)),
    function(rInd) normPath(Filenames(s$s[[rInd]]))
  )))

  FnsB <- Filenames(s$b)
  expect_true(identical(FnsB, fnsGrd))

  # Another stack with identical files
  rlogoFiles <- system.file("ex/test.grd", package = "terra")
  rlogoFiles <- c(rlogoFiles, gsub("grd$", "gri", rlogoFiles))
  secondSet <- file.path(tmpdir, c("one.grd", "one.gri"))
  res <- suppressWarnings(file.link(rlogoFiles, secondSet))
  if (all(res)) {
    b <- c(terra::rast(rlogoFiles[1]), terra::rast(secondSet[1]))
    expect_true(identical(sort(normPath(c(rlogoFiles, secondSet))), sort(Filenames(b))))
  }

  # Test duplicated filenames in same Stack
  b <- c(terra::rast(rlogoFiles[1]), terra::rast(rlogoFiles[1]))
  expect_true(identical(sort(normPath(c(rlogoFiles))), unique(sort(Filenames(b, allowMultiple = TRUE)))))

  rlogoFiles <- system.file("ex/test.grd", package = "terra")
  rlogoDir <- dirname(rlogoFiles)
  b <- terra::rast(rlogoFiles)
  rlogoFiles <- c(rlogoFiles, gsub("grd$", "gri", rlogoFiles))
  expect_true(identical(
    sort(normPath(dir(pattern = "test", rlogoDir, full.names = TRUE))),
    sort(Filenames(b))
  ))
})

test_that("test miscellaneous fns", {
  testInit(opts = list(datatable.print.class = FALSE))

  x1 <- append(as.list(c(0, 1, -1, 10^(-(1:10)))), as.list(c(0L, 1L)))
  a <- lapply(x1, roundTo6Dec)

  # Keeps class
  expect_true(all(unlist(lapply(seq_along(x1), function(y) identical(class(x1[[y]]), class(a[[y]]))))))
  whBig <- which(x1 >= 10e-7)
  expect_true(identical(x1[whBig], a[whBig]))
  whSmall <- which(abs(unlist(x1)) < 10e-7 & unlist(x1) != 0)
  expect_false(all(unlist(lapply(whSmall, function(ws) identical(x1[[ws]], a[[ws]])))))
  whWhole <- which(unlist(x1) %% 1 != unlist(x1))
  expect_true(all(unlist(lapply(whWhole, function(ws) identical(x1[[ws]], a[[ws]])))))
  whZero <- which(unlist(x1) == 0)
  expect_true(all(unlist(lapply(whZero, function(ws) identical(x1[[ws]], a[[ws]])))))

  out <- capture_messages(messageDF(cbind(a = 1.1232), round = 2))
  expect_true(is.character(out))
  expect_identical(length(out), 2L) ## TODO: only passes when run line by line interactively
  expect_true(is.numeric(as.numeric(gsub("\033.*", "", gsub(".*: ", "", out)[2]))))

  out <- capture_messages(messageDF(cbind(a = 1.1232), round = 2, colnames = FALSE))
  expect_true(is.character(out))
  expect_identical(length(out), 1L) ## TODO: only passes when run line by line interactively

  expect_true(is.numeric(as.numeric(gsub("\033.*", "", gsub(".*: ", "", out)))))


  out <- capture_messages(messageDF(1.1232, round = 2, colnames = TRUE))
  expect_true(is.character(out))
  expect_identical(length(out), 2L) ## TODO: only passes when run line by line interactively
  expect_true(is.numeric(as.numeric(gsub("\033.*", "", gsub(".*: ", "", out)[2]))))
})

test_that("test set.randomseed", {
  skip_if(getRversion() < "4.2") # Can't figure out why this doesn't wok
  testInit()

  N <- 1e4
  a <- integer(N)
  for (i in 1:N) {
    a[i] <- set.randomseed()
  }
  expect_false(any(duplicated(a)))
})