Running 'testsAtoC.R' [162s]
  Running 'testsD.R' [2s]
  Running 'testsEtoF.R' [2s]
  Running 'testsGtoJ.R' [2s]
  Running 'testsK.R' [157s]
  Running 'testsL.R' [2s]
  Running 'testsM.R' [2s]
  Running 'testsNtoO.R' [2s]
  Running 'testsP1.R' [2s]
  Running 'testsP2.R' [176s]
  Running 'testsQ.R' [1s]
  Running 'testsR.R' [149s]
  Running 'testsS.R' [168s]
  Running 'testsT.R' [2s]
  Running 'testsUtoZ.R' [2s]
Running the tests in 'tests/testsAtoC.R' failed.
Complete output:
  > #'
  > #'   Header for all (concatenated) test files
  > #'
  > #'   Require spatstat.geom
  > #'   Obtain environment variable controlling tests.
  > #'
  > #'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
  > 
  > require(spatstat.geom)
  Loading required package: spatstat.geom
  Loading required package: spatstat.data
  spatstat.geom 3.2-9
  > 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 -----------
  > ## badwindowcheck.R
  > ## $Revision: 1.3 $  $Date: 2020/04/28 12:58:26 $
  > ##
  > 
  > local({
  +   if(ALWAYS) {
  +     ## Simple example of self-crossing polygon
  +     x <- read.table("selfcross.txt", header=TRUE)
  +     ## Auto-repair
  +     w <- owin(poly=x)
  + 
  +     ## Real data involving various quirks
  +     b <- read.table("badwindow.txt", header=TRUE)
  +     b <- split(b, factor(b$i))
  +     b <- lapply(b, function(z) { as.list(z[,-3]) })
  +     ## make owin without checking
  +     W <- owin(poly=b, check=FALSE, fix=FALSE)
  +     ## Apply stringent checks
  +     owinpolycheck(W,verbose=FALSE)
  +     ## Auto-repair
  +     W2 <- owin(poly=b)
  +   }
  + })
  > 
  > 
  > 
  > 
  > ##  tests/closeshave.R
  > ## check 'closepairs/crosspairs' code
  > ## validity and memory allocation
  > ## $Revision: 1.29 $ $Date: 2022/06/06 10:09:56 $
  > 
  > ## ------- All this code must be run on every hardware -------
  > local({
  +   r <- 0.12
  + 
  +   close.all <- closepairs(redwood, r)
  +   close.ij <- closepairs(redwood, r, what="indices")
  +   close.ijd <- closepairs(redwood, r, what="ijd")
  +   close.every <- closepairs(redwood, r, what="all", distinct=FALSE)
  + 
  +   ## test agreement
  +   stopifnot(identical(close.ij, close.all[c("i","j")]))
  +   stopifnot(identical(close.ijd, close.all[c("i","j","d")]))
  + 
  +   ## validate basic format of result
  +   checkformat <- function(object, callstring) {
  +     if(length(unique(lengths(object))) > 1)
  +       stop(paste("Result of", callstring,
  +                  "contains vectors with different lengths"))
  +     return(invisible(TRUE))
  +   }
  +   checkformat(close.all, "closepairs(redwood, r)")  
  +   checkformat(close.ij, "closepairs(redwood, r, what='indices')")  
  +   checkformat(close.ijd, "closepairs(redwood, r, what='ijd')")  
  +   checkformat(close.every,
  +               "closepairs(redwood, r, what='all', distinct=FALSE)")  
  + 
  +   #' test memory overflow code
  +   close.cigar <- closepairs(redwood, r, what="ijd", nsize=2)
  +   close.cigar <- closepairs(redwood, r, what="ijd", nsize=2, periodic=TRUE)
  + 
  +   #' test special cases
  +   onepoint <- redwood[1]
  +   checkformat(closepairs(onepoint, r),
  +               "closepairs(onepoint, r)")
  +   checkformat(closepairs(onepoint, r, what="indices"),
  +               "closepairs(onepoint, r, what='indices')")
  +   checkformat(closepairs(onepoint, r, what="ijd"),
  +               "closepairs(onepoint, r, what='ijd')")
  +   checkformat(closepairs(onepoint, r, what="all", distinct=FALSE),
  +               "closepairs(onepoint, r, what='all', distinct=FALSE)")
  +   
  +   #' ..............  crosspairs ..................................
  +   Y <- split(amacrine)
  +   on <- Y$on
  +   off <- Y$off
  +   
  +   cross.all <- crosspairs(on, off, r)
  +   cross.ij <- crosspairs(on, off, r, what="indices")
  +   cross.ijd <- crosspairs(on, off, r, what="ijd")
  +   cross.every <- crosspairs(on, off, r, what="all", distinct=FALSE)
  +   cross.period <- crosspairs(on, off, r, periodic=TRUE)
  +   cross.exclude <- crosspairs(cells, cells[1:32], 0.1, iX=1:42, iY=1:32)
  + 
  +   ## validate basic format
  +   checkformat(cross.all, "crosspairs(on, off, r)")
  +   checkformat(cross.ij, "crosspairs(on, off, r, what='indices')")
  +   checkformat(cross.ijd, "crosspairs(on, off, r, what='ijd')")
  +   checkformat(cross.every, "crosspairs(on, off, r, what='all', distinct=FALSE)")
  +   checkformat(cross.period, "crosspairs(on, off, r, periodic=TRUE)")
  +   checkformat(cross.exclude, "crosspairs(cells, cells[], r, iX, iY)")
  +   
  +   ## test agreement
  +   stopifnot(identical(cross.ij, cross.all[c("i","j")]))
  +   stopifnot(identical(cross.ijd, cross.all[c("i","j","d")]))
  + 
  +   # closethresh vs closepairs: EXACT agreement
  +   thresh <- 0.08
  +   clt <- closethresh(redwood, r, thresh)
  +   cl <- with(closepairs(redwood, r),
  +              list(i=i, j=j, th = (d <= thresh)))
  +   if(!identical(cl, clt))
  +     stop("closepairs and closethresh disagree")
  + 
  +   reordered <- function(a) {
  +     o <- with(a, order(i,j))
  +     as.list(as.data.frame(a)[o,,drop=FALSE])
  +   }
  +   samesame <- function(a, b) {
  +     identical(reordered(a), reordered(b))
  +   }
  +   
  +   ## ...............................................
  +   #' compare with older, slower code
  +   op <- spatstat.options(closepairs.newcode=FALSE,
  +                          closepairs.altcode=FALSE,
  +                          crosspairs.newcode=FALSE)
  +   ## ...............................................
  +   old.close.ij <- closepairs(redwood, r, what="indices")
  +   old.cross.ij <- crosspairs(on, off, r, what="indices")
  +   stopifnot(samesame(close.ij, old.close.ij))
  +   stopifnot(samesame(cross.ij, old.cross.ij))
  +   # execute only:
  +   old.close.every <- closepairs(redwood, r, what="all", distinct=FALSE)
  +   old.close.once <- closepairs(redwood, r, what="all", twice=FALSE)
  +   #' test memory overflow code
  +   old.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2)
  +   old.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2, periodic=TRUE)
  +   
  +   ## ...............................................
  +   spatstat.options(op)
  +   ## ...............................................
  + 
  +   ## ...............................................
  +   #' alternative code - execution only
  +   op <- spatstat.options(closepairs.newcode=FALSE,
  +                          closepairs.altcode=TRUE)
  +   alt.close.ij <- closepairs(redwood, r, what="indices")
  +   alt.close.ijd <- closepairs(redwood, r, what="ijd")
  +   alt.close.all <- closepairs(redwood, r, what="all")
  +   #' test memory overflow code
  +   alt.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2)
  +   alt.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2, periodic=TRUE)
  +   spatstat.options(op)
  +   ## ...............................................
  +   
  +   # Rasmus' example
  +   R <- 0.04
  +   U <- as.ppp(gridcenters(owin(), 50, 50), W=owin())
  +   cp <- crosspairs(U, U, R)
  +   G <- matrix(0, npoints(U), npoints(U))
  +   G[cbind(cp$i, cp$j)] <- 1
  +   if(!isSymmetric(G))
  +     stop("crosspairs is not symmetric in Rasmus example")
  + 
  +   #' periodic distance
  +   pclose <- function(X, R, method=c("raw", "C")) {
  +     method <- match.arg(method)
  +     switch(method,
  +            raw = {
  +              D <- pairdist(X, periodic=TRUE)
  +              diag(D) <- Inf
  +              result <- which(D <= R, arr.ind=TRUE)
  +            },
  +            C = {
  +              result <- closepairs(X, R, periodic=TRUE, what="indices")
  +            })
  +     result <- as.data.frame(result)
  +     colnames(result) <- c("i","j")
  +     return(result)
  +   }
  +   #' pick a threshold value which avoids GCC bug 323
  +   RR <- 0.193
  +   A <- pclose(redwood, RR, "raw")
  +   B <- pclose(redwood, RR, "C")
  +   if(!samesame(A,B))
  +     stop("closepairs.ppp(periodic=TRUE) gives wrong answer")
  + 
  +   #' other functions that don't have a help file
  +   niets <- crosspairquad(quadscheme(cells), 0.1)
  + 
  +   #' other code blocks
  +   u <- closepairs(cells, 0.09, periodic=TRUE, what="all")
  +   v <- closepairs(cells, 0.07, twice=FALSE, neat=TRUE)
  +   #' tight cluster - guess count does not work
  +   Xc <- runifrect(100, square(0.01))
  +   Window(Xc) <- square(1)
  +   z <- closepairs(Xc, 0.02, what="indices", distinct=FALSE)
  +   z <- closepairs(Xc, 0.02, what="ijd",     distinct=FALSE)
  +   z <- closepairs(Xc, 0.02, what="all",     distinct=FALSE)
  +   #' same task, older code
  +   aop <- spatstat.options(closepairs.newcode=FALSE)
  +   z <- closepairs(Xc, 0.02, what="indices", distinct=FALSE)
  +   z <- closepairs(Xc, 0.02, what="ijd",     distinct=FALSE)
  +   z <- closepairs(Xc, 0.02, what="all",     distinct=FALSE)
  +   spatstat.options(aop)
  + 
  +   #' experimental
  +   r <- 0.08
  +   a <- closepairs(redwood, r)
  +   b <- tweak.closepairs(a, r, 26, 0.1, 0.1)
  + })
  Using nsize = 2
  Using nsize = 2
  Using nsize = 2
  Using nsize = 2
  Using nsize = 2
  Using nsize = 2
  > 
  > local({
  +   #' Three-dimensional
  +   ##          X <- runifpoint3(100)
  +   X <- pp3(runif(100), runif(100), runif(100), box3(c(0,1)))
  +   cl <- closepairs(X, 0.2, what="indices")
  +   cl <- closepairs(X, 0.2, what="ijd")
  +   cl <- closepairs(X, 0.2, distinct=FALSE)
  +   cl <- closepairs(X, 0.2, distinct=FALSE, what="indices")
  +   cl <- closepairs(X, 0.2, distinct=FALSE, what="ijd")
  +   cl <- closepairs(X, 0.2, twice=FALSE, neat=TRUE)
  +   #' Test memory overflow code
  +   cl <- closepairs(X, 0.2, what="ijd", nsize=2)
  +   #' trap obsolete usage
  +   cl <- closepairs(X, 0.2, ordered=FALSE)
  +   #' crosspairs
  +   ##      Y <- runifpoint3(100)
  +   Y <- pp3(runif(100), runif(100), runif(100), box3(c(0,1)))
  +   cr <- crosspairs(X, Y, 0.2, what="indices")
  +   cr <- crosspairs(X, Y, 0.2, what="ijd")
  +   #' Test memory overflow code
  +   cr <- crosspairs(X, Y, 0.2, what="ijd", nsize=2)
  +   #' experimental
  +   rr <- 0.2
  +   cl <- closepairs(X, rr)
  +   ii <- cl$i[[1]]
  +   xl <- tweak.closepairs(cl, rr, ii, 0.05, -0.05, 0.05)
  + })
  Using nsize = 2
  Using nsize = 2
  Warning message:
  In closepairs.pp3(X, 0.2, ordered = FALSE) :
    Obsolete argument 'ordered' has been replaced by 'twice'
  > 
  > reset.spatstat.options()
  > #'
  > #'   tests/cluck.R
  > #'
  > #'   Tests of "click*" functions
  > #'   using queueing feature of spatstatLocator
  > #'
  > #'   $Revision: 1.8 $ $Date: 2022/10/23 00:45:36 $
  > 
  > local({
  +   #' clickppp
  +   if(ALWAYS) {
  +     spatstat.utils::queueSpatstatLocator(runif(5), runif(5))
  +     XA <- clickppp(hook=square(0.5))
  +   }
  +   if(FULLTEST) {
  +     spatstat.utils::queueSpatstatLocator(runif(6), runif(6))
  +     XB <- clickppp(n=3, types=c("a", "b"))
  +   }
  +   if(ALWAYS) {
  +     #' clickbox
  +     spatstat.utils::queueSpatstatLocator(runif(2), runif(2))
  +     BB <- clickbox()
  +     #' clickdist
  +     spatstat.utils::queueSpatstatLocator(runif(2), runif(2))
  +     dd <- clickdist()
  +     #' clickpoly
  +     hex <- vertices(disc(radius=0.4, centre=c(0.5, 0.5), npoly=6))
  +     spatstat.utils::queueSpatstatLocator(hex)
  +     PA <- clickpoly()
  +   }
  +   if(FULLTEST) {
  +     holy <- vertices(disc(radius=0.2, centre=c(0.5, 0.5), npoly=6))
  +     holy <- lapply(holy, rev)
  +     spatstat.utils::queueSpatstatLocator(concatxy(hex, holy))
  +     PB <- clickpoly(np=2, nv=6)
  +   }
  +   if(ALWAYS) {
  +     #' identify.psp
  +     E <- edges(letterR)[c(FALSE, TRUE)]
  +     Z <- ppp(c(2.86, 3.65, 3.15), c(1.69, 1.98, 2.56), window=Frame(letterR))
  +     spatstat.utils::queueSpatstatLocator(Z)
  +     identify(E)
  +   }
  + })
  Ready to click..
  Click two corners of a box
  to add points: click left mouse button in window
         to exit: press ESC or click middle mouse button
   [The last point should NOT repeat the first point]
  [1] 10  3 15
  > ## tests/colour.R
  > ##
  > ##  Colour value manipulation and colour maps
  > ##
  > ## $Revision: 1.10 $ $Date: 2022/10/23 00:37:44 $
  > ##
  > 
  > local({
  +   if(FULLTEST) {
  +     f <- function(n) grey(seq(0,1,length=n))
  +     z <- to.grey(f)
  + 
  +     h <- colourmap(rainbow(9), range=c(0.01, 0.1))
  +     plot(h, labelmap=100)
  +   }
  + 
  +   if(ALWAYS) {
  +     a <- colourmap(rainbow(12), range=as.Date(c("2018-01-01", "2018-12-31")))
  +     print(a)
  +     print(summary(a))
  +     a(as.Date("2018-06-15"))
  + 
  +     g <- colourmap(rainbow(4),
  +                    breaks=as.Date(c("2018-01-01", "2018-04-01",
  +                                     "2018-07-01", "2018-10-01", "2018-12-31")))
  +     print(g)
  +     print(summary(g))
  +     g(as.Date("2018-06-15"))
  +   }
  + 
  +   if(FULLTEST) {
  +     b <- colourmap(rainbow(12), inputs=month.name)
  +     print(b)
  +     print(summary(b))
  +     to.grey(b)
  +     to.grey(b, transparent=TRUE)
  +     plot(b, vertical=FALSE)
  +     plot(b, vertical=TRUE)
  +     plot(b, vertical=FALSE, gap=0)
  +     plot(b, vertical=TRUE, gap=0)
  +     plot(b, vertical=FALSE, xlim=c(0, 2))
  +     plot(b, vertical=TRUE, xlim=c(0,2))
  +     plot(b, vertical=FALSE, ylim=c(0, 2))
  +     plot(b, vertical=TRUE, ylim=c(0,2))
  + 
  +     argh <- list(a="iets", e="niets", col=b, f=42)
  +     arr <- col.args.to.grey(argh)
  +     rrgh <- col.args.to.grey(argh, transparent=TRUE)
  +   }
  + 
  +   if(ALWAYS) {
  +     #' constant colour map
  +     colourmap("grey", range=c(0.01, 0.1))
  +     colourmap("grey", range=as.Date(c("2018-01-01", "2018-12-31")))
  +     colourmap("grey",
  +               breaks=as.Date(c("2018-01-01", "2018-04-01",
  +                                "2018-07-01", "2018-10-01", "2018-12-31")))
  +     colourmap("grey", inputs=month.name)
  +   }
  + 
  +   if(FULLTEST) {
  +     #' empty colour map
  +     niets <- lut()
  +     print(niets)
  +     summary(niets)
  +     niets <- colourmap()
  +     print(niets)
  +     summary(niets)
  +     plot(niets)
  +   }
  + 
  +   if(FULLTEST) {
  +     #' interpolation - of transparent colours
  +     co <- colourmap(inputs=c(0, 0.5, 1),
  +                     rgb(red=c(1,0,0), green=c(0,1,0), blue=c(0,0,1),
  +                         alpha=c(0.3, 0.6, 0.9)))
  +     tco <- interp.colourmap(co)
  +   }
  + })
  Colour map for the range [2018-01-01, 2018-12-31] 
                     interval  colour
  1  [2018-01-01, 2018-01-31) #FF0000
  2  [2018-01-31, 2018-03-03) #FF8000
  3  [2018-03-03, 2018-04-02) #FFFF00
  4  [2018-04-02, 2018-05-02) #80FF00
  5  [2018-05-02, 2018-06-02) #00FF00
  6  [2018-06-02, 2018-07-02) #00FF80
  7  [2018-07-02, 2018-08-01) #00FFFF
  8  [2018-08-01, 2018-09-01) #0080FF
  9  [2018-09-01, 2018-10-01) #0000FF
  10 [2018-10-01, 2018-10-31) #8000FF
  11 [2018-10-31, 2018-12-01) #FF00FF
  12 [2018-12-01, 2018-12-31] #FF0080
  Colour map for the range [2018-01-01, 2018-12-31] 
                     interval  colour
  1  [2018-01-01, 2018-01-31) #FF0000
  2  [2018-01-31, 2018-03-03) #FF8000
  3  [2018-03-03, 2018-04-02) #FFFF00
  4  [2018-04-02, 2018-05-02) #80FF00
  5  [2018-05-02, 2018-06-02) #00FF00
  6  [2018-06-02, 2018-07-02) #00FF80
  7  [2018-07-02, 2018-08-01) #00FFFF
  8  [2018-08-01, 2018-09-01) #0080FF
  9  [2018-09-01, 2018-10-01) #0000FF
  10 [2018-10-01, 2018-10-31) #8000FF
  11 [2018-10-31, 2018-12-01) #FF00FF
  12 [2018-12-01, 2018-12-31] #FF0080
  Colour map for the range [2018-01-01, 2018-12-31] 
                    interval  colour
  1 [2018-01-01, 2018-04-01) #FF0000
  2 [2018-04-01, 2018-07-01) #80FF00
  3 [2018-07-01, 2018-10-01) #00FFFF
  4 [2018-10-01, 2018-12-31] #8000FF
  Colour map for the range [2018-01-01, 2018-12-31] 
                    interval  colour
  1 [2018-01-01, 2018-04-01) #FF0000
  2 [2018-04-01, 2018-07-01) #80FF00
  3 [2018-07-01, 2018-10-01) #00FFFF
  4 [2018-10-01, 2018-12-31] #8000FF
  > 
  > # tests/correctC.R
  > # check for agreement between C and interpreted code
  > # for interpoint distances etc.
  > # $Revision: 1.10 $ $Date: 2023/12/08 07:10:34 $
  > 
  > 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)")
  + 
  + })
  + 
  + }
  Discrepancy 0 for pairdist()
  Discrepancy 0 for pairdist(periodic=TRUE)
  Discrepancy 0 for pairdist(periodic=TRUE, squared=TRUE)
  Discrepancy 0 for crossdist()
  Discrepancy 5.551115e-17 for crossdist(periodic=TRUE)
  Discrepancy 0 for crossdist(periodic=TRUE, squared=TRUE)
  Discrepancy 0 for nndist()
  Discrepancy 0 for nndist(k=3)
  Discrepancy 0 for nnwhich()
  Discrepancy 0 for nnwhich(k=3)
  [1] TRUE
  > 
  > 
  > proc.time()
     user  system elapsed 
     2.54    0.37    2.89 
Running the tests in 'tests/testsK.R' failed.
Complete output:
  > #'
  > #'   Header for all (concatenated) test files
  > #'
  > #'   Require spatstat.geom
  > #'   Obtain environment variable controlling tests.
  > #'
  > #'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
  > 
  > require(spatstat.geom)
  Loading required package: spatstat.geom
  Loading required package: spatstat.data
  spatstat.geom 3.2-9
  > 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 
     1.23    0.20    1.42 
Running the tests in 'tests/testsP2.R' failed.
Complete output:
  > #'
  > #'   Header for all (concatenated) test files
  > #'
  > #'   Require spatstat.geom
  > #'   Obtain environment variable controlling tests.
  > #'
  > #'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
  > 
  > require(spatstat.geom)
  Loading required package: spatstat.geom
  Loading required package: spatstat.data
  spatstat.geom 3.2-9
  > 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/ppp.R
  > #'
  > #'   $Revision: 1.14 $ $Date: 2022/08/27 04:49:32 $
  > #'
  > #'  Untested cases in ppp() or associated code
  > 
  > local({
  +   ## X <- runifpoint(10, letterR)
  +   ## Y <- runifpoint(10, complement.owin(letterR))
  +   Bin  <- owin(c(2.15, 2.45), c(0.85, 3.0))
  +   Bout <- owin(c(2.75, 2.92), c(0.85, 1.4))
  +   X <- runifrect(10, Bin)[letterR]
  +   Y <- runifrect(10, Bout)[complement.owin(letterR)]
  +   
  +   if(FULLTEST) {
  +     #' test handling of points out-of-bounds
  +     df <- rbind(as.data.frame(X), as.data.frame(Y))
  +     A <- ppp(df$x, df$y, window=letterR, marks=1:20)
  +     #' test handling of points with bad coordinates
  +     df$x[1:3] <- c(Inf, NA, NaN)
  +     df$y[18:20] <- c(Inf, NA, NaN)
  +     B <- ppp(df$x, df$y, window=letterR, marks=1:20)
  +     D <- ppp(df$x, df$y, window=letterR, marks=data.frame(id=1:20, u=runif(20)))
  +   
  +     #' test print/summary/plot methods on these bad objects
  +     print(A)
  +     print(B)
  +     print(D)
  +     print(summary(A))
  +     print(summary(B))
  +     print(summary(D))
  +     plot(A)
  +     plot(B)
  +     plot(D)
  +     plot(attr(A, "rejects"))
  +     plot(attr(B, "rejects"))
  +     plot(attr(D, "rejects"))
  +   
  +     #' subset operator --- cases not covered elsewhere
  +     #'   subset index is a logical image
  +     Z <- distmap(letterR, invert=TRUE)
  +     V <- (Z > 0.2)
  +     XV <- X[V]
  +     #'   multiple columns of marks
  +     fun3 <- finpines[1:3]
  +     #'   multiple columns of marks, one of which is a factor
  +     U <- finpines
  +     marks(U)[,2] <- factor(c(rep("A", 60), rep("B", npoints(U)-60)))
  +     UU <- U[1:3, drop=TRUE]
  + 
  +     #' cut.ppp
  +     CU <- cut(U, "height")
  +     CU <- cut(U, breaks=3)
  + 
  +     #' cases of [<-.ppp
  +     set.seed(999)
  +     X <- cells
  +     B <- square(0.2)
  +     X[B] <- runifrect(3, B)
  +     #' checking 'value'
  +     Y <- flipxy(X)
  +     X[B] <- Y[square(0.3)]
  +     ## deprecated use of second argument
  +     X[,1:4] <- runifrect(3)  # deprecated
  +     X[,B] <- runifrect(3, B) # deprecated 
  +     X[1:3, B] <- runifrect(20)
  +     A <- superimpose(cells, X, W="convex")
  +     A <- superimpose(cells, X, W=ripras)
  +     B <- superimpose(concatxy(cells), concatxy(X), W=NULL)
  +     ## superimpose.splitppp
  +     Y <- superimpose(split(amacrine))
  + 
  +     ## catch outdated usage of scanpp
  +     d <- system.file("rawdata", "amacrine", package="spatstat.data")
  +     if(nzchar(d)) {
  +       W <- owin(c(0, 1060/662), c(0, 1))
  +       Y <- scanpp("amacrine.txt", dir=d, window=W, multitype=TRUE)
  +       print(Y)
  +     }
  +     ## (bad) usage of cobble.xy
  +     xx <- runif(10)
  +     yy <- runif(10)
  +     W1 <- cobble.xy(xx, yy)
  +     W2 <- cobble.xy(xx, yy, boundingbox)
  +     Wnope <- cobble.xy(xx, yy, function(x,y) {cbind(x,y)}, fatal=FALSE)
  + 
  +     ## as.data.frame.ppplist
  +     Z <- runifrect(3, nsim=4)
  +     Z[[2]] <- Z[[2]][1]
  +     Z[[3]] <- Z[[3]][FALSE]
  +     d <- as.data.frame(Z)
  +   }
  + })
  > 
  > #
  > # tests/ppx.R
  > #
  > # Test operations for ppx objects
  > #
  > #  $Revision: 1.9 $ $Date: 2020/12/04 04:49:40 $
  > #
  > 
  > local({
  +   if(ALWAYS) {
  +     ## make data
  +     df <- data.frame(x=c(1,2,2,1)/4, y=c(1,2,3,1)/4, z=c(2,3,4,3)/5)
  +     X <- ppx(data=df, coord.type=rep("s", 3), domain=box3())
  +   }
  +   if(ALWAYS) {
  +     #' methods involving C code
  +     unique(X)
  +     duplicated(X)
  +     anyDuplicated(X)
  +     multiplicity(X)
  +     uniquemap(X)
  +   }
  +   if(FULLTEST) {
  +     #' general tests
  +     print(X)
  +     summary(X)
  +     plot(X)
  +     domain(X)
  +     unitname(X) <- c("metre", "metres")
  +     unitname(X)
  + 
  +     #' subset operator
  +     X[integer(0)]
  +     Y <- X %mark% data.frame(a=df$x, b=1:4)
  +     Y[1:2]
  +     Y[FALSE]
  +     marks(Y) <- as.data.frame(marks(Y))
  +     Y[integer(0)]
  +     Y[1:2]
  +     Y[FALSE]
  +   }
  + 
  +   if(FULLTEST) {
  +     #' two dimensional
  +     A <- ppx(data=df[,1:2], coord.type=rep("s", 2), domain=square(1))
  +     plot(A)
  +     B <- ppx(data=df[,1:2], coord.type=rep("s", 2), domain=NULL)
  +     plot(B)
  +     #' one dimensional
  +     E <- ppx(data=data.frame(x=runif(10)))
  +     plot(E)
  +   
  +     #' bug
  +     stopifnot(identical(unmark(chicago[1]),
  +                         unmark(chicago)[1]))
  + 
  +     #' ppx with zero points
  +     U <- chicago[integer(0)]
  +     V <- U %mark% 1
  +     V <- U %mark% factor("a")
  + 
  +     #' simplify lower-dimensional patterns
  +     X3 <- ppx(data=df, coord.type=rep("s", 3), domain=box3(), simplify=TRUE)
  +     stopifnot(is.pp3(X3))
  +     X2 <- ppx(data=df[,1:2], coord.type=rep("s", 2), domain=square(1), simplify=TRUE)
  +     stopifnot(is.ppp(X2))
  + 
  +     #' marks<-.ppx
  +     M <- as.matrix(X)
  +     marks(X) <- df[,1]
  +     marks(X) <- df[,integer(0)]
  +   }
  + 
  +   if(FULLTEST) {
  +     ## ............  from Ege ..........................
  +     ## Tests for shift:
  +     ## Check ppp and ppx shift are the same
  +     X <- cells
  +     Y <- ppx(coords(cells), domain = boxx(0:1,0:1))
  +     Xs <- shift(X, vec = c(1,1))
  +     Ys <- shift(Y, vec = c(1,1))
  +     stopifnot(all.equal(coords(Xs), coords(Ys),
  +                         check.attributes = FALSE))
  +     stopifnot(all.equal(domain(Xs), as.owin(domain(Ys)),
  +                         check.attributes = FALSE))
  +     ## Check a single numeric for vec in shift.ppx
  +     stopifnot(identical(Ys, shift(Y, vec = 1)))
  + 
  +     ## Tests for scale:
  +     dat <- data.frame(x=1:3, y=1:3, m=letters[1:3])
  +     xrange <- yrange <- c(0,4)
  +     cent <- c(2,2)
  +     scal <- c(5,5)
  +     X <- as.ppp(dat, W = owin(xrange, yrange))
  +     Xscaled <- affine(shift(X, vec = -cent), mat = diag(1/scal))
  +     ## Check ppx without domain:
  +     Y <- ppx(dat, coord.type = c("spatial", "spatial", "mark"))
  +     Yscaled <- scale(Y, center = cent, scale = scal)
  +     stopifnot(all.equal(coords(Xscaled),
  +                         coords(Yscaled),
  +                         check.attributes = FALSE))
  +     ## Check ppx with domain:
  +     Y$domain <- boxx(xrange, yrange)
  +     Yscaled <- scale(Y, center = cent, scale = scal)
  +     stopifnot(all.equal(as.boxx(Window(Xscaled)),
  +                         domain(Yscaled),
  +                         check.attributes = FALSE))
  + 
  +     ## Tests for intersect.boxx:
  +     ## Should be unit 2D box:
  +     A <- intersect.boxx(boxx(c(-1,1),c(0,2)), boxx(c(0,3),c(0,1)))
  +     stopifnot(identical(A, boxx(c(0,1),c(0,1))))
  +     ## Should be empty (NULL)
  +     B <- intersect.boxx(boxx(c(-1,1),c(0,2)),
  +                         boxx(c(0,3),c(0,1)),
  +                         boxx(c(1,2), c(-1,1)))
  +     stopifnot(is.null(B))
  +     ## Should be unit 3D box:
  +     C <- intersect.boxx(boxx(c(-1,1),c(0,2),c(-1,1)),
  +                         boxx(c(0,3),c(0,1),c(0,4)))
  +     stopifnot(identical(C, boxx(c(0,1),c(0,1),c(0,1))))
  +     ## Should be empty (NULL)
  +     D <- intersect.boxx(boxx(c(-1,1),c(0,2),c(-1,1)),
  +                         boxx(c(0,3),c(0,1),c(0,4)), NULL)
  +     stopifnot(is.null(D))
  + 
  +     ## Tests for [.boxx with clip:
  +     ## Check ppp and ppx subset with clip are the same
  +     X <- cells
  +     WX <- shift(domain(X), vec = c(.5,.5))
  +     X2 <- X[WX, clip=TRUE]
  +     Y <- ppx(coords(X), domain = boxx(c(0,1),c(0,1)))
  +     WY <- shift(domain(Y), vec = c(.5,.5))
  +     Y2 <- Y[WY, clip=TRUE]
  +     stopifnot(all.equal(coords(X2), coords(Y2), check.attributes = FALSE))
  +     stopifnot(all.equal(domain(X2), as.owin(domain(Y2))))
  +   }
  + 
  + })
  > 
  > proc.time()
     user  system elapsed 
     1.34    0.20    1.53 
Running the tests in 'tests/testsR.R' failed.
Complete output:
  > #'
  > #'   Header for all (concatenated) test files
  > #'
  > #'   Require spatstat.geom
  > #'   Obtain environment variable controlling tests.
  > #'
  > #'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
  > 
  > require(spatstat.geom)
  Loading required package: spatstat.geom
  Loading required package: spatstat.data
  spatstat.geom 3.2-9
  > 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/randbasic.R
  > #'   Tests of basic random generation code 
  > #'  $Revision: 1.1 $ $Date: 2021/09/09 09:59:23 $
  > 
  > 
  > local({
  +   if(FULLTEST) {
  +     #' cases not covered in examples
  +     A <- runifrect(6, nsim=2)
  +     A <- rsyst(nx=4, nsim=2)
  +     A <- rjitter(cells, nsim=2, retry=FALSE)
  +     A <- rjitter(cells, nndist(cells)/2)
  +     A <- rjitter(cells[FALSE])
  +   }
  + })
  > 
  > 
  > 
  > proc.time()
     user  system elapsed 
     1.17    0.17    1.34 
Running the tests in 'tests/testsS.R' failed.
Complete output:
  > #'
  > #'   Header for all (concatenated) test files
  > #'
  > #'   Require spatstat.geom
  > #'   Obtain environment variable controlling tests.
  > #'
  > #'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $
  > 
  > require(spatstat.geom)
  Loading required package: spatstat.geom
  Loading required package: spatstat.data
  spatstat.geom 3.2-9
  > 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/segments.R
  > ##   Tests of psp class and related code
  > ##                      [SEE ALSO: tests/xysegment.R]
  > ##
  > ##  $Revision: 1.33 $  $Date: 2022/05/22 08:39:47 $
  > 
  > 
  > local({
  + 
  +   if(ALWAYS) { # depends on platform
  +     ## pointed out by Jeff Laake
  +     W <- owin()
  +     X <- psp(x0=.25,x1=.25,y0=0,y1=1,window=W)
  +     X[W]
  +   }
  + 
  +   X <- psp(runif(10),runif(10),runif(10),runif(10), window=owin())
  + 
  +   if(FULLTEST) {
  +     Z <- as.mask.psp(X)
  +     Z <- pixellate(X)
  +   }
  + 
  +   if(ALWAYS) { # platform dependent
  +     ## add short segment
  +     Shorty <- psp(0.5, 0.6, 0.5001, 0.6001, window=Window(X))
  +     XX <- superimpose(X[1:5], Shorty, X[6:10])
  +     ZZ <- as.mask.psp(XX)
  +     ZZ <- pixellate(XX)
  +   }
  + 
  +   if(FULLTEST) {
  +     #' misc
  +     PX <- periodify(X, 2)
  +   }
  + 
  +   if(ALWAYS) { # C code
  +     ## tests of pixellate.psp -> seg2pixL
  +     ns <- 50
  +     out <- numeric(ns)
  +     for(i in 1:ns) {
  +       X <- psp(runif(1), runif(1), runif(1), runif(1), window=owin())
  +       len <- lengths_psp(X)
  +       dlen <- sum(pixellate(X)$v)
  +       out[i] <- if(len > 1e-7) dlen/len else 1
  +     }
  +     if(diff(range(out)) > 0.01) stop(paste(
  +                                   "pixellate.psp test 1: relative error [",
  +                                   paste(diff(range(out)), collapse=", "),
  +                                   "]"))
  + 
  +     ## Michael Sumner's test examples
  +     set.seed(33)
  +     n <- 2001
  +     co <- cbind(runif(n), runif(n))
  +     ow <- owin()
  +     X <- psp(co[-n,1], co[-n,2], co[-1,1], co[-1,2], window=ow)
  +     s1 <- sum(pixellate(X))
  +     s2 <- sum(lengths_psp(X))
  +     if(abs(s1 - s2)/s2 > 0.01) {
  +       stop(paste("pixellate.psp test 2:",
  +                  "sum(pixellate(X)) = ", s1,
  +                  "!=", s2, "= sum(lengths_psp(X))"))
  +     }
  + 
  +     wts <- 1/(lengths_psp(X) * X$n)
  +     s1 <- sum(pixellate(X, weights=wts))
  +     if(abs(s1-1) > 0.01) {
  +       stop(paste("pixellate.psp test 3:",
  +                  "sum(pixellate(X, weights))=", s1,
  +                  " (should be 1)"))
  +     }
  +     
  +     X <- psp(0, 0, 0.01, 0.001, window=owin())
  +     s1 <- sum(pixellate(X))
  +     s2 <- sum(lengths_psp(X))
  +     if(abs(s1 - s2)/s2 > 0.01) {
  +       stop(paste("pixellate.psp test 4:",
  +                  "sum(pixellate(X)) = ", s1,
  +                  "!=", s2, "= sum(lengths_psp(X))"))
  +     }
  + 
  +     X <- psp(0, 0, 0.001, 0.001, window=owin())
  +     s1 <- sum(pixellate(X))
  +     s2 <- sum(lengths_psp(X))
  +     if(abs(s1 - s2)/s2 > 0.01) {
  +       stop(paste("pixellate.psp test 5:",
  +                  "sum(pixellate(X)) = ", s1,
  +                  "!=", s2, "= sum(lengths_psp(X))"))
  +     }
  +   }
  + 
  +   if(FULLTEST) {
  +     #' cases of superimpose.psp
  +     A <- as.psp(matrix(runif(40), 10, 4), window=owin())
  +     B <- as.psp(matrix(runif(40), 10, 4), window=owin())
  +     superimpose(A, B, W=ripras)
  +     superimpose(A, B, W="convex")
  +   }
  + 
  +   if(FULLTEST) {
  +     #' as.psp.data.frame
  +     df <- as.data.frame(matrix(runif(40), ncol=4))
  +     A <- as.psp(df, window=square(1))
  +     colnames(df) <- c("x0","y0","x1","y1")
  +     df <- cbind(df, data.frame(marks=1:nrow(df)))
  +     B <- as.psp(df, window=square(1))
  +     colnames(df) <- c("xmid", "ymid", "length", "angle", "marks")
  +     E <- as.psp(df, window=square(c(-1,2)))
  +     G <- E %mark% factor(sample(letters[1:3], nsegments(E), replace=TRUE))
  +     H <- E %mark% runif(nsegments(E))
  +   
  +     #' print and summary methods
  +     A
  +     B
  +     E
  +     G
  +     H
  +     summary(B)
  +     summary(G)
  +     summary(H)
  +     M <- B
  +     marks(M) <- data.frame(id=marks(B), len=lengths_psp(B))
  +     M
  +     summary(M)
  +     subset(M, select=len)
  + 
  +     #' plot method cases  
  +     spatstat.options(monochrome=TRUE)
  +     plot(B)
  +     plot(G)
  +     plot(M)
  +     spatstat.options(monochrome=FALSE)
  +     plot(B)
  +     plot(G)
  +     plot(M)
  +     #' misuse of 'col' argument - several cases
  +     plot(G, col="grey") # discrete
  +     plot(B, col="grey") 
  +     plot(unmark(B), col="grey") 
  +     plot(M, col="grey") 
  +   
  +     #' miscellaneous class support cases
  +     marks(M) <- marks(M)[1,,drop=FALSE]
  +     
  +     #' undocumented  
  +     as.ppp(B)
  +   }
  + 
  +   if(ALWAYS) { # C code
  +     #' segment crossing code
  +     X <- psp(runif(30),runif(30),runif(30),runif(30), window=owin())
  +     A <- selfcut.psp(X, eps=1e-11)
  +     B <- selfcut.psp(X[1])
  +     #' 
  +     Y <- psp(runif(30),runif(30),runif(30),runif(30), window=owin())
  +     Z <- edges(letterR)[c(FALSE,TRUE)]
  +     spatstat.options(selfcrossing.psp.useCall=FALSE, crossing.psp.useCall=FALSE)
  +     A <- selfcrossing.psp(X)
  +     B <- selfcrossing.psp(Z)
  +     D <- crossing.psp(X,Y,details=TRUE)
  +     spatstat.options(selfcrossing.psp.useCall=TRUE, crossing.psp.useCall=TRUE)
  +     A <- selfcrossing.psp(X)
  +     B <- selfcrossing.psp(Z)
  +     D <- crossing.psp(X,Y,details=TRUE)
  +     reset.spatstat.options()
  +   }
  + 
  +   if(FULLTEST) {
  +     #' geometry
  +     m <- data.frame(A=1:10, B=letters[1:10])
  +     X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin(), marks=m)
  +     Z <- rotate(X, angle=pi/3, centre=c(0.5, 0.5))
  +     Y <- endpoints.psp(X, which="lower")
  +     Y <- endpoints.psp(X, which="upper")
  +     Y <- endpoints.psp(X, which="right")
  +     U <- flipxy(X)
  +   }
  +   
  +   if(ALWAYS) {
  +     ## nnfun.psp
  +     P <- psp(runif(10), runif(10), runif(10), runif(10),
  +              window=square(1), marks=runif(10))
  +     f <- nnfun(P)
  +     f <- nnfun(P, value="mark")
  +     d <- domain(f)
  +     Z <- as.im(f)
  +   }
  + 
  + })
  > 
  > reset.spatstat.options()
  > 
  > 
  > 
  > 
  > 
  > #'
  > #'     tests/simplepan.R
  > #'
  > #'   Tests of user interaction in simplepanel
  > #'   Handled by spatstatLocator()
  > #'
  > #'   $Revision: 1.3 $  $Date: 2020/05/01 09:59:59 $
  > #'
  > 
  > if(ALWAYS) {  # may depend on platform
  + local({
  +   ## Adapted from example(simplepanel)
  +   ## make boxes
  +   outerbox <- owin(c(0,4), c(0,1))
  +   buttonboxes <- layout.boxes(outerbox, 4, horizontal=TRUE, aspect=1)
  +   ## make environment containing an integer count
  +   myenv <- new.env()
  +   assign("answer", 0, envir=myenv)
  +   ## what to do when finished: return the count.
  +   myexit <- function(e) { return(get("answer", envir=e)) }
  +   ## button clicks
  +   ## decrement the count
  +   Cminus <- function(e, xy) {
  +     ans <- get("answer", envir=e)
  +     assign("answer", ans - 1, envir=e)
  +     return(TRUE)
  +   }
  +   ## display the count (clicking does nothing)
  +   Cvalue <- function(...) { TRUE }
  +   ## increment the count
  +   Cplus <- function(e, xy) {
  +     ans <- get("answer", envir=e)
  +     assign("answer", ans + 1, envir=e)
  +     return(TRUE)
  +   }
  +   ## 'Clear' button
  +   Cclear <- function(e, xy) {
  +     assign("answer", 0, envir=e)
  +     return(TRUE)
  +   }
  +   ## quit button
  +   Cdone <- function(e, xy) { return(FALSE) }
  + 
  +   myclicks <- list("-"=Cminus,
  +                    value=Cvalue,
  +                    "+"=Cplus,
  +                    done=Cdone)
  +   ## redraw the button that displays the current value of the count
  +   Rvalue <- function(button, nam, e) {
  +      plot(button, add=TRUE)
  +      ans <- get("answer", envir=e)
  +      text(centroid.owin(button), labels=ans)
  +      return(TRUE)
  +   }
  +   ## make the panel
  +   P <- simplepanel("Counter",
  +                    B=outerbox, boxes=buttonboxes,
  +                    clicks=myclicks,
  +                    redraws = list(NULL, Rvalue, NULL, NULL),
  +                    exit=myexit, env=myenv)
  +   ## queue up a sequence of inputs
  +   boxcentres <- do.call(concatxy, unname(lapply(buttonboxes[c(3,3,1,3,2,4)],
  +                                                 centroid.owin)))
  +   spatstat.utils::queueSpatstatLocator(boxcentres$x, boxcentres$y)
  +   ## go
  +   run.simplepanel(P)
  + })
  + }
  dev.new(): using pdf(file="Rplots1.pdf")
  [1] 2
  > #
  > #  tests/splitpea.R
  > #
  > #  Check behaviour of split.ppp etc
  > #
  > #  Thanks to Marcelino de la Cruz
  > #
  > #  $Revision: 1.17 $  $Date: 2021/04/15 06:19:51 $
  > #
  > 
  > local({
  +   W <- square(8)
  +   X <- ppp(c(2.98, 4.58, 7.27, 1.61, 7.19),
  +            c(7.56, 5.29, 5.03, 0.49, 1.65),
  +            window=W, check=FALSE)
  +   Z <- quadrats(W, 4, 4)
  +   Yall <- split(X, Z, drop=FALSE)
  +   Ydrop <- split(X, Z, drop=TRUE)
  + 
  +   if(ALWAYS) { # may depend on platform
  +     P <- Yall[[1]]
  +     if(!all(inside.owin(P$x, P$y, P$window)))
  +       stop("Black hole detected when drop=FALSE")
  +     P <- Ydrop[[1]]
  +     if(!all(inside.owin(P$x, P$y, P$window)))
  +       stop("Black hole detected when drop=TRUE")
  +     Ydrop[[1]] <- P[1]
  +     split(X, Z, drop=TRUE) <- Ydrop
  +   }
  + 
  +   ## test NA handling
  +   Zbad <- quadrats(square(4), 2, 2)
  +   Ybdrop <- split(X, Zbad, drop=TRUE)
  +   Yball  <- split(X, Zbad, drop=FALSE)
  + 
  +   if(FULLTEST) {
  +     ## other bugs/ code blocks in split.ppp, split<-.ppp, [<-.splitppp
  +     flog <- rep(c(TRUE,FALSE), 21)
  +     fimg <- as.im(dirichlet(runifrect(5, Window(cells))), dimyx=32)
  +     A <- split(cells, flog)
  +     B <- split(cells, square(0.5))
  +     D <- split(cells, fimg)
  +     E <- split(cells, logical(42), drop=TRUE)
  +     Cellules <- cells
  +     split(Cellules, flog) <- solapply(A, rjitter)
  +     split(Cellules, fimg) <- solapply(D, rjitter)
  +     D[[2]] <- rjitter(D[[2]])
  +     Funpines <- finpines
  +     marks(Funpines)[,"diameter"] <- factor(marks(Funpines)[,"diameter"])
  +     G <- split(Funpines)
  +     H <- split(Funpines, "diameter")
  +     split(Funpines) <- solapply(G, rjitter)
  +     split(Funpines, "diameter") <- solapply(H, rjitter)
  + 
  +     ## From Marcelino
  +     set.seed(1)
  +     W<- square(10) # the big window
  +     ## puntos<- rpoispp(0.5, win=W)
  +     puntos<- runifrect(rpois(1, 0.5 * area(W)), win=W)
  +     r00 <- letterR
  +     r05 <- shift(letterR,c(0,5))
  +     r50 <- shift(letterR,c(5,0))
  +     r55 <- shift(letterR,c(5,5))
  +     tessr4 <- tess(tiles=list(r00, r05,r50,r55))
  +     puntosr4 <- split(puntos, tessr4, drop=TRUE)
  +     split(puntos, tessr4, drop=TRUE) <- puntosr4
  + 
  +     ## More headaches with mark format
  +     A <- runifrect(10)
  +     B <- runifrect(10)
  +     AB <- split(superimpose(A=A, B=B))
  + 
  +     #' check that split<- respects ordering where possible
  +     X <- amacrine
  +     Y <- split(X)
  +     split(X) <- Y
  +     stopifnot(identical(X, amacrine))
  + 
  +     #' split.ppx
  +     df <- data.frame(x=runif(4),y=runif(4),t=runif(4),
  +                      age=rep(c("old", "new"), 2),
  +                      mineral=factor(rep(c("Au","Cu"), each=2),
  +                                     levels=c("Au", "Cu", "Pb")),
  +                      size=runif(4))
  +     X <- ppx(data=df, coord.type=c("s","s","t","m", "m","m"))
  +     Y <- split(X, "age")
  +     Y <- split(X, "mineral", drop=TRUE)
  +     Y <- split(X, "mineral")
  +     print(Y)
  +     print(summary(Y))
  +     Y[c(TRUE,FALSE,TRUE)]
  +     Y[1:2]
  +     Y[3] <- Y[1]
  +   }
  + })
  > 
  > ##
  > ## tests/symbolmaps.R
  > ##
  > ##   Quirks associated with symbolmaps, etc.
  > ##
  > ## $Revision: 1.5 $ $Date: 2020/12/04 08:02:52 $
  > 
  > if(FULLTEST) {
  + local({
  +   set.seed(100)
  +   X <- runifrect(8)
  + 
  +   ## symbolmap 
  +   g1 <- symbolmap(range=c(0,100), size=function(x) x/50)
  +   invoke.symbolmap(g1, 50, x=numeric(0), y=numeric(0), add=TRUE)
  +   plot(g1, labelmap=100)
  +   ## constant/trivial
  +   a <- symbolmap(pch=16)
  +   print(a)
  +   plot(a)
  +   symbolmapdomain(a)
  +   b <- symbolmap()
  +   print(b)
  + 
  +   ## textureplot
  +   V <- as.im(dirichlet(X))
  +   tmap <- textureplot(V)
  +   textureplot(V, textures=tmap, legend=TRUE, leg.side="left")
  +   textureplot(V, leg.side="bottom")
  +   textureplot(V, leg.side="top")
  +   ## spacing too large for tiles - upsets various pieces of code
  +   textureplot(V, spacing=2)
  + 
  +   ## plot.texturemap
  +   plot(tmap, vertical=TRUE)
  +   plot(tmap, vertical=TRUE, xlim=c(0,1))
  +   plot(tmap, vertical=TRUE, ylim=c(0,1))
  +   plot(tmap, vertical=FALSE, xlim=c(0,1))
  +   plot(tmap, vertical=FALSE, ylim=c(0,1))
  + 
  +   ## infrastructure
  +   plan.legend.layout(owin(), side="top", started=TRUE)
  + })
  + }
  > 
  > proc.time()
     user  system elapsed 
     1.62    0.31    1.92