Nothing
test_that("prepInputs doesn't work (part 1)", {
skip_on_cran()
skip_on_ci()
testInit("terra", opts = list(
"rasterTmpDir" = tempdir2(rndstr(1, 6)),
"reproducible.inputPaths" = NULL,
"reproducible.overwrite" = TRUE,
reproducible.showSimilar = TRUE
), needInternet = TRUE)
options(reproducible.cachePath = tmpdir)
# Add a study area to Crop and Mask to
# Create a "study area"
coords <- structure(c(-122.98, -116.1, -99.2, -106, -122.98, 59.9, 65.73, 63.58, 54.79, 59.9),
.Dim = c(5L, 2L)
)
StudyArea <- terra::vect(coords, "polygons")
terra::crs(StudyArea) <- crsToUse
dPath <- file.path(tmpdir, "ecozones")
### url
url <- "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip"
noisyOutput <- capture.output({
mess <- capture_messages({
shpEcozone <- prepInputs(destinationPath = dPath, url = url)
})
})
expect_true(any(grepl(mess, pattern = "ecozone_shp[.]zip")))
expect_true(any(grepl(mess, pattern = "Appending")))
# expect_true(any(grepl(mess, pattern = "Finished")))
expect_true(is(shpEcozone, vectorType()))
# Robust to partial file deletions:
unlink(dir(dPath, full.names = TRUE)[1:3])
expect_error(terra::vect(file.path(dPath, "ecozone_shp.zip")))
rm(shpEcozone)
noisyOutput <- capture.output({
shpEcozone1 <- prepInputs(destinationPath = dPath, url = url)
})
expect_true(is(shpEcozone1, vectorType()))
unlink(dPath, recursive = TRUE)
### url, targetFile, alsoExtract ######g
# Once this is done, can be more precise in operational code:
# specify targetFile, alsoExtract, and fun, wrap with Cache
ecozoneFilename <- file.path(dPath, "Ecozones/ecozones.shp")
ecozoneFiles <- c(
"ecozones.dbf",
"ecozones.prj",
"ecozones.sbn",
"ecozones.sbx",
"ecozones.shp",
"ecozones.shx"
)
noisyOutput <- capture.output({
shpEcozone2 <- prepInputs(
targetFile = ecozoneFilename,
url = "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip",
alsoExtract = ecozoneFiles,
destinationPath = dPath
)
})
if (.requireNamespace("sf")) {
expect_true(is(shpEcozone2, "sf"))
testObj <- if (!is(shpEcozone1, "sf")) as(shpEcozone1, "sf") else shpEcozone1
}
# As of Jan 2022 -- these objects are very different; character encoding of accents, numbers interpreted as character
# expect_equivalent(testObj, shpEcozone2) # different attribute newCache
### url, targetFile, alsoExtract -- with Cache
# specify targetFile, alsoExtract, and fun, wrap with Cache -- it is wrong b/c no subfolder
ecozoneFilename <- file.path(dPath, "ecozones.shp")
# Note, you don't need to "alsoExtract" the archive... if the archive is not there, but the
# targetFile is there, it will not redownload the archive.
unlink(dirname(ecozoneFilename), recursive = TRUE)
# Test useCache = FALSE -- doesn't error and has no "loading from cache" or "loading from memoised"
# aaaa <<- 1
# on.exit(rm(aaaa, envir = .GlobalEnv))
noisyOutput <- capture.output({
warn <- suppressWarningsSpecific(
falseWarnings = "attribute variables are assumed to be spatially constant",
{
mess <- capture_messages({
shpEcozoneSm <- Cache(
prepInputs(
url = "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip",
targetFile = reproducible::asPath(ecozoneFilename),
alsoExtract = reproducible::asPath(ecozoneFiles),
studyArea = StudyArea,
destinationPath = dPath,
filename2 = "EcozoneFile.shp",
useCache = FALSE
),
quick = "destinationPath"
)
})
}
)
})
expect_false(all(grepl("loading", mess)))
# Test useCache -- doesn't error and loads from cache
mess <- capture_messages({
warn <- suppressWarningsSpecific(
falseWarnings = "attribute variables are assumed to be spatially constant",
{
shpEcozoneSm <- Cache(
prepInputs(
url = "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip",
targetFile = reproducible::asPath(ecozoneFilename),
alsoExtract = reproducible::asPath(ecozoneFiles),
studyArea = StudyArea,
destinationPath = dPath,
filename2 = "EcozoneFile.shp",
useCache = TRUE # with useTerra = TRUE, this is only for loading, not postProcess
),
quick = "destinationPath"
)
}
)
})
expect_true(any(grepl(.message$LoadedCacheResult(), mess)))
## archive
## don't pass url -- use local copy of archive only
## use purge = TRUE to rm checksums file, rewrite it here
noisyOutput <- capture.output({
shpEcozone <- prepInputs(
destinationPath = dPath,
archive = file.path(dPath, "ecozone_shp.zip"), purge = TRUE
)
})
expect_true(is(shpEcozone, vectorType()))
### archive, alsoExtract char
shpEcozone <- prepInputs(
destinationPath = dPath,
archive = file.path(dPath, "ecozone_shp.zip"),
alsoExtract = c(
"ecozones.dbf", "ecozones.prj", "ecozones.sbn",
"ecozones.sbx", "ecozones.shp", "ecozones.shx"
)
)
expect_true(is(shpEcozone, vectorType()))
rm(shpEcozone)
expect_false(exists("shpEcozone", inherits = FALSE))
### url, alsoExtract, archive
# try again with url - should *not* download, even though checksums came from the
# prepInputs that had locally generated -- confirming that checksums with a manually copied file will work
# instead of forcing prepInputs to get the file.
shpEcozone <- prepInputs(
destinationPath = dPath,
url = "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip",
archive = file.path(dPath, "ecozone_shp.zip"),
alsoExtract = c(
"ecozones.dbf", "ecozones.prj", "ecozones.sbn",
"ecozones.sbx", "ecozones.shp", "ecozones.shx"
)
)
expect_true(is(shpEcozone, vectorType()))
})
test_that("interactive prepInputs", {
skip_on_cran()
skip_on_ci()
testInit("terra",
opts = list(
"rasterTmpDir" = tempdir2(rndstr(1, 6)),
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
# skip_if_not(isInteractive())
#######################################
### url
# tmpdir <- "data/FMA"
# checkPath(tmpdir, create = TRUE)
noisyOutput <- capture.output({
warns <- capture_warnings({
test <- prepInputs(
url = "https://drive.google.com/file/d/1BNsUiMqENJa0I8gzhO68K307ySPHbdGk/view?usp=sharing",
destinationPath = tmpdir
)
})
})
files <- dir(tmpdir, pattern = "FMA_Boundary")
expect_true(length(files) == 9)
expect_true(inherits(test, vectorType()))
#######################################
### url, targetFile
# need authentication for this
# tmpdir <- "data/FMA"
# checkPath(tmpdir, create = TRUE)
noisyOutput <- capture.output({
warns <- capture_warnings({
test <- prepInputs(
targetFile = "FMA_Boundary_Updated.shp",
url = "https://drive.google.com/file/d/1BNsUiMqENJa0I8gzhO68K307ySPHbdGk",
destinationPath = tmpdir
)
})
})
# There is a meaningless warning for this unit test -- ignore it :
# In rgdal::readOGR(dirname(x), fn, stringsAsFactors = stringsAsFactors, :
# Z-dimension discarded
expect_true(inherits(test, vectorType()))
# From Bird/Tati project
testInit("terra",
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
birdSpecies <- c("BBWA", "YRWA")
urls <- c(
"https://drive.google.com/open?id=1CmzYNpxwWr82PoRSbHWG8yg2cC3hncfb",
"https://drive.google.com/open?id=11Hxk0CcwJsoAnUgfrwbJhXBJNM5Xbd9e"
)
#######################################
### url, targetFile, archive
outsideModule <- Map(
x = birdSpecies, url = urls,
MoreArgs = list(tmpdir = tmpdir),
function(x, url, tmpdir) {
ras <- prepInputs(
targetFile = paste0(x, "_currmean.asc"),
archive = paste0(x, "_current.zip"),
# fun = "raster::raster",
url = url,
destinationPath = tmpdir,
overwrite = TRUE
)
}
)
expect_true(inherits(outsideModule[[1]], rasterType()))
expect_true(inherits(outsideModule[[2]], rasterType()))
# expect_true(inherits(terra::crs(outsideModule[[2]]), "CRS"))
# expect_true(inherits(crs(outsideModule[[1]]), "CRS"))
expect_false(identical(outsideModule[[1]], outsideModule[[2]]))
# remove the .prj files -- test "similar"
#######################################
### url, targetFile, archive, alsoExtract similar
file.remove(grep(
pattern = "asc|zip|CHECK",
invert = TRUE, value = TRUE,
dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))]
))
outsideModule <- Map(
x = birdSpecies, url = urls,
MoreArgs = list(tmpdir = tmpdir),
function(x, url, tmpdir, purge) {
ras <- prepInputs(
targetFile = paste0(x, "_currmean.asc"),
archive = paste0(x, "_current.zip"),
url = url,
# fun = "raster::raster",
alsoExtract = "similar",
destinationPath = tmpdir,
overwrite = TRUE
)
}
)
expect_true(inherits(outsideModule[[1]], rasterType()))
expect_true(inherits(outsideModule[[2]], rasterType()))
# expect_true(inherits(crs(outsideModule[[2]]), "CRS"))
# expect_true(inherits(crs(outsideModule[[1]]), "CRS"))
expect_true(!is.na(crs(outsideModule[[1]])))
expect_false(identical(outsideModule[[1]], outsideModule[[2]]))
# remove the .prj files -- test "similar"
file.remove(grep(
pattern = "asc|zip|CHECK",
invert = TRUE, value = TRUE,
dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))]
))
#######################################
### url, targetFile, archive, alsoExtract NA
# because alsoExtract is NA ... no other files are unzipped, so no .prj and so no CRS
outsideModule <- Map(
x = birdSpecies, url = urls,
MoreArgs = list(tmpdir = tmpdir),
function(x, url, tmpdir, purge) {
ras <- prepInputs(
targetFile = paste0(x, "_currmean.asc"),
archive = paste0(x, "_current.zip"),
url = url,
alsoExtract = NULL,
destinationPath = tmpdir,
overwrite = TRUE
)
}
)
expect_true(inherits(outsideModule[[1]], rasterType()))
expect_true(inherits(outsideModule[[2]], rasterType()))
expect_false(identical(terra::crs(outsideModule[[1]]), "")) # now with subfolders & all files, has crs
expect_false(identical(outsideModule[[1]], outsideModule[[2]]))
})
test_that("preProcess doesn't work", {
skip_on_cran()
skip_on_ci()
skip_if_not(isInteractive())
testInit("terra",
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
cls <- rasterType()
# cls <- .fileExtsKnown()[.fileExtsKnown()[, "extension"] == "tif", "type"]
# Note urlShapefiles1Zip, urlShapefilesZip, and urlTif1 are in helper-allEqual.R
# # # # # Comment
##### url
# # # # # Comment
noisyOutput <- capture.output({ # the sf::st_read
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(url = urlTif1, destinationPath = tmpdir)
})
})
})
runTest("1_2_7_10_13", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
# 2nd time # no targetFile, but since url is simple, can guess correctly
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(url = urlTif1, destinationPath = tmpdir)
})
})
runTest("1_2_8_10", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# url is an archive on googledrive -- can get file.info from remote -- so can do checksums
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(url = urlShapefiles1Zip, destinationPath = tmpdir)
})
})
})
runTest("1_4_7_10_12_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", # the file name is actually Shapefile1...
tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warning({
test <- prepInputs(url = urlShapefiles1Zip, destinationPath = tmpdir)
})
})
})
runTest("1_8_9_10_12", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
###### url, targetFile
# # # # # Comment
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(url = urlTif1, targetFile = basename(urlTif1), destinationPath = tmpdir)
})
})
})
runTest("1_2_7_13", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(url = urlTif1, targetFile = basename(urlTif1), destinationPath = tmpdir)
})
})
runTest("1_2_8", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# url is an archive on googledrive --
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefiles1Zip, targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
## 2nd time; can checksums
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefiles1Zip, targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
})
runTest("1_2_8_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
###### url, alsoExtract
# # # # # Comment
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(url = urlTif1, alsoExtract = "DEM.tif", destinationPath = tmpdir)
})
})
})
runTest("1_2_7_10_13", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
# 2nd time # can use checksums, even though don't have targetFile, b/c simple url
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlTif1,
alsoExtract = "DEM.tif",
destinationPath = tmpdir
)
})
})
runTest("1_2_8_10", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# url is an archive on googledrive --
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefiles1Zip,
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
})
runTest("1_4_7_10_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can't checksums because no targetfile
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefiles1Zip,
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
})
runTest("1_8_9_10", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
###### url, archive
# # # # # Comment
# url is an archive on googledrive -- here, zip has 2 Shapefile filesets -- Shapefile1* and Shapefile2*
# should extract all
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
destinationPath = tmpdir
)
})
})
})
runTest("1_4_7_10_12_13", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
destinationPath = tmpdir
)
})
})
runTest("1_8_9_10_12", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
###### url, archive, targetFile
# # # # # Comment
# url is an archive on googledrive --
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefiles1Zip,
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefiles1Zip,
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
})
runTest("1_2_8_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
###### url, targetFile, alsoExtract #####
# # # # # Comment
# url is an archive on googledrive --
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
targetFile = "Shapefile1.shp",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
targetFile = "Shapefile1.shp",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_2_8_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
targetFile = "Shapefile1.shp",
alsoExtract = c("similar"),
destinationPath = tmpdir
)
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
noisyOutput <- capture.output({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlTif1,
targetFile = "DEM.tif",
alsoExtract = c("DEM.tif"),
destinationPath = tmpdir
)
})
})
})
runTest("1_2_7_13", cls, 1, mess,
expectedMess = expectedMessage,
filePattern = "DEM", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
##### url, archive, alsoExtract #####
# # # # # Comment
# url is an archive on googledrive --
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
alsoExtract = "similar",
destinationPath = tmpdir
)
})
})
runTest("1_4_7_10_12_13", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
alsoExtract = "similar",
destinationPath = tmpdir
)
})
})
runTest("1_8_9_10_12", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
expect_error({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
})
unlink(dir(tmpdir, full.names = TRUE))
# # # # # # Comment
###### url, targetFile, alsoExtract #####
# # # # # Comment
# url is an archive on googledrive --
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
alsoExtract = "similar",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
alsoExtract = "similar",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_8_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shx"),
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shx"),
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_8_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
unlink(dir(tmpdir, full.names = TRUE))
# # # # # Comment
###### url, archive, targetFile, alsoExtract #####
# # # # # Comment
# url is an archive on googledrive --
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
alsoExtract = "similar",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_4_7_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
url = urlShapefilesZip,
archive = "Shapefiles1.zip",
alsoExtract = "similar",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_8_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# # # # # Comment
###### archive
# # # # # Comment
# archive exists locally
# remove all non archive files
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
destinationPath = tmpdir
)
})
})
runTest("1_4_9_10_13", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
destinationPath = tmpdir
)
})
})
runTest("1_9_10_12", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# # # # # Comment
###### archive, targetFile
# # # # # Comment
# archive exists locally
# remove all non archive files
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_4_9_13", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
destinationPath = tmpdir
)
})
})
runTest("1_2_9", vectorType(), 9, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# # # # # Comment
###### archive, targetFile, alsoExtract #####
# # # # # Comment
# archive exists locally
# remove all non archive files
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_2_4_9_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_2_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE
))
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "CHECKSUMS.txt", value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
alsoExtract = "similar",
destinationPath = tmpdir
)
})
})
runTest("1_2_4_9_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
alsoExtract = c("similar"),
destinationPath = tmpdir
)
})
})
runTest("1_2_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# # # # # Comment
###### targetFile
# # # # # Comment
file.remove(grep(dir(tmpdir, full.names = TRUE), pattern = "CHECKSUMS.txt", value = TRUE))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(targetFile = "Shapefile1.shp", destinationPath = tmpdir)
})
})
runTest("1_2", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(targetFile = "Shapefile1.shp", destinationPath = tmpdir)
})
})
runTest("1_2", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# # # # # Comment
###### targetFile, alsoExtract
# # # # # Comment
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "CHECKSUMS.txt", value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
targetFile = "Shapefile1.shp",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_2", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
targetFile = "Shapefile1.shp",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_2", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# # # # # Comment
###### alsoExtract -- previously failed b/c no information; now ok-- .guessAtTargetAndFun #####
# # # # # Comment
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "CHECKSUMS.txt", value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
# # # # # Comment
###### archive, alsoExtract
# # # # # Comment
# archive exists locally
# remove all non archive files
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE
))
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "CHECKSUMS.txt", value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_4_9_10_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shp", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
runTest("1_9_10", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# Try without .shp -- fail
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE
))
expect_error({
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
alsoExtract = c("Shapefile1.dbf", "Shapefile1.prj", "Shapefile1.shx"),
destinationPath = tmpdir
)
})
})
})
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "\\.zip", invert = TRUE, value = TRUE
))
file.remove(grep(dir(tmpdir, full.names = TRUE)[!isDirectory(dir(tmpdir))],
pattern = "CHECKSUMS.txt", value = TRUE
))
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
alsoExtract = "similar",
destinationPath = tmpdir
)
})
})
runTest("1_2_4_9_13", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
# 2nd time # can checksums
mess <- capture_messages({
warns <- capture_warnings({
test <- prepInputs(
archive = "Shapefiles1.zip",
targetFile = "Shapefile1.shp",
alsoExtract = c("similar"),
destinationPath = tmpdir
)
})
})
runTest("1_2_9", vectorType(), 5, mess,
expectedMess = expectedMessage,
filePattern = "Shapefile", tmpdir = tmpdir, test = test
)
})
test_that("prepInputs when fun = NA", {
skip_on_cran()
skip_if_not(getRversion() > "3.3.0")
testInit(c("sf", "terra"), opts = list(
"rasterTmpDir" = tempdir2(rndstr(1, 6)),
"reproducible.overwrite" = TRUE,
reproducible.interactiveOnDownloadFail = FALSE,
"reproducible.inputPaths" = NULL
), needGoogleDriveAuth = TRUE)
coords <- structure(c(6, 6.1, 6.2, 6.15, 6, 49.5, 49.7, 49.8, 49.6, 49.5), .Dim = c(5L, 2L))
StudyArea <- terra::vect(coords, "polygons")
terra::crs(StudyArea) <- crsToUse
noisyOutput <- capture.output(type = "message", {
mess1 <- capture_messages({
test1 <- try(silent = TRUE, {
prepInputs(
fun = NA,
dlFun = getDataFn, name = "GADM", country = "LUX", level = 0,
path = tmpdir
)
})
})
})
if (!is(test1, "try-error")) {
expect_true(is(test1, "SpatVector"))
# test quoted version of `dlFun`
noisyOutput3 <- capture.output(type = "message", {
mess3 <- capture_messages({
test3 <- prepInputs(
fun = NA,
dlFun = quote(getDataFn(name = "GADM", country = "LUX", level = 0, path = tmpdir)),
destinationPath = tmpdir
)
})
})
expect_true(is(test3, "SpatVector"))
if (.requireNamespace("sf")) {
noisyOutput6 <- capture.output(type = "message", {
mess6 <- capture_messages({
test6 <- prepInputs(
# targetFile = targetFileLuxRDS,
dlFun = quote({
out <- getDataFn(name = "GADM", country = "LUX", level = 0, path = tmpdir)
sf::st_as_sf(out)
}),
tmpdir = tmpdir
)
})
})
expect_is(test6, "sf")
}
}
})
test_that("load rdata in prepInputs", {
testInit("terra",
tmpFileExt = "rda",
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
), needGoogleDriveAuth = TRUE
)
a <- 1
b <- 2
save(a, b, file = tmpfile)
aa <- prepInputs(tmpfile, fun = "base::load")
expect_true(identical(aa, list(a = a, b = b)))
d <- new.env(parent = emptyenv())
aa <- prepInputs(tmpfile, fun = "base::load", envir = d)
expect_false(identical(aa, list(a = a, b = b))) # not in aa, because loaded to d
expect_true(identical(as.list(d), list(a = a, b = b)))
})
test_that("assessDataType doesn't work", {
testInit("terra", opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
), needGoogleDriveAuth = TRUE)
## LOG1S
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- c(0, NaN, rep(c(0, 1), 49))
expect_true(assessDataType(ras) == "LOG1S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- rep(c(0, 1), 50)
expect_true(assessDataType(ras) == "LOG1S")
ras[] <- rep(c(TRUE, FALSE), 50)
expect_true(assessDataType(ras) == "LOG1S")
ras[] <- c(NA, NA, rep(c(0, 1), 49))
expect_true(assessDataType(ras) == "LOG1S")
## INT1S
ras[] <- -1:98
expect_true(assessDataType(ras) == "INT1S")
ras[] <- c(NA, -1:97)
expect_true(assessDataType(ras) == "INT1S")
## INT1U
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- 1:100
expect_true(assessDataType(ras) == "INT1U")
ras[] <- c(NA, 2:100)
expect_true(assessDataType(ras) == "INT1U")
## INT2U
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = 64000, max = 65000))
expect_true(assessDataType(ras) == "INT2U")
## INT2S
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = -32767, max = 32767))
expect_true(assessDataType(ras) == "INT2S")
ras[54] <- NA
expect_true(assessDataType(ras) == "INT2S")
## INT4U
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = 0, max = 500000000))
expect_true(assessDataType(ras) == "INT4U")
ras[14] <- NA
expect_true(assessDataType(ras) == "INT4U")
## INT4S
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = -200000000, max = 200000000))
expect_true(assessDataType(ras) == "INT4S")
ras[14] <- NA
expect_true(assessDataType(ras) == "INT4S")
## FLT4S
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- runif(100, min = -10, max = 87)
expect_true(assessDataType(ras) == "FLT4S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = -3.4e+26, max = 3.4e+28))
expect_true(assessDataType(ras) == "FLT4S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = 3.4e+26, max = 3.4e+28))
expect_true(assessDataType(ras) == "FLT4S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = -3.4e+26, max = -1))
expect_true(assessDataType(ras) == "FLT4S")
## FLT8S
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = -1.7e+30, max = 1.7e+308))
expect_true(assessDataType(ras) == "FLT8S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = 1.7e+30, max = 1.7e+308))
expect_true(assessDataType(ras) == "FLT8S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- round(runif(100, min = -1.7e+308, max = -1))
expect_true(assessDataType(ras) == "FLT8S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- c(-Inf, 1, rep(c(0, 1), 49))
expect_true(assessDataType(ras) == "FLT8S")
ras <- terra::rast(ncols = 10, nrows = 10)
ras[] <- c(Inf, 1, rep(c(0, 1), 49))
expect_true(assessDataType(ras) == "FLT8S")
})
test_that("assessDataType for categorical rasters", {
testInit(c("terra", "raster"))
r <- terra::rast(terra::ext(c(0, 2, 0, 2)), vals = 1:4, resolution = 1)
levels(r) <- data.frame(ID = 1:4, Lett = LETTERS[1:4])
expect_identical(assessDataType(r), "INT1U")
r <- raster::raster(raster::extent(c(0, 2, 0, 2)), vals = 1:4, resolution = 1)
levels(r) <- data.frame(ID = 1:4, Lett = LETTERS[1:4])
expect_identical(assessDataType(r), "INT1U")
})
test_that("lightweight tests for code coverage", {
skip_on_cran()
testInit(c("sf", "terra"),
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
url <- "http://sis.agr.gc.ca/cansis/nsdb/ecostrat/zone/ecozone_shp.zip"
checkPath(tmpdir, create = TRUE)
checkSums <- .emptyChecksumsResult
checkSumFilePath <- file.path(tmpdir, "CHECKSUMS.txt")
noisyOutput <- capture.output(
downloadFile(
url = url, neededFiles = "ecozones.shp", checkSums = checkSums,
archive = "ecozone_shp.zip", needChecksums = TRUE, quick = FALSE,
destinationPath = tmpdir, checksumFile = checkSumFilePath
)
)
expect_true(file.exists(dir(tmpdir, pattern = "ecozone", full.names = TRUE)))
# have local copy
unzip("ecozone_shp.zip", exdir = tmpdir)
expect_true(all(file.copy(dir(file.path(tmpdir, "Ecozones"), full.names = TRUE), tmpdir)))
checkSums <- Checksums(path = tmpdir, write = TRUE)
aMess <- capture_messages(
downloadFile(
url = url, neededFiles = "ecozones.shp", checkSums = checkSums,
targetFile = "ecozones.shp",
archive = NULL, needChecksums = TRUE, quick = FALSE,
destinationPath = file.path(tmpdir, "Ecozones"),
checksumFile = file.path(tmpdir, "CHECKSUMS.txt")
)
)
if (!isMac()) {
expect_true(any(grepl("Skipping download", aMess))) ## 2023-05-08: fails on macOS
}
filesForShp <- dir(file.path(tmpdir), pattern = "ecozones", full.names = TRUE)
expect_true(all(file.copy(filesForShp, tmpCache)))
# Need these in a test further down -- mostly just need the CRS
filesForShp2 <- dir(file.path(tmpCache), pattern = "ecozones", full.names = TRUE)
if (.requireNamespace("sf")) {
noisyOutput <- capture.output({
shpFile <- sf::st_read(grep(filesForShp2, pattern = "\\.shp", value = TRUE))
})
}
# Test when wrong archive exists, wrong checkSums
expect_true(file.remove(file.path(tmpdir, "ecozone_shp.zip")))
expect_true(all(file.remove(filesForShp)))
expect_true(file.create(file.path(tmpdir, "ecozone_shp.zip")))
checkSums <- Checksums(path = tmpdir, write = TRUE)
expect_true(file.remove(file.path(tmpdir, "ecozone_shp.zip")))
checkSums <- Checksums(path = tmpdir)
noisyOutput <- capture.output({
out <- try(
silent = TRUE,
downloadFile(
url = url,
neededFiles = c(
"ecozones.dbf", "ecozones.prj", "ecozones.sbn", "ecozones.sbx",
"ecozones.shp", "ecozones.shx"
),
checkSums = checkSums,
targetFile = "ecozones.shp",
archive = "ecozone_shp.zip", needChecksums = TRUE, quick = FALSE,
destinationPath = tmpdir, checksumFile = checkSumFilePath
)
)
})
## 2023-05-08: does not error on macOS
isErr <- is(out, "try-error")
# if (isMac()) expect_false(isErr) else
expect_true(isErr)
## postProcess.default
b <- 1
expect_no_error(postProcess(b))
## postProcess.list
b <- list(1, 1)
expect_no_error(postProcess(b))
ras <- terra::rast(terra::ext(0, 10, 0, 10), resolution = 1, vals = 1:100)
terra::crs(ras) <- crsToUse
expect_error(postProcess(ras, studyArea = 1), .message$Greps$anySpatialClass)
expect_error(postProcess(ras, rasterToMatch = 1), .message$Greps$anySpatialClass)
## cropInputs.default
b <- 1
a <- cropInputs(b)
expect_true(identical(a, b))
ras2 <- terra::rast(terra::ext(0, 5, 0, 5), resolution = 1, vals = 1:25)
terra::crs(ras2) <- crsToUse
a <- cropInputs(ras, extentToMatch = terra::ext(ras2), extentCRS = terra::crs(ras2))
expect_true(inherits(a, "SpatRaster"))
ras4 <- terra::rast(terra::ext(7, 11, 7, 11), resolution = 1, vals = 1:16)
sp4 <- terra::vect(terra::ext(ras4))
terra::crs(sp4) <- crsToUse
# sp4 <- sf::st_as_sfc(sf::st_bbox(ras4))
# sf::st_crs(sp4) <- crsToUse
grepMessHere <- "extents do not overlap"
expect_error(cropInputs(ras2, studyArea = sp4), grepMessHere)
ras3 <- terra::rast(terra::ext(0, 5, 0, 5), resolution = 1, vals = 1:25)
terra::crs(ras3) <- crsToUse
################################################
# Different crs
# Because studyArea is a Raster, then it doesn't work correctly
a <- cropInputs(ras2, studyArea = ras3)
expect_true(inherits(a, "SpatRaster"))
expect_true(identical(terra::crs(a), terra::crs(ras2)))
# Now rasterToMatch used -- internally reprojects it to x
a <- cropInputs(ras2, rasterToMatch = ras3)
expect_true(inherits(a, "SpatRaster"))
expect_true(identical(terra::crs(a), terra::crs(ras2)))
## fixErrors.default
b <- 1
a <- fixErrors(b)
expect_true(identical(a, b))
## projectInputs.Raster
a <- projectInputs(ras2, rasterToMatch = ras3, method = "near")
expect_true(inherits(a, "SpatRaster"))
expect_true(identical(terra::crs(a), terra::crs(ras3)))
a <- projectInputs(ras2, targetCRS = terra::crs(ras3), rasterToMatch = ras3, method = "near")
expect_true(inherits(a, "SpatRaster"))
expect_true(identical(terra::crs(a), terra::crs(ras3)))
# warns if bilinear is passed for reprojecting integer
if (.requireNamespace("sf")) {
expect_warning(projectInputs(ras2, targetCRS = terra::crs(shpFile), method = "bilinear"))
}
# Works with no rasterToMatch
a <- projectInputs(ras2, targetCRS = crs(ras3), method = "near")
expect_true(identical(crs(a), crs(ras3)))
# }
# sp::CRS("+proj=lcc +lat_1=49 +lat_2=77 +lat_0=0 +lon_0=-95 +x_0=0 +y_0=0 +ellps=GRS80 +units=m +no_defs"))
})
test_that("lightweight tests 2 for code coverage", {
skip_on_cran()
testInit("terra",
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
theZipFile <- tempfile(tmpdir = tmpdir, fileext = ".zip")
theZipFile2 <- tempfile(tmpdir = tmpdir, fileext = ".zip")
theZipFile3 <- tempfile(tmpdir = tmpdir, fileext = ".zip")
theZipName <- file.path(tmpdir, "hi.zip")
theZapFile <- tempfile(tmpdir = tmpdir, fileext = ".zap")
theRDSFile <- tempfile(tmpdir = tmpdir, fileext = ".rds")
a <- 1
saveRDS(a, file = theRDSFile)
origWD <- setwd(dirname(theRDSFile))
noisyOutput <- capture_output(zip(zipfile = theZipFile, files = basename(theRDSFile)))
noisyOutput <- capture.output(zip(zipfile = theZipFile2, files = basename(theZipFile)))
noisyOutput <- capture.output(zip(zipfile = theZipFile3, files = basename(theZipFile2)))
setwd(origWD)
expect_error(extractFromArchive(theZapFile), "Archives of type zap are not currently supported")
expect_error(extractFromArchive(theZipName), "No archive exists with filename")
extractFromArchive(theZipFile, neededFiles = character())
csfp <- file.path(tmpdir, "CHECKSUMS.txt")
data.table::fwrite(.emptyChecksumsFileContent, file = csfp, sep = "\t")
# check Checksums fn
a <- extractFromArchive(theZipFile,
neededFiles = character(), checkSumFilePath = csfp,
destinationPath = tmpdir
)
expect_true(file.exists(a$filesExtracted))
# check Checksums fn
expect_error(
suppressWarnings(extractFromArchive(theZipFile,
neededFiles = character(),
checkSumFilePath = theRDSFile,
destinationPath = tmpdir
)),
"checkSumFilePath is not a CHECKSUMS.txt"
)
# Doubley nested zips -- extract inner, inner
a <- extractFromArchive(c(theZipFile2, theZipFile),
neededFiles = character(), checkSumFilePath = csfp,
destinationPath = tmpdir
)
expect_true(isTRUE(all(file.exists(a$filesExtracted))))
# triply
a <- extractFromArchive(theZipFile3,
neededFiles = theRDSFile, checkSumFilePath = csfp,
destinationPath = tmpdir, .tempPath = tempdir2()
)
expect_true(length(a$extractedArchives) == 3)
expect_true(length(a$filesExtracted) == 3)
expect_true(all(basename(a$filesExtracted) %in% basename(c(theZipFile, theZipFile2, theRDSFile))))
expect_true(all(basename(a$extractedArchives) %in% basename(c(theZipFile, theZipFile2, theZipFile3))))
allZipsAndRDS <- c(theZipFile, theZipFile2, theZipFile3, theRDSFile)
Checksums(tmpdir, write = TRUE, files = allZipsAndRDS, overwrite = TRUE)
a <- extractFromArchive(theZipFile3,
neededFiles = theRDSFile, checkSumFilePath = csfp,
destinationPath = tmpdir, checkSums = Checksums(tmpdir, files = allZipsAndRDS)
)
})
test_that("options inputPaths", {
skip_on_cran()
skip_if_not_installed("geodata")
skip_if_not(getRversion() > "4.1.3") ## geodata::gadm seems to time out on R <= 4.1.3
testInit(c("terra", "geodata"),
opts = list(
"reproducible.inputPaths" = NULL,
"reproducible.inputPathsRecursive" = FALSE
),
needInternet = TRUE
)
f <- formals3(prepInputs)
getDataFn <- getDataFn # not exported from reproducible; can access here, not in the dlFun
if (getRversion() <= "3.3.0") skip("Doesn't work on R 3.3.0") # Not sure why this fails on 3.3.0
options("reproducible.inputPaths" = NULL)
options("reproducible.inputPathsRecursive" = FALSE)
noisyOutput <- capture.output({
noisyOutput <- capture.output(type = "message", {
mess1 <- capture_messages({
test0 <- try(getDataFn(path = tmpdir, country = "LUX"), silent = TRUE)
})
})
})
useGADM <- !is(test0, "try-error")
if (useGADM) {
noisyOutput <- capture.output({
noisyOutput <- capture.output(type = "message", {
mess1 <- capture_messages({
test1 <- try(prepInputs(
destinationPath = tmpdir,
# url = if (!useGADM) url2 else f$url,
# targetFile = if (useGADM) theFile else f$targetFile,
dlFun = getDataFn,
name = "GADM",
country = "LUX",
level = 0,
path = tmpdir
))
})
})
})
}
theFile <- if (useGADM) {
targetFileLuxRDS
} else {
"rasterTest.tif"
}
url2 <- "https://github.com/tati-micheletti/host/raw/master/data/rasterTest.tif"
noisyOutput <- capture.output({
noisyOutput <- capture.output(type = "message", {
mess1 <- capture_messages({
test1 <- try(prepInputs(
destinationPath = tmpdir,
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL
))
})
})
})
# Use inputPaths -- should do a link to tmpCache (the destinationPath)
options("reproducible.inputPaths" = tmpdir)
options("reproducible.inputPathsRecursive" = FALSE)
dlFun1 <- if (useGADM) getDataFn else NULL
noisyOutput <- capture.output({
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = dlFun1,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpCache,
getDataFn = dlFun1, verbose = 2
)
})
})
expect_true(sum(grepl(paste0("Hardlinked", ".*:"), mess1)) == 1)
# Now two folders - file not in destinationPath, not in 1st inputPaths, but yes 2nd
# should hardlink from 2nd IP to destinationPath, make sure CHECKSUMS.txt is correct in both
options("reproducible.inputPaths" = c(tmpdir, tmpCache))
file.remove(file.path(tmpdir, theFile))
tmpdir3 <- file.path(tmpCache, "test")
noisyOutput <- capture.output({
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpdir3, verbose = 2
)
})
})
expect_true(sum(grepl(paste0(hardlinkOrSymlinkMessagePrefixForGrep), mess1)) == 1)
expect_true(sum(grepl(paste0(tmpdir3), mess1)) == 1)
# THIS NEXT ONE DOESN"T PASS ON GA on WINDOWS, skip it
# should copy from 2nd directory (tmpCache) because it is removed in the lower
# tmpdir directory & has a CHECKSUMS.txt
if (!isTRUE(as.logical(Sys.getenv("CI")))) { # (!testthat:::on_ci()) { # can't use the :::
options("reproducible.inputPaths" = tmpdir)
options("reproducible.inputPathsRecursive" = TRUE)
file.remove(file.path(tmpCache, theFile))
tmpdir1 <- file.path(tmpCache, "test1")
noisyOutput <- capture.output({
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpdir1, verbose = 3
)
})
})
mess1 <- gsub("\n ", " ", mess1) ## remove misc new lines
expect_true(sum(grepl(paste0(hardlinkOrSymlinkMessagePrefixForGrep), mess1)) == 1)
expect_true(sum(grepl(whPointsToMessForGrep, mess1)) == 1)
expect_true(sum(grepl(file.path(tmpdir1, theFile), mess1)) == 1)
expect_true(sum(basename(dir(file.path(tmpdir), recursive = TRUE)) %in% theFile) == 3)
}
## Try download to inputPath, intercepting the destination, creating a link
testInit("terra",
opts = list(
"reproducible.inputPaths" = NULL,
"reproducible.inputPathsRecursive" = FALSE
)
)
options("reproducible.inputPaths" = tmpdir)
tmpdir2 <- file.path(tmpdir, rndstr(1, 5))
noisyOutput <- capture.output({
noisyOutput <- capture.output(type = "message", {
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpdir2
)
})
})
})
# Must remove the link that happens during downloading to a .tempPath
test10 <- grep(hardlinkOrSymlinkMessagePrefixForGrep, mess1, value = TRUE)
test10 <- grep(tmpdir2, test10, invert = TRUE, value = TRUE)
expect_true(length(test10) == (1 - useGADM)) #
# Have file in inputPath, not in destinationPath
unlink(file.path(tmpdir2, theFile))
expect_false(file.exists(file.path(tmpdir2, theFile))) # FALSE -- confirm previous line
expect_true(file.exists(file.path(tmpdir, theFile))) # TRUE b/c is in getOption('reproducible.inputPaths')
tmpdir2 <- file.path(tmpdir, rndstr(1, 5))
noisyOutput <- capture.output({
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpdir2, verbose = 3
)
})
})
expect_true(sum(grepl(hardlinkOrSymlinkMessagePrefixForGrep, mess1)) == 1) # used a linked version
expect_true(sum(grepl(paste0("Hardlinked.*"), mess1)) == 1) # it is now in tmpdir2, i.e., the destinationPath
expect_true(sum(grepl(paste0(basename(tmpdir2)), mess1)) == 2) # it is now in tmpdir2, i.e., the destinationPath
# Have file in destinationPath, not in inputPath
unlink(file.path(tmpdir, theFile))
expect_false(file.exists(file.path(tmpdir, theFile))) # FALSE -- confirm previous line
expect_true(file.exists(file.path(tmpdir2, theFile))) # TRUE b/c is in getOption('reproducible.inputPaths')
noisyOutput <- capture.output({
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpdir2, verbose = 2
)
})
})
# expect_true(sum(grepl(hardlinkOrSymlinkMessagePrefixForGrep, mess1)) == 1) # used a linked version
# expect_true(sum(grepl(paste0("Hardlinked.*",basename(tmpdir2)), mess1)) == 1) # it is now in tmpdir2, i.e., the destinationPath
## Try with inputPaths == destinationPath
unlink(file.path(tmpdir, theFile))
unlink(file.path(tmpdir2, theFile))
expect_false(file.exists(file.path(tmpdir, theFile))) # FALSE -- confirm previous line
expect_false(file.exists(file.path(tmpdir2, theFile))) # TRUE b/c is in getOption('reproducible.inputPaths')
options("reproducible.inputPaths" = tmpdir)
noisyOutput <- capture.output({
noisyOutput <- capture.output(type = "message", {
mess1 <- capture_messages({
test1 <- prepInputs(
url = if (!useGADM) url2 else f$url,
targetFile = if (useGADM) theFile else f$targetFile,
dlFun = if (useGADM) getDataFn else NULL,
name = if (useGADM) "GADM" else NULL,
country = if (useGADM) "LUX" else NULL,
level = if (useGADM) 0 else NULL,
path = if (useGADM) tmpdir else NULL,
destinationPath = tmpdir, verbose = 2
)
})
})
})
objType <- if (useGADM) vectorType() else rasterType()
expect_true(is(test1, objType) || is(test1, "SpatVector"))
test11 <- grep(hardlinkOrSymlinkMessagePrefixForGrep, mess1, value = TRUE)
test11 <- grep(tmpdir, test11, invert = TRUE)
expect_true(length(test11) == 0) # no link made b/c identical dir
expect_true(sum(grepl(paste0("Hardlinked.*", basename(tmpdir2)), mess1)) == 0) # no link made b/c identical dir
})
test_that("writeOutputs saves factor rasters with .grd class to preserve levels", {
skip_on_cran()
testInit("terra",
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
a <- terra::rast(terra::ext(0, 2, 0, 2), resolution = 1, vals = c(1, 1, 2, 2))
levels(a) <- data.frame(ID = 1:2, Factor = c("This", "That"))
tifTmp <- tempfile(tmpdir = tmpdir, fileext = ".tif")
file.create(tifTmp)
tifTmp <- normPath(tifTmp)
b1 <- suppressWarnings(terra::writeRaster(a, filename = tifTmp, overwrite = TRUE)) # the GDAL>6 issue
b1a <- writeOutputs(a, filename2 = tifTmp)
expect_equivalent(b1, b1a)
expect_equivalent(b1[], b1a[])
expect_true(identical(normPath(Filenames(b1)), normPath(tifTmp)))
})
test_that("rasters aren't properly resampled", {
skip_on_cran()
testInit("terra",
opts = list(
"reproducible.overwrite" = TRUE,
"reproducible.inputPaths" = NULL
),
needGoogleDriveAuth = TRUE
)
a <- terra::rast(terra::ext(0, 20, 0, 20), resolution = 2, vals = as.integer(1:100 * 4))
b <- terra::rast(terra::ext(0, 30, 0, 30), resolution = c(3, 3), vals = 1L:100L)
crs(a) <- crsToUse
crs(b) <- crsToUse
tiftemp1 <- normPath(tempfile(tmpdir = tmpdir, fileext = ".tif"))
tiftemp2 <- normPath(tempfile(tmpdir = tmpdir, fileext = ".tif"))
suppressWarnings({
a <- terra::writeRaster(a, filename = tiftemp1, datatype = "INT2U")
b <- terra::writeRaster(b, filename = tiftemp2, datatype = "INT2U")
}) ## TODO: temporary GDAL>6
# Test bilinear --> but keeps integer if it is integer
suppressWarnings({
out2 <- prepInputs(
targetFile = tiftemp1, rasterToMatch = terra::rast(tiftemp2),
destinationPath = dirname(tiftemp1), method = "bilinear",
datatype = "INT2S",
filename2 = tempfile(tmpdir = tmpdir, fileext = ".tif")
)
}) # about "raster layer has integer values"
if (getRversion() >= "4.1" || !isWindows()) {
expect_true(dataType2(out2) %in% c("INT2S")) # because of "bilinear", it can become negative
rrr1 <- terra::rast(terra::ext(0, 20, 0, 20), resolution = 1, vals = runif(400, 0, 1))
terra::crs(rrr1) <- crsToUse
tiftemp3 <- tempfile(tmpdir = tmpdir, fileext = ".tif")
tiftemp4 <- tempfile(tmpdir = tmpdir, fileext = ".tif")
suppressWarningsSpecific(terra::writeRaster(rrr1, filename = tiftemp3), proj6Warn)
out3 <- prepInputs(
targetFile = tiftemp3, rasterToMatch = terra::rast(tiftemp2),
destinationPath = dirname(tiftemp3),
filename2 = tempfile(tmpdir = tmpdir, fileext = ".tif")
)
expect_true(dataType2(out3) == "FLT4S")
# Test for raster::stack
rasStack <- c(terra::rast(tiftemp3), terra::rast(tiftemp3))
rasStack[] <- rasStack[]
rasStack[131][1] <- 1.5
tiftemp4 <- tempfile(tmpdir = tmpdir, fileext = ".tif")
rasStack <- terra::writeRaster(rasStack, filename = tiftemp4)
rm(rasStack)
out3 <- prepInputs(
targetFile = tiftemp4, rasterToMatch = terra::rast(tiftemp2),
destinationPath = dirname(tiftemp3),
filename2 = tempfile(tmpdir = tmpdir, fileext = ".tif")
)
expect_true(is(out3, rasterType()))
expect_true(identical(length(Filenames(out3)), 1L))
if (.requireNamespace("raster")) {
rasterStackFn <- "raster::stack"
suppressWarningsSpecific(
falseWarnings = "partial argument match", {
out4 <- prepInputs(
targetFile = tiftemp4, rasterToMatch = terra::rast(tiftemp2),
destinationPath = dirname(tiftemp3),
fun = rasterStackFn,
filename2 = c(
tempfile(tmpdir = tmpdir, fileext = ".grd"),
tempfile(tmpdir = tmpdir, fileext = ".grd")
)
)
})
expect_true(is(out4, rasterType(nlayers = nlayers2(out4), rasterRead = rasterStackFn)))
expect_true(identical(length(Filenames(out4, allowMultiple = TRUE)), 4L))
# Test for raster::stack with 3 layers, different types of writeRaster file ext
rasStack <- c(terra::rast(tiftemp3), terra::rast(tiftemp3), terra::rast(tiftemp3))
rasStack[] <- rasStack[]
rasStack[131][1] <- 1.5
rasStack[131][2] <- 2.5
tiftemp5 <- tempfile(tmpdir = tmpdir, fileext = ".tif")
rasStack <- writeRaster(rasStack, filename = tiftemp5)
rm(rasStack)
suppressWarningsSpecific(
falseWarnings = "partial argument match", {
out5 <- prepInputs(
targetFile = tiftemp5, rasterToMatch = terra::rast(tiftemp2),
destinationPath = dirname(tiftemp3),
fun = rasterStackFn,
filename2 = c(
tempfile(tmpdir = tmpdir, fileext = ".grd"),
tempfile(tmpdir = tmpdir, fileext = ".grd"),
tempfile(tmpdir = tmpdir, fileext = ".tif")
)
)
})
expect_true(is(out5, "RasterStack"))
expect_true(identical(length(Filenames(out5, allowMultiple = TRUE)), 5L))
suppressWarningsSpecific(
falseWarnings = "partial argument match", {
out4 <- prepInputs(
targetFile = tiftemp4, rasterToMatch = terra::rast(tiftemp2),
destinationPath = dirname(tiftemp3),
fun = rasterStackFn,
filename2 = c(
tempfile(tmpdir = tmpdir, fileext = ".grd"),
tempfile(tmpdir = tmpdir, fileext = ".grd")
)
)
})
expect_true(is(out4, rasterType(nlayers2(out4), rasterStackFn)))
expect_true(identical(length(Filenames(out4)), 4L))
}
}
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.