#'
#' Header for all (concatenated) test files
#'
#' Require spatstat.model
#' Obtain environment variable controlling tests.
#'
#' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
require(spatstat.model)
FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0)
ALWAYS <- TRUE
cat(paste("--------- Executing",
if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of",
"test code -----------\n"))
#
# tests/envelopes.R
#
# Test validity of envelope data
#
# $Revision: 1.28 $ $Date: 2022/11/24 01:35:26 $
#
local({
checktheo <- function(fit) {
fitname <- deparse(substitute(fit))
en <- envelope(fit, nsim=4, verbose=FALSE, nrep=1e3)
nama <- names(en)
expecttheo <- is.poisson(fit) && is.stationary(fit)
context <- paste("Envelope of", fitname)
if(expecttheo) {
if(!("theo" %in% nama))
stop(paste(context, "did not contain", sQuote("theo")))
if("mmean" %in% nama)
stop(paste(context, "unexpectedly contained", sQuote("mmean")))
} else {
if("theo" %in% nama)
stop(paste(context, "unexpectedly contained", sQuote("theo")))
if(!("mmean" %in% nama))
stop(paste(context, "did not contain", sQuote("mmean")))
}
cat(paste(context, "has correct format\n"))
}
if(ALWAYS) {
checktheo(ppm(cells ~x))
}
if(FULLTEST) {
checktheo(ppm(cells))
checktheo(ppm(cells ~1, Strauss(0.1)))
}
#' check savefuns/savepatterns with global
fit <- ppm(cells~x)
if(ALWAYS) Ef <- envelope(fit, Kest, nsim=4, savefuns=TRUE, global=TRUE)
if(FULLTEST) Ep <- envelope(fit, Kest, nsim=4, savepatterns=TRUE, global=TRUE)
#' check handling of 'dangerous' cases
if(FULLTEST) {
fut <- ppm(redwood ~ x)
Ek <- envelope(fut, Kinhom, update=FALSE, nsim=4)
kfut <- kppm(redwood3 ~ x)
Ekk <- envelope(kfut, Kinhom, lambda=density(redwood3), nsim=7)
}
if(ALWAYS) { # invokes C code
fit <- ppm(japanesepines ~ 1, Strauss(0.04))
e6 <- envelope(fit, Kest, nsim=4, fix.n=TRUE)
fit2 <- ppm(amacrine ~ 1, Strauss(0.03))
e7 <- envelope(fit2, Gcross, nsim=4, fix.marks=TRUE)
}
if(FULLTEST) {
fit <- ppm(cells ~ 1, Strauss(0.07))
U <- envelope(fit, nsim=3, simulate=expression(runifpoint(20)))
kfit <- kppm(redwood3 ~ x)
UU <- envelope(kfit, nsim=7, simulate=expression(simulate(kfit, drop=TRUE)))
VV <- envelope(kfit, nsim=7, weights=1:7)
MM <- envelope(kfit, nsim=7, Kinhom, lambda=density(redwood3))
}
if(FULLTEST) {
#' envelope computations in other functions
P <- lurking(cells, expression(x), envelope=TRUE, nsim=9)
print(P)
#' re-using envelope objects in other functions
A <- envelope(cells, nsim=9, savepatterns=TRUE, savefuns=TRUE)
S <- lurking(cells, expression(x), envelope=A, nsim=9)
#' envelope.envelope
B <- envelope(cells, nsim=5, savepatterns=TRUE, savefuns=FALSE)
envelope(B)
}
## close 'local'
})
#' tests/enveltest.R
#' Envelope tests (dclf.test, mad.test)
#' and two-stage tests (bits.test, dg.test, bits.envelope, dg.envelope)
#'
#' $Revision: 1.3 $ $Date: 2020/04/28 12:58:26 $
#'
if(FULLTEST) {
local({
#' handling of NA function values (due to empty point patterns)
set.seed(1234)
X <- rThomas(5, 0.05, 10)
fit <- kppm(X ~ 1, "Thomas")
set.seed(100000)
dclf.test(fit)
set.seed(909)
dg.test(fit, nsim=9)
#' other code blocks
dclf.test(fit, rinterval=c(0, 3), nsim=9)
envelopeTest(X, exponent=3, clamp=TRUE, nsim=9)
})
}
#
# tests/fastgeyer.R
#
# checks validity of fast C implementation of Geyer interaction
#
# $Revision: 1.4 $ $Date: 2020/04/28 12:58:26 $
#
if(FULLTEST) { # depends on hardware
local({
X <- redwood
Q <- quadscheme(X)
U <- union.quad(Q)
EP <- equalpairs.quad(Q)
G <- Geyer(0.11, 2)
# The value r=0.11 is chosen to avoid hardware numerical effects (gcc bug 323).
# It avoids being close any value of pairdist(redwood).
# The nearest such values are 0.1077.. and 0.1131..
# By contrast if r = 0.1 there are values differing from 0.1 by 3e-17
a <- pairsat.family$eval(X,U,EP,G$pot,G$par,"border")
b <- G$fasteval(X,U,EP,G$pot,G$par,"border")
if(!all(a==b))
stop("Results of Geyer()$fasteval and pairsat.family$eval do not match")
# ...
# and again for a non-integer value of 'sat'
# (spotted by Thordis Linda Thorarinsdottir)
G <- Geyer(0.11, 2.5)
a <- pairsat.family$eval(X,U,EP,G$pot,G$par,"border")
b <- G$fasteval(X,U,EP,G$pot,G$par,"border")
if(!all(a==b))
stop("Results of Geyer()$fasteval and pairsat.family$eval do not match when sat is not an integer")
# and again for sat < 1
# (spotted by Rolf)
G <- Geyer(0.11, 0.5)
a <- pairsat.family$eval(X,U,EP,G$pot,G$par,"border")
b <- G$fasteval(X,U,EP,G$pot,G$par,"border")
if(!all(a==b))
stop("Results of Geyer()$fasteval and pairsat.family$eval do not match when sat < 1")
})
}
#' tests/formuli.R
#'
#' Test machinery for manipulating formulae
#'
#' $Revision: 1.7 $ $Date: 2020/04/28 12:58:26 $
local({
ff <- function(A, deletevar, B) {
D <- reduceformula(A, deletevar)
if(!spatstat.utils::identical.formulae(D, B)) {
AD <- as.expression(substitute(reduceformula(A,d),
list(A=A, d=deletevar)))
stop(paste(AD, "\n\tyields ", spatstat.utils::pasteFormula(D),
" instead of ", spatstat.utils::pasteFormula(B)),
call.=FALSE)
}
invisible(NULL)
}
ff(~ x + z, "x", ~z)
ff(y ~ x + z, "x", y~z)
ff(~ I(x^2) + z, "x", ~z)
ff(y ~ poly(x,2) + poly(z,3), "x", y ~poly(z,3))
ff(y ~ x + z, "g", y ~ x + z)
reduceformula(y ~ x+z, "g", verbose=TRUE)
reduceformula(y ~ sin(x-z), "z", verbose=TRUE)
illegal.iformula(~str*g, itags="str", dfvarnames=c("marks", "g", "x", "y"))
})
##
## tests/funnymarks.R
##
## tests involving strange mark values
## $Revision: 1.7 $ $Date: 2020/04/28 12:58:26 $
if(ALWAYS) { # depends on locale
local({
## ppm() where mark levels contain illegal characters
hyphenated <- c("a", "not-a")
spaced <- c("U", "non U")
suffixed <- c("a+", "a*")
charred <- c("+", "*")
irad <- matrix(0.1, 2,2)
hrad <- matrix(0.005, 2, 2)
tryit <- function(types, X, irad, hrad) {
levels(marks(X)) <- types
fit <- ppm(X ~marks + polynom(x,y,2),
MultiStraussHard(types=types,iradii=irad,hradii=hrad))
print(fit)
print(coef(fit))
val <- fitted(fit)
pred <- predict(fit)
return(invisible(NULL))
}
tryit(hyphenated, amacrine, irad, hrad)
tryit(spaced, amacrine, irad, hrad)
tryit(suffixed, amacrine, irad, hrad)
tryit(charred, amacrine, irad, hrad)
## marks which are dates
X <- cells
n <- npoints(X)
endoftime <- rep(ISOdate(2001,1,1), n)
eotDate <- rep(as.Date("2001-01-01"), n)
markformat(endoftime)
markformat(eotDate)
marks(X) <- endoftime
print(X)
Y <- X %mark% data.frame(id=1:42, date=endoftime, dd=eotDate)
print(Y)
md <- markformat(endoftime)
## mark formats
Z <- Y
marks(Z) <- marks(Z)[1,,drop=FALSE]
ms <- markformat(solist(cells, redwood))
marks(Z) <- factor(1:npoints(Z))
marks(Z)[12] <- NA
mz <- is.multitype(Z)
cZ <- coerce.marks.numeric(Z)
marks(Z) <- data.frame(n=1:npoints(Z),
a=factor(sample(letters, npoints(Z), replace=TRUE)))
cZ <- coerce.marks.numeric(Z)
stopifnot(is.multitype(cells %mark% data.frame(a=factor(1:npoints(cells)))))
a <- numeric.columns(finpines)
b1 <- numeric.columns(amacrine)
b2 <- coerce.marks.numeric(amacrine)
d <- numeric.columns(cells)
f <- numeric.columns(longleaf)
ff <- data.frame(a=factor(letters[1:10]), y=factor(sample(letters, 10)))
numeric.columns(ff)
## mark operations
df <- data.frame(x=1:2, y=sample(letters, 2))
h <- hyperframe(z=1:2, p=solist(cells, cells))
a <- NULL %mrep% 3
a <- 1:4 %mrep% 3
a <- df %mrep% 3
a <- h %mrep% 3
b <- markcbind(df, h)
b <- markcbind(h, df)
})
}
Generated by dwww version 1.15 on Sat May 18 14:05:33 CEST 2024.