* using log directory 'd:/RCompile/CRANincoming/R-devel/spatstat.model.Rcheck' * using R Under development (unstable) (2024-03-21 r86166 ucrt) * using platform: x86_64-w64-mingw32 * R was compiled by gcc.exe (GCC) 13.2.0 GNU Fortran (GCC) 13.2.0 * running under: Windows Server 2022 x64 (build 20348) * using session charset: UTF-8 * checking for file 'spatstat.model/DESCRIPTION' ... OK * this is package 'spatstat.model' version '3.2-11' * checking CRAN incoming feasibility ... [17s] Note_to_CRAN_maintainers Maintainer: 'Adrian Baddeley ' * checking package namespace information ... OK * checking package dependencies ... NOTE Depends: includes the non-default packages: 'spatstat.data', 'spatstat.geom', 'spatstat.random', 'spatstat.explore', 'nlme', 'rpart' Adding so many packages to the search path is excessive and importing selectively is preferable. * checking if this is a source package ... OK * checking if there is a namespace ... OK * checking for hidden files and directories ... OK * checking for portable file names ... OK * checking whether package 'spatstat.model' can be installed ... OK * used C compiler: 'gcc.exe (GCC) 13.2.0' * checking installed package size ... OK * checking package directory ... OK * checking for future file timestamps ... OK * checking DESCRIPTION meta-information ... OK * checking top-level files ... OK * checking for left-over files ... OK * checking index information ... OK * checking package subdirectories ... OK * checking code files for non-ASCII characters ... OK * checking R files for syntax errors ... OK * checking whether the package can be loaded ... OK * checking whether the package can be loaded with stated dependencies ... OK * checking whether the package can be unloaded cleanly ... OK * checking whether the namespace can be loaded with stated dependencies ... OK * checking whether the namespace can be unloaded cleanly ... OK * checking loading without being on the library search path ... OK * checking whether startup messages can be suppressed ... OK * checking use of S3 registration ... OK * checking dependencies in R code ... OK * checking S3 generic/method consistency ... OK * checking replacement functions ... OK * checking foreign function calls ... OK * checking R code for possible problems ... [44s] OK * checking Rd files ... OK * checking Rd metadata ... OK * checking Rd line widths ... OK * checking Rd cross-references ... OK * checking for missing documentation entries ... OK * checking for code/documentation mismatches ... OK * checking Rd \usage sections ... OK * checking Rd contents ... OK * checking for unstated dependencies in examples ... OK * checking R/sysdata.rda ... OK * checking line endings in C/C++/Fortran sources/headers ... OK * checking pragmas in C/C++ headers and code ... OK * checking compilation flags used ... OK * checking compiled code ... OK * checking installed files from 'inst/doc' ... OK * checking examples ... [93s] OK * checking for unstated dependencies in 'tests' ... OK * checking tests ... [421s] ERROR Running 'testsAtoC.R' Running 'testsD.R' Running 'testsEtoF.R' Running 'testsGtoJ.R' [61s] Running 'testsK.R' Running 'testsL.R' [84s] Running 'testsM.R' Running 'testsNtoO.R' [63s] Running 'testsP1.R' Running 'testsP2.R' Running 'testsQ.R' [56s] Running 'testsR1.R' Running 'testsR2.R' [65s] Running 'testsS.R' [59s] Running 'testsT.R' Running 'testsUtoZ.R' Running the tests in 'tests/testsGtoJ.R' failed. Complete output: > #' > #' 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) Loading required package: spatstat.model Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-9 Loading required package: spatstat.random spatstat.random 3.2-3 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.2-7 Loading required package: rpart spatstat.model 3.2-11 > 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/hobjects.R > #' > #' Validity of methods for ppm(... method="ho") > #' > #' $Revision: 1.4 $ $Date: 2022/06/18 10:14:44 $ > > > if(FULLTEST) { + local({ + set.seed(42) + fit <- ppm(cells ~1, Strauss(0.1), improve.type="ho", nsim=10) + fitx <- ppm(cells ~offset(x), Strauss(0.1), improve.type="ho", nsim=10) + + a <- AIC(fit) + ax <- AIC(fitx) + + f <- fitted(fit) + fx <- fitted(fitx) + + p <- predict(fit) + px <- predict(fitx) + }) + } > > > #' tests/hypotests.R > #' Hypothesis tests > #' > #' $Revision: 1.10 $ $Date: 2023/07/17 07:30:48 $ > > if(FULLTEST) { + local({ + + #' scan test with baseline + fit <- ppm(cells ~ x) + lam <- predict(fit) + rr <- c(0.05, 1) + scan.test(cells, rr, nsim=5, + method="poisson", baseline=fit, alternative="less") + scan.test(cells, rr, nsim=5, + method="poisson", baseline=lam, alternative="less") + }) + } > #' > #' tests/interact.R > #' > #' Support for interaction objects > #' > #' $Revision: 1.2 $ $Date: 2020/04/28 12:58:26 $ > > if(FULLTEST) { + local({ + #' print.intermaker + Strauss + Geyer + Ord + #' intermaker + BS <- get("BlankStrauss", envir=environment(Strauss)) + BD <- function(r) { instantiate.interact(BS, list(r=r)) } + BlueDanube <- intermaker(BD, BS) + }) + } > > #' tests/ippm.R > #' Tests of 'ippm' class > #' $Revision: 1.6 $ $Date: 2020/04/28 12:58:26 $ > > if(FULLTEST) { + local({ + # .......... set up example from help file ................. + nd <- 10 + gamma0 <- 3 + delta0 <- 5 + POW <- 3 + # Terms in intensity + Z <- function(x,y) { -2*y } + f <- function(x,y,gamma,delta) { 1 + exp(gamma - delta * x^POW) } + # True intensity + lamb <- function(x,y,gamma,delta) { 200 * exp(Z(x,y)) * f(x,y,gamma,delta) } + # Simulate realisation + lmax <- max(lamb(0,0,gamma0,delta0), lamb(1,1,gamma0,delta0)) + set.seed(42) + X <- rpoispp(lamb, lmax=lmax, win=owin(), gamma=gamma0, delta=delta0) + # Partial derivatives of log f + DlogfDgamma <- function(x,y, gamma, delta) { + topbit <- exp(gamma - delta * x^POW) + topbit/(1 + topbit) + } + DlogfDdelta <- function(x,y, gamma, delta) { + topbit <- exp(gamma - delta * x^POW) + - (x^POW) * topbit/(1 + topbit) + } + # irregular score + Dlogf <- list(gamma=DlogfDgamma, delta=DlogfDdelta) + # fit model + fit <- ippm(X ~Z + offset(log(f)), + covariates=list(Z=Z, f=f), + iScore=Dlogf, + start=list(gamma=1, delta=1), + nd=nd) + # fit model with logistic likelihood but without iScore + fitlo <- ippm(X ~Z + offset(log(f)), + method="logi", + covariates=list(Z=Z, f=f), + start=list(gamma=1, delta=1), + nd=nd) + + ## ............. test ippm class support ...................... + Ar <- model.matrix(fit) + Ai <- model.matrix(fit, irregular=TRUE) + An <- model.matrix(fit, irregular=TRUE, keepNA=FALSE) + AS <- model.matrix(fit, irregular=TRUE, subset=(abs(Z) < 0.5)) + + Zr <- model.images(fit) + Zi <- model.images(fit, irregular=TRUE) + ## update.ippm + fit2 <- update(fit, . ~ . + I(Z^2)) + fit0 <- update(fit, + . ~ . - Z, + start=list(gamma=2, delta=4)) + oldfit <- ippm(X, + ~Z + offset(log(f)), + covariates=list(Z=Z, f=f), + iScore=Dlogf, + start=list(gamma=1, delta=1), + nd=nd) + oldfit2 <- update(oldfit, . ~ . + I(Z^2)) + oldfit0 <- update(oldfit, + . ~ . - Z, + start=list(gamma=2, delta=4)) + ## again with logistic + fitlo2 <- update(fitlo, . ~ . + I(Z^2)) + fitlo0 <- update(fitlo, + . ~ . - Z, + start=list(gamma=2, delta=4)) + oldfitlo <- ippm(X, + ~Z + offset(log(f)), + method="logi", + covariates=list(Z=Z, f=f), + start=list(gamma=1, delta=1), + nd=nd) + oldfitlo2 <- update(oldfitlo, . ~ . + I(Z^2)) + oldfitlo0 <- update(oldfitlo, + . ~ . - Z, + start=list(gamma=2, delta=4)) + ## anova.ppm including ippm objects + fit0 <- update(fit, . ~ Z) + fit0lo <- update(fitlo, . ~ Z) + A <- anova(fit0, fit) + Alo <- anova(fit0lo, fitlo) + }) + } > > proc.time() user system elapsed 1.01 0.17 1.17 Running the tests in 'tests/testsL.R' failed. Complete output: > #' > #' 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) Loading required package: spatstat.model Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-9 Loading required package: spatstat.random spatstat.random 3.2-3 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.2-7 Loading required package: rpart spatstat.model 3.2-11 > 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/legacy.R > ## > ## Test that current version of spatstat is compatible with outmoded usage > ## $Revision: 1.3 $ $Date: 2020/04/29 08:55:17 $ > > if(FULLTEST) { + local({ + + ## (1) Old syntax of ppm + ppm(cells, ~x) + + ## (2) Old syntax of MultiStrauss etc. + r <- matrix(3, 2, 2) + a <- MultiStrauss( , r) + a <- MultiStrauss(NULL, r) + a <- MultiHard(, r) + + h <- r/2 + a <- MultiStraussHard( , r, h) + + NULL + }) + } > #' > #' tests/leverinf.R > #' > #' leverage and influence for Gibbs models > #' > #' $Revision: 1.35 $ $Date: 2022/06/18 10:15:17 $ > #' > > if(FULLTEST) { + Cells <- cells + Amacrine <- amacrine + Redwood <- redwood + } else { + ## reduce number of data + dummy points + spatstat.options(npixel=32, ndummy.min=16) + Cells <- cells[c(FALSE,TRUE)] + Redwood <- redwood[c(FALSE, TRUE)] + Amacrine <- amacrine[c(FALSE, TRUE)] + } > > local({ + cat("Running non-sparse algorithm...", fill=TRUE) + # original non-sparse algorithm + Leverage <- function(...) leverage(..., sparseOK=FALSE) + Influence <- function(...) influence(..., sparseOK=FALSE) + Dfbetas <- function(...) dfbetas(..., sparseOK=FALSE) + if(ALWAYS) { + ## Strauss()$delta2 + fitS <- ppm(Cells ~ x, Strauss(0.12), rbord=0) + levS <- Leverage(fitS) + infS <- Influence(fitS) + dfbS <- Dfbetas(fitS) + ## Geyer()$delta2 + fitG <- ppm(Redwood ~ 1, Geyer(0.1, 2), rbord=0) + levG <- Leverage(fitG) + infG <- Influence(fitG) + ## AreaInter()$delta2 + fitA <- ppm(Cells ~ 1, AreaInter(0.06), rbord=0, nd=11) + levA <- Leverage(fitA) + infA <- Influence(fitA) + ## pairwise.family$delta2 + fitD <- ppm(Cells ~ 1, DiggleGatesStibbard(0.12), rbord=0) + levD <- Leverage(fitD) + infD <- Influence(fitD) + ## DiggleGratton() special code + fitDG <- ppm(Cells ~ 1, DiggleGratton(0.05, 0.12), rbord=0) + levDG <- Leverage(fitDG) + infDG <- Influence(fitDG) + ## ppmInfluence; offset is present; coefficient vector has length 0 + fitH <- ppm(Cells ~ 1, Hardcore(0.07)) + levH <- Leverage(fitH) + infH <- Influence(fitH) + ## ppmInfluence; hard core + fitSH <- ppm(Cells ~ 1, StraussHard(0.07, 0.01)) + levSH <- Leverage(fitSH) + infSH <- Influence(fitSH) + ## ppmInfluence; offset is present; coefficient vector has length 1 + fitHx <- ppm(Cells ~ x, Hardcore(0.07), rbord=0) + levHx <- Leverage(fitHx) + infHx <- Influence(fitHx) + ## multitype + futAm <- ppm(Amacrine ~ x + marks, Strauss(0.07)) + levAm <- leverage(futAm) + } + + if(FULLTEST) { + ## ......... class support ............................. + ## other methods for classes leverage.ppm and influence.ppm + ## not elsewhere tested + cat("Testing class support...", fill=TRUE) + w <- domain(levS) + w <- Window(infS) + vv <- shift(levS, c(1.2, 1.3)) + vv <- shift(infS, c(1.2, 1.3)) + A <- quadrats(Window(Cells), 2) + a <- integral(levS,domain=A) + b <- integral(infS,domain=A) + u <- Smooth(levS, sigma=0.07) + v <- Smooth(infS, sigma=0.1) + ## plot options + plot(levS, what="exact") + plot(levS, what="nearest") + contour(levS, what="nearest") + persp(levS, what="nearest") + ## plotting for multitype models + plot(levAm) + contour(levAm) + persp(levAm) + plot(levAm, multiplot=FALSE) + contour(levAm, multiplot=FALSE) + } + + if(ALWAYS) { + ## .......... compare algorithms ......................... + ## divide and recombine algorithm + cat("Reduce maximum block side to 50,000 ...", fill=TRUE) + op <- spatstat.options(maxmatrix=50000) + ## non-sparse + levSB <- Leverage(fitS) + infSB <- Influence(fitS) + dfbSB <- Dfbetas(fitS) + } + + chk <- function(x, y, what, + from="single-block and multi-block", + thresh=1e-12) { + if(max(abs(x-y)) > thresh) + stop(paste("Different results for", what, "obtained from", + from, "algorithms"), + call.=FALSE) + invisible(NULL) + } + + if(ALWAYS) { + cat("Compare single-block to multi-block...", fill=TRUE) + chk(marks(as.ppp(infS)), marks(as.ppp(infSB)), "influence") + chk(as.im(levS), as.im(levSB), "leverage") + chk(dfbS$val, dfbSB$val, "dfbetas$value") + chk(dfbS$density, dfbSB$density, "dfbetas$density") + } + + if(FULLTEST) { + ## also check case of zero cif + cat("Check zero cif cases...", fill=TRUE) + levHB <- Leverage(fitH) + infHB <- Influence(fitH) + dfbHB <- Dfbetas(fitH) + levHxB <- Leverage(fitHx) + infHxB <- Influence(fitHx) + dfbHxB <- Dfbetas(fitHx) + } + + ## run all code segments + Everything <- function(model, ...) { ppmInfluence(model, ..., what="all") } + + if(FULLTEST) { + cat("Run full code on AreaInteraction model...", fill=TRUE) + pmiA <- Everything(fitA) + + ## sparse algorithm, with blocks + cat("Run sparse algorithm with blocks...", fill=TRUE) + pmiSSB <- Everything(fitS, sparseOK=TRUE) + ## also check case of zero cif + pmiHSB <- Everything(fitH, sparseOK=TRUE) + pmiSHSB <- Everything(fitSH, sparseOK=TRUE) + pmiHxSB <- Everything(fitHx, sparseOK=TRUE) + + cat("Reinstate maxmatrix...", fill=TRUE) + spatstat.options(op) + } + + if(ALWAYS) { + ## sparse algorithm, no blocks + cat("Compare sparse and non-sparse results...", fill=TRUE) + pmi <- Everything(fitS, sparseOK=TRUE) + levSp <- pmi$leverage + infSp <- pmi$influence + dfbSp <- pmi$dfbetas + chks <- function(...) chk(..., from="sparse and non-sparse") + + chks(marks(as.ppp(infS)), marks(as.ppp(infSp)), "influence") + chks(as.im(levS), as.im(levSp), "leverage") + chks(dfbS$val, dfbSp$val, "dfbetas$value") + chks(dfbS$density, dfbSp$density, "dfbetas$density") + } + + if(ALWAYS) { + #' case of zero cif + cat("zero cif...", fill=TRUE) + pmiH <- Everything(fitH, sparseOK=TRUE) + pmiSH <- Everything(fitSH, sparseOK=TRUE) + pmiHx <- Everything(fitHx, sparseOK=TRUE) + } + if(FULLTEST) { + #' other code blocks - check execution only + cat("other code blocks...", fill=TRUE) + a <- Everything(fitS) + a <- Everything(fitS, method="interpreted") + a <- Everything(fitS, method="interpreted", entrywise=FALSE) + a <- Everything(fitS, entrywise=FALSE) + #' zero cif + b <- Everything(fitSH) + b <- Everything(fitSH, method="interpreted") + b <- Everything(fitSH, method="interpreted", entrywise=FALSE) + b <- Everything(fitSH, entrywise=FALSE) + } + #' NOTE: code for irregular parameters is tested below, and in 'make bookcheck' + + ## ........... logistic fits ....................... + cat("Logistic fits...", fill=TRUE) + #' special algorithm for delta2 + fitSlogi <- ppm(Cells ~ x, Strauss(0.12), rbord=0, method="logi") + + if(FULLTEST) { + pmiSlogi <- Everything(fitSlogi) + #' special algorithm for delta2 + fitGlogi <- ppm(Redwood ~ 1, Geyer(0.1, 2), rbord=0, method="logi") + pmiGlogi <- Everything(fitGlogi) + #' generic algorithm for delta2 + fitDlogi <- ppm(Cells ~ 1, DiggleGatesStibbard(0.12), + rbord=0, method="logi") + pmiDlogi <- Everything(fitDlogi) + #' generic algorithm for delta2 : offset; zero-dimensional + fitHlogi <- ppm(Cells ~ 1, Hardcore(0.07), method="logi") + pmiHlogi <- Everything(fitHlogi) + #' generic algorithm for delta2 : offset; 1-dimensional + fitHxlogi <- ppm(Cells ~ x, Hardcore(0.07), rbord=0, method="logi") + pmiHxlogi <- Everything(fitHxlogi) + #' plotting + plot(leverage(fitSlogi)) + plot(influence(fitSlogi)) + plot(dfbetas(fitSlogi)) + } + + if(ALWAYS) { + #' other code blocks - check execution only + cat("Other code blocks...", fill=TRUE) + b <- Everything(fitSlogi) # i.e. full set of results + b <- Everything(fitSlogi, method="interpreted") + b <- Everything(fitSlogi, method="interpreted", entrywise=FALSE) + b <- Everything(fitSlogi, entrywise=FALSE) + } + + #' irregular parameters + cat("Irregular parameters...", fill=TRUE) + ytoa <- function(x,y, alpha=1) { y^alpha } + lam <- function(x,y,alpha=1) { exp(4 + y^alpha) } + set.seed(90210) + X <- rpoispp(lam, alpha=2) + iScor <- list(alpha=function(x,y,alpha) { alpha * y^(alpha-1) } ) + iHess <- list(alpha=function(x,y,alpha) { alpha * (alpha-1) * y^(alpha-2) } ) + gogo <- function(tag, ..., iS=iScor, iH=iHess) { + cat(tag, fill=TRUE) + #' compute all leverage+influence terms + ppmInfluence(..., what="all", iScore=iS, iHessian=iH) + } + gogogo <- function(hdr, fit) { + cat(hdr, fill=TRUE) + force(fit) + #' try all code options + d <- gogo("a", fit) + d <- gogo("b", fit, method="interpreted") + d <- gogo("c", fit, method="interpreted", entrywise=FALSE) + d <- gogo("d", fit, entrywise=FALSE) + invisible(NULL) + } + gogogo("Offset model...", + ippm(X ~ offset(ytoa), start=list(alpha=1), iterlim=40)) + gogogo("Offset model (logistic) ...", + ippm(X ~ offset(ytoa), start=list(alpha=1), + method="logi", iterlim=40)) + gogogo("Offset+x model...", + ippm(X ~ x + offset(ytoa), start=list(alpha=1), iterlim=40)) + gogogo("Offset+x model (logistic) ...", + ippm(X ~ x + offset(ytoa), start=list(alpha=1), + method="logi", iterlim=40)) + gogogo("Offset model Strauss ...", + ippm(X ~ offset(ytoa), Strauss(0.07), start=list(alpha=1), iterlim=40)) + gogogo("Offset model Strauss (logistic) ...", + ippm(X ~ offset(ytoa), Strauss(0.07), start=list(alpha=1), + method="logi", iterlim=40)) + if(FULLTEST) { + gogogo("Offset+x model Strauss ...", + ippm(X ~ x + offset(ytoa), Strauss(0.07), start=list(alpha=1), + iterlim=40)) + gogogo("Offset+x model Strauss (logistic)...", + ippm(X ~ x + offset(ytoa), Strauss(0.07), start=list(alpha=1), + method="logi", iterlim=40)) + } + #' + if(FULLTEST) { + set.seed(452) + foo <- ppm(Cells ~ 1, Strauss(0.15), improve.type="ho", nsim=5) + aa <- Everything(foo) + + #' Gradient and Hessian obtained by symbolic differentiation + f <- deriv(expression((1+x)^a), + "a", function.arg=c("x", "y", "a"), + hessian=TRUE) + #' check they can be extracted + fit <- ippm(Cells ~offset(f), start=list(a=0.7)) + Everything(fit) + } + }) Running non-sparse algorithm... Reduce maximum block side to 50,000 ... Compare single-block to multi-block... Compare sparse and non-sparse results... zero cif... Logistic fits... Other code blocks... Irregular parameters... Offset model... a b c d Offset model (logistic) ... a b c d Offset+x model... a b c d Offset+x model (logistic) ... a b c d Offset model Strauss ... a Large quadrature scheme split into blocks to avoid memory size limits; 404 dummy points split into 2 blocks, each containing 202 dummy points b Large quadrature scheme split into blocks to avoid memory size limits; 404 dummy points split into 2 blocks, each containing 202 dummy points c Large quadrature scheme split into blocks to avoid memory size limits; 404 dummy points split into 2 blocks, each containing 202 dummy points d Large quadrature scheme split into blocks to avoid memory size limits; 404 dummy points split into 2 blocks, each containing 202 dummy points Offset model Strauss (logistic) ... a Large quadrature scheme split into blocks to avoid memory size limits; 400 dummy points split into 2 blocks, each containing 200 dummy points b Large quadrature scheme split into blocks to avoid memory size limits; 400 dummy points split into 2 blocks, each containing 200 dummy points c Large quadrature scheme split into blocks to avoid memory size limits; 400 dummy points split into 2 blocks, each containing 200 dummy points d Large quadrature scheme split into blocks to avoid memory size limits; 400 dummy points split into 2 blocks, each containing 200 dummy points There were 11 warnings (use warnings() to see them) > > reset.spatstat.options() > > proc.time() user system elapsed 22.54 4.84 27.37 Running the tests in 'tests/testsNtoO.R' failed. Complete output: > #' > #' 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) Loading required package: spatstat.model Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-9 Loading required package: spatstat.random spatstat.random 3.2-3 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.2-7 Loading required package: rpart spatstat.model 3.2-11 > 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/NAinCov.R > # > # Testing the response to the presence of NA's in covariates > # > # $Revision: 1.9 $ $Date: 2023/11/05 01:45:36 $ > > if(FULLTEST) { + local({ + X <- runifpoint(42) + Y <- as.im(function(x,y) { x+y }, owin()) + Y[owin(c(0.2,0.4),c(0.2,0.4))] <- NA + # fit model: should produce a warning but no failure + misfit <- ppm(X ~Y, covariates=list(Y=Y)) + # prediction + Z <- predict(misfit, type="trend", se=TRUE) + # covariance matrix: all should be silent + v <- vcov(misfit) + ss <- vcov(misfit, what="internals") + }) + } > > proc.time() user system elapsed 0.96 0.26 1.23 Running the tests in 'tests/testsQ.R' failed. Complete output: > #' > #' 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) Loading required package: spatstat.model Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-9 Loading required package: spatstat.random spatstat.random 3.2-3 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.2-7 Loading required package: rpart spatstat.model 3.2-11 > 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 ----------- > > proc.time() user system elapsed 0.95 0.20 1.15 Running the tests in 'tests/testsR2.R' failed. Complete output: > #' > #' 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) Loading required package: spatstat.model Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-9 Loading required package: spatstat.random spatstat.random 3.2-3 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.2-7 Loading required package: rpart spatstat.model 3.2-11 > 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/rmhExpand.R > # > # test decisions about expansion of simulation window > # > # $Revision: 1.9 $ $Date: 2022/10/23 01:17:33 $ > # > > local({ + if(FULLTEST) { + ## check expansion in rmhmodel.ppm + fit <- ppm(cells ~x) + mod <- rmhmodel(fit) + is.expandable(mod) + wsim <- as.rectangle(mod$trend) + ## work around changes in 'unitname' + wcel <- as.owin(cells) + unitname(wcel) <- unitname(cells) + ## test + if(!identical(wsim, wcel)) + stop("Expansion occurred improperly in rmhmodel.ppm") + } + }) > > > > # > # tests/rmhTrend.R > # > # Problems with trend images (rmhmodel.ppm or rmhEngine) > # > > if(ALWAYS) { + local({ + set.seed(42) + + # Bug folder 37 of 8 feb 2011 + # rmhmodel.ppm -> predict.ppm + # + rmhResolveTypes -> is.subset.owin + + Z <- rescale(demopat, 7000) + X <- unmark(Z) + X1 <- split(Z)[[1]] + Int <- density(X,dimyx=200) + Lint <- eval.im(log(npoints(X1)*Int/npoints(X))) + M <- as.owin(Int) + MR <- intersect.owin(M,scalardilate(M,0.5,origin="midpoint")) + X1 <- X1[MR] + Fut <- ppm(X1~offset(Lint),covariates=list(Lint=Lint), + inter=BadGey(r=c(0.03,0.05),sat=3)) + Y <- rmh(Fut,control=list(expand=M,nrep=1e3), verbose=FALSE) + + }) + } > # > # tests/rmhmodel.ppm.R > # > # $Revision: 1.10 $ $Date: 2020/05/01 05:29:42 $ > # > # Case-by-case tests of rmhmodel.ppm > # > > if(FULLTEST) { + local({ + f <- ppm(cells) + m <- rmhmodel(f) + + f <- ppm(cells ~x) + m <- rmhmodel(f) + + f <- ppm(cells ~1, Strauss(0.1)) + m <- rmhmodel(f) + + f <- ppm(cells ~1, StraussHard(r=0.1,hc=0.05)) + m <- rmhmodel(f) + print(m) + + f <- ppm(cells ~1, Hardcore(0.07)) + m <- rmhmodel(f) + + f <- ppm(cells ~1, DiggleGratton(0.05,0.1)) + m <- rmhmodel(f) + + f <- ppm(cells ~1, Softcore(0.5), correction="isotropic") + m <- rmhmodel(f) + + f <- ppm(cells ~1, Geyer(0.07,2)) + m <- rmhmodel(f) + + f <- ppm(cells ~1, BadGey(c(0.07,0.1,0.13),2)) + m <- rmhmodel(f) + + f <- ppm(cells ~1, PairPiece(r = c(0.05, 0.1, 0.2))) + m <- rmhmodel(f) + + f <- ppm(cells ~1, AreaInter(r=0.06)) + m <- rmhmodel(f) + print(m) + + # multitype + + r <- matrix(0.07, 2, 2) + f <- ppm(amacrine ~1, MultiStrauss(c("off","on"),r)) + m <- rmhmodel(f) + print(m) + + h <- matrix(min(nndist(amacrine))/2, 2, 2) + f <- ppm(amacrine ~1, MultiStraussHard(c("off","on"),r, h)) + m <- rmhmodel(f) + + diag(r) <- NA + diag(h) <- NA + f <- ppm(amacrine ~1, MultiStrauss(c("off","on"),r)) + m <- rmhmodel(f) + + f <- ppm(amacrine ~1, MultiStraussHard(c("off","on"),r, h)) + m <- rmhmodel(f) + + # multitype data, interaction not dependent on type + + f <- ppm(amacrine ~marks, Strauss(0.05)) + m <- rmhmodel(f) + print(m) + + # trends + + f <- ppm(cells ~x, Strauss(0.1)) + m <- rmhmodel(f) + + f <- ppm(cells ~y, StraussHard(r=0.1,hc=0.05)) + m <- rmhmodel(f) + + f <- ppm(cells ~x+y, Hardcore(0.07)) + m <- rmhmodel(f) + print(m) + + f <- ppm(cells ~polynom(x,y,2), Softcore(0.5), correction="isotropic") + m <- rmhmodel(f) + + # covariates + + Z <- as.im(function(x,y){ x^2+y^2 }, as.owin(cells)) + f <- ppm(cells ~z, covariates=list(z=Z)) + m <- rmhmodel(f) + m <- rmhmodel(f, control=list(p=1)) + print(m) + + Zim <- as.im(Z, as.owin(cells)) + f <- ppm(cells ~z, covariates=list(z=Zim)) + m <- rmhmodel(f) + + Z <- as.im(function(x,y){ x^2+y }, as.owin(amacrine)) + f <- ppm(amacrine ~z + marks, covariates=list(z=Z)) + m <- rmhmodel(f) + print(m) + m <- rmhmodel(f, control=list(p=1)) + m <- rmhmodel(f, control=list(p=1,fixall=TRUE)) + print(m) + + Zim <- as.im(Z, as.owin(amacrine)) + f <- ppm(amacrine ~z + marks, covariates=list(z=Zim)) + m <- rmhmodel(f) + print(m) + + }) + } > # > # tests/rmhmodelHybrids.R > # > # Test that rmhmodel.ppm and rmhmodel.default > # work on Hybrid interaction models > # > # $Revision: 1.6 $ $Date: 2022/10/23 01:17:56 $ > # > > if(ALWAYS) { # involves C code + local({ + + ## ......... rmhmodel.ppm ....................... + fit1 <- ppm(redwood ~1, + Hybrid(A=Strauss(0.02), B=Geyer(0.1, 2), C=Geyer(0.15, 1))) + m1 <- rmhmodel(fit1) + m1 + reach(m1) + + ## Test of handling 'IsOffset' + fit2 <- ppm(cells ~1, Hybrid(H=Hardcore(0.05), G=Geyer(0.15, 2))) + m2 <- rmhmodel(fit2) + ## also test C code for hybrid interaction with hard core + fakecells <- rmh(fit2, nrep=1e4) + + ## Test of handling Poisson components + fit3 <- ppm(cells ~1, Hybrid(P=Poisson(), S=Strauss(0.05))) + X3 <- rmh(fit3, control=list(nrep=1e3,expand=1), verbose=FALSE) + + + }) + } Extracting model information...Evaluating trend...done. Extracting model information...Evaluating trend...done. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. > > # > # tests/rmh.ppm.R > # > # $Revision: 1.5 $ $Date: 2020/05/01 05:29:42 $ > # > # Examples removed from rmh.ppm.Rd > # stripped down to minimal tests of validity > # > > local({ + op <- spatstat.options() + spatstat.options(rmh.nrep=10, npixel=10, ndummy.min=10) + spatstat.options(project.fast=TRUE) + Nrep <- 10 + + X <- swedishpines + if(FULLTEST) { + ## Poisson process + fit <- ppm(X ~1, Poisson()) + Xsim <- rmh(fit) + } + if(ALWAYS) { # Gibbs model => C code + ## Strauss process + fit <- ppm(X ~1, Strauss(r=7)) + Xsim <- rmh(fit) + + ## Strauss process simulated on a larger window + ## then clipped to original window + Xsim <- rmh(fit, control=list(nrep=Nrep, expand=1.1, periodic=TRUE)) + + ## Extension of model to another window (thanks to Tuomas Rajala) + Xsim <- rmh(fit, w=square(2)) + Xsim <- simulate(fit, w=square(2)) + + ## Strauss - hard core process + ## fit <- ppm(X ~1, StraussHard(r=7,hc=2)) + ## Xsim <- rmh(fit, start=list(n.start=X$n)) + + ## Geyer saturation process + ## fit <- ppm(X ~1, Geyer(r=7,sat=2)) + ## Xsim <- rmh(fit, start=list(n.start=X$n)) + + ## Area-interaction process + fit <- ppm(X ~1, AreaInter(r=7)) + Xsim <- rmh(fit, start=list(n.start=X$n)) + + ## Penttinen process + fit <- ppm(X ~1, Penttinen(r=7)) + Xsim <- rmh(fit, start=list(n.start=X$n)) + + ## soft core interaction process + ## X <- quadscheme(X, nd=50) + ## fit <- ppm(X ~1, Softcore(kappa=0.1), correction="isotropic") + ## Xsim <- rmh(fit, start=list(n.start=X$n)) + + ## Diggle-Gratton pairwise interaction model + ## fit <- ppm(cells ~1, DiggleGratton(0.05, 0.1)) + ## Xsim <- rmh(fit, start=list(n.start=cells$n)) + ## plot(Xsim, main="simulation from fitted Diggle-Gratton model") + + + ## piecewise-constant pairwise interaction function + X <- rSSI(0.05, 100) + fit <- ppm(X ~1, PairPiece(seq(0.02, 0.1, by=0.01))) + Xsim <- rmh(fit) + } + + ## marked point pattern + Y <- amacrine + + if(FULLTEST) { + #' marked Poisson models + fit <- ppm(Y) + Ysim <- rmh(fit) + + fit <- ppm(Y~marks) + Ysim <- rmh(fit) + + fit <- ppm(Y~x) + Ysim <- rmh(fit) + + fit <- ppm(Y~marks+x) + Ysim <- rmh(fit) + } + + if(ALWAYS) { + #' multitype Strauss + typ <- levels(Y$marks) + MS <- MultiStrauss(types = typ, + radii=matrix(0.07, ncol=2, nrow=2)) + + fit <- ppm(Y~marks*x, MS) + Ysim <- rmh(fit) + + #' multitype Hardcore + h0 <- minnndist(unmark(Y)) * 0.95 + MH <- MultiHard(types = typ, + hradii=matrix(h0, ncol=2, nrow=2)) + fit <- ppm(Y ~ marks+x, MH) + Ysim <- rmh(fit) + #' other code blocks + Ysim <- rmh(fit, control=list(periodic=TRUE, expand=1)) + Ysim <- rmh(fit, control=list(periodic=FALSE, expand=1)) + #' multihard core with invalid initial state + Ydouble <- superimpose(Y, rjitter(Y, h0/10)) + Ysim <- rmh(fit, start=list(x.start=Ydouble)) + + #' Lennard-Jones + fut <- ppm(unmark(longleaf) ~ 1, LennardJones(), rbord=1) + Ysim <- rmh(fut) + Ysim <- rmh(fut, control=list(periodic=TRUE, expand=1)) + } + + spatstat.options(op) + }) Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Model is invalid - projecting it Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Starting simulation. Initial state...Ready to simulate. Generating proposal points...Running Metropolis-Hastings. > > > reset.spatstat.options() > #' > #' tests/rmhsnoopy.R > #' > #' Test the rmh interactive debugger > #' > #' $Revision: 1.11 $ $Date: 2022/10/23 01:19:00 $ > > if(ALWAYS) { # may depend on platform + local({ + R <- 0.1 + ## fit a model and prepare to simulate + model <- ppm(amacrine ~ marks + x, Strauss(R)) + siminfo <- rmh(model, preponly=TRUE) + Wsim <- siminfo$control$internal$w.sim + Wclip <- siminfo$control$internal$w.clip + if(is.null(Wclip)) Wclip <- Window(cells) + + ## determine debugger interface panel geometry + Xinit <- runifpoint(ex=amacrine)[1:40] + P <- rmhsnoop(Wsim=Wsim, Wclip=Wclip, R=R, + xcoords=Xinit$x, + ycoords=Xinit$y, + mlevels=levels(marks(Xinit)), + mcodes=as.integer(marks(Xinit)) - 1L, + irep=3L, itype=1L, + proptype=1, proplocn=c(0.5, 0.5), propmark=0, propindx=0, + numerator=42, denominator=24, + panel.only=TRUE) + boxes <- P$boxes + clicknames <- names(P$clicks) + boxcentres <- do.call(concatxy, lapply(boxes, centroid.owin)) + + ## design a sequence of clicks + actionsequence <- c("Up", "Down", "Left", "Right", + "At Proposal", "Zoom Out", "Zoom In", "Reset", + "Accept", "Reject", "Print Info", + "Next Iteration", "Next Shift", "Next Death", + "Skip 10", "Skip 100", "Skip 1000", "Skip 10,000", + "Skip 100,000", "Exit Debugger") + actionsequence <- match(actionsequence, clicknames) + actionsequence <- actionsequence[!is.na(actionsequence)] + xy <- lapply(boxcentres, "[", actionsequence) + + ## queue the click sequence + spatstat.utils::queueSpatstatLocator(xy$x,xy$y) + + ## go + rmh(model, snoop=TRUE) + }) + } Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Extracting model information...Evaluating trend...done. Checking arguments..determining simulation windows...Evaluating trend integral...Starting simulation. Initial state... Creating debugger environment..Done. Ready to simulate. Generating proposal points...Running Metropolis-Hastings. ------------------- Iteration 0 Simulation window: window: rectangle = [0, 1.6012085] x [0, 1] units (one unit = 662 microns) Clipping window: window: rectangle = [0, 1.6012085] x [0, 1] units (one unit = 662 microns) Current state: Marked planar point pattern: 72 points Multitype, with levels = off, on window: rectangle = [0, 1.6012085] x [0, 1] units (one unit = 662 microns) Proposal type: Shift Shift data point 18 from current location (0.290108, 0.0160037, "off") to new location (0.620599, 0.378428, "off") Hastings ratio = 6831.92992943083 / 14545.6615344214 = 0.469688498750194 Fate of proposal: Rejected Marked planar point pattern: 350 points Multitype, with levels = off, on window: rectangle = [0, 1.6012085] x [0, 1] units (one unit = 662 microns) Pattern was generated by Metropolis-Hastings simulation. > > proc.time() user system elapsed 8.62 0.59 9.20 Running the tests in 'tests/testsS.R' failed. Complete output: > #' > #' 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) Loading required package: spatstat.model Loading required package: spatstat.data Loading required package: spatstat.geom spatstat.geom 3.2-9 Loading required package: spatstat.random spatstat.random 3.2-3 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.2-7 Loading required package: rpart spatstat.model 3.2-11 > 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/slrm.R > # > # $Revision: 1.3 $ $Date: 2020/05/01 09:59:59 $ > # > # Test slrm fitting and prediction when there are NA's > # > > if(ALWAYS) { + local({ + X <- copper$SouthPoints + W <- owin(poly=list(x=c(0,35,35,1),y=c(1,1,150,150))) + Y <- X[W] + fit <- slrm(Y ~ x+y) + pred <- predict(fit) + extractAIC(fit) + fitx <- update(fit, . ~ x) + simulate(fitx, seed=42) + if(FULLTEST) { + unitname(fitx) + unitname(fitx) <- "km" + + mur <- solapply(murchison,rescale, 1000, "km") + mur$dfault <- distfun(mur$faults) + fut <- slrm(gold ~ dfault, data=mur, splitby="greenstone") + A <- model.images(fut) + } + }) + } > > > # > # tests/step.R > # > # $Revision: 1.5 $ $Date: 2020/05/01 09:59:59 $ > # > # test for step() operation > # > if(FULLTEST) { + local({ + Z <- as.im(function(x,y){ x^3 - y^2 }, nztrees$window) + fitP <- ppm(nztrees ~x+y+Z, covariates=list(Z=Z)) + step(fitP) + fitS <- update(fitP, Strauss(7)) + step(fitS) + fitM <- ppm(amacrine ~ marks*(x+y), + MultiStrauss(types=levels(marks(amacrine)), radii=matrix(0.04, 2, 2))) + step(fitM) + }) + } > > > > > proc.time() user system elapsed 1.23 0.28 1.46 * checking PDF version of manual ... [29s] OK * checking HTML version of manual ... [57s] OK * DONE Status: 1 ERROR, 1 NOTE