Nothing
context("Estimation - Covariance")
if (identical(Sys.getenv("NOT_CRAN"), "true")){
spatstat.options(npixel = 512) #to make default pixelisations higher resolution
proptol = 0.1
} else {
spatstat.options(npixel = xiimg$dim[[1]]) #matches the number of pixels of the discretised xi
proptol = 0.1
}
#estimate covariance of owin (covariance of image already estimated in help code)
covarest.frowin.all <- racscovariance(xi, obswin = w)
test_that("Covariance Estimation from an owin object matches the estimates from an im object", {
covarest.frowin <- covarest.frowin.all[["pickaH"]]
expect_is(covarest.frim, "im")
expect_is(covarest.frowin, "im")
covarest.diffs <- eval.im(a - b, harmonise.im(a = covarest.frowin, b = covarest.frim))
expect_lt(mean(covarest.diffs) / max(abs(covarest.frim)), proptol)
expect_lt(max(abs(covarest.diffs)) / max(abs(covarest.frim)), proptol)
})
#Test on a Boolean Model
#takes a few minutes
test_that("racscovariance pickaH method matches theoretical covariance for Boolean Model", {
skip_on_cran()
#isotropise covar functions
covarest.frim <- covarest.frim[owin(xrange = c(-1, 1) * 3.5 * discr, yrange = c(-1, 1) * 3.5 * discr), drop = TRUE]
covarest.frowin.all <- lapply(covarest.frowin.all,
function(x) x[owin(xrange = c(-1, 1) * 3.5 * discr, yrange = c(-1, 1) * 3.5 * discr), drop = TRUE])
covarest.frim.iso <- rotmean(covarest.frim, padzero = FALSE)
covarest.frowin.all.iso <- lapply(covarest.frowin.all, rotmean, padzero = FALSE)
truecovar.iso <- with.fv(covarest.frim.iso, bddcovar.iso(.x, lambda, discr),
fun = TRUE)
names(truecovar.iso) <- c("r", "f")
covarest.all.iso <- collapse.fv(harmonise.fv(c(list(truecovar = truecovar.iso),
list(frim = covarest.frim.iso),
covarest.frowin.all.iso)), different = "f")
#residual to theoretical covariance
isocovarresid <- with.fv(covarest.all.iso, (. - truecovar) / truecovar, FUN = TRUE)
#truncate residuals
isocovarresid <- isocovarresid[isocovarresid$r < max(isocovarresid$r/2), ] #the condition removes large radii relative to window size
#expect that this residual is smaller than 10% of the true covariance
expect_lt(max(isocovarresid$pickaH), proptol)
expect_lt(max(isocovarresid$pickaint), proptol)
expect_lt(max(isocovarresid$mattfeldt), proptol)
expect_lt(max(isocovarresid[, fvnames(isocovarresid, a = "."), drop = TRUE]), proptol)
#expect_lt(max(isocovarresid[, fvnames(isocovarresid, a = ".") != "plugin"]), 0.1)
})
reset.spatstat.options()
test_that("unbalanced covariance estimation is symmetric for non-symmetric windows", {
unsymmw <- union.owin(square(100),
shift.owin(square(100), vec = (c(100, 100))),
shift.owin(square(100), vec = (c(100, 200))),
shift.owin(square(100), vec = (c(200, 100)))
)
setcovw <- setcov(unsymmw)
expect_equal(max(abs(setcovw - reflect.im(setcovw))), 0)
covarest.frowin <- racscovariance(xi, obswin = unsymmw, estimators = "pickaH", drop = TRUE)
expect_equal(max(abs(covarest.frowin - reflect.im(covarest.frowin))), 0)
})
test_that("racscovariance gives results in correct structure", {
out <- racscovariance(xi, obswin = w)
expect_length(out, 4)
expect_named(out)
expect_s3_class(out, "imlist")
})
test_that("racscovariance errors correctly", {
expect_error(racscovariance(heather$coarse), regexp = "owin")
expect_error(racscovariance(as.im(heather$coarse, value = TRUE, na.replace = FALSE),
obswin = shift.owin(disc(), vec = c(3, 3))))
})
test_that("plugincvc errors when not passed a binary map", {
xi <- heather$coarse
xiimg <- as.im(xi, W = w, eps = c(0.1, 0.1), na.replace = 0)
xiimg[5, 10] <- 1.1
expect_error(plugincvc(xiimg), regexp = "Input xi has values other than 0, 1 or NA")
})
test_that("plugincvc errors when passed a foreground set and no observation window", {
xi <- heather$coarse
expect_error(plugincvc(xi), regexp = "obswin")
})
test_that("plugincvc maintains unitnames", {
xi <- heather$coarse
cvcest <- plugincvc(xi, obswin = Frame(xi))
expect_equal(unitname(xi), unitname(cvcest))
})
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.