R Under development (unstable) (2024-11-18 r87347 ucrt) -- "Unsuffered Consequences" Copyright (C) 2024 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.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.univar spatstat.univar 3.1-1 Loading required package: spatstat.geom spatstat.geom 3.3-4 Loading required package: spatstat.random spatstat.random 3.3-2 Loading required package: spatstat.explore Loading required package: nlme spatstat.explore 3.3-3 Loading required package: rpart spatstat.model 3.3-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/envelopes.R > # > # Test validity of envelope data > # > # $Revision: 1.29 $ $Date: 2024/01/10 13:45:29 $ > # > > 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) { + ## from Marcelino de la Cruz - scoping in update.ppm + X <- cells + Z <- density(X) + pfit <- ppm(X ~ Z) + cat("Fitted ppm(X~Z)", fill=TRUE) + penv <- envelope(pfit, Kinhom, lambda=pfit, nsim=3) + RX <- rotate(X, pi/3, centre="centroid") + RZ <- density(RX) + Rpfit <- ppm(RX ~ RZ) + cat("Fitted ppm(RX~RZ)", fill=TRUE) + Rpenv <- envelope(Rpfit, Kinhom, lambda=Rpfit, nsim=3) + } + + 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' + }) Envelope of ppm(cells ~ x) has correct format Generating 8 simulated realisations of fitted Poisson model (4 to estimate the mean and 4 to calculate envelopes) ... 1, 2, 3, 4, 5, 6, 7, 8. Done. Generating 4 simulated realisations of fitted Gibbs model with fixed number of points ... 1, 2, 3, 4. Done. Generating 4 simulated realisations of fitted Gibbs model with fixed number of points of each type ... 1, 2, 3, 4. Done. > #' 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")) + }) The formula does not involve "g" and is therefore unchanged Don't know how to reduce the term "sin(x - z)" NULL > > > > ## > ## 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) + }) + } Nonstationary Multitype Strauss Hardcore process Fitted to point pattern dataset 'X' Possible marks: 'a' and 'not-a' Log trend: ~marks + (x + y + I(x^2) + I(x * y) + I(y^2)) Fitted trend coefficients: (Intercept) marksnot-a x y I(x^2) I(x * y) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 0.3384324 I(y^2) -0.5425654 2 types of points Possible types: [1] a not-a Interaction radii: a not-a a 0.1 0.1 not-a 0.1 0.1 Hardcore radii: a not-a a 0.005 0.005 not-a 0.005 0.005 Fitted interaction parameters gamma_ij a not-a a 0.2699920 0.8920719 not-a 0.8920719 0.2694374 Relevant coefficients: markaxa markaxnot.a marknot.axnot.a -1.3093629 -0.1142086 -1.3114192 For standard errors, type coef(summary(x)) (Intercept) marksnot-a x y I(x^2) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 I(x * y) I(y^2) markaxa markaxnot.a marknot.axnot.a 0.3384324 -0.5425654 -1.3093629 -0.1142086 -1.3114192 Nonstationary Multitype Strauss Hardcore process Fitted to point pattern dataset 'X' Possible marks: 'U' and 'non U' Log trend: ~marks + (x + y + I(x^2) + I(x * y) + I(y^2)) Fitted trend coefficients: (Intercept) marksnon U x y I(x^2) I(x * y) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 0.3384324 I(y^2) -0.5425654 2 types of points Possible types: [1] U non U Interaction radii: U non U U 0.1 0.1 non U 0.1 0.1 Hardcore radii: U non U U 0.005 0.005 non U 0.005 0.005 Fitted interaction parameters gamma_ij U non U U 0.2699920 0.8920719 non U 0.8920719 0.2694374 Relevant coefficients: markUxU markUxnon.U marknon.Uxnon.U -1.3093629 -0.1142086 -1.3114192 For standard errors, type coef(summary(x)) (Intercept) marksnon U x y I(x^2) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 I(x * y) I(y^2) markUxU markUxnon.U marknon.Uxnon.U 0.3384324 -0.5425654 -1.3093629 -0.1142086 -1.3114192 Nonstationary Multitype Strauss Hardcore process Fitted to point pattern dataset 'X' Possible marks: 'a+' and 'a*' Log trend: ~marks + (x + y + I(x^2) + I(x * y) + I(y^2)) Fitted trend coefficients: (Intercept) marksa* x y I(x^2) I(x * y) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 0.3384324 I(y^2) -0.5425654 2 types of points Possible types: [1] a+ a* Interaction radii: a+ a* a+ 0.1 0.1 a* 0.1 0.1 Hardcore radii: a+ a* a+ 0.005 0.005 a* 0.005 0.005 Fitted interaction parameters gamma_ij a+ a* a+ 0.2699920 0.8920719 a* 0.8920719 0.2694374 Relevant coefficients: marka.xa. marka.xa..1 marka..1xa..1 -1.3093629 -0.1142086 -1.3114192 For standard errors, type coef(summary(x)) (Intercept) marksa* x y I(x^2) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 I(x * y) I(y^2) marka.xa. marka.xa..1 marka..1xa..1 0.3384324 -0.5425654 -1.3093629 -0.1142086 -1.3114192 Nonstationary Multitype Strauss Hardcore process Fitted to point pattern dataset 'X' Possible marks: '+' and '*' Log trend: ~marks + (x + y + I(x^2) + I(x * y) + I(y^2)) Fitted trend coefficients: (Intercept) marks* x y I(x^2) I(x * y) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 0.3384324 I(y^2) -0.5425654 2 types of points Possible types: [1] + * Interaction radii: + * + 0.1 0.1 * 0.1 0.1 Hardcore radii: + * + 0.005 0.005 * 0.005 0.005 Fitted interaction parameters gamma_ij + * + 0.2699920 0.8920719 * 0.8920719 0.2694374 Relevant coefficients: markX.xX. markX.xX..1 markX..1xX..1 -1.3093629 -0.1142086 -1.3114192 For standard errors, type coef(summary(x)) (Intercept) marks* x y I(x^2) 7.3741600 0.1223023 1.2302865 0.2403500 -0.7560707 I(x * y) I(y^2) markX.xX. markX.xX..1 markX..1xX..1 0.3384324 -0.5425654 -1.3093629 -0.1142086 -1.3114192 Marked planar point pattern: 42 points marks are dates, of class 'POSIXt' window: rectangle = [0, 1] x [0, 1] units Marked planar point pattern: 42 points Mark variables: id, date, dd window: rectangle = [0, 1] x [0, 1] units Warning messages: 1: In is.multitype.ppp(Z) : some mark values are NA in the point pattern Z 2: Factor-valued marks were converted to integer codes 3: Factor-valued mark variable 'a' was converted to integer codes 4: Factor-valued marks were converted to integer codes > > proc.time() user system elapsed 4.53 0.93 5.45