Nothing
test_that("spread2 tests", {
testInit("terra")
rastDF <- needTerraAndRaster()
# inputs for x
aOrig <- terra::rast(system.file("extdata", "a.tif", package = "SpaDES.tools"))
bOrig <- terra::rast(aOrig)
bSimple <- terra::rast(terra::ext(0, 10, 0, 10), res = 1)
spRas <- terra::rast(system.file("extdata", "spRas.tif", package = "SpaDES.tools"))
for (ii in seq(NROW(rastDF))) {
pkg <- rastDF$pkg[ii]
cls <- rastDF$class[ii]
# read <- rastDF$read[ii]
read <- eval(parse(text = rastDF$read[ii]))
a <- read(aOrig)
b <- read(bOrig)
sp <- 0.225
spRas[] <- spRas[] / reproducible::maxFn(spRas) * sp / 2 + sp / 2 * 1.5
b[] <- 1
bb <- focal(b, matrix(1 / 9, nrow = 3, ncol = 3), fun = sum, pad = TRUE, padValue = 0)
innerCells <- which(bb[] %==% 1)
sams <- sample(innerCells, 2)
set.seed(123)
for (jjj in 1:20) {
sams <- sample(innerCells, 2)
out <- spread2(a, start = sams, spreadProb = 0.225, asRaster = FALSE)
expect_true(length(unique(out$initialPixels)) == 2)
expect_true(all(out$active == 0))
}
# Test numeric vector passed to spreadProb
sams <- sample(innerCells, 2)
numNAs <- 25
sps <- sample(c(rep(NA_real_, numNAs), runif(ncell(a) - numNAs, 0, 1)))
spsRas <- read(aOrig)
spsRas[] <- sps
set.seed(123)
out1 <- spread2(a, start = sams, spreadProb = sps, asRaster = FALSE)
set.seed(123)
out2 <- spread2(a, start = sams, spreadProb = spsRas, asRaster = FALSE)
expect_true(identical(out1, out2))
# Test warning for raster on disk
spsRas[] <- sps
spsRas <- writeRaster(spsRas, filename = tempfile(fileext = ".tif"))
warn <- capture_warnings({
out1 <- spread2(a, start = sams, spreadProb = spsRas, asRaster = FALSE)
})
expect_true(grepl("spreadProb is a raster layer stored on disk", warn))
if (interactive()) message("testing maxSize")
maxSizes <- 2:3
for (kkk in 1:20) {
seed <- sample(1e6, 1)
set.seed(seed)
sams <- sample(innerCells, 2)
out <- spread2(a, start = sams, spreadProb = 0.225, maxSize = maxSizes, asRaster = FALSE)
expect_true(all(out[, .N, by = "initialPixels"]$N <= maxSizes[order(sams)]))
}
if (interactive()) message("testing exactSize")
exactSizes <- c(5, 3.1)
for (mmm in 1:20) {
sams <- sample(innerCells, 2)
out <- spread2(
a, start = sams, spreadProb = 0.225, exactSize = exactSizes, asRaster = FALSE
)
attrib <- attr(out, "spreadState")$cluster$numRetries > 10
if (any(attrib)) {
frequ <- out[, .N, by = "initialPixels"]$N
expect_true(all(frequ[attrib] <= floor(exactSizes[order(sams)][attrib])))
expect_true(all(frequ[!attrib] == floor(exactSizes[order(sams)][!attrib])))
} else {
expect_true(all(out[, .N, by = "initialPixels"]$N == floor(exactSizes[order(sams)])))
}
}
if (interactive()) message("testing exactSize")
exactSizes <- c(5.01, 3.1, 4)
for (nnn in 1:20) {
sams <- sample(innerCells, length(exactSizes))
out <- spread2(a, start = sams, spreadProb = 0.225, exactSize = exactSizes, asRaster = FALSE)
attrib <- attr(out, "spreadState")$clusterDT$numRetries > 10
if (any(attrib)) {
frequ <- out[, .N, by = "initialPixels"]$N
expect_true(all(frequ[attrib] <= floor(exactSizes[order(sams)][attrib])))
expect_true(all(frequ[!attrib] == floor(exactSizes[order(sams)][!attrib])))
} else {
expect_true(all(out[, .N, by = "initialPixels"]$N == floor(exactSizes[order(sams)])))
}
}
if (interactive()) message("testing exact maxSize, can't be achieved, allow jumping")
exactSizes <- c(154, 111, 134) # too big for landscape, can't achieve it --
# will hit max numRetries, and will try jumping
for (rrr in 1:20) {
seed <- sample(1e6, 1)
set.seed(seed)
sams <- sample(innerCells, 3)
out <- spread2(a, start = sams, spreadProb = 0.225, exactSize = exactSizes, asRaster = FALSE)
expect_true(all(out[, .N, by = "initialPixels"]$N < exactSizes))
expect_true(all(out$numRetries == 11)) # current max
}
if (interactive()) message("test circle = TRUE")
for (ppp in 1:20) {
message(ppp)
seed <- sample(1e6, 1)
set.seed(seed)
sams <- sample(innerCells, length(sams))
expect_error(spread2(a, start = sams, spreadProb = runif(1, 1.00000001, 1e4),
circle = TRUE, asRaster = FALSE, plot.it = TRUE))
expect_error(spread2(a, start = sams, spreadProb = runif(1, -1e5, -0.00000001, 1e4),
circle = TRUE, asRaster = FALSE, plot.it = TRUE))
out <- spread2(a, start = sams, spreadProb = 1, circle = TRUE, asRaster = FALSE)
expect_true(is.numeric(out$distance))
expect_true(NROW(out) == ncell(a))
}
# test circle
sams <- sort(sample(innerCells, 3)) # sorted -- makes comparisons later easier
out <- spread2(a, start = sams, spreadProb = 1, circle = TRUE, asRaster = FALSE,
returnDistances = TRUE)
expect_true(NROW(out) == ncell(a))
expect_true(all(out$state == "inactive"))
expect_true(all(out$distance <= (sqrt(2) * ncol(a))))
out <- spread2(a, start = sams, spreadProb = 1, circle = TRUE, allowOverlap = TRUE,
asRaster = FALSE, returnDistances = TRUE)
expect_true(NROW(out) == ncell(a) * length(sams))
expect_true(all(out$state == "inactive"))
expect_true(all(out$distance <= (sqrt(2) * ncol(a))))
setkey(out, initialPixels, distance)
if (interactive()) {
count <- 1
for (ids in unique(out$initialPixels)) {
# dev(3 + count)
count <- count + 1
ras <- read(aOrig)
ras[] <- 0
ras[out[initialPixels == ids, pixels]] <- out[initialPixels == ids, distance]
# clearPlot()
terra::plot(ras)#Plot(ras)
}
}
if (interactive()) message("compare spread2 circle with cir circle")
cirOut <- data.table(
cir(a, allowOverlap = TRUE, loci = sams, minRadius = 0, maxRadius = 15,
returnDistances = TRUE, simplify = TRUE)
)
if (interactive()) {
for (ids in seq(unique(cirOut$id))) {
# dev(3 + ids)
ras[cirOut[id == ids, indices]] <- cirOut[id == ids, dists]
# clearPlot()
terra::plot(ras) # Plot(ras)
}
}
cirOut$dists <- round(cirOut$dists, 4)
out$distance <- round(out$distance, 4)
setkey(cirOut, id, dists)
#quickDT <- data.table(id = seq_along(sams), initialPixels = sams, key = "id")
cirOut <- unique(cirOut)
#cirOut <- quickDT[cirOut, on = ]
setnames(cirOut, "id", "initialPixels")
compare <- out[cirOut, on = c(initialPixels = "initialPixels", pixels = "indices")]
expect_true(sum(abs(compare$dists - compare$distance)) %==% 0)
## TODO: need better test for hov this scales
#if (interactive()) message("Scales with number of starts, not maxSize of raster")
#set.seed(21)
#b <- terra::rast(terra::ext(0, 33000, 0, 33000), res = 1)
#sams <- sample(ncell(b), 2)
#st1 <- system.time({
# out <- spread2(b, start = sams, spreadProb = 0.225, allowOverlap = TRUE, asRaster = FALSE)
#})
#expect_true(st1[1] < 1) ## don't check timing as it fluctuates ased on machine load!
if (interactive()) message("test neighProbs")
maxSizes <- 14
sp <- read(aOrig)
spreadProbOptions <- 1:5
sp[] <- sample(spreadProbOptions, ncell(sp), replace = TRUE)
set.seed(2123)
sams <- sample(innerCells, 2)
set.seed(321)
out <- spread2(a, spreadProb = 1, spreadProbRel = sp, start = sams,
neighProbs = c(0.7, 0.3), maxSize = maxSizes, asRaster = FALSE)
expect_true(uniqueN(out) == maxSizes * length(sams))
expect_true(NROW(out) == maxSizes * length(sams))
if (interactive()) message("check variable lengths of neighProbs")
set.seed(29937)
sams <- sample(innerCells, 2)
for (www in 1:8) {
alwaysN <- rep(0, www)
alwaysN[www] <- 1
out <- spread2(
a, spreadProb = 1, spreadProbRel = sp, iterations = 1,start = sams,
neighProbs = alwaysN, asRaster = FALSE
)
expect_true(NROW(out) == (length(alwaysN) * 2 + length(sams)))
}
if (interactive()) {
message(
paste(
"Test that when using neighProbs & a Raster of spreadProbs,",
"the spreadProb raster is followed probabilistically.",
"This test does only 1 iteration from 2 pixels that are",
"not interacting with edges or each other"
)
)
}
sams <- sort(c(0:2 * 3 + 12) + rep(c(0, 30, 60, 90), 3))
sams <- sams[sams < 90]
set.seed(654)
out <- list()
for (yyy in 1:10) {
out[[yyy]] <- spread2(a, spreadProbRel = sp, spreadProb = 1, iterations = 1,
start = sams, neighProbs = c(1), asRaster = FALSE)
}
out <- rbindlist(out)[state == "activeSource"]
uniquePixels <- out[, list(uniquePix = unique(pixels)), by = "initialPixels"]
avail <- table(sp[uniquePixels$uniquePix])
actual <- unname(table(sp[out$pixels]))
relProbs <- spreadProbOptions / sum(spreadProbOptions)
aa <- rmultinom(1, size = 1e4, prob = relProbs)[, 1] * unname(avail)
suppressWarnings({
cht <- chisq.test(x = cbind(aa, actual))
})
#if (as.numeric_version(paste0(R.version$major, ".", R.version$minor)) < "3.6.0") {
expect_true(cht$p.value > 0.05)
#} else {
# expect_false(cht$p.value > 0.05) ## TODO: is this valid/correct test?
#}
message("Scales with number of starts, not maxSize of raster")
set.seed(21)
b <- read(bSimple)
bProb <- read(system.file("extdata", "bProb.tif", package = "SpaDES.tools"))
set.seed(1232)
out <- spread2(spreadProb = 0.5, landscape = b, asRaster = FALSE,
start = ncell(b) / 2 - ncol(b) / 2, spreadProbRel = bProb,
returnFrom = TRUE, neighProbs = c(0.3, 0.7), exactSize = 30)
set(out, NULL, "relProb", bProb[][out$pixels])
if (interactive()) out
if (interactive())
message("check wide range of spreadProbs and that it makes a RasterLayer")
set.seed(654)
rasts <- list()
for (ccc in 1:20) {
rasts[[ccc]] <- spread2(a, spreadProb = stats::runif(1, 0, 1))
expect_s4_class(rasts[[ccc]], cls)
}
if (interactive()) {
names(rasts) <- paste0("ras", 1:20)
rasts <- eval(parse(text = rastDF$stack[ii]))(rasts)
terra::plot(rasts)
}
if (interactive())
message("testing iterative calling of spread2")
set.seed(299)
sams <- sample(innerCells, 2)
set.seed(299)
out <- spread2(a, iterations = 1, start = sams, asRaster = FALSE)
stillActive <- TRUE
while (stillActive) {
stillActive <- any(out$state == "activeSource")
out <- spread2(a, iterations = 1, start = out, asRaster = FALSE)
}
set.seed(299)
out2 <- spread2(a, start = sams, asRaster = FALSE)
keyedCols <- c("initialPixels", "pixels")
expect_equal(out2, out, ignore_attr = TRUE)
if (interactive())
message("testing iterative calling of spread2, but asRaster = TRUE")
set.seed(299)
sams <- sample(innerCells, 2)
set.seed(299)
out1 <- spread2(a, iterations = 1, start = sams, asRaster = TRUE)
stillActive <- TRUE
while (stillActive) {
stillActive <- any(attr(out1, "pixel")$state == "activeSource")
out1 <- spread2(a, iterations = 1, start = out1, asRaster = TRUE)
}
expect_true(identical(out, attr(out1, "pixel")))
if (interactive())
message("testing iterative with maxSize")
set.seed(299)
seed <- sample(1e6, 1)
set.seed(seed)
sams <- sample(innerCells, 2)
exactSizes <- 5:6
out <- spread2(a, start = sams, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
for (pip in 1:20) {
out <- spread2(a, start = out, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
}
if (interactive())
message("testing iterative with maxSize -- where needRetry occurs")
set.seed(299)
sams <- sample(innerCells, 2)
exactSizes <- 60:61
out <- spread2(a, start = sams, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
out2 <- spread2(a, start = sams, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
for (wip in 1:25) {
out <- spread2(a, start = out, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
attr(out2, "spreadState") <- NULL
out2 <- spread2(a, start = out2, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
}
expect_true(is.data.table(out))
expect_true(is.data.table(out2))
expect_true(all(attr(out2, "spreadState")$clusterDT$numRetries == 0))
expect_true(all(attr(out, "spreadState")$clusterDT$numRetries > 10))
# because loses info on how many retries, it will always be smaller
expect_true(all(attr(out, "spreadState")$clusterDT$numRetries >
attr(out2, "spreadState")$clusterDT$numRetries))
sams <- c(25, 75)
set.seed(234)
out <- spread2(a, start = sams, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
set.seed(234)
out2 <- spread2(a, start = sams, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
for (jij in 1:4) {
# limit this so it doesn't get into retries, which will cause them to differ
set.seed(234)
out <- spread2(a, start = out, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
attr(out2, "spreadState") <- NULL
set.seed(234)
out2 <- spread2(a, start = out2, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
}
## they start to diverge if there is a jump that occurs, because the one without
## memory doesn't know how many retries it has had
#expect_identical(data.table(out2), data.table(out)) ## TODO: fix this test
for (eoe in 1:25) {
set.seed(234)
out <- spread2(a, start = out, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
attr(out2, "spreadState") <- NULL
set.seed(234)
out2 <- spread2(a, start = out2, spreadProb = 0.225, iterations = 1,
exactSize = exactSizes, asRaster = FALSE)
}
expect_false(identical(data.table(out2), data.table(out)))
}
})
test_that("spread2 tests -- asymmetry", {
testInit("terra")
rastDF <- needTerraAndRaster()
aOrig <- terra::rast(terra::ext(0, 100, 0, 100), res = 1)
for (ii in seq(NROW(rastDF))) {
read <- eval(parse(text = rastDF$read[ii]))
# inputs for x
b <- read(aOrig)
a <- read(aOrig)
b[] <- 1
bb <- focal(b, matrix(1 / 9, nrow = 3, ncol = 3), fun = sum, pad = TRUE, padValue = 0)
innerCells <- which(bb[] %==% 1)
set.seed(123)
sams <- sample(innerCells, 2)
out <- spread2(a, start = sams, 0.215, asRaster = FALSE, asymmetry = 2,
asymmetryAngle = 90)
for (eof in 1:20) {
expect_silent({
out <- spread2(a, start = out, 0.215, asRaster = FALSE, asymmetry = 2,
asymmetryAngle = 90)
})
}
hab <- read(system.file("extdata", "hab.tif", package = "SpaDES.tools"))
names(hab) <- "hab"
hab2 <- hab > 0
maxRadius <- 25
maxVal <- 50
set.seed(53432)
startCells <- as.integer(sample(1:ncell(hab), 1))
n <- 16
avgAngles <- numeric(n)
lenAngles <- numeric(n)
# function to calculate mean angle -- returns in degrees
meanAngle <- function(angles) {
deg2(atan2(mean(sin(rad2(angles))), mean(cos(rad2(angles)))))
}
# if (interactive()) {
# # dev()
# # clearPlot()
# }
seed <- sample(1e6, 1)
set.seed(seed)
for (asymAng in (2:n)) {
circs <- spread2(hab, spreadProb = 0.25, start = ncell(hab) / 2 - ncol(hab) / 2,
asymmetry = 40, asymmetryAngle = asymAng * 20, asRaster = FALSE)
ci <- read(hab)
ci[] <- 0
ci[circs$pixels] <- circs$initialPixels
ciCentre <- read(ci)
ciCentre[] <- 0
ciCentre[unique(circs$initialPixels)] <- 1
newName <- paste0("ci", asymAng * 20)
assign(newName, ci)
where2 <- function(name, env = parent.frame()) {
# simplified from pryr::where
if (exists(name, env, inherits = FALSE)) env else where2(name, parent.env(env))
}
env <- where2(newName)
if (interactive()) {
objToPlot <- get(newName, envir = env)
terra::plot(objToPlot) #, add = TRUE)
ciCentre[ciCentre == 0] <- NA
terra::plot(ciCentre, add = TRUE, col = "black")
}
a <- cbind(id = circs$initialPixels, to = circs$pixels, xyFromCell(hab, circs$pixels))
initialLociXY <- cbind(id = unique(circs$initialPixels),
xyFromCell(hab, unique(circs$initialPixels)))
dirs <- directionFromEachPoint(from = initialLociXY, to = a)
dirs[, "angles"] <- deg2(dirs[, "angles"])
avgAngles[asymAng] <- tapply(dirs[, "angles"], dirs[, "id"], meanAngle) %% 360
lenAngles[asymAng] <- tapply(dirs[, "angles"], dirs[, "id"], length)
}
whBig <- which(lenAngles > 50)
pred <- (1:n)[whBig] * 20
expect_true(abs(coef(lm(avgAngles[whBig] ~ pred))[[2]] - 1) < 0.1)
# test that the events spread to the middle
# Create a raster with one point at the centre
ciCentre <- read(hab)
terra::crs(ciCentre) <- "epsg:23028"
ciCentre <- setValues(ciCentre, 1)
ciCentre[seq_len(ncell(ciCentre))[-(ncell(ciCentre) / 2 - ncol(ciCentre) / 2)]] <- NA_integer_
# create a direction raster with all points leading to that point
directionRas <- direction(ciCentre)
directionRas[] <- deg2(directionRas[])
seed <- 4406
set.seed(seed)
sams <- ncol(directionRas) + 2
circs <- spread2(hab, spreadProb = 0.265, start = sams, asymmetry = 300,
asymmetryAngle = directionRas, asRaster = TRUE)
circs2 <- spread2(hab, spreadProb = 0.265, start = sams, asRaster = TRUE)
if (interactive()) {
terra::plot(circs)
ciCentrePlot <- ciCentre
ciCentrePlot[ciCentrePlot == 2] <- NA
ciCentrePlot[sams] <- 2
ciCentrePlot[ciCentrePlot == 0] <- NA
terra::plot(ciCentrePlot, add = TRUE, col = c("black", "red"))
terra::plot(circs2, add = TRUE, col = "#1211AA33")
# Plot(ciCentrePlot, cols = c("transparent", "black", "red"), addTo = "circs")
# Plot(circs2, addTo = "circs", col = "#1211AA33")
}
#test whether it stopped before hitting the whole map
expect_true(sum(circs[], na.rm = TRUE) < ncell(circs))
if (as.numeric_version(paste0(R.version$major, ".", R.version$minor)) < "3.6.0") {
#test that it reached the centre, but not circs2 that did not have directionality
expect_equal(circs[sams], circs[which(ciCentre[] == 1)]) ## TODO: restore this test
}
expect_true(is.na(circs2[ciCentre == 1]))
expect_true(!is.na(circs2[sams]))
# Here, test that the asymmetry version, with adjusted downward spreadProb is creating the
# same size events as the Non-asymmetry one. This is a weak test, really. It should
sizes <- data.frame(a = numeric())
set.seed(1234)
for (rso in 1:10) {
sams <- ncell(hab) / 4 - ncol(hab) / 4 * 3
circs <- spread2(hab, spreadProb = 0.18, start = sams,
asymmetry = 2, asymmetryAngle = 135, asRaster = TRUE)
sizes <- rbind(sizes, cbind(a = attr(circs, "pixel")[, .N]))
if (FALSE) {
Plot(circs, new = TRUE)
ciCentre[ciCentre == 2] <- NA
ciCentre[sams] <- 2
Plot(ciCentre, cols = c("black", "red"), addTo = "circs")
Plot(circs2, addTo = "circs", cols = "#1211AA33")
}
}
ttestOut <- t.test(sizes$a, mu = 994)
expect_true(ttestOut$p.value > 0.05)
next # the following isn't tested
if (!interactive()) next
# This code is used to get the mean value for the t.test above
n <- 100
sizes <- integer(n)
for (iwo in 1:n) {
circs <- spread2(hab, spreadProb = 0.225,
start = ncell(hab) / 4 - ncol(hab) / 4 * 3,
asRaster = FALSE)
sizes[iwo] <- circs[, .N]
}
goalSize <- mean(sizes)
library(parallel)
# only need 10 cores for 10 populations in DEoptim
cl <- makeCluster(pmin(10, detectCores() - 2))
parallel::clusterEvalQ(cl, {
library(SpaDES.tools)
library(raster)
library(fpCompare)
})
objFn <- function(sp, n = 20, ras, goalSize) {
sizes <- integer(n)
for (wnn in 1:n) {
circs <- spread2(ras, spreadProb = sp,
start = ncell(ras) / 4 - ncol(ras) / 4 * 3,
asymmetry = 2, asymmetryAngle = 135,
asRaster = FALSE)
sizes[wnn] <- circs[, .N]
}
abs(mean(sizes) - goalSize)
}
aa <- DEoptim(objFn, lower = 0.2, upper = 0.23,
control = DEoptim.control(
cluster = cl, NP = 10, VTR = 0.02,
initialpop = as.matrix(rnorm(10, 0.213, 0.001))
),
ras = hab, goalSize = goalSize)
# The value of spreadProb that will give the same expected event sizes to spreadProb = 0.225 is:
sp <- aa$optim$bestmem
circs <- spread2(ras, spreadProb = sp, start = ncell(ras) / 4 - ncol(ras) / 4 * 3,
asymmetry = 2, asymmetryAngle = 135, asRaster = FALSE)
####### Calibration curve
skip("Calibration curves")
# n <- 500
# ras <- terra::rast(terra::ext(0, 1000, 0, 1000), res = 1)
# sp <- runif(n, 0.15, 0.25)
# sizes <- integer()
# for (qwe in 1:n) {
# circs <- spread2(ras, spreadProb = sp[qwe], start = ncell(ras) / 2 - ncol(ras) / 2,
# asRaster = FALSE)
# sizes[qwe] <- NROW(circs)
# message(qwe)
# }
# dt1 <- data.table(sp, sizes)
# library(mgcv)
# aa <- gam(log10(dt1$sizes) ~ s(dt1$sp))
# aap <- predict(aa, se.fit = FALSE)
# plot(dt1$sp, log10(dt1$sizes), axes = FALSE, ylab = "Fire Size, ha", xlab = "Spread Probability")
# axis(2, 0:5, labels = 10 ^ (0:5))
# axis(1)
# aapOrd <- order(dt1$sp)
# lines(dt1$sp[aapOrd], aap[aapOrd], lwd = 2, col = "red")
# mtext(side = 3, paste("Resulting fire sizes, for given spread probabilities",
# "Red line shows expected size", sep = "\n"))
#
# aa1 <- gam(dt1$sp ~ s(log10(dt1$sizes)))
# aap1 <- predict(aa1, se.fit = FALSE, type = "response")
# plot(log10(dt1$sizes), dt1$sp, axes = FALSE, xlab = "Fire Size, ha", ylab = "Spread Probability")
# axis(2)
# axis(1, 0:5, labels = 10 ^ (0:5))
# aap1Ord <- order(log10(dt1$sizes))
# lines(log10(dt1$sizes)[aap1Ord], aap1[aap1Ord], lwd = 2, col = "red")
# mtext(side = 3, paste("Resulting fire sizes, for given spread probabilities",
# "Red line shows expected size", sep = "\n"))
}
})
test_that("spread2 returnFrom", {
testInit("terra")
rastDF <- needTerraAndRaster()
aOrig <- terra::rast(terra::ext(0, 100, 0, 100), res = 1)
for (ii in seq(NROW(rastDF))) {
read <- eval(parse(text = rastDF$read[ii]))
# inputs for x
a <- read(aOrig)
b <- read(aOrig)
b[] <- 1
bb <- focal(b, matrix(1 / 9, nrow = 3, ncol = 3), fun = sum, pad = TRUE, padValue = 0)
innerCells <- which(bb[] %==% 1)
set.seed(123)
for (iso in 1:20) {
sams <- sample(innerCells, 2)
expect_silent(out <- spread2(a, start = sams, 0.215, asRaster = FALSE,
returnFrom = TRUE))
out <- spread2(a, start = sams, 0.215, asRaster = FALSE, returnFrom = TRUE)
expect_true("from" %in% colnames(out))
expect_true(sum(is.na(out$from)) == length(sams))
}
}
})
test_that("spread2 tests", {
testInit("terra")
rastDF <- needTerraAndRaster()
aOrig <- terra::rast(terra::ext(0, 100, 0, 100), res = 1)
for (ii in seq(NROW(rastDF))) {
read <- eval(parse(text = rastDF$read[ii]))
a <- read(aOrig)
b <- read(aOrig)
b[] <- 1
bb <- focal(b, matrix(1 / 9, nrow = 3, ncol = 3), fun = sum, pad = TRUE, padValue = 0)
innerCells <- which(bb[] %==% 1)
sams <- sample(innerCells, 9)
# dev()
expect_no_error({
out <- spread2(a, start = sams, 1, circle = TRUE, asymmetry = 4,
asymmetryAngle = 120, iterations = 10, asRaster = FALSE,
returnDistances = TRUE, allowOverlap = TRUE)
})
expect_true("effectiveDistance" %in% colnames(out))
expect_true(all(out$state == "activeSource"))
expect_true(all(out$distance[out$distance > 0] <= out$effectiveDistance[out$distance > 0]))
}
})
test_that("spread2 works with terra", {
testInit("terra")
rastDF <- needTerraAndRaster()
aOrig <- terra::rast(terra::ext(0, 100, 0, 100), res = 1)
for (ii in seq(NROW(rastDF))) {
read <- eval(parse(text = rastDF$read[ii]))
a <- read(aOrig)
b <- read(aOrig)
# inputs for x
b[] <- 1
bb <- focal(b, matrix(1 / 9, nrow = 3, ncol = 3), fun = sum, pad = TRUE, padValue = 0)
innerCells <- which(bb[] %==% 1)
sams <- sample(innerCells, 9)
expect_silent({
out <- spread2(a, start = sams, 1, iterations = 1, asRaster = FALSE)
})
#TODO: add more tests once asymmetry, circle, etc works
expect_true(all(out[pixels %in% sams]$state == "inactive"))
expect_true(any("activeSource" %in% out$state))
}
})
test_that("spread2 tests -- persistence", {
testInit("terra")
rastDF <- needTerraAndRaster()
aOrig <- terra::rast(terra::ext(0, 50, 0, 50), res = 1)
for (ii in seq(NROW(rastDF))) {
read <- eval(parse(text = rastDF$read[ii]))
a <- read(aOrig)
b <- read(aOrig)
landscape <- read(aOrig)
landscape[] <- 1
start <- 1:5
## test the effect of persistence as a single numeric value
set.seed(5)
noPersist <- spread2(landscape = landscape, start = start, asRaster = FALSE,
spreadProb = 0.23, persistProb = 0, iterations = 10, directions = 8L, plot.it = FALSE)
wPersist <- spread2(landscape = landscape, start = start, asRaster = FALSE,
spreadProb = 0.23, persistProb = 0.8, iterations = 10, directions = 8L, plot.it = FALSE)
expect_true(sum(noPersist$state == "activeSource") < sum(wPersist$state == "activeSource"))
## test the effect of persistence as a raster layer
M <- matrix(0.8, nrow = 50, ncol = 50)
M[upper.tri(M)] <- 0
persistRas <- read(aOrig)
persistRas[] <- as.vector(M)
## first fire in high persistence area,
## second fire in low persistence area:
start <- c(50, ncell(landscape) - 49)
set.seed(5)
wRasPersist <- spread2(landscape = landscape, start = start,
spreadProb = 0.23, persistProb = persistRas, iterations = 10,
directions = 8L, asRaster = TRUE, plot.it = FALSE)
expect_true(sum(wRasPersist[] == 1, na.rm = TRUE) > sum(wRasPersist[] == 2, na.rm = TRUE))
}
})
test_that("spread2 tests -- SpaDES.tools issue #22 NA in spreadProb", {
testInit("terra")
rastDF <- needTerraAndRaster()
aOrig <- terra::rast(terra::ext(0, 50, 0, 50), res = 1)
for (ii in seq(NROW(rastDF))) {
read <- eval(parse(text = rastDF$read[ii]))
landscape <- read(aOrig)
landscape[] <- 1
landscape[51:55] <- NA
start <- 1:5
spreadProb <- landscape
spreadProb[!is.na(landscape[])] <- runif(sum(!is.na(landscape[])))
expect_silent(
spread2(landscape = landscape, spreadProb = spreadProb, start = start, plot.it = FALSE)
)
}
})
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.