tests/testsAtoK.R

In spatstat.linnet: Linear Networks Functionality of the 'spatstat' Family

#'
#'   Header for all (concatenated) test files
#'
#'   Require spatstat.linnet
#'   Obtain environment variable controlling tests.
#'
#'   $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $

require(spatstat.linnet)
FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0)
ALWAYS   <- TRUE
cat(paste("--------- Executing",
          if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of",
          "test code -----------\n"))
#'  tests/aucroc.R
#'
#'  AUC and ROC code
#'
#'  $Revision: 1.6 $ $Date: 2020/11/02 06:26:45 $

local({
  if(FULLTEST) {
    A <- roc(spiders, "x")
    B <- auc(spiders, "y")
    fut <- lppm(spiders ~ I(y-x))
    f <- roc(fut)
    g <- auc(fut)
  }
})
## tests/cdf.test.R


local({
  NSIM <- 9
  op <- spatstat.options(ndummy.min=16, npixel=32)
  op <- spatstat.options(ndummy.min=16, npixel=32)
  if(ALWAYS) {
    ## (3) linear networks
    set.seed(42)
    X <- runiflpp(20, simplenet)
    cdf.test(X, "x")
    if(FULLTEST) {
      cdf.test(X, "x", "cvm")
      cdf.test(X %mark% runif(20), "x")
    }
    fit <- lppm(X ~1)
    cdf.test(fit, "y", "cvm", nsim=NSIM)
    if(FULLTEST) {
      cdf.test(fit, "y", nsim=NSIM)
      cdf.test(fit, "y", "ad", nsim=NSIM)
    }
    if(FULLTEST) {
      ## marked
      cdf.test(chicago, "y")
      cdf.test(subset(chicago, marks != "assault"), "y")
    }
  }
  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({
  Y <- coords(runiflpp(6, simplenet))
  if(FULLTEST) {
    #' clicklpp
    spatstat.utils::queueSpatstatLocator(Y)
    XL <- clicklpp(simplenet)
  }
  if(ALWAYS) {
    spatstat.utils::queueSpatstatLocator(Y)
    XM <- clicklpp(simplenet, n=3, types=c("a", "b"))
  }
  if(ALWAYS) {
    #' lineardisc
    plot(simplenet)
    spatstat.utils::queueSpatstatLocator(as.ppp(runiflpp(1, simplenet)))
    V <- lineardisc(simplenet, r=0.3)
  }
})
#'
#'   tests/disconnected.R
#'
#'   disconnected linear networks
#'
#'    $Revision: 1.4 $ $Date: 2020/04/28 12:58:26 $


local({

  #'   disconnected network
  m <- simplenet$m
  m[4,5] <- m[5,4] <- m[6,10] <- m[10,6] <- m[4,6] <- m[6,4] <- FALSE
  L <- linnet(vertices(simplenet), m)
  if(FULLTEST) {
    L
    summary(L)
    is.connected(L)
    Z <- connected(L, what="components")
  }

  #' point pattern with no points in one connected component
  set.seed(42)
  X <- rpoislpp(lambda=function(x,y) { 10 * (x < 0.5)}, L)
  B <- lineardirichlet(X)
  if(FULLTEST) {
    plot(B)
    summary(B)
  }
  if(ALWAYS) {
    D <- pairdist(X)
    A <- nndist(X)
  }
  if(FULLTEST) {
    H <- nnwhich(X)
    Y <- rpoislpp(lambda=function(x,y) { 10 * (x < 0.5)}, L)
    G <- nncross(X, Y)
    J <- crossdist(X, Y)
    plot(distfun(X))  # includes evaluation of nncross(what="dist")
  }
  
  #' K functions in disconnected network
  if(ALWAYS) {
    K <- linearK(X)
    lamX <- intensity(X)
    nX <- npoints(X)
    KI <- linearKinhom(X, lambda=rep(lamX, nX))
    P <- linearpcf(X)
    PJ <- linearpcfinhom(X, lambda=rep(lamX, nX))
  }
  Y <- X %mark% factor(rep(1:2, nX)[1:nX])
  if(FULLTEST) {
    Y1 <- split(Y)[[1]]
    Y2 <- split(Y)[[2]]
    KY <- linearKcross(Y)
    PY <- linearpcfcross(Y)
    KYI <- linearKcross.inhom(Y, lambdaI=rep(intensity(Y1), npoints(Y1)),
                              lambdaJ=rep(intensity(Y2), npoints(Y2)))
    PYI <- linearpcfcross.inhom(Y, lambdaI=rep(intensity(Y1), npoints(Y1)),
                                lambdaJ=rep(intensity(Y2), npoints(Y2)))
  }

  #' internal utilities
  if(FULLTEST) {
    K <- ApplyConnected(X, linearK, rule=function(...) list())
  }
})


#
#  tests/envelopes.R
#
#  Test validity of envelope data
#
#  $Revision: 1.29 $  $Date: 2024/01/10 13:45:29 $
#

local({
  








if(FULLTEST) {
  X <- runiflpp(10, simplenet)
  Xr <- X %mark% runif(10)
  Xc <- X %mark% factor(letters[c(1:4,3,2,4:1)])
  X2 <- X %mark% data.frame(height=runif(10), width=runif(10))

  E  <- envelope(X,  linearK, nsim=9)
  Er <- envelope(Xr, linearK, nsim=9)
  Ec <- envelope(Xc, linearK, nsim=9)
  E2 <- envelope(X2, linearK, nsim=9)
  
  Erf <- envelope(Xr, linearK, nsim=9, fix.n=TRUE)
  E2f <- envelope(X2, linearK, nsim=9, fix.n=TRUE)

  Ecf <- envelope(Xc, linearK,      nsim=9, fix.n=TRUE)
  Ecm <- envelope(Xc, linearKcross, nsim=9, fix.n=TRUE, fix.marks=TRUE)

  fut <- lppm(Xc ~ marks)
  EEf <- envelope(fut, linearK,      fix.n=TRUE)
  EEm <- envelope(fut, linearKcross, fix.n=TRUE, fix.marks=TRUE)
}

## close 'local'
})
#
#  tests/func.R
#
#   $Revision: 1.9 $   $Date: 2022/10/23 00:48:40 $
#
#  Tests of 'funxy' infrastructure etc

if(FULLTEST) {
local({
  ## Check the peculiar function-building code in funxy
  W <- square(1)
  f1a <- function(x, y) sqrt(x^2 + y^2)
  F1a <- funxy(f1a, W)
  Y <- runiflpp(5, simplenet)
  b <- F1a(Y)
})
}


#'     tests/hypotests.R
#'     Hypothesis tests
#' 
#'  $Revision: 1.10 $ $Date: 2023/07/17 07:30:48 $

if(FULLTEST) {
local({
  berman.test(spiders, "x")
  berman.test(lppm(spiders ~ x), "y")

})
}
#
#  tests/imageops.R
#
#   $Revision: 1.43 $   $Date: 2023/08/29 01:03:59 $
#



if(FULLTEST) {
  local({
    d <- distmap(cells, dimyx=32)
    ## linear networks
    ee  <- d[simplenet, drop=FALSE]
    eev <- d[simplenet]
  })
}