R Under development (unstable) (2023-09-06 r85088 ucrt) -- "Unsuffered Consequences" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-w64-mingw32/x64 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > #' > #' Header for all (concatenated) test files > #' > #' Require spatstat.explore > #' Obtain environment variable controlling tests. > #' > #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ > > require(spatstat.explore) Loading required package: spatstat.explore Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-5 Loading required package: spatstat.random spatstat.random 3.1-5 Loading required package: nlme spatstat.explore 3.2-3 > FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) > ALWAYS <- TRUE > cat(paste("--------- Executing", + if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", + "test code -----------\n")) --------- Executing **RESTRICTED** subset of test code ----------- > #' > #' tests/density.R > #' > #' Test behaviour of density() methods, > #' relrisk(), Smooth() > #' and inhomogeneous summary functions > #' and idw, adaptive.density, intensity > #' > #' $Revision: 1.62 $ $Date: 2022/05/22 11:14:51 $ > #' > > if(!FULLTEST) + spatstat.options(npixel=32, ndummy.min=16) > > > local({ + + # test all cases of density.ppp and densityfun.ppp + + tryit <- function(..., do.fun=TRUE, badones=FALSE) { + Z <- density(cells, ..., at="pixels") + Z <- density(cells, ..., at="points") + if(do.fun) { + f <- densityfun(cells, ...) + U <- f(0.1, 0.3) + if(badones) { + U2 <- f(1.1, 0.3) + U3 <- f(1.1, 0.3, drop=FALSE) + } + } + return(invisible(NULL)) + } + + if(ALWAYS) { + tryit(0.05) + tryit(0.05, diggle=TRUE) + tryit(0.05, se=TRUE) + tryit(0.05, weights=expression(x)) + tryit(0.07, kernel="epa") + tryit(sigma=Inf) + tryit(0.05, badones=TRUE) + } + if(FULLTEST) { + tryit(0.07, kernel="quartic") + tryit(0.07, kernel="disc") + tryit(0.07, kernel="epa", weights=expression(x)) + tryit(sigma=Inf, weights=expression(x)) + } + + V <- diag(c(0.05^2, 0.07^2)) + + if(ALWAYS) { + tryit(varcov=V) + } + if(FULLTEST) { + tryit(varcov=V, diggle=TRUE) + tryit(varcov=V, weights=expression(x)) + tryit(varcov=V, weights=expression(x), diggle=TRUE) + Z <- distmap(runifpoint(5, Window(cells))) + tryit(0.05, weights=Z) + tryit(0.05, weights=Z, diggle=TRUE) + } + + trymost <- function(...) tryit(..., do.fun=FALSE) + wdf <- data.frame(a=1:42,b=42:1) + if(ALWAYS) { + trymost(0.05, weights=wdf) + trymost(sigma=Inf, weights=wdf) + } + if(FULLTEST) { + trymost(0.05, weights=wdf, diggle=TRUE) + trymost(varcov=V, weights=wdf) + trymost(varcov=V, weights=expression(cbind(x,y))) + } + + ## check conservation of mass + checkconserve <- function(X, xname, sigma, toler=0.01) { + veritas <- npoints(X) + vino <- integral(density(X, sigma, diggle=TRUE)) + relerr <- abs(vino - veritas)/veritas + if(relerr > toler) + stop(paste("density.ppp(diggle=TRUE) fails to conserve mass:", + vino, "!=", veritas, + "for", sQuote(xname)), + call.=FALSE) + return(relerr) + } + if(FULLTEST) { + checkconserve(cells, "cells", 0.15) + } + if(ALWAYS) { + checkconserve(split(chorley)[["lung"]], "lung", 2) + } + + ## run C algorithm 'denspt' + opa <- spatstat.options(densityC=TRUE, densityTransform=FALSE) + if(ALWAYS) { + tryit(varcov=V) + } + if(FULLTEST) { + tryit(varcov=V, weights=expression(x)) + trymost(varcov=V, weights=wdf) + } + spatstat.options(opa) + + crossit <- function(..., sigma=NULL) { + U <- runifpoint(20, Window(cells)) + a <- densitycrossEngine(cells, U, ..., sigma=sigma) + a <- densitycrossEngine(cells, U, ..., sigma=sigma, diggle=TRUE) + invisible(NULL) + } + if(ALWAYS) { + crossit(varcov=V, weights=cells$x) + crossit(sigma=Inf) + } + if(FULLTEST) { + crossit(varcov=V, weights=wdf) + crossit(sigma=0.1, weights=wdf) + crossit(sigma=0.1, kernel="epa", weights=wdf) + } + + ## apply different discretisation rules + if(ALWAYS) { + Z <- density(cells, 0.05, fractional=TRUE) + } + if(FULLTEST) { + Z <- density(cells, 0.05, preserve=TRUE) + Z <- density(cells, 0.05, fractional=TRUE, preserve=TRUE) + } + + ## compare results with different algorithms + crosscheque <- function(expr) { + e <- as.expression(substitute(expr)) + ename <- sQuote(deparse(substitute(expr))) + ## interpreted R + opa <- spatstat.options(densityC=FALSE, densityTransform=FALSE) + val.interpreted <- eval(e) + ## established C algorithm 'denspt' + spatstat.options(densityC=TRUE, densityTransform=FALSE) + val.C <- eval(e) + ## new C algorithm 'Gdenspt' using transformed coordinates + spatstat.options(densityC=TRUE, densityTransform=TRUE) + val.Transform <- eval(e) + spatstat.options(opa) + if(max(abs(val.interpreted - val.C)) > 0.001) + stop(paste("Numerical discrepancy between R and C algorithms in", + ename)) + if(max(abs(val.C - val.Transform)) > 0.001) + stop(paste("Numerical discrepancy between C algorithms", + "using transformed and untransformed coordinates in", + ename)) + invisible(NULL) + } + + ## execute & compare results of density(at="points") with different algorithms + wdfr <- cbind(1:npoints(redwood), 2) + if(ALWAYS) { + crosscheque(density(redwood, at="points", sigma=0.13, edge=FALSE)) + crosscheque(density(redwood, at="points", sigma=0.13, edge=FALSE, + weights=wdfr[,1])) + crosscheque(density(redwood, at="points", sigma=0.13, edge=FALSE, + weights=wdfr)) + } + + ## correctness of non-Gaussian kernel calculation + leavein <- function(ker, maxd=0.025) { + ZI <- density(redwood, 0.12, kernel=ker, edge=FALSE, + dimyx=256)[redwood] + ZP <- density(redwood, 0.12, kernel=ker, edge=FALSE, + at="points", leaveoneout=FALSE) + discrep <- max(abs(ZP - ZI))/npoints(redwood) + if(discrep > maxd) + stop(paste("Discrepancy", + signif(discrep, 3), + "in calculation for", ker, "kernel")) + return(invisible(NULL)) + } + if(ALWAYS) { + leavein("epanechnikov", 0.015) + } + if(FULLTEST) { + leavein("quartic", 0.010) + leavein("disc", 0.100) + } + + ## bandwidth selection code blocks + sigvec <- 0.01 * 2:15 + sigran <- range(sigvec) + if(ALWAYS) { + bw.ppl(redwood, sigma=sigvec) + bw.CvL(redwood, sigma=sigvec) + } + if(FULLTEST) { + bw.ppl(redwood, srange=sigran, ns=5) + bw.CvL(redwood, srange=sigran, ns=5) + } + ## adaptive bandwidth + if(ALWAYS) { + a <- bw.abram(redwood) + } + if(FULLTEST) { + a <- bw.abram(redwood, pilot=density(redwood, 0.2)) + a <- bw.abram(redwood, smoother="densityVoronoi", at="pixels") + } + + ## Kinhom + if(ALWAYS) { + lam <- density(redwood) + K <- Kinhom(redwood, lam) + + lamX <- density(redwood, at="points") + KX <- Kinhom(redwood, lamX) + } + + ## test all code cases of new 'relrisk.ppp' algorithm + pants <- function(..., X=ants, sigma=100, se=TRUE) { + a <- relrisk(X, sigma=sigma, se=se, ...) + return(TRUE) + } + if(ALWAYS) { + pants() + pants(diggle=TRUE) + pants(edge=FALSE) + pants(at="points") + pants(casecontrol=FALSE) + pants(relative=TRUE) + pants(sigma=Inf) + pants(sigma=NULL, varcov=diag(c(100,100)^2)) + f <- 1/area(Window(ants)) + pants(fudge=f) + } + if(FULLTEST) { + pants(diggle=TRUE, at="points") + pants(edge=FALSE, at="points", fudge=f) + pants(casecontrol=FALSE, relative=TRUE) + pants(casecontrol=FALSE,at="points") + pants(relative=TRUE,at="points", fudge=f) + pants(casecontrol=FALSE, relative=TRUE,at="points") + pants(relative=TRUE, control="Cataglyphis", case="Messor", fudge=f) + pants(relative=TRUE, control="Cataglyphis", case="Messor", at="points") + pants(casecontrol=FALSE, case="Messor", se=FALSE) + pants(case=2, at="pixels", relative=TRUE) + pants(case=2, at="points", relative=TRUE) + pants(case=2, at="pixels", relative=FALSE) + pants(case=2, at="points", relative=FALSE) + } + if(ALWAYS) { + ## underflow example from stackoverflow! + funky <- scanpp("funky.tab", owin(c(4, 38), c(0.3, 17))) + P <- relrisk(funky, 0.5) + R <- relrisk(funky, 0.5, relative=TRUE) + } + ## more than 2 types + if(ALWAYS) { + pants(X=sporophores) + pants(X=sporophores, sigma=20, at="points") + pants(X=sporophores, sigma=20, at="points", fudge=f) + bw.relrisk(sporophores, method="leastsquares") + } + if(FULLTEST) { + pants(X=sporophores, sigma=20, relative=TRUE, at="points", fudge=f) + pants(X=sporophores, sigma=20, at="pixels", se=FALSE) + pants(X=sporophores, sigma=20, relative=TRUE, at="pixels", se=FALSE) + bw.relrisk(sporophores, method="weightedleastsquares") + } + + ## execute Smooth.ppp and Smoothfun.ppp in all cases + stroke <- function(..., Y = longleaf, FUN=TRUE) { + Z <- Smooth(Y, ..., at="pixels") + Z <- Smooth(Y, ..., at="points", leaveoneout=TRUE) + Z <- Smooth(Y, ..., at="points", leaveoneout=FALSE) + if(FUN) { + f <- Smoothfun(Y, ...) + f(120, 80) + f(Y[1:2]) + f(Y[FALSE]) + U <- as.im(f) + } + return(invisible(NULL)) + } + if(ALWAYS) { + stroke() + stroke(5, diggle=TRUE) + stroke(5, geometric=TRUE) + stroke(1e-6) # generates warning about small bandwidth + stroke(5, weights=expression(x)) + stroke(5, kernel="epa") + stroke(sigma=Inf) + } + if(FULLTEST) { + Z <- as.im(function(x,y){abs(x)+1}, Window(longleaf)) + stroke(5, weights=Z) + stroke(5, weights=runif(npoints(longleaf))) + stroke(varcov=diag(c(25, 36))) + stroke(varcov=diag(c(25, 36)), weights=runif(npoints(longleaf))) + stroke(5, Y=longleaf %mark% 1) + stroke(5, Y=cut(longleaf,breaks=3)) + stroke(5, weights=Z, geometric=TRUE) + g <- function(x,y) { dnorm(x, sd=10) * dnorm(y, sd=10) } + stroke(kernel=g, cutoff=30, FUN=FALSE) + stroke(kernel=g, cutoff=30, scalekernel=TRUE, sigma=1, FUN=FALSE) + } + if(FULLTEST) { + ## standard errors - single column of marks + stroke(sigma=5, se=TRUE) + stroke(sigma=5, se=TRUE, loctype="f") + w <- runif(npoints(longleaf)) + stroke(sigma=5, se=TRUE, weights=w, loctype="r", wtype="i") + stroke(sigma=5, se=TRUE, weights=w, loctype="r", wtype="m") + stroke(sigma=5, se=TRUE, weights=w, loctype="f", wtype="i") + stroke(sigma=5, se=TRUE, weights=w, loctype="f", wtype="m") + } + + niets <- markmean(longleaf, 9) + + strike <- function(..., Y=finpines) { + Z <- Smooth(Y, ..., at="pixels") + Z <- Smooth(Y, ..., at="points", leaveoneout=TRUE) + Z <- Smooth(Y, ..., at="points", leaveoneout=FALSE) + f <- Smoothfun(Y, ...) + f(4, 1) + f(Y[1:2]) + f(Y[FALSE]) + U <- as.im(f) + return(invisible(NULL)) + } + if(ALWAYS) { + strike() + strike(sigma=1.5, kernel="epa") + strike(varcov=diag(c(1.2, 2.1))) + strike(sigma=1e-6) + strike(sigma=Inf) + } + if(FULLTEST) { + strike(sigma=1e-6, kernel="epa") + strike(1.5, weights=runif(npoints(finpines))) + strike(1.5, weights=expression(y)) + strike(1.5, geometric=TRUE) + strike(1.5, Y=finpines[FALSE]) + flatfin <- finpines %mark% data.frame(a=rep(1, npoints(finpines)), b=2) + strike(1.5, Y=flatfin) + strike(1.5, Y=flatfin, geometric=TRUE) + } + if(FULLTEST) { + ## standard errors - multivariate marks + strike(sigma=1.5, se=TRUE) + strike(sigma=1.5, se=TRUE, loctype="f") + w <- runif(npoints(finpines)) + strike(sigma=1.5, se=TRUE, weights=w, loctype="r", wtype="i") + strike(sigma=1.5, se=TRUE, weights=w, loctype="r", wtype="m") + strike(sigma=1.5, se=TRUE, weights=w, loctype="f", wtype="i") + strike(sigma=1.5, se=TRUE, weights=w, loctype="f", wtype="m") + } + opx <- spatstat.options(densityTransform=FALSE) + if(ALWAYS) { + stroke(5, Y=longleaf[order(longleaf$x)], sorted=TRUE) + } + if(FULLTEST) { + strike(1.5, Y=finpines[order(finpines$x)], sorted=TRUE) + } + spatstat.options(opx) + + ## detect special cases + if(ALWAYS) { + Smooth(longleaf[FALSE]) + Smooth(longleaf, minnndist(longleaf)) + Xconst <- cells %mark% 1 + Smooth(Xconst, 0.1) + Smooth(Xconst, 0.1, at="points") + Smooth(cells %mark% runif(42), sigma=Inf) + Smooth(cells %mark% runif(42), sigma=Inf, at="points") + Smooth(cells %mark% runif(42), sigma=Inf, at="points", leaveoneout=FALSE) + Smooth(cut(longleaf, breaks=4)) + } + + ## code not otherwise reached + if(ALWAYS) { + smoothpointsEngine(cells, values=rep(1, npoints(cells)), sigma=0.2) + } + if(FULLTEST) { + smoothpointsEngine(cells, values=runif(npoints(cells)), sigma=Inf) + smoothpointsEngine(cells, values=runif(npoints(cells)), sigma=1e-16) + } + + ## validity of Smooth.ppp(at='points') + Y <- longleaf %mark% runif(npoints(longleaf), min=41, max=43) + Z <- Smooth(Y, 5, at="points", leaveoneout=TRUE) + rZ <- range(Z) + if(rZ[1] < 40 || rZ[2] > 44) + stop("Implausible results from Smooth.ppp(at=points, leaveoneout=TRUE)") + + Z <- Smooth(Y, 5, at="points", leaveoneout=FALSE) + rZ <- range(Z) + if(rZ[1] < 40 || rZ[2] > 44) + stop("Implausible results from Smooth.ppp(at=points, leaveoneout=FALSE)") + + ## compare Smooth.ppp results with different algorithms + if(ALWAYS) { + crosscheque(Smooth(longleaf, at="points", sigma=6)) + wt <- runif(npoints(longleaf)) + crosscheque(Smooth(longleaf, at="points", sigma=6, weights=wt)) + } + if(FULLTEST) { + vc <- diag(c(25,36)) + crosscheque(Smooth(longleaf, at="points", varcov=vc)) + crosscheque(Smooth(longleaf, at="points", varcov=vc, weights=wt)) + } + ## drop-dimension coding errors + if(FULLTEST) { + X <- longleaf + marks(X) <- cbind(marks(X), 1) + Z <- Smooth(X, 5) + + ZZ <- bw.smoothppp(finpines, hmin=0.01, hmax=0.012, nh=2) # reshaping problem + } + + ## geometric-mean smoothing + if(ALWAYS) { + U <- Smooth(longleaf, 5, geometric=TRUE) + } + if(FULLTEST) { + UU <- Smooth(X, 5, geometric=TRUE) + V <- Smooth(longleaf, 5, geometric=TRUE, at="points") + VV <- Smooth(X, 5, geometric=TRUE, at="points") + } + }) There were 22 warnings (use warnings() to see them) > > reset.spatstat.options() > > local({ + if(ALWAYS) { + #' Kmeasure, second.moment.engine + #' Expansion of window + Zno <- Kmeasure(redwood, sigma=0.2, expand=FALSE) + Zyes <- Kmeasure(redwood, sigma=0.2, expand=TRUE) + #' All code blocks + sigmadouble <- rep(0.1, 2) + diagmat <- diag(sigmadouble^2) + generalmat <- matrix(c(1, 0.5, 0.5, 1)/100, 2, 2) + Z <- Kmeasure(redwood, sigma=sigmadouble) + Z <- Kmeasure(redwood, varcov=diagmat) + Z <- Kmeasure(redwood, varcov=generalmat) + A <- second.moment.calc(redwood, 0.1, what="all", debug=TRUE) + B <- second.moment.calc(redwood, varcov=diagmat, what="all") + B <- second.moment.calc(redwood, varcov=diagmat, what="all") + D <- second.moment.calc(redwood, varcov=generalmat, what="all") + PR <- pixellate(redwood) + DRno <- second.moment.calc(PR, 0.2, debug=TRUE, expand=FALSE, + npts=npoints(redwood), obswin=Window(redwood)) + DRyes <- second.moment.calc(PR, 0.2, debug=TRUE, expand=TRUE, + npts=npoints(redwood), obswin=Window(redwood)) + DR2 <- second.moment.calc(solist(PR, PR), 0.2, debug=TRUE, expand=TRUE, + npts=npoints(redwood), obswin=Window(redwood)) + Gmat <- generalmat * 100 + isoGauss <- function(x,y) {dnorm(x) * dnorm(y)} + ee <- evaluate2Dkernel(isoGauss, runif(10), runif(10), + varcov=Gmat, scalekernel=TRUE) + isoGaussIm <- as.im(isoGauss, square(c(-3,3))) + gg <- evaluate2Dkernel(isoGaussIm, runif(10), runif(10), + varcov=Gmat, scalekernel=TRUE) + ## experimental code + op <- spatstat.options(developer=TRUE) + DR <- density(redwood, 0.1) + spatstat.options(op) + } + }) smooth: maximum imaginary part= 1.2e-18 smooth: mass error= 0 2nd moment measure: maximum imaginary part= 4.69e-17 2nd moment measure: mass error= 0 smooth: maximum imaginary part= 8.16e-19 smooth: mass error= 0 2nd moment measure: maximum imaginary part= 3.05e-17 2nd moment measure: mass error= 0 smooth: maximum imaginary part= 1.77e-18 smooth: mass error= 0 2nd moment measure: maximum imaginary part= 8e-17 2nd moment measure: mass error= 0 smooth component 1 : maximum imaginary part= 1.77e-18 smooth component 1 : mass error= 0 smooth component 2 : maximum imaginary part= 1.77e-18 smooth component 2 : mass error= 0 2nd moment measure: maximum imaginary part= 8e-17 2nd moment measure: mass error= 0 2nd moment measure: maximum imaginary part= 8e-17 2nd moment measure: mass error= 0 > > local({ + if(FULLTEST) { + #' bandwidth selection + op <- spatstat.options(n.bandwidth=8) + bw.diggle(cells) + bw.diggle(cells, method="interpreted") # undocumented test + ## bw.relrisk(urkiola, hmax=20) is tested in man/bw.relrisk.Rd + bw.relrisk(urkiola, hmax=20, method="leastsquares") + bw.relrisk(urkiola, hmax=20, method="weightedleastsquares") + ZX <- density(swedishpines, at="points") + bw.pcf(swedishpines, lambda=ZX) + bw.pcf(swedishpines, lambda=ZX, + bias.correct=FALSE, simple=FALSE, cv.method="leastSQ") + spatstat.options(op) + } + }) > > local({ + if(FULLTEST) { + #' code in kernels.R + kernames <- c("gaussian", "rectangular", "triangular", + "epanechnikov", "biweight", "cosine", "optcosine") + X <- rnorm(20) + U <- runif(20) + for(ker in kernames) { + dX <- dkernel(X, ker) + fX <- pkernel(X, ker) + qU <- qkernel(U, ker) + m0 <- kernel.moment(0, 0, ker) + m1 <- kernel.moment(1, 0, ker) + m2 <- kernel.moment(2, 0, ker) + m3 <- kernel.moment(3, 0, ker) + } + } + }) > > local({ + if(FULLTEST) { + ## idw + Z <- idw(longleaf, power=4) + Z <- idw(longleaf, power=4, se=TRUE) + ZX <- idw(longleaf, power=4, at="points") + ZX <- idw(longleaf, power=4, at="points", se=TRUE) + } + if(ALWAYS) { + ## former bug in densityVoronoi.ppp + X <- redwood[1:2] + A <- densityVoronoi(X, f=0.51, counting=FALSE, fixed=FALSE, nrep=50, verbose=FALSE) + ## dodgy code blocks in densityVoronoi.R + A <- adaptive.density(nztrees, nrep=2, f=0.5, counting=TRUE) + B <- adaptive.density(nztrees, nrep=2, f=0.5, counting=TRUE, fixed=TRUE) + D <- adaptive.density(nztrees, nrep=2, f=0.5, counting=FALSE) + E <- adaptive.density(nztrees, nrep=2, f=0.5, counting=FALSE, fixed=TRUE) + } + if(FULLTEST) { + #' adaptive kernel estimation + d10 <- nndist(nztrees, k=10) + d10fun <- distfun(nztrees, k=10) + d10im <- as.im(d10fun) + uN <- 2 * runif(npoints(nztrees)) + AA <- densityAdaptiveKernel(nztrees, bw=d10) + BB <- densityAdaptiveKernel(nztrees, bw=d10, weights=uN) + DD <- densityAdaptiveKernel(nztrees, bw=d10fun, weights=uN) + EE <- densityAdaptiveKernel(nztrees, bw=d10im, weights=uN) + } + }) Computing 2 intensity estimates...1, 2. Done. Computing 2 intensity estimates...1, 2. Done. Computing 2 intensity estimates...1, 2. Done. Computing 2 intensity estimates...1, 2. Done. > > local({ + if(ALWAYS) { + ## unnormdensity + x <- rnorm(20) + d0 <- unnormdensity(x, weights=rep(0, 20)) + dneg <- unnormdensity(x, weights=c(-runif(19), 0)) + } + if(FULLTEST) { + ## cases of 'intensity' etc + a <- intensity(amacrine, weights=expression(x)) + SA <- split(amacrine) + a <- intensity(SA, weights=expression(x)) + a <- intensity(SA, weights=amacrine$x) + + ## check infrastructure for 'densityfun' + f <- densityfun(cells, 0.05) + Z <- as.im(f) + Z <- as.im(f, W=square(0.5)) + } + }) > > > reset.spatstat.options() > > > proc.time() user system elapsed 6.14 0.59 6.73