tests/testthat/test-covar.R

In lacunaritycovariance: Gliding Box Lacunarity and Other Metrics for 2D Random Closed Sets

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))
})