R/envelope3.R

In spatstat.explore: Exploratory Data Analysis for the 'spatstat' Family

#
#   envelope3.R
#
#   simulation envelopes for pp3 
#
#   $Revision: 1.17 $  $Date: 2026/03/15 23:51:04 $
#

envelope.pp3 <-
  function(Y, fun=K3est, nsim=99, nrank=1, ...,
           funargs=list(), funYargs=funargs,
           simulate=NULL, fix.n=FALSE, fix.marks=FALSE,
           verbose=TRUE, 
           transform=NULL, global=FALSE, ginterval=NULL, use.theory=NULL,
           theoryfun=NULL,
           alternative=c("two.sided", "less", "greater"),
           scale=NULL, clamp=FALSE,
           savefuns=FALSE, savepatterns=FALSE, nsim2=nsim,
           VARIANCE=FALSE, nSD=2,
           Yname=NULL, maxnerr=nsim, rejectNA=FALSE, silent=FALSE,
           do.pwrong=FALSE, envir.simul=NULL) {
  cl <- short.deparse(sys.call())
  if(is.null(Yname)) Yname <- short.deparse(substitute(Y))
  if(is.null(fun)) fun <- K3est

  if("clipdata" %in% names(list(...)))
    stop(paste("The argument", sQuote("clipdata"),
               "is not available for envelope.pp3"))
  
  envir.user <- if(!is.null(envir.simul)) envir.simul else parent.frame()
  envir.here <- sys.frame(sys.nframe())

  #' Data pattern X is argument Y
  X <- Y
  
  if(is.null(simulate)) {
    # ...................................................
    # Realisations of complete spatial randomness or binomial process
    simrecipe <- make.simulrecipe(X, envir=envir.here,
                                  fix.n=fix.n, fix.marks=fix.marks)
  } else {
    # ...................................................
    # Simulations are determined by 'simulate' argument
    # Processing is deferred to envelopeEngine
    simrecipe <- simulate
  }

  envelopeEngine(X=X, fun=fun, simul=simrecipe,
                 nsim=nsim, nrank=nrank, ...,
                 funargs=funargs, funYargs=funYargs,
                 verbose=verbose, clipdata=FALSE,
                 transform=transform,
                 global=global, ginterval=ginterval, use.theory=use.theory,
                 theoryfun=theoryfun,
                 alternative=alternative, scale=scale, clamp=clamp,
                 savefuns=savefuns, savepatterns=savepatterns, nsim2=nsim2,
                 VARIANCE=VARIANCE, nSD=nSD,
                 Yname=Yname,
                 maxnerr=maxnerr, rejectNA=rejectNA, silent=silent,
                 cl=cl,
                 envir.user=envir.user,
                 expected.arg=c("rmax", "nrval"),
                 do.pwrong=do.pwrong)
}

make.simulrecipe.pp3 <- function(object, envir, ..., 
                                 fix.n=FALSE, fix.marks=FALSE) {
  X <- object
  nX <- npoints(X)
  Xbox <- domain(X)
  Xmarx <- marks(X)
  Xintens <- nX/volume(Xbox)
  assign("nX", nX, envir=envir)
  assign("Xbox",    Xbox,    envir=envir)
  assign("Xmarx", Xmarx, envir=envir)
  assign("Xintens", Xintens, envir=envir)

  if(!fix.n && !fix.marks) {
    #' Realisations of complete spatial randomness with lambda = intensity(X)
    simexpr <- if(is.null(Xmarx)) {
      #' unmarked point pattern
      expression(rpoispp3(Xintens, domain=Xbox))
    } else if(is.null(dim(Xmarx))) {
      #' single column of marks
      expression({
        A <- rpoispp3(Xintens, domain=Xbox);
        j <- sample(nX, npoints(A), replace=TRUE);
        A %mark% Xmarx[j]
      })
    } else {
      #' multiple columns of marks
      expression({
        A <- rpoispp3(Xintens, domain=Xbox);
        j <- sample(nX, npoints(A), replace=TRUE);
        A %mark% Xmarx[j, , drop=FALSE]
      })
    }
    # evaluate in 'envir'
    simrecipe <- simulrecipe(type = "csr",
                             expr = simexpr,
                             envir = envir,
                             csr   = TRUE,
                             pois  = TRUE,
                             realisations = "simulated realisations of 3D CSR")
  } else if(fix.marks) {
    # ...................................................
    # Realisations of binomial process
    # with fixed number of points and fixed marks
    # will be generated by runifpoint3
    simexpr <- expression(runifpoint3(nX, domain=Xbox) %mark% Xmarx)
    # simulation constraints (explanatory string)
    constraints <-
      if(is.multitype(X)) "with fixed number of points of each type" else
                          "with fixed number of points and fixed marks"
    rlz <- "simulated realisations of 3D binomial process"
    #' evaluate in THIS environment
    simrecipe <- simulrecipe(type = "csr",
                             expr = simexpr,
                             envir = envir,
                             csr   = TRUE,
                             pois  = TRUE,
                             constraints = constraints,
                             realisations = rlz)
  } else {
    # ...................................................
    # Realisations of binomial process
    # will be generated by runifpoint3
    simexpr <- if(is.null(Xmarx)) {
      ## unmarked
      expression(runifpoint3(nX, domain=Xbox))
    } else if(is.null(dim(Xmarx))) {
      ## single column of marks
      expression({
        A <- runifpoint3(nX, domain = Xbox);
        j <- sample(nX, npoints(A), replace=TRUE);
        A %mark% Xmarx[j]
      })
    } else {
      ## multiple columns of marks
      expression({
        A <- runifpoint3(nX, domain=Xbox);
        j <- sample(nX, npoints(A), replace=TRUE);
        A %mark% Xmarx[j, ,drop=FALSE]
      })
    }
    # evaluate in THIS environment
    rlz <- "simulated realisations of 3D binomial process"
    simrecipe <- simulrecipe(type = "csr",
                             expr = simexpr,
                             envir = envir,
                             csr   = TRUE,
                             pois  = TRUE,
                             constraints = "with fixed number of points",
                             realisations = rlz)
  }
  return(simrecipe)
}