Nothing
#'
#' Header for all (concatenated) test files
#'
#' Require spatstat.core
#' Obtain environment variable controlling tests.
#'
#' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
require(spatstat.core)
FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0)
ALWAYS <- TRUE
cat(paste("--------- Executing",
if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of",
"test code -----------\n"))
#' tests/aucroc.R
#'
#' AUC and ROC code
#'
#' $Revision: 1.6 $ $Date: 2020/11/02 06:26:45 $
local({
if(FULLTEST) {
fit <- kppm(redwood ~ I(y-x))
a <- roc(fit)
b <- auc(fit)
fet <- ppm(amacrine~x+y+marks)
d <- roc(fet)
e <- auc(fet)
}
})
## tests/cdf.test.R
local({
NSIM <- 9
op <- spatstat.options(ndummy.min=16, npixel=32)
AA <- split(ants, un=FALSE)
AC <- AA[["Cataglyphis"]]
AM <- AA[["Messor"]]
DM <- distmap(AM)
if(ALWAYS) {
## (1) check cdf.test with strange data
## Marked point patterns with some marks not represented
## should produce a warning, rather than a crash:
cdf.test(AC, DM)
}
if(FULLTEST) {
## should be OK:
cdf.test(unmark(AC), DM)
cdf.test(unmark(AC), DM, "cvm")
cdf.test(unmark(AC), DM, "ad")
## other code blocks
cdf.test(finpines, "x")
}
if(FULLTEST) {
## (2) Monte Carlo test for Gibbs model
fit <- ppm(cells ~ 1, Strauss(0.07))
cdf.test(fit, "x", nsim=NSIM)
## cdf.test.slrm
fut <- slrm(japanesepines ~ x + y)
Z <- distmap(japanesepines)
cdf.test(fut, Z)
}
reset.spatstat.options()
})
#' tests/circular.R
#'
#' Circular data and periodic distributions
#'
#' $Revision: 1.4 $ $Date: 2020/04/28 12:58:26 $
local({
if(ALWAYS) {
a <- pairorient(redwood, 0.05, 0.15, correction="none")
rose(a)
}
if(FULLTEST) {
b <- pairorient(redwood, 0.05, 0.15, correction="best")
rose(b, start="N", clockwise=TRUE)
}
if(ALWAYS) {
#' arcs on the circle
#' (depends on numerical behaviour)
set.seed(19171025)
aa <- replicate(7, runif(1, 0, 2*pi) + c(0, runif(1, 0, pi)),
simplify=FALSE)
bb <- circunion(aa)
assertsingle <- function(x, a, id) {
y <- circunion(x)
if(length(y) != 1 || max(abs(y[[1]] - a)) > .Machine$double.eps)
stop(paste("Incorrect result from circunion in case", id),
call.=FALSE)
invisible(NULL)
}
assertsingle(list(c(pi/3, pi), c(pi/2, 3*pi/2)),
c(pi/3, 3*pi/2),
1)
assertsingle(list(c(0, pi/2), c(pi/4, pi)),
c(0,pi),
2)
assertsingle(list(c(-pi/4, pi/2), c(pi/4, pi)),
c((2-1/4)*pi, pi),
3)
}
})
#'
#' tests/closecore.R
#'
#' check 'closepairs/crosspairs' code
#' invoked in core package
#'
#' $Revision: 1.4 $ $Date: 2021/04/17 04:16:43 $
#'
#' ------- All this code must be run on every hardware -------
#'
local({
#' weightedclosepairs is currently in strauss.R
wi <- weightedclosepairs(redwood, 0.05, "isotropic")
if(FULLTEST) {
wt <- weightedclosepairs(redwood, 0.05, "translate")
wp <- weightedclosepairs(redwood, 0.05, "periodic")
}
#' markmarkscatter uses closepairs.pp3
X <- runifpoint3(100)
marks(X) <- runif(100)
markmarkscatter(X, 0.2)
if(FULLTEST) {
markmarkscatter(X[FALSE], 0.2)
}
})
#'
#' contact.R
#'
#' Check machinery for first contact distributions
#'
#' $Revision: 1.8 $ $Date: 2021/04/17 02:25:55 $
local({
if(ALWAYS) {
#' reduce complexity
Y <- as.mask(heather$coarse, dimyx=c(50, 25))
X <- runifpoint(100, win = complement.owin(Y))
if(FULLTEST) G <- Gfox(X, Y)
J <- Jfox(X, Y)
Y <- as.polygonal(Y)
X <- runifpoint(100, win = complement.owin(Y))
if(FULLTEST) G <- Gfox(X, Y)
J <- Jfox(X, Y)
op <- spatstat.options(exactdt.checks.data=TRUE)
U <- exactdt(X)
spatstat.options(op)
}
})
reset.spatstat.options()
#'
#' tests/contrib.R
#'
#' Tests for user-contributed code in spatstat
#'
#' $Revision: 1.4 $ $Date: 2021/04/17 02:32:24 $
local({
#' Jinhom
#' Marie-Colette van Lieshout and Ottmar Cronie
X <- redwood3
if(FULLTEST) {
fit <- ppm(X ~ polynom(x,y,2))
} else {
X <- X[c(TRUE,FALSE)]
spatstat.options(npixel=32, ndummy.min=16)
fit <- ppm(X ~ x)
}
lam <- predict(fit)
lamX <- fitted(fit, dataonly=TRUE)
lmin <- 0.9 * min(lam)
g1 <- Ginhom(X, lambda=fit, update=TRUE)
if(FULLTEST) {
g2 <- Ginhom(X, lambda=fit, update=FALSE, lmin = lmin)
g3 <- Ginhom(X, lambda=lam, lmin=lmin)
g4 <- Ginhom(X, lambda=lamX, lmin=lmin)
}
if(ALWAYS) {
f2 <- Finhom(X, lambda=fit, update=FALSE)
}
if(FULLTEST) {
f1 <- Finhom(X, lambda=fit, update=TRUE)
f3 <- Finhom(X, lambda=lam, lmin=lmin)
}
if(!FULLTEST) reset.spatstat.options()
})
# tests/correctC.R
# check for agreement between C and interpreted code
# for interpoint distances etc.
# $Revision: 1.8 $ $Date: 2020/12/03 03:06:04 $
if(ALWAYS) { # depends on hardware
local({
eps <- .Machine$double.eps * 4
checkagree <- function(A, B, blurb) {
maxerr <- max(abs(A-B))
cat("Discrepancy", maxerr, "for", blurb, fill=TRUE)
if(maxerr > eps)
stop(paste("Algorithms for", blurb, "disagree"))
return(TRUE)
}
## pairdist.ppp
set.seed(190901)
## X <- rpoispp(42)
X <- runifrect(max(2, rpois(1, 42)))
dC <- pairdist(X, method="C")
dR <- pairdist(X, method="interpreted")
checkagree(dC, dR, "pairdist()")
dCp <- pairdist(X, periodic=TRUE, method="C")
dRp <- pairdist(X, periodic=TRUE, method="interpreted")
checkagree(dCp, dRp, "pairdist(periodic=TRUE)")
dCp2 <- pairdist(X, periodic=TRUE, squared=TRUE, method="C")
dRp2 <- pairdist(X, periodic=TRUE, squared=TRUE, method="interpreted")
checkagree(dCp2, dRp2, "pairdist(periodic=TRUE, squared=TRUE)")
## crossdist.ppp
## Y <- rpoispp(42)
Y <- runifrect(max(2, rpois(1, 42)))
dC <- crossdist(X, Y, method="C")
dR <- crossdist(X, Y, method="interpreted")
checkagree(dC, dR, "crossdist()")
dC <- crossdist(X, Y, periodic=TRUE, method="C")
dR <- crossdist(X, Y, periodic=TRUE, method="interpreted")
checkagree(dC, dR, "crossdist(periodic=TRUE)")
dC2 <- crossdist(X, Y, periodic=TRUE, squared=TRUE, method="C")
dR2 <- crossdist(X, Y, periodic=TRUE, squared=TRUE, method="interpreted")
checkagree(dC2, dR2, "crossdist(periodic=TRUE, squared=TRUE)")
# nndist.ppp
nnC <- nndist(X, method="C")
nnI <- nndist(X, method="interpreted")
checkagree(nnC, nnI, "nndist()")
nn3C <- nndist(X, k=3, method="C")
nn3I <- nndist(X, k=3, method="interpreted")
checkagree(nn3C, nn3I, "nndist(k=3)")
# nnwhich.ppp
nwC <- nnwhich(X, method="C")
nwI <- nnwhich(X, method="interpreted")
checkagree(nwC, nwI, "nnwhich()")
nw3C <- nnwhich(X, k=3, method="C")
nw3I <- nnwhich(X, k=3, method="interpreted")
checkagree(nw3C, nw3I, "nnwhich(k=3)")
# whist
set.seed(98123)
x <- runif(1000)
w <- sample(1:5, 1000, replace=TRUE)
b <- seq(0,1,length=101)
op <- spatstat.options(Cwhist=TRUE)
aT <- whist(x,b,w)
spatstat.options(Cwhist=FALSE)
aF <- whist(x,b,w)
if(!all(aT == aF))
stop("Algorithms for whist disagree")
spatstat.options(op)
})
reset.spatstat.options()
}
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.