spatstat.random/0000755000176200001440000000000014570061662013403 5ustar liggesusersspatstat.random/NAMESPACE0000644000176200001440000001425714567023173014634 0ustar liggesusers## spatstat.random NAMESPACE file ## ................ Import packages .................. import(stats,utils,methods) import(spatstat.utils,spatstat.data,spatstat.geom) ## import(spatstat.sparse) currently not needed importFrom("grDevices", "xy.coords") ## ................ Load dynamic library .............. ## (native routines are registered in init.c) ## (entry points are symbols with prefix "SR_") useDynLib(spatstat.random, .registration=TRUE, .fixes="SR_") ## ////////// DO NOT EDIT THE FOLLOWING /////////////// ## //////// it is generated automatically ///////////// # .................................................. # Automatically-generated list of documented objects # .................................................. export("as.owin.rmhmodel") export("change.default.expand") export("clusterfield") export("clusterfield.character") export("clusterfield.function") export("clusterkernel") export("clusterkernel.character") export("clusterradius") export("clusterradius.character") export("datagen.rpoisppOnLines") export("datagen.runifpointOnLines") export("datagen.runifpoisppOnLines") export("default.clipwindow") export("default.expand") export("default.rmhcontrol") export("detect.par.format") export("dknn") export("dmixpois") export("domain.rmhmodel") export("dpakes") export("expand.owin") export("expandwinPerfect") export("fakeNeyScot") export("gauss.hermite") export("getRandomFieldsModelGen") export("handle.rshift.args") export("HermiteCoefs") export("indefinteg") export("is.cadlag") export("is.expandable") export("is.expandable.rmhmodel") export("is.poisson") export("is.poisson.rmhmodel") export("is.stationary") export("is.stationary.rmhmodel") export("kraever") export("kraeverRandomFields") export("MultiPair.checkmatrix") export("optimalinflation") export("pknn") export("pmixpois") export("ppakes") export("print.rmhcontrol") export("print.rmhexpand") export("print.rmhInfoList") export("print.rmhmodel") export("print.rmhstart") export("print.summary.rmhexpand") export("qknn") export("qmixpois") export("qpakes") export("quadratresample") export("rags") export("ragsAreaInter") export("ragsMultiHard") export("RandomFieldsSafe") export("rCauchy") export("rCauchyHom") export("rcell") export("rcellnumber") export("rclusterBKBC") export("rDGS") export("rDiggleGratton") export("reach") export("reach.rmhmodel") export("recipEnzpois") export("reheat") export("resolve.vargamma.shape") export("retrieve.param") export("rGaussPoisson") export("rGRFcircembed") export("rGRFexpo") export("rGRFgauss") export("rGRFgencauchy") export("rGRFmatern") export("rGRFstable") export("rHardcore") export("rjitter.psp") export("rknn") export("rlabel") export("rLGCP") export("rMatClust") export("rMatClustHom") export("rMaternI") export("rMaternII") export("rMaternInhibition") export("rmh") export("rmhcontrol") export("rmhcontrol.default") export("rmhcontrol.list") export("rmhcontrol.rmhcontrol") export("rmh.default") export("rmhEngine") export("rmhexpand") export("RmhExpandRule") export("rmhmodel") export("rmhmodel.default") export("rmhmodel.list") export("rmhmodel.rmhmodel") export("rmhResolveControl") export("rmhResolveExpansion") export("rmhResolveTypes") export("rmhsnoop") export("rmhSnoopEnv") export("rmhstart") export("rmhstart.default") export("rmhstart.list") export("rmhstart.rmhstart") export("rmixpois") export("rMosaicField") export("rMosaicSet") export("rmpoint") export("rmpoint.I.allim") export("rmpoispp") export("rNeymanScott") export("rnoise") export("rpakes") export("rPenttinen") export("rpoint") export("rpoint.multi") export("rpoisline") export("rpoislinetess") export("rpoisnonzero") export("rpoispp") export("rpoispp3") export("rpoisppOnLines") export("rpoisppx") export("rPoissonCluster") export("rPoissonClusterEngine") export("rpoistrunc") export("rPSNCP") export("rshift") export("rshift.ppp") export("rshift.psp") export("rshift.splitppp") export("rSSI") export("rstrat") export("rStrauss") export("rStraussHard") export("rtemper") export("rthin") export("rthinclumps") export("rthinEngine") export("rThomas") export("rThomasHom") export("runifdisc") export("runifpoint") export("runifpoint3") export("runifpointOnLines") export("runifpointx") export("runifpoispp") export("runifpoisppOnLines") export("rVarGamma") export("spatstatClusterModelInfo") export("spatstatClusterSimInfo") export("spatstatClusterSimModelMatch") export("spatstatRmhInfo") export("summarise.trend") export("summary.rmhexpand") export("thinjump") export("thinParents") export("update.rmhcontrol") export("update.rmhstart") export("validate.kappa.mu") export("will.expand") export("Window.rmhmodel") # ....... Special cases ........... # ....... End of special cases ... # ......................................... # Automatically generated list of S3 methods # ......................................... S3method("as.owin", "rmhmodel") S3method("clusterfield", "character") S3method("clusterfield", "function") S3method("clusterkernel", "character") S3method("clusterradius", "character") S3method("domain", "rmhmodel") S3method("is.expandable", "rmhmodel") S3method("is.poisson", "rmhmodel") S3method("is.stationary", "rmhmodel") S3method("print", "rmhcontrol") S3method("print", "rmhexpand") S3method("print", "rmhInfoList") S3method("print", "rmhmodel") S3method("print", "rmhstart") S3method("print", "summary.rmhexpand") S3method("reach", "rmhmodel") S3method("rjitter", "psp") S3method("rmhcontrol", "default") S3method("rmhcontrol", "list") S3method("rmhcontrol", "rmhcontrol") S3method("rmh", "default") S3method("rmhmodel", "default") S3method("rmhmodel", "list") S3method("rmhmodel", "rmhmodel") S3method("rmhstart", "default") S3method("rmhstart", "list") S3method("rmhstart", "rmhstart") S3method("rshift", "ppp") S3method("rshift", "psp") S3method("rshift", "splitppp") S3method("summary", "rmhexpand") S3method("update", "rmhcontrol") S3method("update", "rmhstart") S3method("Window", "rmhmodel") # ......................................... # Assignment methods # ......................................... # ......................................... # End of methods # ......................................... spatstat.random/man/0000755000176200001440000000000014372410721014150 5ustar liggesusersspatstat.random/man/rMaternII.Rd0000644000176200001440000000532314243054775016306 0ustar liggesusers\name{rMaternII} \alias{rMaternII} \title{Simulate Matern Model II} \description{ Generate a random point pattern, a simulated realisation of the \Matern Model II inhibition process. } \usage{ rMaternII(kappa, r, win = owin(c(0,1),c(0,1)), stationary=TRUE, ..., nsim=1, drop=TRUE) } \arguments{ \item{kappa}{ Intensity of the Poisson process of proposal points. A single positive number. } \item{r}{ Inhibition distance. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. Alternatively a higher-dimensional box of class \code{"box3"} or \code{"boxx"}. } \item{stationary}{ Logical. Whether to start with a stationary process of proposal points (\code{stationary=TRUE}) or to generate the proposal points only inside the window (\code{stationary=FALSE}). } \item{\dots}{Ignored.} \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Each point pattern is normally an object of class \code{"ppp"}, but may be of class \code{"pp3"} or \code{"ppx"} depending on the window. } \details{ This algorithm generates one or more realisations of \Matern's Model II inhibition process inside the window \code{win}. The process is constructed by first generating a uniform Poisson point process of ``proposal'' points with intensity \code{kappa}. If \code{stationary = TRUE} (the default), the proposal points are generated in a window larger than \code{win} that effectively means the proposals are stationary. If \code{stationary=FALSE} then the proposal points are only generated inside the window \code{win}. Then each proposal point is marked by an ``arrival time'', a number uniformly distributed in \eqn{[0,1]} independently of other variables. A proposal point is deleted if it lies within \code{r} units' distance of another proposal point \emph{that has an earlier arrival time}. Otherwise it is retained. The retained points constitute \Matern's Model II. The difference between \Matern's Model I and II is the italicised statement above. Model II has a higher intensity for the same parameter values. } \seealso{ \code{\link{rpoispp}}, \code{\link{rMatClust}}, \code{\link{rMaternI}} } \examples{ X <- rMaternII(20, 0.05) Y <- rMaternII(20, 0.05, stationary=FALSE) } \author{ \adrian , Ute Hahn, \rolf and \ege } \keyword{spatial} \keyword{datagen} spatstat.random/man/rmpoispp.Rd0000644000176200001440000001741214243054775016327 0ustar liggesusers\name{rmpoispp} \alias{rmpoispp} \title{Generate Multitype Poisson Point Pattern} \description{ Generate a random point pattern, a realisation of the (homogeneous or inhomogeneous) multitype Poisson process. } \usage{ rmpoispp(lambda, lmax=NULL, win, types, \dots, nsim=1, drop=TRUE, warnwin=!missing(win)) } \arguments{ \item{lambda}{ Intensity of the multitype Poisson process. Either a single positive number, a vector, a \code{function(x,y,m, \dots)}, a pixel image, a list of functions \code{function(x,y, \dots)}, or a list of pixel images. } \item{lmax}{ An upper bound for the value of \code{lambda}. May be omitted } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. Ignored if \code{lambda} is a pixel image or list of images. } \item{types}{ All the possible types for the multitype pattern. } \item{\dots}{ Arguments passed to \code{lambda} if it is a function. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{warnwin}{ Logical value specifying whether to issue a warning when \code{win} is ignored. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Each point pattern is multitype (it carries a vector of marks which is a factor). } \details{ This function generates a realisation of the marked Poisson point process with intensity \code{lambda}. Note that the intensity function \eqn{\lambda(x,y,m)}{lambda(x,y,m)} is the average number of points \bold{of type m} per unit area near the location \eqn{(x,y)}. Thus a marked point process with a constant intensity of 10 and three possible types will have an average of 30 points per unit area, with 10 points of each type on average. The intensity function may be specified in any of the following ways. \describe{ \item{single number:}{ If \code{lambda} is a single number, then this algorithm generates a realisation of the uniform marked Poisson process inside the window \code{win} with intensity \code{lambda} for each type. The total intensity of points of all types is \code{lambda * length(types)}. The argument \code{types} must be given and determines the possible types in the multitype pattern. } \item{vector:}{ If \code{lambda} is a numeric vector, then this algorithm generates a realisation of the stationary marked Poisson process inside the window \code{win} with intensity \code{lambda[i]} for points of type \code{types[i]}. The total intensity of points of all types is \code{sum(lambda)}. The argument \code{types} defaults to \code{names(lambda)}, or if that is null, \code{1:length(lambda)}. } \item{function:}{ If \code{lambda} is a function, the process has intensity \code{lambda(x,y,m,\dots)} at spatial location \code{(x,y)} for points of type \code{m}. The function \code{lambda} must work correctly with vectors \code{x}, \code{y} and \code{m}, returning a vector of function values. (Note that \code{m} will be a factor with levels equal to \code{types}.) The value \code{lmax}, if present, must be an upper bound on the values of \code{lambda(x,y,m,\dots)} for all locations \code{(x, y)} inside the window \code{win} and all types \code{m}. The argument \code{types} must be given. } \item{list of functions:}{ If \code{lambda} is a list of functions, the process has intensity \code{lambda[[i]](x,y,\dots)} at spatial location \code{(x,y)} for points of type \code{types[i]}. The function \code{lambda[[i]]} must work correctly with vectors \code{x} and \code{y}, returning a vector of function values. The value \code{lmax}, if given, must be an upper bound on the values of \code{lambda(x,y,\dots)} for all locations \code{(x, y)} inside the window \code{win}. The argument \code{types} defaults to \code{names(lambda)}, or if that is null, \code{1:length(lambda)}. } \item{pixel image:}{ If \code{lambda} is a pixel image object of class \code{"im"} (see \code{\link{im.object}}), the intensity at a location \code{(x,y)} for points of any type is equal to the pixel value of \code{lambda} for the pixel nearest to \code{(x,y)}. The argument \code{win} is ignored; the window of the pixel image is used instead. The argument \code{types} must be given. } \item{list of pixel images:}{ If \code{lambda} is a list of pixel images, then the image \code{lambda[[i]]} determines the intensity of points of type \code{types[i]}. The argument \code{win} is ignored; the window of the pixel image is used instead. The argument \code{types} defaults to \code{names(lambda)}, or if that is null, \code{1:length(lambda)}. } } If \code{lmax} is missing, an approximate upper bound will be calculated. To generate an inhomogeneous Poisson process the algorithm uses ``thinning'': it first generates a uniform Poisson process of intensity \code{lmax} for points of each type \code{m}, then randomly deletes or retains each point independently, with retention probability \eqn{p(x,y,m) = \lambda(x,y,m)/\mbox{lmax}}{p(x,y,m) = lambda(x,y)/lmax}. } \seealso{ \code{\link{rpoispp}} for unmarked Poisson point process; \code{\link{rmpoint}} for a fixed number of random marked points; \code{\link{ppp.object}}, \code{\link{owin.object}}. } \examples{ # uniform bivariate Poisson process with total intensity 100 in unit square pp <- rmpoispp(50, types=c("a","b")) # stationary bivariate Poisson process with intensity A = 30, B = 70 pp <- rmpoispp(c(30,70), types=c("A","B")) pp <- rmpoispp(c(30,70)) # works in any window pp <- rmpoispp(c(30,70), win=letterR, types=c("A","B")) # inhomogeneous lambda(x,y,m) # note argument 'm' is a factor lam <- function(x,y,m) { 50 * (x^2 + y^3) * ifelse(m=="A", 2, 1)} pp <- rmpoispp(lam, win=letterR, types=c("A","B")) # extra arguments lam <- function(x,y,m,scal) { scal * (x^2 + y^3) * ifelse(m=="A", 2, 1)} pp <- rmpoispp(lam, win=letterR, types=c("A","B"), scal=50) # list of functions lambda[[i]](x,y) lams <- list(function(x,y){50 * x^2}, function(x,y){20 * abs(y)}) pp <- rmpoispp(lams, win=letterR, types=c("A","B")) pp <- rmpoispp(lams, win=letterR) # functions with extra arguments lams <- list(function(x,y,scal){5 * scal * x^2}, function(x,y, scal){2 * scal * abs(y)}) pp <- rmpoispp(lams, win=letterR, types=c("A","B"), scal=10) pp <- rmpoispp(lams, win=letterR, scal=10) # florid example lams <- list(function(x,y){ 100*exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } # log quadratic trend , function(x,y){ 100*exp(-0.6*x+0.5*y) } # log linear trend ) X <- rmpoispp(lams, win=unit.square(), types=c("on", "off")) # pixel image Z <- as.im(function(x,y){30 * (x^2 + y^3)}, letterR) pp <- rmpoispp(Z, types=c("A","B")) # list of pixel images ZZ <- list( as.im(function(x,y){20 * (x^2 + y^3)}, letterR), as.im(function(x,y){40 * (x^3 + y^2)}, letterR)) pp <- rmpoispp(ZZ, types=c("A","B")) pp <- rmpoispp(ZZ) # randomising an existing point pattern rmpoispp(intensity(amacrine), win=Window(amacrine)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoistrunc.Rd0000644000176200001440000000527014372411051016650 0ustar liggesusers\name{rpoistrunc} \alias{rpoisnonzero} \alias{rpoistrunc} \title{ Random Values from the Truncated Poisson Distribution } \description{ Generate realisations of a Poisson random variable which are truncated, that is, conditioned to be nonzero, or conditioned to be at least a given number. } \usage{ rpoisnonzero(n, lambda, method=c("harding", "transform"), implem=c("R", "C")) rpoistrunc(n, lambda, minimum = 1, method=c("harding", "transform"), implem=c("R", "C")) } \arguments{ \item{n}{Number of random values to be generated.} \item{lambda}{ Mean value of the un-truncated Poisson distribution. A nonnegative number, or vector of nonnegative numbers. } \item{minimum}{ Minimum permitted value for the random variables. A nonnegative integer, or vector of nonnegative integers. } \item{method}{ Character string (partially matched) specifying the simulation algorithm to be used. See Details. } \item{implem}{ Character string specifying whether to use the implementation in interpreted R code (\code{implem="R"}, the default) or C code (\code{implem="C"}). } } \details{ \code{rpoisnonzero} generates realisations of the Poisson distribution with mean \code{lambda} conditioned on the event that the values are not equal to zero. \code{rpoistrunc} generates realisations of the Poisson distribution with mean \code{lambda} conditioned on the event that the values are greater than or equal to \code{minimum}. The default \code{minimum=1} is equivalent to generating zero-truncated Poisson random variables using \code{rpoisnonzero}. The value \code{minimum=0} is equivalent to generating un-truncated Poisson random variables using \code{\link[stats]{rpois}}. The arguments \code{lambda} and \code{minimum} can be vectors of length \code{n}, specifying different means for the un-truncated Poisson distribution, and different minimum values, for each of the \code{n} random output values. If \code{method="transform"} the simulated values are generated by transforming a uniform random variable using the quantile function of the Poisson distribution. If \code{method="harding"} (the default) the simulated values are generated using an algorithm proposed by E.F. Harding which exploits properties of the Poisson point process. The Harding algorithm seems to be faster. } \value{ An integer vector of length \code{n}. } \author{ \adrian, after ideas of Ted Harding and Peter Dalgaard. } \seealso{ \code{\link[stats]{rpois}} for Poisson random variables. \code{\link{recipEnzpois}} for the reciprocal moment of \code{rpoisnonzero}. } \examples{ rpoisnonzero(10, 0.8) rpoistrunc(10, 1, 2) } \keyword{datagen} spatstat.random/man/rStraussHard.Rd0000644000176200001440000000747214243054775017110 0ustar liggesusers\name{rStraussHard} \alias{rStraussHard} \title{Perfect Simulation of the Strauss-Hardcore Process} \description{ Generate a random pattern of points, a simulated realisation of the Strauss-Hardcore process, using a perfect simulation algorithm. } \usage{ rStraussHard(beta, gamma = 1, R = 0, H = 0, W = owin(), expand=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{beta}{ intensity parameter (a positive number). } \item{gamma}{ interaction parameter (a number between 0 and 1, inclusive). } \item{R}{ interaction radius (a non-negative number). } \item{H}{ hard core distance (a non-negative number smaller than \code{R}). } \item{W}{ window (object of class \code{"owin"}) in which to generate the random pattern. Currently this must be a rectangular window. } \item{expand}{ Logical. If \code{FALSE}, simulation is performed in the window \code{W}, which must be rectangular. If \code{TRUE} (the default), simulation is performed on a larger window, and the result is clipped to the original window \code{W}. Alternatively \code{expand} can be an object of class \code{"rmhexpand"} (see \code{\link[spatstat.random]{rmhexpand}}) determining the expansion method. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function generates a realisation of the Strauss-Hardcore point process in the window \code{W} using a \sQuote{perfect simulation} algorithm. The Strauss-Hardcore process is described in \code{\link[spatstat.model]{StraussHard}}. The simulation algorithm used to generate the point pattern is \sQuote{dominated coupling from the past} as implemented by Berthelsen and \Moller (2002, 2003). This is a \sQuote{perfect simulation} or \sQuote{exact simulation} algorithm, so called because the output of the algorithm is guaranteed to have the correct probability distribution exactly (unlike the Metropolis-Hastings algorithm used in \code{\link[spatstat.random]{rmh}}, whose output is only approximately correct). A limitation of the perfect simulation algorithm is that the interaction parameter \eqn{\gamma}{gamma} must be less than or equal to \eqn{1}. To simulate a Strauss-hardcore process with \eqn{\gamma > 1}{gamma > 1}, use \code{\link[spatstat.random]{rmh}}. There is a tiny chance that the algorithm will run out of space before it has terminated. If this occurs, an error message will be generated. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}). If \code{nsim > 1}, a list of point patterns. } \references{ Berthelsen, K.K. and \Moller, J. (2002) A primer on perfect simulation for spatial point processes. \emph{Bulletin of the Brazilian Mathematical Society} 33, 351-367. Berthelsen, K.K. and \Moller, J. (2003) Likelihood and non-parametric Bayesian MCMC inference for spatial point processes based on perfect simulation and path sampling. \emph{Scandinavian Journal of Statistics} 30, 549-564. \Moller, J. and Waagepetersen, R. (2003). \emph{Statistical Inference and Simulation for Spatial Point Processes.} Chapman and Hall/CRC. } \author{ Kasper Klitgaard Berthelsen and \adrian } \examples{ Z <- rStraussHard(100,0.7,0.05,0.02) Y <- rStraussHard(100,0.7,0.05,0.01, nsim=2) } \seealso{ \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.model]{StraussHard}}. \code{\link[spatstat.random]{rHardcore}}, \code{\link[spatstat.random]{rStrauss}}, \code{\link[spatstat.random]{rDiggleGratton}}, \code{\link[spatstat.random]{rDGS}}, \code{\link[spatstat.random]{rPenttinen}}. } \keyword{spatial} \keyword{datagen} spatstat.random/man/recipEnzpois.Rd0000644000176200001440000000401314475562447017130 0ustar liggesusers\name{recipEnzpois} \alias{recipEnzpois} \title{ First Reciprocal Moment of the Truncated Poisson Distribution } \description{ Computes the first reciprocal moment (first negative moment) of the truncated Poisson distribution (the Poisson distribution conditioned to have a nonzero value). } \usage{ recipEnzpois(mu, exact=TRUE) } \arguments{ \item{mu}{ The mean of the original Poisson distribution. A single positive numeric value, or a vector of positive numbers. } \item{exact}{ Logical value specifying whether to use the exact analytic formula if possible. } } \details{ This function calculates the expected value of \eqn{1/N} given \eqn{N > 0}, where \eqn{N} is a Poisson random variable with mean \eqn{\mu}. If the library \pkg{gsl} is loaded, and if \code{exact=TRUE} (the default), then the calculation uses the exact analytic formula \deqn{ \nu = \frac{e^{-\mu}}{1- e^{-\mu}} \left( Ei(\mu) - \log \mu - \gamma \right) }{ nu = (exp(-mu)/(1 - exp(-mu))) (Ei(mu) - log(mu) - gamma) } (see e.g. Grab and Savage, 1954) where \eqn{\nu} is the desired reciprocal moment, and \deqn{ Ei(x) = \int_{-\infty}^x t e^{-t} dt }{ Ei(x) = int_[-infty]^x t * exp(-t) dt } is the first exponential integral, and \eqn{\gamma \approx 0.577}{\gamma ~= 0.577} is the Euler-Mascheroni constant. If \pkg{gsl} is not loaded, or if \code{exact=FALSE} is specified, the value is computed approximately (and more slowly) by summing over the possible values of \eqn{N} up to a finite limit. } \value{ A single numerical value or a numeric vector. } \author{ \adrian. } \seealso{ \code{\link{rpoisnonzero}} } \examples{ if(require(gsl)) { v <- recipEnzpois(10) print(v) } recipEnzpois(10, exact=FALSE) } \references{ Grab, E.L. and Savage, I.R. (1954) Tables of the expected value of 1/X for positive Bernoulli and Poisson variables. \emph{Journal of the American Statistical Association} \bold{49}, 169--177. } \keyword{math} \keyword{distribution} spatstat.random/man/dmixpois.Rd0000644000176200001440000000512314243054774016305 0ustar liggesusers\name{dmixpois} \alias{dmixpois} \alias{pmixpois} \alias{qmixpois} \alias{rmixpois} \title{ Mixed Poisson Distribution } \description{ Density, distribution function, quantile function and random generation for a mixture of Poisson distributions. } \usage{ dmixpois(x, mu, sd, invlink = exp, GHorder = 5) pmixpois(q, mu, sd, invlink = exp, lower.tail = TRUE, GHorder = 5) qmixpois(p, mu, sd, invlink = exp, lower.tail = TRUE, GHorder = 5) rmixpois(n, mu, sd, invlink = exp) } \arguments{ \item{x}{vector of (non-negative integer) quantiles.} \item{q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{number of random values to return.} \item{mu}{ Mean of the linear predictor. A single numeric value. } \item{sd}{ Standard deviation of the linear predictor. A single numeric value. } \item{invlink}{ Inverse link function. A function in the \R language, used to transform the linear predictor into the parameter \code{lambda} of the Poisson distribution. } \item{lower.tail}{ Logical. If \code{TRUE} (the default), probabilities are \eqn{P[X \le x]}, otherwise, \eqn{P[X > x]}. } \item{GHorder}{ Number of quadrature points in the Gauss-Hermite quadrature approximation. A small positive integer. } } \details{ These functions are analogous to \code{\link{dpois}} \code{\link{ppois}}, \code{\link{qpois}} and \code{\link{rpois}} except that they apply to a mixture of Poisson distributions. In effect, the Poisson mean parameter \code{lambda} is randomised by setting \code{lambda = invlink(Z)} where \code{Z} has a Gaussian \eqn{N(\mu,\sigma^2)}{N(\mu, \sigma^2)} distribution. The default is \code{invlink=exp} which means that \code{lambda} is lognormal. Set \code{invlink=I} to assume that \code{lambda} is approximately Normal. For \code{dmixpois}, \code{pmixpois} and \code{qmixpois}, the probability distribution is approximated using Gauss-Hermite quadrature. For \code{rmixpois}, the deviates are simulated exactly. } \value{ Numeric vector: \code{dmixpois} gives probability masses, \code{ppois} gives cumulative probabilities, \code{qpois} gives (non-negative integer) quantiles, and \code{rpois} generates (non-negative integer) random deviates. } \seealso{ \code{\link{dpois}}, \code{\link{gauss.hermite}}. } \examples{ dmixpois(7, 10, 1, invlink = I) dpois(7, 10) pmixpois(7, log(10), 0.2) ppois(7, 10) qmixpois(0.95, log(10), 0.2) qpois(0.95, 10) x <- rmixpois(100, log(10), log(1.2)) mean(x) var(x) } \author{\adrian , \rolf and \ege } \keyword{distribution} spatstat.random/man/reach.Rd0000644000176200001440000000666214243054775015545 0ustar liggesusers\name{reach} \alias{reach} \alias{reach.rmhmodel} \title{Interaction Distance of a Point Process Model} \description{ Computes the interaction distance of a point process model. } \usage{ reach(x, \dots) \method{reach}{rmhmodel}(x, \dots) } \arguments{ \item{x}{Either a fitted point process model (object of class \code{"ppm"}), an interpoint interaction (object of class \code{"interact"}), a fitted interpoint interaction (object of class \code{"fii"}) or a point process model for simulation (object of class \code{"rmhmodel"}). } \item{\dots}{ Other arguments are ignored. } } \value{ The interaction distance, or \code{NA} if this cannot be computed from the information given. } \details{ The function \code{reach} computes the `interaction distance' or `interaction range' of a point process model. The definition of the interaction distance depends on the type of point process model. This help page explains the interaction distance for a Gibbs point process. For other kinds of models, see \code{\link[spatstat.model]{reach.kppm}} and \code{\link[spatstat.model]{reach.dppm}}. For a Gibbs point process model, the interaction distance is the shortest distance \eqn{D} such that any two points in the process which are separated by a distance greater than \eqn{D} do not interact with each other. For example, the interaction range of a Strauss process (see \code{\link[spatstat.model]{Strauss}} or \code{\link{rStrauss}}) with parameters \eqn{\beta,\gamma,r}{beta,gamma,r} is equal to \eqn{r}, unless \eqn{\gamma=1}{gamma=1} in which case the model is Poisson and the interaction range is \eqn{0}. The interaction range of a Poisson process is zero. The interaction range of the Ord threshold process (see \code{\link[spatstat.model]{OrdThresh}}) is infinite, since two points \emph{may} interact at any distance apart. The function \code{reach} is generic, with methods for the case where \code{x} is \itemize{ \item a fitted point process model (object of class \code{"ppm"}, usually obtained from the model-fitting function \code{\link[spatstat.model]{ppm}}); \item an interpoint interaction structure (object of class \code{"interact"}) \item a fitted interpoint interaction (object of class \code{"fii"}) \item a point process model for simulation (object of class \code{"rmhmodel"}), usually obtained from \code{\link[spatstat.random]{rmhmodel}}. } } \section{Other types of models}{ Methods for \code{reach} are also defined for point process models of class \code{"kppm"} and \code{"dppm"}. Their technical definition is different from this one. See \code{\link[spatstat.model]{reach.kppm}} and \code{\link[spatstat.model]{reach.dppm}}. } \seealso{ \code{\link[spatstat.model]{reach.ppm}} \code{\link{rmhmodel}} See \code{\link[spatstat.model]{reach.kppm}} and \code{\link[spatstat.model]{reach.dppm}} for other types of point process models. } \examples{ reach(rmhmodel(cif='poisson', par=list(beta=100))) # returns 0 reach(rmhmodel(cif='strauss', par=list(beta=100, gamma=0.1, r=7))) # returns 7 reach(rmhmodel(cif='sftcr', par=list(beta=100, sigma=1, kappa=0.7))) # returns Inf reach(rmhmodel(cif='multihard', par=list(beta=c(10,10), hradii=matrix(c(1,3,3,1),2,2)))) # returns 3 } \author{ \adrian and \rolf } \keyword{spatial} \keyword{models} spatstat.random/man/rags.Rd0000644000176200001440000000347614243054774015416 0ustar liggesusers\name{rags} \alias{rags} \title{ Alternating Gibbs Sampler for Multitype Point Processes } \description{ Simulate a realisation of a point process model using the alternating Gibbs sampler. } \usage{ rags(model, \dots, ncycles = 100) } \arguments{ \item{model}{ Data specifying some kind of point process model. } \item{\dots}{ Additional arguments passed to other code. } \item{ncycles}{ Number of cycles of the alternating Gibbs sampler that should be performed. } } \details{ The Alternating Gibbs Sampler for a multitype point process is an iterative simulation procedure. Each step of the sampler updates the pattern of points of a particular type \code{i}, by drawing a realisation from the conditional distribution of points of type \code{i} given the points of all other types. Successive steps of the sampler update the points of type 1, then type 2, type 3, and so on. This is an experimental implementation which currently works only for multitype hard core processes (see \code{\link[spatstat.model]{MultiHard}}) in which there is no interaction between points of the same type. The argument \code{model} should be an object describing a point process model. At the moment, the only permitted format for \code{model} is of the form \code{list(beta, hradii)} where \code{beta} gives the first order trend and \code{hradii} is the matrix of interaction radii. See \code{\link[spatstat.random]{ragsMultiHard}} for full details. } \value{ A point pattern (object of class \code{"ppp"}). } \author{ \adrian } \seealso{ \code{\link[spatstat.random]{ragsMultiHard}}, \code{\link[spatstat.random]{ragsAreaInter}} } \examples{ mo <- list(beta=c(30, 20), hradii = 0.05 * matrix(c(0,1,1,0), 2, 2)) rags(mo, ncycles=10) } \keyword{spatial} \keyword{datagen} spatstat.random/man/rshift.splitppp.Rd0000644000176200001440000000477314252332033017617 0ustar liggesusers\name{rshift.splitppp} \alias{rshift.splitppp} \title{Randomly Shift a List of Point Patterns} \description{ Randomly shifts each point pattern in a list of point patterns. } \usage{ \method{rshift}{splitppp}(X, \dots, which=seq_along(X), nsim=1, drop=TRUE) } \arguments{ \item{X}{ An object of class \code{"splitppp"}. Basically a list of point patterns. } \item{\dots}{ Parameters controlling the generation of the random shift vector and the handling of edge effects. See \code{\link{rshift.ppp}}. } \item{which}{ Optional. Identifies which patterns will be shifted, while other patterns are not shifted. Any valid subset index for \code{X}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a split point pattern object, rather than a list containing the split point pattern. } } \value{ Another object of class \code{"splitppp"}, or a list of such objects. } \details{ This operation applies a random shift to each of the point patterns in the list \code{X}. The function \code{\link{rshift}} is generic. This function \code{rshift.splitppp} is the method for objects of class \code{"splitppp"}, which are essentially lists of point patterns, created by the function \code{\link{split.ppp}}. By default, every pattern in the list \code{X} will be shifted. The argument \code{which} indicates that only some of the patterns should be shifted, while other groups should be left unchanged. \code{which} can be any valid subset index for \code{X}. Each point pattern in the list \code{X} (or each pattern in \code{X[which]}) is shifted by a random displacement vector. The shifting is performed by \code{\link{rshift.ppp}}. See the help page for \code{\link{rshift.ppp}} for details of the other arguments. If \code{nsim > 1}, then the simulation procedure is performed \code{nsim} times; the result is a list of split point patterns. } \seealso{ \code{\link{rshift}}, \code{\link{rshift.ppp}} } \examples{ Y <- split(amacrine) # random toroidal shift # shift "on" and "off" points separately X <- rshift(Y) # shift "on" points and leave "off" points fixed X <- rshift(Y, which="on") # maximum displacement distance 0.1 units X <- rshift(Y, radius=0.1) # shift with erosion X <- rshift(Y, radius=0.1, edge="erode") } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/gauss.hermite.Rd0000644000176200001440000000322214243054774017225 0ustar liggesusers\name{gauss.hermite} \alias{gauss.hermite} \title{ Gauss-Hermite Quadrature Approximation to Expectation for Normal Distribution } \description{ Calculates an approximation to the expected value of any function of a normally-distributed random variable, using Gauss-Hermite quadrature. } \usage{ gauss.hermite(f, mu = 0, sd = 1, ..., order = 5) } \arguments{ \item{f}{ The function whose moment should be approximated. } \item{mu}{ Mean of the normal distribution. } \item{sd}{ Standard deviation of the normal distribution. } \item{\dots}{ Additional arguments passed to \code{f}. } \item{order}{ Number of quadrature points in the Gauss-Hermite quadrature approximation. A small positive integer. } } \details{ This algorithm calculates the approximate expected value of \code{f(Z)} when \code{Z} is a normally-distributed random variable with mean \code{mu} and standard deviation \code{sd}. The expected value is an integral with respect to the Gaussian density; this integral is approximated using Gauss-Hermite quadrature. The argument \code{f} should be a function in the \R language whose first argument is the variable \code{Z}. Additional arguments may be passed through \code{\dots}. The value returned by \code{f} may be a single numeric value, a vector, or a matrix. The values returned by \code{f} for different values of \code{Z} must have compatible dimensions. The result is a weighted average of several values of \code{f}. } \value{ Numeric value, vector or matrix. } \author{\adrian , \rolf and \ege. } \examples{ gauss.hermite(function(x) x^2, 3, 1) } \keyword{math} spatstat.random/man/rclusterBKBC.Rd0000644000176200001440000002347214514616745016750 0ustar liggesusers\name{rclusterBKBC} \alias{rclusterBKBC} \title{ Simulate Cluster Process using Brix-Kendall Algorithm or Modifications } \description{ Generates simulated realisations of a stationary Neyman-Scott cluster point process, using the Brix-Kendall (2002) algorithm or various modifications proposed by Baddeley and Chang (2023). For advanced research use. } \usage{ rclusterBKBC(clusters="Thomas", kappa, mu, scale, \dots, W = unit.square(), nsim = 1, drop = TRUE, best = FALSE, external = c("BK", "superBK", "border"), internal = c("dominating", "naive"), inflate = 1, psmall = 1e-04, use.inverse=TRUE, use.special=TRUE, integralmethod=c("quadrature", "trapezoid"), verbose = TRUE, warn=TRUE) } \arguments{ \item{clusters}{ Character string (partially matched) specifying the cluster process. Current options include \code{"Thomas"}, \code{"MatClust"}, \code{"Cauchy"} and \code{"VarGamma"}. } \item{kappa}{ Intensity of the parent process. A nonnegative number. } \item{mu}{ Mean number of offspring per parent. A nonnegative number. } \item{scale}{ Cluster scale. Interpretation depends on the model. } \item{\dots}{ Additional arguments controlling the shape of the cluster kernel, if any. } \item{W}{ Window in which the simulation should be generated. An object of class \code{"owin"}. } \item{nsim}{ The number of simulated point patterns to be generated. A positive integer. } \item{drop}{ Logical value. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{best}{ Logical value. If \code{best=TRUE}, the code will choose the fastest algorithm. If \code{best=FALSE} (the default), the algorithm will be specified by the other arguments \code{external} and \code{internal}. See Details. } \item{external}{ Algorithm to be used to generate parent points which lie outside the bounding window. See Details. } \item{internal}{ Algorithm to be used to generate parent points which lie inside the bounding window. See Details. } \item{inflate}{ Numerical value determining the position of the bounding window. See Details. } \item{psmall}{ Threshold of small probability for use in the algorithm. } \item{use.inverse}{ Logical value specifying whether to compute the inverse function analytically, if possible (\code{use.inverse=TRUE}, the default) or by numerical root-finding (\code{use.inverse=FALSE}). This is mainly for checking validity of code. } \item{use.special}{ Logical value specifying whether to use efficient special code (if available) to generate the simulations (\code{use.special=TRUE}, the default) or to use generic code (\code{use.special=FALSE}). This is mainly for checking validity of code. } \item{integralmethod}{ Character string (partially matched) specifying how to perform numerical computation of integrals when required. This argument is passed to \code{\link[spatstat.random]{indefinteg}}. The default \code{integralmethod="quadrature"} is accurate but can be slow. Faster, but possibly less accurate, integration can be performed by setting \code{integralmethod="trapezoid"}. } \item{verbose}{ Logical value specifying whether to print detailed information about the simulation algorithm during execution. } \item{warn}{ Logical value specifying whether to issue a warning if the number of random proposal points is very large. } } \details{ This function is intended for advanced research use. It implements the algorithm of Brix and Kendall (2002) for generating simulated realisations of a stationary Neyman-Scott process, and various modifications of this algorithm proposed in Baddeley and Chang (2023). It is an alternative to \code{\link[spatstat.random]{rNeymanScott}}. The function supports the following models: \itemize{ \item \code{clusters="Thomas"}: the (modified) Thomas cluster process which can also be simulated by \code{\link[spatstat.random]{rThomas}}. \item \code{clusters="MatClust"}: the \Matern cluster process which can also be simulated by \code{\link[spatstat.random]{rMatClust}}. \item \code{clusters="Cauchy"}: the Cauchy cluster process which can also be simulated by \code{\link[spatstat.random]{rCauchy}}. \item \code{clusters="VarGamma"}: the variance-gamma cluster process which can also be simulated by \code{\link[spatstat.random]{rVarGamma}}. \item any other Poisson cluster process models that may be recognised by \code{\link[spatstat.model]{kppm}}. } By default, the code executes the original Brix-Kendall algorithm described in Sections 2.3 and 3.1 of Brix and Kendall (2002). Modifications of this algorithm, proposed in Baddeley and Chang (2023), can be selected using the arguments \code{external} and \code{internal}, or \code{best}. If \code{best=TRUE}, the code will choose the algorithm that would run fastest with the given parameters. If \code{best=FALSE} (the default), the choice of algorithm is determined by the arguments \code{external} and \code{internal}. First the window \code{W} is enclosed in a disc \code{D} and Monte Carlo proposal densities are defined with reference to \code{D} as described in Brix and Kendall (2002). Then \code{D} is inflated by the scale factor \code{inflate} to produce a larger disc \code{E} (by default \code{inflate=1} implying \code{E=D}). Then the parent points of the clusters are generated, possibly using different mechanisms inside and outside \code{E}. The argument \code{external} determines the algorithm for generating parent points outside \code{E}. \itemize{ \item If \code{external="BK"} (the default), proposed parents outside \code{E} will be generated from a dominating point process as described in Section 3.1 of Brix and Kendall (2002). These points will be thinned to obtain the correct intensity of parent points. For each accepted parent, offspring points are generated inside \code{D}, subject to the condition that the parent has at least one offspring inside \code{D}. Offspring points are subsequently clipped to the true window \code{W}. \item If \code{external="superBK"}, proposed parents will initially be generated from a process that dominates the dominating point process as described in Baddeley and Chang (2023). These proposals will then be thinned to obtain the correct intensity of the dominating process, then thinned again to obtain the correct intensity of parent points. This procedure reduces computation time when \code{scale} is large. For each accepted parent, offspring points are generated inside \code{D}, subject to the condition that the parent has at least one offspring inside \code{D}. Offspring points are subsequently clipped to the true window \code{W}. \item If \code{external="border"} then proposed parents will be generated with uniform intensity in a border region surrounding the disc \code{D}. For each proposed parent, offspring points are generated in the entire plane according to the cluster offspring distribution, without any restriction. Offspring points are subsequently clipped to the true window \code{W}. This is the technique currently used in \code{\link[spatstat.random]{rNeymanScott}}. } The argument \code{internal} determines the algorithm for generating proposed parent points inside \code{E}. \itemize{ \item If \code{internal="dominating"}, parent points in \code{E} are generated according to the dominating point process described in Sections 2.3 and 3.1 of Brix and Kendall (2002), and then thinned to obtain the correct intensity of parent points. For each accepted parent, offspring points are generated inside \code{D}, subject to the condition that the parent has at least one offspring inside \code{D}. Offspring points are subsequently clipped to the true window \code{W}. \item If \code{internal="naive"}, parent points in \code{E} are generated with uniform intensity inside \code{E} and are not thinned. For each proposed parent, offspring points are generated in the entire plane according to the cluster offspring distribution, without any restriction. Offspring points are subsequently clipped to the true window \code{W}. This is the technique currently used in \code{\link[spatstat.random]{rNeymanScott}}. } If \code{warn=TRUE}, then a warning will be issued if the number of random proposal points (proposed parents and proposed offspring) is very large. The threshold is \code{\link{spatstat.options}("huge.npoints")}. This warning has no consequences, but it helps to trap a number of common problems. } \value{ A point pattern, or a list of point patterns. If \code{nsim=1} and \code{drop=TRUE}, the result is a point pattern (an object of class \code{"ppp"}). Otherwise, the result is a list of \code{nsim} point patterns, and also belongs to the class \code{"solist"}. } \author{ \adrian and \yamei. } \references{ \baddchangclustersim Brix, A. and Kendall, W.S. (2002) Simulation of cluster point processes without edge effects. \emph{Advances in Applied Probability} \bold{34}, 267--280. } \seealso{ \code{\link[spatstat.random]{rNeymanScott}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rThomas}}, \code{\link[spatstat.random]{rCauchy}}, \code{\link[spatstat.random]{rVarGamma}} } \examples{ Y <- rclusterBKBC("Thomas", 10,5,0.2) Y Z <- rclusterBKBC("VarGamma", 10,5,0.2, nu=-1/4, internal="naive", external="super", verbose=FALSE) } \keyword{datagen} \keyword{spatial} spatstat.random/man/rthinclumps.Rd0000644000176200001440000000401714243054775017023 0ustar liggesusers\name{rthinclumps} \alias{rthinclumps} \title{Random Thinning of Clumps} \description{ Finds the topologically-connected clumps of a spatial region and randomly deletes some of the clumps. } \usage{ rthinclumps(W, p, \dots) } \arguments{ \item{W}{ Window (object of class \code{"owin"} or pixel image (object of class \code{"im"}). } \item{p}{ Probability of \emph{retaining} each clump. A single number between 0 and 1. } \item{\dots}{ Additional arguments passed to \code{\link{connected.im}} or \code{\link{connected.owin}} to determine the connected clumps. } } \details{ The argument \code{W} specifies a region of space, typically consisting of several clumps that are not connected to each other. The algorithm randomly deletes or retains each clump. The fate of each clump is independent of other clumps. If \code{W} is a spatial window (class \code{"owin"}) then it will be divided into clumps using \code{\link{connected.owin}}. Each clump will either be retained (with probability \code{p}) or deleted in its entirety (with probability \code{1-p}). If \code{W} is a pixel image (class \code{"im"}) then its domain will be divided into clumps using \code{\link{connected.im}}. The default behaviour depends on the type of pixel values. If the pixel values are logical, then the spatial region will be taken to consist of all pixels whose value is \code{TRUE}. Otherwise, the spatial region is taken to consist of all pixels whose value is defined (i.e. not equal to \code{NA}). This behaviour can be changed using the argument \code{background} passed to \code{\link{connected.im}}. The result is a window comprising all the clumps that were retained. } \value{ Window (object of class \code{"owin"}). } \author{ \adrian. } \seealso{ \code{\link{rthin}} for thinning other kinds of objects. } \examples{ A <- (distmap(cells) < 0.06) opa <- par(mfrow=c(1,2)) plot(A) plot(rthinclumps(A, 0.5)) par(opa) } \keyword{spatial} \keyword{datagen} \keyword{manip} spatstat.random/man/rPenttinen.Rd0000644000176200001440000001036714243054775016606 0ustar liggesusers\name{rPenttinen} \alias{rPenttinen} \title{Perfect Simulation of the Penttinen Process} \description{ Generate a random pattern of points, a simulated realisation of the Penttinen process, using a perfect simulation algorithm. } \usage{ rPenttinen(beta, gamma=1, R, W = owin(), expand=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{beta}{ intensity parameter (a positive number). } \item{gamma}{ Interaction strength parameter (a number between 0 and 1). } \item{R}{ disc radius (a non-negative number). } \item{W}{ window (object of class \code{"owin"}) in which to generate the random pattern. } \item{expand}{ Logical. If \code{FALSE}, simulation is performed in the window \code{W}, which must be rectangular. If \code{TRUE} (the default), simulation is performed on a larger window, and the result is clipped to the original window \code{W}. Alternatively \code{expand} can be an object of class \code{"rmhexpand"} (see \code{\link[spatstat.random]{rmhexpand}}) determining the expansion method. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function generates a realisation of the Penttinen point process in the window \code{W} using a \sQuote{perfect simulation} algorithm. Penttinen (1984, Example 2.1, page 18), citing Cormack (1979), described the pairwise interaction point process with interaction factor \deqn{ h(d) = e^{\theta A(d)} = \gamma^{A(d)} }{ h(d) = exp(theta * A(d)) = gamma^(A(d)) } between each pair of points separated by a distance $d$. Here \eqn{A(d)} is the area of intersection between two discs of radius \eqn{R} separated by a distance \eqn{d}, normalised so that \eqn{A(0) = 1}. The simulation algorithm used to generate the point pattern is \sQuote{dominated coupling from the past} as implemented by Berthelsen and \Moller (2002, 2003). This is a \sQuote{perfect simulation} or \sQuote{exact simulation} algorithm, so called because the output of the algorithm is guaranteed to have the correct probability distribution exactly (unlike the Metropolis-Hastings algorithm used in \code{\link[spatstat.random]{rmh}}, whose output is only approximately correct). There is a tiny chance that the algorithm will run out of space before it has terminated. If this occurs, an error message will be generated. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}). If \code{nsim > 1}, a list of point patterns. } \references{ Berthelsen, K.K. and \Moller, J. (2002) A primer on perfect simulation for spatial point processes. \emph{Bulletin of the Brazilian Mathematical Society} 33, 351-367. Berthelsen, K.K. and \Moller, J. (2003) Likelihood and non-parametric Bayesian MCMC inference for spatial point processes based on perfect simulation and path sampling. \emph{Scandinavian Journal of Statistics} 30, 549-564. Cormack, R.M. (1979) Spatial aspects of competition between individuals. Pages 151--212 in \emph{Spatial and Temporal Analysis in Ecology}, eds. R.M. Cormack and J.K. Ord, International Co-operative Publishing House, Fairland, MD, USA. \Moller, J. and Waagepetersen, R. (2003). \emph{Statistical Inference and Simulation for Spatial Point Processes.} Chapman and Hall/CRC. Penttinen, A. (1984) \emph{Modelling Interaction in Spatial Point Patterns: Parameter Estimation by the Maximum Likelihood Method.} \Jyvaskyla Studies in Computer Science, Economics and Statistics \bold{7}, University of \Jyvaskyla, Finland. } \author{ \adrian, based on original code for the Strauss process by Kasper Klitgaard Berthelsen. } \examples{ X <- rPenttinen(50, 0.5, 0.02) Z <- rPenttinen(50, 0.5, 0.01, nsim=2) } \seealso{ \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.random]{rStrauss}}, \code{\link[spatstat.random]{rHardcore}}, \code{\link[spatstat.random]{rStraussHard}}, \code{\link[spatstat.random]{rDiggleGratton}}, \code{\link[spatstat.random]{rDGS}}. \code{\link[spatstat.model]{Penttinen}}. } \keyword{spatial} \keyword{datagen} spatstat.random/man/Window.rmhmodel.Rd0000644000176200001440000000164114426632311017517 0ustar liggesusers\name{Window.rmhmodel} \alias{Window.rmhmodel} \title{Extract Window of Spatial Object} \description{ Given a spatial object (such as a point pattern or pixel image) in two dimensions, these functions extract the window in which the object is defined. } \usage{ \method{Window}{rmhmodel}(X, \dots) } \arguments{ \item{X}{A spatial object.} \item{\dots}{Ignored.} } \value{ An object of class \code{"owin"} (see \code{\link{owin.object}}) specifying an observation window. } \details{ These are methods for the generic function \code{\link{Window}} which extract the spatial window in which the object \code{X} is defined. } \seealso{ \code{\link{Window}}, \code{\link{Window.ppp}}, \code{\link{Window.psp}}. \code{\link{owin.object}} } \examples{ A <- rmhmodel(cif='poisson', par=list(beta=10), w=square(2)) Window(A) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.random/man/rmhmodel.Rd0000644000176200001440000000625214243054775016265 0ustar liggesusers\name{rmhmodel} \alias{rmhmodel} \title{Define Point Process Model for Metropolis-Hastings Simulation.} \description{ Builds a description of a point process model for use in simulating the model by the Metropolis-Hastings algorithm. } \usage{ rmhmodel(...) } \arguments{ \item{\dots}{Arguments specifying the point process model in some format. } } \value{ An object of class \code{"rmhmodel"}, which is essentially a list of parameter values for the model. There is a \code{print} method for this class, which prints a sensible description of the model chosen. } \details{ Simulated realisations of many point process models can be generated using the Metropolis-Hastings algorithm \code{\link{rmh}}. The algorithm requires the model to be specified in a particular format: an object of class \code{"rmhmodel"}. The function \code{\link{rmhmodel}} takes a description of a point process model in some other format, and converts it into an object of class \code{"rmhmodel"}. It also checks that the parameters of the model are valid. The function \code{\link{rmhmodel}} is generic, with methods for \describe{ \item{fitted point process models:}{ an object of class \code{"ppm"}, obtained by a call to the model-fitting function \code{\link[spatstat.model]{ppm}}. See \code{\link[spatstat.model]{rmhmodel.ppm}}. } \item{lists:}{ a list of parameter values in a certain format. See \code{\link{rmhmodel.list}}. } \item{default:}{ parameter values specified as separate arguments to \code{\dots}. See \code{\link{rmhmodel.default}}. } } } \references{ Diggle, P. J. (2003) \emph{Statistical Analysis of Spatial Point Patterns} (2nd ed.) Arnold, London. Diggle, P.J. and Gratton, R.J. (1984) Monte Carlo methods of inference for implicit statistical models. \emph{Journal of the Royal Statistical Society, series B} \bold{46}, 193 -- 212. Diggle, P.J., Gates, D.J., and Stibbard, A. (1987) A nonparametric estimator for pairwise-interaction point processes. Biometrika \bold{74}, 763 -- 770. \emph{Scandinavian Journal of Statistics} \bold{21}, 359--373. Geyer, C.J. (1999) Likelihood Inference for Spatial Point Processes. Chapter 3 in O.E. Barndorff-Nielsen, W.S. Kendall and M.N.M. Van Lieshout (eds) \emph{Stochastic Geometry: Likelihood and Computation}, Chapman and Hall / CRC, Monographs on Statistics and Applied Probability, number 80. Pages 79--140. } \seealso{ \code{\link[spatstat.model]{rmhmodel.ppm}}, \code{\link{rmhmodel.default}}, \code{\link{rmhmodel.list}}, \code{\link{rmh}}, \code{\link{rmhcontrol}}, \code{\link{rmhstart}}, \code{\link[spatstat.model]{ppm}}, \code{\link[spatstat.model]{Strauss}}, \code{\link[spatstat.model]{Softcore}}, \code{\link[spatstat.model]{StraussHard}}, \code{\link[spatstat.model]{Triplets}}, \code{\link[spatstat.model]{MultiStrauss}}, \code{\link[spatstat.model]{MultiStraussHard}}, \code{\link[spatstat.model]{DiggleGratton}}, \code{\link[spatstat.model]{PairPiece}} \code{\link[spatstat.model]{Penttinen}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rPSNCP.Rd0000644000176200001440000001447414531532360015517 0ustar liggesusers\name{rPSNCP} \alias{rPSNCP} \title{Simulate Product Shot-noise Cox Process} \description{ Generate a random multitype point pattern, a realisation of the product shot-noise Cox process. } \usage{ rPSNCP(lambda=rep(100, 4), kappa=rep(25, 4), omega=rep(0.03, 4), alpha=matrix(runif(16, -1, 3), nrow=4, ncol=4), kernels=NULL, nu.ker=NULL, win=owin(), nsim=1, drop=TRUE, \dots, cnames=NULL, epsth=0.001) % , mc.cores=1L } \arguments{ \item{lambda}{ List of intensities of component processes. Either a numeric vector determining the constant (homogeneous) intensities or a list of pixel images (objects of class \code{"im"}) determining the (inhomogeneous) intensity functions of component processes. The length of \code{lambda} determines the number of component processes. } \item{kappa}{ Numeric vector of intensities of the Poisson process of cluster centres for component processes. Must have the same size as \code{lambda}. } \item{omega}{ Numeric vector of bandwidths of cluster dispersal kernels for component processes. Must have the same size as \code{lambda} and \code{kappa}. } \item{alpha}{ Matrix of interaction parameters. Square numeric matrix with the same number of rows and columns as the length of \code{lambda}, \code{kappa} and \code{omega}. All entries of \code{alpha} must be greater than -1. } \item{kernels}{ Vector of character string determining the cluster dispersal kernels of component processes. Implemented kernels are Gaussian kernel (\code{"Thomas"}) with bandwidth \code{omega}, Variance-Gamma (Bessel) kernel (\code{"VarGamma"}) with bandwidth \code{omega} and shape parameter \code{nu.ker} and Cauchy kernel (\code{"Cauchy"}) with bandwidth \code{omega}. Must have the same length as \code{lambda}, \code{kappa} and \code{omega}. } \item{nu.ker}{ Numeric vector of bandwidths of shape parameters for Variance-Gamma kernels. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"}. } \item{nsim}{Number of simulated realisations to be generated.} \item{cnames}{ Optional vector of character strings giving the names of the component processes. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel array geometry. See \code{\link[spatstat.geom]{as.mask}}. } \item{epsth}{ Numerical threshold to determine the maximum interaction range for cluster kernels. % See Details. % NO DETAILS ARE GIVEN! } \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } % \item{mc.cores}{ % Integer value indicating the number of cores for parallel computing using % \code{"mclapply"} function in the \pkg{parallel} package. % } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Each point pattern is multitype (it carries a vector of marks which is a factor). } \details{ This function generates a realisation of a product shot-noise Cox process (PSNCP). This is a multitype (multivariate) Cox point process in which each element of the multivariate random intensity \eqn{\Lambda(u)} of the process is obtained by \deqn{ \Lambda_i(u) = \lambda_i(u) S_i(u) \prod_{j \neq i} E_{ji}(u) }{ Lambda[i](u) = lambda[i](u) S[i](u) prod[j != i] E[ji](u) } where \eqn{\lambda_i(u)}{\lambda[i](u)} is the intensity of component \eqn{i} of the process, \deqn{ S_i(u) = \frac{1}{\kappa_{i}} \sum_{v \in \Phi_i} k_{i}(u - v) }{ S[i](u) = 1 / (kappa[i]) sum[v in Phi[i]] k[i](u - v) } is the shot-noise random field for component \eqn{i} and \deqn{ E_{ji}(u) = \exp(-\kappa_{j} \alpha_{ji} / k_{j}(0)) \prod_{v \in \Phi_{j}} {1 + \alpha_{ji} \frac{k_j(u-v)}{k_j(0)}} }{ E[ji](u) = exp(-\kappa[j] \alpha[ji] / k[j](0)) prod[v in Phi[j]] (1 + alpha[ji] k[j](u-v) / k[j](0)) } is a product field controlling impulses from the parent Poisson process \eqn{\Phi_j}{\Phi[j]} with constant intensity \eqn{\kappa_j}{\kappa[j]} of component process \eqn{j} on \eqn{\Lambda_i(u)}{\Lambda[i](u)}. Here \eqn{k_i(u)}{k[i](u)} is an isotropic kernel (probability density) function on \eqn{R^2} with bandwidth \eqn{\omega_i}{\omega[i]} and shape parameter \eqn{\nu_i}{\nu[i]}, and \eqn{\alpha_{ji}>-1}{\alpha[j,i] > -1} is the interaction parameter. } \seealso{ \code{\link{rmpoispp}}, \code{\link{rThomas}}, \code{\link{rVarGamma}}, \code{\link{rCauchy}}, \code{\link{rNeymanScott}} } \references{ Jalilian, A., Guan, Y., Mateu, J. and Waagepetersen, R. (2015) Multivariate product-shot-noise Cox point process models. \emph{Biometrics} \bold{71}(4), 1022--1033. } \examples{ online <- interactive() # Example 1: homogeneous components lambda <- c(250, 300, 180, 400) kappa <- c(30, 25, 20, 25) omega <- c(0.02, 0.025, 0.03, 0.02) alpha <- matrix(runif(16, -1, 1), nrow=4, ncol=4) if(!online) { lambda <- lambda[1:2]/10 kappa <- kappa[1:2] omega <- omega[1:2] alpha <- alpha[1:2, 1:2] } X <- rPSNCP(lambda, kappa, omega, alpha) if(online) { plot(X) plot(split(X)) } #Example 2: inhomogeneous components z1 <- scaletointerval.im(bei.extra$elev, from=0, to=1) z2 <- scaletointerval.im(bei.extra$grad, from=0, to=1) if(!online) { ## reduce resolution to reduce check time z1 <- as.im(z1, dimyx=c(40,80)) z2 <- as.im(z2, dimyx=c(40,80)) } lambda <- list( exp(-8 + 1.5 * z1 + 0.5 * z2), exp(-7.25 + 1 * z1 - 1.5 * z2), exp(-6 - 1.5 * z1 + 0.5 * z2), exp(-7.5 + 2 * z1 - 3 * z2)) kappa <- c(35, 30, 20, 25) / (1000 * 500) omega <- c(15, 35, 40, 25) alpha <- matrix(runif(16, -1, 1), nrow=4, ncol=4) if(!online) { lambda <- lapply(lambda[1:2], "/", e2=10) kappa <- kappa[1:2] omega <- omega[1:2] alpha <- alpha[1:2, 1:2] } else { sapply(lambda, integral) } X <- rPSNCP(lambda, kappa, omega, alpha, win = Window(bei), dimyx=dim(z1)) if(online) { plot(X) plot(split(X), cex=0.5) } } \author{Abdollah Jalilian. Modified by \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rshift.ppp.Rd0000644000176200001440000001672014243054775016554 0ustar liggesusers\name{rshift.ppp} \alias{rshift.ppp} \title{Randomly Shift a Point Pattern} \description{ Randomly shifts the points of a point pattern. } \usage{ \method{rshift}{ppp}(X, \dots, which=NULL, group, nsim=1, drop=TRUE) } \arguments{ \item{X}{Point pattern to be subjected to a random shift. An object of class \code{"ppp"} } \item{\dots}{ Arguments that determine the random shift. See Details. } \item{group}{ Optional. Factor specifying a grouping of the points of \code{X}, or \code{NULL} indicating that all points belong to the same group. Each group will be shifted together, and separately from other groups. By default, points in a marked point pattern are grouped according to their mark values, while points in an unmarked point pattern are treated as a single group. } \item{which}{ Optional. Identifies which groups of the pattern will be shifted, while other groups are not shifted. A vector of levels of \code{group}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (object of class \code{"ppp"}) or a list of point patterns. } \details{ This operation randomly shifts the locations of the points in a point pattern. The function \code{rshift} is generic. This function \code{rshift.ppp} is the method for point patterns. The most common use of this function is to shift the points in a multitype point pattern. By default, points of the same type are shifted in parallel (i.e. points of a common type are shifted by a common displacement vector), and independently of other types. This is useful for testing the hypothesis of independence of types (the null hypothesis that the sub-patterns of points of each type are independent point processes). In general the points of \code{X} are divided into groups, then the points within a group are shifted by a common random displacement vector. Different groups of points are shifted independently. The grouping is determined as follows: \itemize{ \item If the argument \code{group} is present, then this determines the grouping. \item Otherwise, if \code{X} is a multitype point pattern, the marks determine the grouping. \item Otherwise, all points belong to a single group. } The argument \code{group} should be a factor, of length equal to the number of points in \code{X}. Alternatively \code{group} may be \code{NULL}, which specifies that all points of \code{X} belong to a single group. By default, every group of points will be shifted. The argument \code{which} indicates that only some of the groups should be shifted, while other groups should be left unchanged. \code{which} must be a vector of levels of \code{group} (for example, a vector of types in a multitype pattern) indicating which groups are to be shifted. The displacement vector, i.e. the vector by which the data points are shifted, is generated at random. Parameters that control the randomisation and the handling of edge effects are passed through the \code{\dots} argument. They are \describe{ \item{radius,width,height}{ Parameters of the random shift vector. } \item{edge}{ String indicating how to deal with edges of the pattern. Options are \code{"torus"}, \code{"erode"} and \code{"none"}. } \item{clip}{ Optional. Window to which the final point pattern should be clipped. } } If the window is a rectangle, the \emph{default} behaviour is to generate a displacement vector at random with equal probability for all possible displacements. This means that the \eqn{x} and \eqn{y} coordinates of the displacement vector are independent random variables, uniformly distributed over the range of possible coordinates. Alternatively, the displacement vector can be generated by another random mechanism, controlled by the arguments \code{radius}, \code{width} and \code{height}. \describe{ \item{rectangular:}{ if \code{width} and \code{height} are given, then the displacement vector is uniformly distributed in a rectangle of these dimensions, centred at the origin. The maximum possible displacement in the \eqn{x} direction is \code{width/2}. The maximum possible displacement in the \eqn{y} direction is \code{height/2}. The \eqn{x} and \eqn{y} displacements are independent. (If \code{width} and \code{height} are actually equal to the dimensions of the observation window, then this is equivalent to the default.) } \item{radial:}{ if \code{radius} is given, then the displacement vector is generated by choosing a random point inside a disc of the given radius, centred at the origin, with uniform probability density over the disc. Thus the argument \code{radius} determines the maximum possible displacement distance. The argument \code{radius} is incompatible with the arguments \code{width} and \code{height}. } } The argument \code{edge} controls what happens when a shifted point lies outside the window of \code{X}. Options are: \describe{ \item{"none":}{ Points shifted outside the window of \code{X} simply disappear. } \item{"torus":}{ Toroidal or periodic boundary. Treat opposite edges of the window as identical, so that a point which disappears off the right-hand edge will re-appear at the left-hand edge. This is called a ``toroidal shift'' because it makes the rectangle topologically equivalent to the surface of a torus (doughnut). The window must be a rectangle. Toroidal shifts are undefined if the window is non-rectangular. } \item{"erode":}{ Clip the point pattern to a smaller window. If the random displacements are generated by a radial mechanism (see above), then the window of \code{X} is eroded by a distance equal to the value of the argument \code{radius}, using \code{\link{erosion}}. If the random displacements are generated by a rectangular mechanism, then the window of \code{X} is (if it is not rectangular) eroded by a distance \code{max(height,width)} using \code{\link{erosion}}; or (if it is rectangular) trimmed by a margin of width \code{width} at the left and right sides and trimmed by a margin of height \code{height} at the top and bottom. The rationale for this is that the clipping window is the largest window for which edge effects can be ignored. } } The optional argument \code{clip} specifies a smaller window to which the pattern should be restricted. If \code{nsim > 1}, then the simulation procedure is performed \code{nsim} times; the result is a list of \code{nsim} point patterns. } \seealso{ \code{\link{rshift}}, \code{\link{rshift.psp}} } \examples{ # random toroidal shift # shift "on" and "off" points separately X <- rshift(amacrine) # shift "on" points and leave "off" points fixed X <- rshift(amacrine, which="on") # shift all points simultaneously X <- rshift(amacrine, group=NULL) # maximum displacement distance 0.1 units X <- rshift(amacrine, radius=0.1, nsim=2) # shift with erosion X <- rshift(amacrine, radius=0.1, edge="erode") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rCauchy.Rd0000644000176200001440000002547514356430614016057 0ustar liggesusers\name{rCauchy} \alias{rCauchy} \title{Simulate Neyman-Scott Point Process with Cauchy cluster kernel} \description{ Generate a random point pattern, a simulated realisation of the Neyman-Scott process with Cauchy cluster kernel. } \usage{ rCauchy(kappa, scale, mu, win = square(1), nsim=1, drop=TRUE, \dots, algorithm=c("BKBC", "naive"), nonempty=TRUE, thresh = 0.001, poisthresh=1e-6, expand = NULL, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{scale}{ Scale parameter for cluster kernel. Determines the size of clusters. A single positive number, in the same units as the spatial coordinates. } \item{mu}{ Mean number of points per cluster (a single positive number) or reference intensity for the cluster points (a function or a pixel image). } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link[spatstat.geom]{as.owin}}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{\dots}{ Passed to \code{\link[spatstat.random]{clusterfield}} to control the image resolution when \code{saveLambda=TRUE}, and to \code{\link[spatstat.random]{clusterradius}} when \code{expand} is missing or \code{NULL}. } \item{algorithm}{ String (partially matched) specifying the simulation algorithm. See Details. } \item{nonempty}{ Logical. If \code{TRUE} (the default), a more efficient algorithm is used, in which parents are generated conditionally on having at least one offspring point. If \code{FALSE}, parents are generated even if they have no offspring. Both choices are valid; the default is recommended unless you need to simulate all the parent points for some other purpose. } \item{thresh}{ Threshold relative to the cluster kernel value at the origin (parent location) determining when the cluster kernel will be treated as zero for simulation purposes. Will be overridden by argument \code{expand} if that is given. } \item{poisthresh}{ Numerical threshold below which the model will be treated as a Poisson process. See Details. } \item{expand}{ Window expansion distance. A single number. The distance by which the original window will be expanded in order to generate parent points. Has a sensible default, determined by calling \code{\link[spatstat.random]{clusterradius}} with the numeric threshold value given in \code{thresh}. } \item{saveparents}{ Logical value indicating whether to save the locations of the parent points as an attribute. } \item{saveLambda}{ Logical. If \code{TRUE} then the random intensity corresponding to the simulated parent points will also be calculated and saved, and returns as an attribute of the point pattern. } \item{kappamax}{ Optional. Numerical value which is an upper bound for the values of \code{kappa}, when \code{kappa} is a pixel image or a function. } \item{mumax}{ Optional. Numerical value which is an upper bound for the values of \code{mu}, when \code{mu} is a pixel image or a function. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of this point pattern (see \code{\link[spatstat.random]{rNeymanScott}}). Furthermore, the simulated intensity function is returned as an attribute \code{"Lambda"}, if \code{saveLambda=TRUE}. } \details{ This algorithm generates a realisation of the Neyman-Scott process with Cauchy cluster kernel, inside the window \code{win}. The process is constructed by first generating a Poisson point process of \dQuote{parent} points with intensity \code{kappa}. Then each parent point is replaced by a random cluster of points, the number of points in each cluster being random with a Poisson (\code{mu}) distribution, and the points being placed independently and uniformly according to a Cauchy kernel. Note that, for correct simulation of the model, the parent points are not restricted to lie inside the window \code{win}; the parent process is effectively the uniform Poisson process on the infinite plane. The algorithm can also generate spatially inhomogeneous versions of the cluster process: \itemize{ \item The parent points can be spatially inhomogeneous. If the argument \code{kappa} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is taken as specifying the intensity function of an inhomogeneous Poisson process that generates the parent points. \item The offspring points can be inhomogeneous. If the argument \code{mu} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is interpreted as the reference density for offspring points, in the sense of Waagepetersen (2006). } When the parents are homogeneous (\code{kappa} is a single number) and the offspring are inhomogeneous (\code{mu} is a function or pixel image), the model can be fitted to data using \code{\link[spatstat.model]{kppm}}. If the pair correlation function of the model is very close to that of a Poisson process, deviating by less than \code{poisthresh}, then the model is approximately a Poisson process, and will be simulated as a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Simulation Algorithm}{ Two simulation algorithms are implemented. \itemize{ \item The \emph{naive} algorithm generates the cluster process by directly following the description given above. First the window \code{win} is expanded by a distance equal to \code{expand}. Then the parent points are generated in the expanded window according to a Poisson process with intensity \code{kappa}. Then each parent point is replaced by a finite cluster of offspring points as described above. The naive algorithm is used if \code{algorithm="naive"} or if \code{nonempty=FALSE}. \item The \emph{BKBC} algorithm, proposed by Baddeley and Chang (2023), is a modification of the algorithm of Brix and Kendall (2002). Parents are generated in the infinite plane, subject to the condition that they have at least one offspring point inside the window \code{win}. The BKBC algorithm is used when \code{algorithm="BKBC"} (the default) and \code{nonempty=TRUE} (the default). } The naive algorithm becomes very slow when \code{scale} is large, while the BKBC algorithm is uniformly fast (Baddeley and Chang, 2023). If \code{saveparents=TRUE}, then the simulated point pattern will have an attribute \code{"parents"} containing the coordinates of the parent points, and an attribute \code{"parentid"} mapping each offspring point to its parent. If \code{nonempty=TRUE} (the default), then parents are generated subject to the condition that they have at least one offspring point in the window \code{win}. \code{nonempty=FALSE}, then parents without offspring will be included; this option is not available in the \emph{BKBC} algorithm. Note that if \code{kappa} is a pixel image, its domain must be larger than the window \code{win}. This is because an offspring point inside \code{win} could have its parent point lying outside \code{win}. In order to allow this, the naive simulation algorithm first expands the original window \code{win} by a distance equal to \code{expand} and generates the Poisson process of parent points on this larger window. If \code{kappa} is a pixel image, its domain must contain this larger window. If the pair correlation function of the model is very close to that of a Poisson process, with maximum deviation less than \code{poisthresh}, then the model is approximately a Poisson process. This is detected by the naive algorithm which then simulates a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Fitting cluster models to data}{ The Cauchy cluster model with homogeneous parents (i.e. where \code{kappa} is a single number) where the offspring are either homogeneous or inhomogeneous (\code{mu} is a single number, a function or pixel image) can be fitted to point pattern data using \code{\link[spatstat.model]{kppm}}, or fitted to the inhomogeneous \eqn{K} function using \code{\link[spatstat.model]{cauchy.estK}} or \code{\link[spatstat.model]{cauchy.estpcf}}. Currently \pkg{spatstat} does not support fitting the Cauchy cluster process model with inhomogeneous parents. A Cauchy cluster process model fitted by \code{\link[spatstat.model]{kppm}} can be simulated automatically using \code{\link[spatstat.model]{simulate.kppm}} (which invokes \code{rCauchy} to perform the simulation). } \seealso{ \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rThomas}}, \code{\link[spatstat.random]{rVarGamma}}, \code{\link[spatstat.random]{rNeymanScott}}, \code{\link[spatstat.random]{rGaussPoisson}}. For fitting the model, see \code{\link[spatstat.model]{kppm}}, \code{\link[spatstat.model]{clusterfit}}. } \examples{ # homogeneous X <- rCauchy(30, 0.01, 5) # inhomogeneous ff <- function(x,y){ exp(2 - 3 * abs(x)) } Z <- as.im(ff, W= owin()) Y <- rCauchy(50, 0.01, Z) YY <- rCauchy(ff, 0.01, 5) } \references{ \baddchangclustersim Brix, A. and Kendall, W.S. (2002) Simulation of cluster point processes without edge effects. \emph{Advances in Applied Probability} \bold{34}, 267--280. Ghorbani, M. (2013) Cauchy cluster process. \emph{Metrika} \bold{76}, 697-706. Jalilian, A., Guan, Y. and Waagepetersen, R. (2013) Decomposition of variance for spatial Cox processes. \emph{Scandinavian Journal of Statistics} \bold{40}, 119-137. Waagepetersen, R. (2007) An estimating function approach to inference for inhomogeneous Neyman-Scott processes. \emph{Biometrics} \bold{63}, 252--258. } \author{ Original algorithm by Abdollah Jalilian and Rasmus Waagepetersen. Adapted for \pkg{spatstat} by \adrian. Brix-Kendall-Baddeley-Chang algorithm implemented by \adrian and \yamei. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rMatClust.Rd0000644000176200001440000002651214466564543016403 0ustar liggesusers\name{rMatClust} \alias{rMatClust} \title{Simulate Matern Cluster Process} \description{ Generate a random point pattern, a simulated realisation of the \Matern Cluster Process. } \usage{ rMatClust(kappa, scale, mu, win = square(1), nsim=1, drop=TRUE, \dots, n.cond=NULL, w.cond=NULL, algorithm=c("BKBC", "naive"), nonempty=TRUE, poisthresh=1e-6, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{scale}{ Radius of the clusters. A single positive number. } \item{mu}{ Mean number of points per cluster (a single positive number) or reference intensity for the cluster points (a function or a pixel image). } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link[spatstat.geom]{as.owin}}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{\dots}{ Passed to \code{\link[spatstat.random]{clusterfield}} to control the image resolution when \code{saveLambda=TRUE}. } \item{n.cond}{ Optional. Integer specifying a fixed number of points. See the section on \emph{Conditional Simulation}. } \item{w.cond}{ Optional. Conditioning region. A window (object of class \code{"owin"}) specifying the region which must contain exactly \code{n.cond} points. See the section on \emph{Conditional Simulation}. } \item{algorithm}{ String (partially matched) specifying the simulation algorithm. See Details. } \item{nonempty}{ Logical. If \code{TRUE} (the default), a more efficient algorithm is used, in which parents are generated conditionally on having at least one offspring point in the window. If \code{FALSE}, parents are generated even if they have no offspring in the window. The default is recommended unless you need to simulate all the parent points for some other purpose. } \item{poisthresh}{ Numerical threshold below which the model will be treated as a Poisson process. See Details. } \item{saveparents}{ Logical value indicating whether to save the locations of the parent points as an attribute. } \item{saveLambda}{ Logical. If \code{TRUE} then the random intensity corresponding to the simulated parent points will also be calculated and saved, and returns as an attribute of the point pattern. } \item{kappamax}{ Optional. Numerical value which is an upper bound for the values of \code{kappa}, when \code{kappa} is a pixel image or a function. } \item{mumax}{ Optional. Numerical value which is an upper bound for the values of \code{mu}, when \code{mu} is a pixel image or a function. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of this point pattern (see \code{\link[spatstat.random]{rNeymanScott}}). Furthermore, the simulated intensity function is returned as an attribute \code{"Lambda"}, if \code{saveLambda=TRUE}. } \details{ This algorithm generates a realisation of \Matern's cluster process, a special case of the Neyman-Scott process, inside the window \code{win}. In the simplest case, where \code{kappa} and \code{mu} are single numbers, the cluster process is formed by first generating a uniform Poisson point process of \dQuote{parent} points with intensity \code{kappa}. Then each parent point is replaced by a random cluster of \dQuote{offspring} points, the number of points per cluster being Poisson (\code{mu}) distributed, and their positions being placed and uniformly inside a disc of radius \code{scale} centred on the parent point. The resulting point pattern is a realisation of the classical \dQuote{stationary \Matern cluster process}. This point process has intensity \code{kappa * mu}. The algorithm can also generate spatially inhomogeneous versions of the \Matern cluster process: \itemize{ \item The parent points can be spatially inhomogeneous. If the argument \code{kappa} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is taken as specifying the intensity function of an inhomogeneous Poisson process that generates the parent points. \item The offspring points can be inhomogeneous. If the argument \code{mu} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is interpreted as the reference density for offspring points, in the sense of Waagepetersen (2007). For a given parent point, the offspring constitute a Poisson process with intensity function equal to \code{mu/(pi * scale^2)} inside the disc of radius \code{scale} centred on the parent point, and zero intensity outside this disc. Equivalently we first generate, for each parent point, a Poisson (\eqn{M}) random number of offspring (where \eqn{M} is the maximum value of \code{mu}) placed independently and uniformly in the disc of radius \code{scale} centred on the parent location, and then randomly thin the offspring points, with retention probability \code{mu/M}. \item Both the parent points and the offspring points can be inhomogeneous, as described above. } The intensity of the \Matern cluster process is \code{kappa * mu} if either \code{kappa} or \code{mu} is a single number. In the general case the intensity is an integral involving \code{kappa}, \code{mu} and \code{scale}. } \section{Simulation Algorithm}{ Two simulation algorithms are implemented. \itemize{ \item The \emph{naive} algorithm generates the cluster process by directly following the description given above. First the window \code{win} is expanded by a distance equal to \code{scale}. Then the parent points are generated in the expanded window according to a Poisson process with intensity \code{kappa}. Then each parent point is replaced by a finite cluster of offspring points as described above. The naive algorithm is used if \code{algorithm="naive"} or if \code{nonempty=FALSE}. \item The \emph{BKBC} algorithm, proposed by Baddeley and Chang (2023), is a modification of the algorithm of Brix and Kendall (2002). Parents are generated in the infinite plane, subject to the condition that they have at least one offspring point inside the window \code{win}. The BKBC algorithm is used when \code{algorithm="BKBC"} (the default) and \code{nonempty=TRUE} (the default). } The naive algorithm becomes very slow when \code{scale} is large, while the BKBC algorithm is uniformly fast (Baddeley and Chang, 2023). If \code{saveparents=TRUE}, then the simulated point pattern will have an attribute \code{"parents"} containing the coordinates of the parent points, and an attribute \code{"parentid"} mapping each offspring point to its parent. If \code{nonempty=TRUE} (the default), then parents are generated subject to the condition that they have at least one offspring point in the window \code{win}. \code{nonempty=FALSE}, then parents without offspring will be included; this option is not available in the \emph{BKBC} algorithm. Note that if \code{kappa} is a pixel image, its domain must be larger than the window \code{win}. This is because an offspring point inside \code{win} could have its parent point lying outside \code{win}. In order to allow this, the naive simulation algorithm first expands the original window \code{win} by a distance equal to \code{scale} and generates the Poisson process of parent points on this larger window. If \code{kappa} is a pixel image, its domain must contain this larger window. If the pair correlation function of the model is very close to that of a Poisson process, with maximum deviation less than \code{poisthresh}, then the model is approximately a Poisson process. This is detected by the naive algorithm which then simulates a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Fitting cluster models to data}{ The \Matern cluster process model with homogeneous parents (i.e. where \code{kappa} is a single number) where the offspring are either homogeneous or inhomogeneous (\code{mu} is a single number, a function or pixel image) can be fitted to point pattern data using \code{\link[spatstat.model]{kppm}}, or fitted to the inhomogeneous \eqn{K} function using \code{\link[spatstat.model]{matclust.estK}} or \code{\link[spatstat.model]{matclust.estpcf}}. Currently \pkg{spatstat} does not support fitting the \Matern cluster process model with inhomogeneous parents. A fitted \Matern cluster process model can be simulated automatically using \code{\link[spatstat.model]{simulate.kppm}} (which invokes \code{rMatClust} to perform the simulation). } \section{Conditional Simulation}{ If \code{n.cond} is specified, it should be a single integer. Simulation will be conditional on the event that the pattern contains exactly \code{n.cond} points (or contains exactly \code{n.cond} points inside the region \code{w.cond} if it is given). Conditional simulation uses the rejection algorithm described in Section 6.2 of Moller, Syversveen and Waagepetersen (1998). There is a maximum number of proposals which will be attempted. Consequently the return value may contain fewer than \code{nsim} point patterns. } \seealso{ \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rThomas}}, \code{\link[spatstat.random]{rCauchy}}, \code{\link[spatstat.random]{rVarGamma}}, \code{\link[spatstat.random]{rNeymanScott}}, \code{\link[spatstat.random]{rGaussPoisson}}. For fitting the model, see \code{\link[spatstat.model]{kppm}}, \code{\link[spatstat.model]{clusterfit}}. } \examples{ # homogeneous X <- rMatClust(10, 0.05, 4) # inhomogeneous ff <- function(x,y){ 4 * exp(2 * abs(x) - 1) } Z <- as.im(ff, owin()) Y <- rMatClust(10, 0.05, Z) YY <- rMatClust(ff, 0.05, 3) } \references{ \baddchangclustersim Brix, A. and Kendall, W.S. (2002) Simulation of cluster point processes without edge effects. \emph{Advances in Applied Probability} \bold{34}, 267--280. \Matern, B. (1960) \emph{Spatial Variation}. Meddelanden \ifelse{latex}{\out{fr\r{a}n}}{fraan} Statens Skogsforskningsinstitut, volume 59, number 5. Statens Skogsforskningsinstitut, Sweden. \Matern, B. (1986) \emph{Spatial Variation}. Lecture Notes in Statistics 36, Springer-Verlag, New York. \Moller, J., Syversveen, A. and Waagepetersen, R. (1998) Log Gaussian Cox Processes. \emph{Scandinavian Journal of Statistics} \bold{25}, 451--482. Waagepetersen, R. (2007) An estimating function approach to inference for inhomogeneous Neyman-Scott processes. \emph{Biometrics} \bold{63}, 252--258. } \author{ \adrian, \yamei and \rolf. } \keyword{spatial} \keyword{datagen} spatstat.random/man/expand.owin.Rd0000644000176200001440000000232314243054774016702 0ustar liggesusers\name{expand.owin} \alias{expand.owin} \title{Apply Expansion Rule} \description{ Applies an expansion rule to a window. } \usage{ expand.owin(W, \dots) } \arguments{ \item{W}{A window.} \item{\dots}{ Arguments passed to \code{\link{rmhexpand}} to determine an expansion rule. } } \value{ A window (object of class \code{"owin"}). } \details{ The argument \code{W} should be a window (an object of class \code{"owin"}). This command applies the expansion rule specified by the arguments \code{\dots} to the window \code{W}, yielding another window. The arguments \code{\dots} are passed to \code{\link{rmhexpand}} to determine the expansion rule. For other transformations of the scale, location and orientation of a window, see \code{\link{shift}}, \code{\link{affine}} and \code{\link{rotate}}. } \seealso{ \code{\link{rmhexpand}} about expansion rules. \code{\link{shift}}, \code{\link{rotate}}, \code{\link{affine}} for other types of manipulation. } \examples{ expand.owin(square(1), 9) expand.owin(square(1), distance=0.5) expand.owin(letterR, length=2) expand.owin(letterR, distance=0.1) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.random/man/rDiggleGratton.Rd0000644000176200001440000001102714243054774017365 0ustar liggesusers\name{rDiggleGratton} \alias{rDiggleGratton} \title{Perfect Simulation of the Diggle-Gratton Process} \description{ Generate a random pattern of points, a simulated realisation of the Diggle-Gratton process, using a perfect simulation algorithm. } \usage{ rDiggleGratton(beta, delta, rho, kappa=1, W = owin(), expand=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{beta}{ intensity parameter (a positive number). } \item{delta}{ hard core distance (a non-negative number). } \item{rho}{ interaction range (a number greater than \code{delta}). } \item{kappa}{ interaction exponent (a non-negative number). } \item{W}{ window (object of class \code{"owin"}) in which to generate the random pattern. Currently this must be a rectangular window. } \item{expand}{ Logical. If \code{FALSE}, simulation is performed in the window \code{W}, which must be rectangular. If \code{TRUE} (the default), simulation is performed on a larger window, and the result is clipped to the original window \code{W}. Alternatively \code{expand} can be an object of class \code{"rmhexpand"} (see \code{\link[spatstat.random]{rmhexpand}}) determining the expansion method. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function generates a realisation of the Diggle-Gratton point process in the window \code{W} using a \sQuote{perfect simulation} algorithm. Diggle and Gratton (1984, pages 208-210) introduced the pairwise interaction point process with pair potential \eqn{h(t)} of the form \deqn{ h(t) = \left( \frac{t-\delta}{\rho-\delta} \right)^\kappa \quad\quad \mbox{ if } \delta \le t \le \rho }{ h(t) = ((t - delta)/(rho - delta))^kappa, { } delta <= t <= rho } with \eqn{h(t) = 0} for \eqn{t < \delta}{t < delta} and \eqn{h(t) = 1} for \eqn{t > \rho}{t > rho}. Here \eqn{\delta}{delta}, \eqn{\rho}{rho} and \eqn{\kappa}{kappa} are parameters. Note that we use the symbol \eqn{\kappa}{kappa} where Diggle and Gratton (1984) use \eqn{\beta}{beta}, since in \pkg{spatstat} we reserve the symbol \eqn{\beta}{beta} for an intensity parameter. The parameters must all be nonnegative, and must satisfy \eqn{\delta \le \rho}{delta <= rho}. The simulation algorithm used to generate the point pattern is \sQuote{dominated coupling from the past} as implemented by Berthelsen and \Moller (2002, 2003). This is a \sQuote{perfect simulation} or \sQuote{exact simulation} algorithm, so called because the output of the algorithm is guaranteed to have the correct probability distribution exactly (unlike the Metropolis-Hastings algorithm used in \code{\link[spatstat.random]{rmh}}, whose output is only approximately correct). There is a tiny chance that the algorithm will run out of space before it has terminated. If this occurs, an error message will be generated. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}). If \code{nsim > 1}, a list of point patterns. } \references{ Berthelsen, K.K. and \Moller, J. (2002) A primer on perfect simulation for spatial point processes. \emph{Bulletin of the Brazilian Mathematical Society} 33, 351-367. Berthelsen, K.K. and \Moller, J. (2003) Likelihood and non-parametric Bayesian MCMC inference for spatial point processes based on perfect simulation and path sampling. \emph{Scandinavian Journal of Statistics} 30, 549-564. Diggle, P.J. and Gratton, R.J. (1984) Monte Carlo methods of inference for implicit statistical models. \emph{Journal of the Royal Statistical Society, series B} \bold{46}, 193 -- 212. \Moller, J. and Waagepetersen, R. (2003). \emph{Statistical Inference and Simulation for Spatial Point Processes.} Chapman and Hall/CRC. } \author{ \adrian based on original code for the Strauss process by Kasper Klitgaard Berthelsen. } \examples{ X <- rDiggleGratton(50, 0.02, 0.07) Z <- rDiggleGratton(50, 0.02, 0.07, 2, nsim=2) } \seealso{ \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.random]{rStrauss}}, \code{\link[spatstat.random]{rHardcore}}, \code{\link[spatstat.random]{rStraussHard}}, \code{\link[spatstat.random]{rDGS}}, \code{\link[spatstat.random]{rPenttinen}}. For fitting the model, see \code{\link[spatstat.model]{DiggleGratton}}. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoispp.Rd0000644000176200001440000001474414452153466016156 0ustar liggesusers\name{rpoispp} \alias{rpoispp} \title{Generate Poisson Point Pattern} \description{ Generate a random point pattern using the (homogeneous or inhomogeneous) Poisson process. Includes CSR (complete spatial randomness). } \usage{ rpoispp(lambda, lmax=NULL, win=owin(), \dots, nsim=1, drop=TRUE, ex=NULL, forcewin=FALSE, warnwin=TRUE) } \arguments{ \item{lambda}{ Intensity of the Poisson process. Either a single positive number, a \code{function(x,y, \dots)}, or a pixel image. } \item{lmax}{ Optional. An upper bound for the value of \code{lambda(x,y)}, if \code{lambda} is a function. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. (Ignored if \code{lambda} is a pixel image unless \code{forcewin=TRUE}.) } \item{\dots}{ Arguments passed to \code{lambda} if it is a function. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{ex}{ Optional. A point pattern to use as the example. If \code{ex} is given and \code{lambda,lmax,win} are missing, then \code{lambda} and \code{win} will be calculated from the point pattern \code{ex}. } \item{forcewin}{ Logical value specifying whether to use the argument \code{win} as the simulation window when \code{lambda} is an image. } \item{warnwin}{ Logical value specifying whether to issue a warning when \code{win} is ignored (which occurs when \code{lambda} is an image, \code{win} is present and \code{forcewin=FALSE}). } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ If \code{lambda} is a single number, then this algorithm generates a realisation of the uniform Poisson process (also known as Complete Spatial Randomness, CSR) inside the window \code{win} with intensity \code{lambda} (points per unit area). If \code{lambda} is a function, then this algorithm generates a realisation of the inhomogeneous Poisson process with intensity function \code{lambda(x,y,\dots)} at spatial location \code{(x,y)} inside the window \code{win}. The function \code{lambda} must work correctly with vectors \code{x} and \code{y}. If \code{lmax} is given, it must be an upper bound on the values of \code{lambda(x,y,\dots)} for all locations \code{(x, y)} inside the window \code{win}. That is, we must have \code{lambda(x,y,\dots) <= lmax} for all locations \code{(x,y)}. If this is not true then the results of the algorithm will be incorrect. If \code{lmax} is missing or \code{NULL}, an approximate upper bound is computed by finding the maximum value of \code{lambda(x,y,\dots)} on a grid of locations \code{(x,y)} inside the window \code{win}, and adding a safety margin equal to 5 percent of the range of \code{lambda} values. This can be computationally intensive, so it is advisable to specify \code{lmax} if possible. If \code{lambda} is a pixel image object of class \code{"im"} (see \code{\link{im.object}}), this algorithm generates a realisation of the inhomogeneous Poisson process with intensity equal to the pixel values of the image. (The value of the intensity function at an arbitrary location is the pixel value of the nearest pixel.) If \code{forcewin=FALSE} (the default), the simulation window will be the window of the pixel image (converted to a rectangle if possible using \code{\link{rescue.rectangle}}). If \code{forcewin=TRUE}, the simulation window will be the argument \code{win}. For \emph{marked} point patterns, use \code{\link{rmpoispp}}. } \section{Warning}{ Note that \code{lambda} is the \bold{intensity}, that is, the expected number of points \bold{per unit area}. The total number of points in the simulated pattern will be random with expected value \code{mu = lambda * a} where \code{a} is the area of the window \code{win}. } \section{Reproducibility}{ The simulation algorithm, for the case where \code{lambda} is a pixel image, was changed in \pkg{spatstat} version \code{1.42-3}. Set \code{spatstat.options(fastpois=FALSE)} to use the previous, slower algorithm, if it is desired to reproduce results obtained with earlier versions. The previous slower algorithm uses ``thinning'': it first generates a uniform Poisson process of intensity \code{lmax}, then randomly deletes or retains each point, independently of other points, with retention probability \eqn{p(x,y) = \lambda(x,y)/\mbox{lmax}}{p(x,y) = lambda(x,y)/lmax}. The new faster algorithm randomly selects pixels with probability proportional to intensity, and generates point locations inside the selected pixels. Thinning is still used when \code{lambda} is a \code{function(x,y,\dots)}. } \seealso{ \code{\link{rmpoispp}} for Poisson \emph{marked} point patterns, \code{\link{runifpoint}} for a fixed number of independent uniform random points; \code{\link{rpoint}}, \code{\link{rmpoint}} for a fixed number of independent random points with any distribution; \code{\link{rMaternI}}, \code{\link{rMaternII}}, \code{\link{rSSI}}, \code{\link{rStrauss}}, \code{\link{rstrat}} for random point processes with spatial inhibition or regularity; \code{\link{rThomas}}, \code{\link{rGaussPoisson}}, \code{\link{rMatClust}}, \code{\link{rcell}} for random point processes exhibiting clustering; \code{\link{rmh.default}} for Gibbs processes. See also \code{\link{ppp.object}}, \code{\link{owin.object}}. } \examples{ # uniform Poisson process with intensity 100 in the unit square pp <- rpoispp(100) # uniform Poisson process with intensity 1 in a 10 x 10 square pp <- rpoispp(1, win=owin(c(0,10),c(0,10))) # plots should look similar ! # inhomogeneous Poisson process in unit square # with intensity lambda(x,y) = 100 * exp(-3*x) # Intensity is bounded by 100 pp <- rpoispp(function(x,y) {100 * exp(-3*x)}, 100) # How to tune the coefficient of x lamb <- function(x,y,a) { 100 * exp( - a * x)} pp <- rpoispp(lamb, 100, a=3) # pixel image Z <- as.im(function(x,y){100 * sqrt(x+y)}, unit.square()) pp <- rpoispp(Z) # randomising an existing point pattern rpoispp(intensity(cells), win=Window(cells)) rpoispp(ex=cells) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rPoissonCluster.Rd0000644000176200001440000001122214353202050017604 0ustar liggesusers\name{rPoissonCluster} \alias{rPoissonCluster} \title{Simulate Poisson Cluster Process} \description{ Generate a random point pattern, a realisation of the general Poisson cluster process. } \usage{ rPoissonCluster(kappa, expand, rcluster, win = owin(c(0,1),c(0,1)), \dots, nsim=1, drop=TRUE, saveparents=TRUE, kappamax=NULL) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{expand}{ Size of the expansion of the simulation window for generating parent points. A single non-negative number. } \item{rcluster}{ A function which generates random clusters. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. } \item{\dots}{ Arguments passed to \code{rcluster} } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{saveparents}{ Logical value indicating whether to save the locations of the parent points as an attribute. } \item{kappamax}{ Optional. Upper bound on the values of \code{kappa} when \code{kappa} is a function or pixel image. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of the point pattern: see Details. } \details{ This algorithm generates a realisation of the general Poisson cluster process, with the cluster mechanism given by the function \code{rcluster}. First, the algorithm generates a Poisson point process of ``parent'' points with intensity \code{kappa} in an expanded window as explained below.. Here \code{kappa} may be a single positive number, a function \code{kappa(x, y)}, or a pixel image object of class \code{"im"} (see \code{\link{im.object}}). See \code{\link{rpoispp}} for details. Second, each parent point is replaced by a random cluster of points, created by calling the function \code{rcluster}. These clusters are combined together to yield a single point pattern, and the restriction of this pattern to the window \code{win} is then returned as the result of \code{rPoissonCluster}. The expanded window consists of \code{\link{as.rectangle}(win)} extended by the amount \code{expand} in each direction. The size of the expansion is saved in the attribute \code{"expand"} and may be extracted by \code{attr(X, "expand")} where \code{X} is the generated point pattern. The function \code{rcluster} should expect to be called as \code{rcluster(xp[i],yp[i],\dots)} for each parent point at a location \code{(xp[i],yp[i])}. The return value of \code{rcluster} should be a list with elements \code{x,y} which are vectors of equal length giving the absolute \eqn{x} and \code{y} coordinates of the points in the cluster. If the return value of \code{rcluster} is a point pattern (object of class \code{"ppp"}) then it may have marks. The result of \code{rPoissonCluster} will then be a marked point pattern. If required, the intermediate stages of the simulation (the parents and the individual clusters) can also be extracted from the return value of \code{rPoissonCluster} through the attributes \code{"parents"} and \code{"parentid"}. The attribute \code{"parents"} is the point pattern of parent points. The attribute \code{"parentid"} is an integer vector specifying the parent for each of the points in the simulated pattern. (If these data are not required, it is more efficient to set \code{saveparents=FALSE}.) } \seealso{ \code{\link{rpoispp}}, \code{\link{rMatClust}}, \code{\link{rThomas}}, \code{\link{rCauchy}}, \code{\link{rVarGamma}}, \code{\link{rNeymanScott}}, \code{\link{rGaussPoisson}}. } \examples{ # each cluster consist of 10 points in a disc of radius 0.2 nclust <- function(x0, y0, radius, n) { return(runifdisc(n, radius, centre=c(x0, y0))) } plot(rPoissonCluster(10, 0.2, nclust, radius=0.2, n=5)) # multitype Neyman-Scott process (each cluster is a multitype process) nclust2 <- function(x0, y0, radius, n, types=c("a", "b")) { X <- runifdisc(n, radius, centre=c(x0, y0)) M <- sample(types, n, replace=TRUE) marks(X) <- M return(X) } plot(rPoissonCluster(15,0.1,nclust2, radius=0.1, n=5)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rmh.Rd0000644000176200001440000000571314243054775015245 0ustar liggesusers\name{rmh} \alias{rmh} \title{Simulate point patterns using the Metropolis-Hastings algorithm.} \description{ Generic function for running the Metropolis-Hastings algorithm to produce simulated realisations of a point process model. } \usage{rmh(model, \dots)} \arguments{ \item{model}{The point process model to be simulated. } \item{\dots}{Further arguments controlling the simulation. } } \details{ The Metropolis-Hastings algorithm can be used to generate simulated realisations from a wide range of spatial point processes. For caveats, see below. The function \code{rmh} is generic; it has methods \code{\link[spatstat.model]{rmh.ppm}} (for objects of class \code{"ppm"}) and \code{\link{rmh.default}} (the default). The actual implementation of the Metropolis-Hastings algorithm is contained in \code{\link{rmh.default}}. For details of its use, see \code{\link[spatstat.model]{rmh.ppm}} or \code{\link{rmh.default}}. [If the model is a Poisson process, then Metropolis-Hastings is not used; the Poisson model is generated directly using \code{\link{rpoispp}} or \code{\link{rmpoispp}}.] In brief, the Metropolis-Hastings algorithm is a Markov Chain, whose states are spatial point patterns, and whose limiting distribution is the desired point process. After running the algorithm for a very large number of iterations, we may regard the state of the algorithm as a realisation from the desired point process. However, there are difficulties in deciding whether the algorithm has run for ``long enough''. The convergence of the algorithm may indeed be extremely slow. No guarantees of convergence are given! While it is fashionable to decry the Metropolis-Hastings algorithm for its poor convergence and other properties, it has the advantage of being easy to implement for a wide range of models. } \section{Warning}{ As of version 1.22-1 of \code{spatstat} a subtle change was made to \code{rmh.default()}. We had noticed that the results produced were sometimes not ``scalable'' in that two models, differing in effect only by the units in which distances are measured and starting from the same seed, gave different results. This was traced to an idiosyncracy of floating point arithmetic. The code of \code{rmh.default()} has been changed so that the results produced by \code{rmh} are now scalable. The downside of this is that code which users previously ran may now give results which are different from what they formerly were. In order to recover former behaviour (so that previous results can be reproduced) set \code{spatstat.options(scalable=FALSE)}. See the last example in the help for \code{\link{rmh.default}}. } \value{ A point pattern, in the form of an object of class \code{"ppp"}. See \code{\link{rmh.default}} for details. } \seealso{ \code{\link{rmh.default}} } \examples{ # See examples in rmh.default and rmh.ppm } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rmhcontrol.Rd0000644000176200001440000003345314243054775016650 0ustar liggesusers\name{rmhcontrol} \alias{rmhcontrol} \alias{rmhcontrol.default} \title{Set Control Parameters for Metropolis-Hastings Algorithm.} \description{ Sets up a list of parameters controlling the iterative behaviour of the Metropolis-Hastings algorithm. } \usage{ rmhcontrol(\dots) \method{rmhcontrol}{default}(\dots, p=0.9, q=0.5, nrep=5e5, expand=NULL, periodic=NULL, ptypes=NULL, x.cond=NULL, fixall=FALSE, nverb=0, nsave=NULL, nburn=nsave, track=FALSE, pstage=c("block", "start")) } \arguments{ \item{\dots}{Arguments passed to methods.} \item{p}{Probability of proposing a shift (as against a birth/death).} \item{q}{Conditional probability of proposing a death given that a birth or death will be proposed.} \item{nrep}{Total number of steps (proposals) of Metropolis-Hastings algorithm that should be run.} \item{expand}{ Simulation window or expansion rule. Either a window (object of class \code{"owin"}) or a numerical expansion factor, specifying that simulations are to be performed in a domain other than the original data window, then clipped to the original data window. This argument is passed to \code{\link{rmhexpand}}. A numerical expansion factor can be in several formats: see \code{\link{rmhexpand}}. } \item{periodic}{ Logical value (or \code{NULL}) indicating whether to simulate ``periodically'', i.e. identifying opposite edges of the rectangular simulation window. A \code{NULL} value means ``undecided.'' } \item{ptypes}{For multitype point processes, the distribution of the mark attached to a new random point (when a birth is proposed)} \item{x.cond}{Conditioning points for conditional simulation.} \item{fixall}{(Logical) for multitype point processes, whether to fix the number of points of each type.} \item{nverb}{Progress reports will be printed every \code{nverb} iterations} \item{nsave,nburn}{ If these values are specified, then intermediate states of the simulation algorithm will be saved every \code{nsave} iterations, after an initial burn-in period of \code{nburn} iterations. } \item{track}{ Logical flag indicating whether to save the transition history of the simulations. } \item{pstage}{ Character string specifying when to generate proposal points. Either \code{"start"} or \code{"block"}. } } \value{ An object of class \code{"rmhcontrol"}, which is essentially a list of parameter values for the algorithm. There is a \code{print} method for this class, which prints a sensible description of the parameters chosen. } \details{ The Metropolis-Hastings algorithm, implemented as \code{\link{rmh}}, generates simulated realisations of point process models. The function \code{rmhcontrol} sets up a list of parameters which control the iterative behaviour and termination of the Metropolis-Hastings algorithm, for use in a subsequent call to \code{\link{rmh}}. It also checks that the parameters are valid. (A separate function \code{\link{rmhstart}} determines the initial state of the algorithm, and \code{\link{rmhmodel}} determines the model to be simulated.) The parameters are as follows: \describe{ \item{p}{The probability of proposing a ``shift'' (as opposed to a birth or death) in the Metropolis-Hastings algorithm. If \eqn{p = 1} then the algorithm only alters existing points, so the number of points never changes, i.e. we are simulating conditionally upon the number of points. The number of points is determined by the initial state (specified by \code{\link{rmhstart}}). If \eqn{p=1} and \code{fixall=TRUE} and the model is a multitype point process model, then the algorithm only shifts the locations of existing points and does not alter their marks (types). This is equivalent to simulating conditionally upon the number of points of each type. These numbers are again specified by the initial state. If \eqn{p = 1} then no expansion of the simulation window is allowed (see \code{expand} below). The default value of \code{p} can be changed by setting the parameter \code{rmh.p} in \code{\link{spatstat.options}}. } \item{q}{The conditional probability of proposing a death (rather than a birth) given that a shift is not proposed. This is of course ignored if \code{p} is equal to 1. The default value of \code{q} can be changed by setting the parameter \code{rmh.q} in \code{\link{spatstat.options}}. } \item{nrep}{The number of repetitions or iterations to be made by the Metropolis-Hastings algorithm. It should be large. The default value of \code{nrep} can be changed by setting the parameter \code{rmh.nrep} in \code{\link{spatstat.options}}. } \item{expand}{ Either a number or a window (object of class \code{"owin"}). Indicates that the process is to be simulated on a domain other than the original data window \code{w}, then clipped to \code{w} when the algorithm has finished. This would often be done in order to approximate the simulation of a stationary process (Geyer, 1999) or more generally a process existing in the whole plane, rather than just in the window \code{w}. If \code{expand} is a window object, it is taken as the larger domain in which simulation is performed. If \code{expand} is numeric, it is interpreted as an expansion factor or expansion distance for determining the simulation domain from the data window. It should be a \emph{named} scalar, such as \code{expand=c(area=2)}, \code{expand=c(distance=0.1)}, \code{expand=c(length=1.2)}. See \code{\link{rmhexpand}()} for more details. If the name is omitted, it defaults to \code{area}. Expansion is not permitted if the number of points has been fixed by setting \code{p = 1} or if the starting configuration has been specified via the argument \code{x.start} in \code{\link{rmhstart}}. If \code{expand} is \code{NULL}, this is interpreted to mean \dQuote{not yet decided}. An expansion rule will be determined at a later stage, using appropriate defaults. See \code{\link{rmhexpand}}. } \item{periodic}{A logical value (or \code{NULL}) determining whether to simulate \dQuote{periodically}. If \code{periodic} is \code{TRUE}, and if the simulation window is a rectangle, then the simulation algorithm effectively identifies opposite edges of the rectangle. Points near the right-hand edge of the rectangle are deemed to be close to points near the left-hand edge. Periodic simulation usually gives a better approximation to a stationary point process. For periodic simulation, the simulation window must be a rectangle. (The simulation window is determined by \code{expand} as described above.) The value \code{NULL} means \sQuote{undecided}. The decision is postponed until \code{\link{rmh}} is called. Depending on the point process model to be simulated, \code{rmh} will then set \code{periodic=TRUE} if the simulation window is expanded \emph{and} the expanded simulation window is rectangular; otherwise \code{periodic=FALSE}. Note that \code{periodic=TRUE} is only permitted when the simulation window (i.e. the expanded window) is rectangular. } \item{ptypes}{A vector of probabilities (summing to 1) to be used in assigning a random type to a new point. Defaults to a vector each of whose entries is \eqn{1/nt} where \eqn{nt} is the number of types for the process. Convergence of the simulation algorithm should be improved if \code{ptypes} is close to the relative frequencies of the types which will result from the simulation. } \item{x.cond}{ If this argument is given, then \emph{conditional simulation} will be performed, and \code{x.cond} specifies the location of the fixed points as well as the type of conditioning. It should be either a point pattern (object of class \code{"ppp"}) or a \code{list(x,y)} or a \code{data.frame}. See the section on Conditional Simulation. } \item{fixall}{A logical scalar specifying whether to condition on the number of points of each type. Meaningful only if a marked process is being simulated, and if \eqn{p = 1}. A warning message is given if \code{fixall} is set equal to \code{TRUE} when it is not meaningful. } \item{nverb}{An integer specifying how often ``progress reports'' (which consist simply of the number of repetitions completed) should be printed out. If nverb is left at 0, the default, the simulation proceeds silently. } \item{nsave,nburn}{ If these integers are given, then the current state of the simulation algorithm (i.e. the current random point pattern) will be saved every \code{nsave} iterations, starting from iteration \code{nburn}. (Alternatively \code{nsave} can be a vector, specifying different numbers of iterations between each successive save. This vector will be recycled until the end of the simulations.) } \item{track}{ Logical flag indicating whether to save the transition history of the simulations (i.e. information specifying what type of proposal was made, and whether it was accepted or rejected, for each iteration). } \item{pstage}{ Character string specifying the stage of the algorithm at which the randomised proposal points should be generated. If \code{pstage="start"} or if \code{nsave=0}, the entire sequence of \code{nrep} random proposal points is generated at the start of the algorithm. This is the original behaviour of the code, and should be used in order to maintain consistency with older versions of \pkg{spatstat}. If \code{pstage="block"} and \code{nsave > 0}, then a set of \code{nsave} random proposal points will be generated before each block of \code{nsave} iterations. This is much more efficient. The default is \code{pstage="block"}. } } } \section{Conditional Simulation}{ For a Gibbs point process \eqn{X}, the Metropolis-Hastings algorithm easily accommodates several kinds of conditional simulation: \describe{ \item{conditioning on the total number of points:}{ We fix the total number of points \eqn{N(X)} to be equal to \eqn{n}. We simulate from the conditional distribution of \eqn{X} given \eqn{N(X) = n}. } \item{conditioning on the number of points of each type:}{ In a multitype point process, where \eqn{Y_j}{Y[[j]]} denotes the process of points of type \eqn{j}, we fix the number \eqn{N(Y_j)}{N(Y[[j]])} of points of type \eqn{j} to be equal to \eqn{n_j}{n[j]}, for \eqn{j=1,2,\ldots,m}{j=1,2,...,m}. We simulate from the conditional distribution of \eqn{X} given \eqn{N(Y_j)=n_j}{N(Y[[j]]) = n[j]} for \eqn{j=1,2,\ldots,m}{j=1,2,...,m}. } \item{conditioning on the realisation in a subwindow:}{ We require that the point process \eqn{X} should, within a specified sub-window \eqn{V}, coincide with a specified point pattern \eqn{y}. We simulate from the conditional distribution of \eqn{X} given \eqn{X \cap V = y}{(X intersect V) = y}. } \item{Palm conditioning:}{ We require that the point process \eqn{X} include a specified list of points \eqn{y}. We simulate from the point process with probability density \eqn{g(x) = c f(x \cup y)}{g(x) = c * f(x union y)} where \eqn{f} is the probability density of the original process \eqn{X}, and \eqn{c} is a normalising constant. } } To achieve each of these types of conditioning we do as follows: \describe{ \item{conditioning on the total number of points:}{ Set \code{p=1}. The number of points is determined by the initial state of the simulation: see \code{\link{rmhstart}}. } \item{conditioning on the number of points of each type:}{ Set \code{p=1} and \code{fixall=TRUE}. The number of points of each type is determined by the initial state of the simulation: see \code{\link{rmhstart}}. } \item{conditioning on the realisation in a subwindow:}{ Set \code{x.cond} to be a point pattern (object of class \code{"ppp"}). Its window \code{V=Window(x.cond)} becomes the conditioning subwindow \eqn{V}. } \item{Palm conditioning:}{ Set \code{x.cond} to be a \code{list(x,y)} or \code{data.frame} with two columns containing the coordinates of the points, or a \code{list(x,y,marks)} or \code{data.frame} with three columns containing the coordinates and marks of the points. } } The arguments \code{x.cond}, \code{p} and \code{fixall} can be combined. } \references{ Geyer, C.J. (1999) Likelihood Inference for Spatial Point Processes. Chapter 3 in O.E. Barndorff-Nielsen, W.S. Kendall and M.N.M. Van Lieshout (eds) \emph{Stochastic Geometry: Likelihood and Computation}, Chapman and Hall / CRC, Monographs on Statistics and Applied Probability, number 80. Pages 79--140. } \seealso{ \code{\link{rmh}}, \code{\link{rmhmodel}}, \code{\link{rmhstart}}, \code{\link{rmhexpand}}, \code{\link{spatstat.options}} } \examples{ # parameters given as named arguments c1 <- rmhcontrol(p=0.3,periodic=TRUE,nrep=1e6,nverb=1e5) # parameters given as a list liz <- list(p=0.9, nrep=1e4) c2 <- rmhcontrol(liz) # parameters given in rmhcontrol object c3 <- rmhcontrol(c1) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rstrat.Rd0000644000176200001440000000377114243054775016000 0ustar liggesusers\name{rstrat} \alias{rstrat} \title{Simulate Stratified Random Point Pattern} \description{ Generates a ``stratified random'' pattern of points in a window, by dividing the window into rectangular tiles and placing \code{k} random points independently in each tile. } \usage{ rstrat(win=square(1), nx, ny=nx, k = 1, nsim=1, drop=TRUE) } \arguments{ \item{win}{ A window. An object of class \code{\link{owin}}, or data in any format acceptable to \code{\link{as.owin}()}. } \item{nx}{Number of tiles in each column. } \item{ny}{Number of tiles in each row. } \item{k}{Number of random points to generate in each tile. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This function generates a random pattern of points in a ``stratified random'' sampling design. It can be useful for generating random spatial sampling points. The bounding rectangle of \code{win} is divided into a regular \eqn{nx \times ny}{nx * ny} grid of rectangular tiles. In each tile, \code{k} random points are generated independently with a uniform distribution in that tile. Some of these grid points may lie outside the window \code{win}: if they do, they are deleted. The result is a point pattern inside the window \code{win}. This function is useful in creating dummy points for quadrature schemes (see \code{\link{quadscheme}}) as well as in simulating random point patterns. } \seealso{ \code{\link{rsyst}}, \code{\link{runifpoint}}, \code{\link{quadscheme}} } \examples{ X <- rstrat(nx=10) plot(X) # polygonal boundary X <- rstrat(letterR, 5, 10, k=3) plot(X) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rshift.psp.Rd0000644000176200001440000001044114243054775016551 0ustar liggesusers\name{rshift.psp} \alias{rshift.psp} \title{Randomly Shift a Line Segment Pattern} \description{ Randomly shifts the segments in a line segment pattern. } \usage{ \method{rshift}{psp}(X, \dots, group=NULL, which=NULL) } \arguments{ \item{X}{Line segment pattern to be subjected to a random shift. An object of class \code{"psp"}. } \item{\dots}{ Arguments controlling the randomisation and the handling of edge effects. See \code{\link{rshift.ppp}}. } \item{group}{ Optional. Factor specifying a grouping of the line segments of \code{X}, or \code{NULL} indicating that all line segments belong to the same group. Each group will be shifted together, and separately from other groups. } \item{which}{ Optional. Identifies which groups of the pattern will be shifted, while other groups are not shifted. A vector of levels of \code{group}. } } \value{ A line segment pattern (object of class \code{"psp"}). } \details{ This operation randomly shifts the locations of the line segments in a line segment pattern. The function \code{rshift} is generic. This function \code{rshift.psp} is the method for line segment patterns. The line segments of \code{X} are first divided into groups, then the line segments within a group are shifted by a common random displacement vector. Different groups of line segments are shifted independently. If the argument \code{group} is present, then this determines the grouping. Otherwise, all line segments belong to a single group. The argument \code{group} should be a factor, of length equal to the number of line segments in \code{X}. Alternatively \code{group} may be \code{NULL}, which specifies that all line segments of \code{X} belong to a single group. By default, every group of line segments will be shifted. The argument \code{which} indicates that only some of the groups should be shifted, while other groups should be left unchanged. \code{which} must be a vector of levels of \code{group} indicating which groups are to be shifted. The displacement vector, i.e. the vector by which the data line segments are shifted, is generated at random. The \emph{default} behaviour is to generate a displacement vector at random with equal probability for all possible displacements. This means that the \eqn{x} and \eqn{y} coordinates of the displacement vector are independent random variables, uniformly distributed over the range of possible coordinates. Alternatively, the displacement vector can be generated by another random mechanism, controlled by the arguments \code{radius}, \code{width} and \code{height}. \describe{ \item{rectangular:}{ if \code{width} and \code{height} are given, then the displacement vector is uniformly distributed in a rectangle of these dimensions, centred at the origin. The maximum possible displacement in the \eqn{x} direction is \code{width/2}. The maximum possible displacement in the \eqn{y} direction is \code{height/2}. The \eqn{x} and \eqn{y} displacements are independent. (If \code{width} and \code{height} are actually equal to the dimensions of the observation window, then this is equivalent to the default.) } \item{radial:}{ if \code{radius} is given, then the displacement vector is generated by choosing a random line segment inside a disc of the given radius, centred at the origin, with uniform probability density over the disc. Thus the argument \code{radius} determines the maximum possible displacement distance. The argument \code{radius} is incompatible with the arguments \code{width} and \code{height}. } } The argument \code{edge} controls what happens when a shifted line segment lies partially or completely outside the window of \code{X}. Currently the only option is \code{"erode"} which specifies that the segments will be clipped to a smaller window. The optional argument \code{clip} specifies a smaller window to which the pattern should be restricted. } \seealso{ \code{\link{rshift}}, \code{\link{rshift.ppp}} } \examples{ X <- psp(runif(20), runif(20), runif(20), runif(20), window=owin()) Y <- rshift(X, radius=0.1) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/will.expand.Rd0000644000176200001440000000171414243054775016701 0ustar liggesusers\name{will.expand} \alias{will.expand} \title{ Test Expansion Rule } \description{ Determines whether an expansion rule will actually expand the window or not. } \usage{ will.expand(x) } \arguments{ \item{x}{ Expansion rule. An object of class \code{"rmhexpand"}. } } \details{ An object of class \code{"rmhexpand"} describes a rule for expanding a simulation window. See \code{\link{rmhexpand}} for details. One possible expansion rule is to do nothing, i.e. not to expand the window. This command inspects the expansion rule \code{x} and determines whether it will or will not actually expand the window. It returns \code{TRUE} if the window will be expanded. } \value{ Logical value. } \author{\adrian and \rolf } \seealso{ \code{\link{rmhexpand}}, \code{\link{expand.owin}} } \examples{ x <- rmhexpand(distance=0.2) y <- rmhexpand(area=1) will.expand(x) will.expand(y) } \keyword{spatial} \keyword{manip} spatstat.random/man/ragsMultiHard.Rd0000644000176200001440000000555614243054774017231 0ustar liggesusers\name{ragsMultiHard} \alias{ragsMultiHard} \title{ Alternating Gibbs Sampler for Multitype Hard Core Process } \description{ Generate a realisation of the multitype hard core point process using the alternating Gibbs sampler. } \usage{ ragsMultiHard(beta, hradii, \dots, types=NULL, bmax = NULL, periodic=FALSE, ncycles = 100) } \arguments{ \item{beta}{ First order trend. A numeric vector, a pixel image, a function, a list of functions, or a list of pixel images. } \item{hradii}{ Matrix of hard core radii between each pair of types. Diagonal entries should be \code{0} or \code{NA}. } \item{types}{ Vector of all possible types for the multitype point pattern. } \item{\dots}{ Arguments passed to \code{\link[spatstat.random]{rmpoispp}} when generating random points. } \item{bmax}{ Optional upper bound on \code{beta}. } \item{periodic}{ Logical value indicating whether to measure distances in the periodic sense, so that opposite sides of the (rectangular) window are treated as identical. } \item{ncycles}{ Number of cycles of the sampler to be performed. } } \details{ The Alternating Gibbs Sampler for a multitype point process is an iterative simulation procedure. Each step of the sampler updates the pattern of points of a particular type \code{i}, by drawing a realisation from the conditional distribution of points of type \code{i} given the points of all other types. Successive steps of the sampler update the points of type 1, then type 2, type 3, and so on. This is an experimental implementation which currently works only for multitype hard core processes (see \code{\link[spatstat.model]{MultiHard}}) in which there is no interaction between points of the same type, and for the area-interaction process (see \code{\link[spatstat.random]{ragsAreaInter}}). The argument \code{beta} gives the first order trend for each possible type of point. It may be a single number, a numeric vector, a \code{function(x,y)}, a pixel image, a list of functions, a \code{function(x,y,m)}, or a list of pixel images. The argument \code{hradii} is the matrix of hard core radii between each pair of possible types of points. Two points of types \code{i} and \code{j} respectively are forbidden to lie closer than a distance \code{hradii[i,j]} apart. The diagonal of this matrix must contain \code{NA} or \code{0} values, indicating that there is no hard core constraint applying between points of the same type. } \value{ A point pattern (object of class \code{"ppp"}). } \author{ \adrian } \seealso{ \code{\link[spatstat.random]{rags}}, \code{\link[spatstat.random]{ragsAreaInter}} } \examples{ b <- c(30,20) h <- 0.05 * matrix(c(0,1,1,0), 2, 2) ragsMultiHard(b, h, ncycles=10) ragsMultiHard(b, h, ncycles=5, periodic=TRUE) } \keyword{spatial} \keyword{datagen} spatstat.random/man/spatstat.random-internal.Rd0000644000176200001440000001230614567023173021404 0ustar liggesusers\name{spatstat.random-internal} \title{Internal spatstat.random functions} \alias{change.default.expand} \alias{datagen.runifpointOnLines} \alias{datagen.runifpoisppOnLines} \alias{datagen.rpoisppOnLines} \alias{default.clipwindow} \alias{detect.par.format} \alias{expandwinPerfect} \alias{fakeNeyScot} \alias{getRandomFieldsModelGen} \alias{handle.rshift.args} \alias{HermiteCoefs} \alias{is.cadlag} \alias{is.expandable} \alias{is.expandable.rmhmodel} \alias{kraever} \alias{kraeverRandomFields} \alias{MultiPair.checkmatrix} \alias{optimalinflation} \alias{print.rmhcontrol} \alias{print.rmhexpand} \alias{print.rmhmodel} \alias{print.rmhstart} \alias{print.rmhInfoList} \alias{print.summary.rmhexpand} \alias{RandomFieldsSafe} \alias{reheat} \alias{resolve.vargamma.shape} \alias{retrieve.param} \alias{rMaternInhibition} \alias{rMatClustHom} \alias{rThomasHom} \alias{rCauchyHom} \alias{rGRFcircembed} \alias{rGRFgauss} \alias{rGRFexpo} \alias{rGRFstable} \alias{rGRFgencauchy} \alias{rGRFmatern} \alias{rPoissonClusterEngine} \alias{RmhExpandRule} \alias{rmhsnoop} \alias{rmhResolveControl} \alias{rmhResolveExpansion} \alias{rmhResolveTypes} \alias{rmhSnoopEnv} \alias{rmhcontrol.rmhcontrol} \alias{rmhcontrol.list} \alias{rmhEngine} \alias{rmhmodel.rmhmodel} \alias{rmhstart.rmhstart} \alias{rmhstart.list} \alias{rmpoint.I.allim} \alias{rpoint.multi} \alias{rthinEngine} \alias{runifpoispp} \alias{runifpoisppOnLines} \alias{spatstatClusterModelInfo} \alias{spatstatClusterSimInfo} \alias{spatstatClusterSimModelMatch} \alias{spatstatRmhInfo} \alias{summarise.trend} \alias{summary.rmhexpand} \alias{thinjump} \alias{thinParents} \alias{update.rmhstart} \alias{validate.kappa.mu} %%%%%%% \description{ Internal spatstat.random functions. } \usage{ change.default.expand(x, newdefault) datagen.runifpointOnLines(n, L) datagen.runifpoisppOnLines(lambda, L) datagen.rpoisppOnLines(lambda, L, lmax, \dots, check) default.clipwindow(object, epsilon) expandwinPerfect(W, expand, amount) detect.par.format(par, native, generic) fakeNeyScot(Y, lambda, win, saveLambda, saveparents) getRandomFieldsModelGen(model) handle.rshift.args(W, \dots, radius, width, height, edge, clip, edgedefault) HermiteCoefs(order) is.cadlag(s) is.expandable(x) \method{is.expandable}{rmhmodel}(x) kraever(package, fatal) kraeverRandomFields() MultiPair.checkmatrix(mat, n, matname, naok, zerook, asymmok) optimalinflation(clusters, mod, rD) \method{print}{rmhcontrol}(x, \dots) \method{print}{rmhexpand}(x, \dots, prefix=TRUE) \method{print}{rmhmodel}(x, \dots) \method{print}{rmhstart}(x, \dots) \method{print}{rmhInfoList}(x, \dots) \method{print}{summary.rmhexpand}(x, \dots) RandomFieldsSafe() reheat(model, invtemp) resolve.vargamma.shape(\dots, nu.ker, nu.pcf, nu, allow.nu, allow.default) retrieve.param(desired, aliases, \dots, par) rMaternInhibition(type, kappa, r, win, stationary, \dots, nsim, drop) rMatClustHom(kappa, mu, R, W, \dots, nsim, drop, inflate, saveparents) rThomasHom(kappa, mu, sigma, W, \dots, nsim, drop, inflate, saveparents, maxinflate) rCauchyHom(kappa, mu, scale, W, \dots, nsim, drop, inflate, saveparents, maxinflate) rGRFcircembed(W, mu, var, corrfun, \dots, nsim, drop) rGRFgauss(W, mu, var, scale, \dots, nsim, drop) rGRFexpo(W, mu, var, scale, \dots, nsim, drop) rGRFstable(W, mu, var, scale, alpha, \dots, nsim, drop) rGRFgencauchy(W, mu, var, scale, alpha, beta, \dots, nsim, drop) rGRFmatern(W, mu, var, scale, nu, \dots, nsim, drop) rPoissonClusterEngine(kappa, expand, rcluster, win, \dots, nsim, drop, saveparents, kappamax, lmax, rmax) RmhExpandRule(nama) \method{rmhcontrol}{rmhcontrol}(\dots) \method{rmhcontrol}{list}(\dots) rmhEngine(InfoList, \dots, verbose, kitchensink, preponly, snoop, overrideXstart, overrideclip) rmhResolveControl(control, model) rmhResolveExpansion(win, control, imagelist, itype) rmhResolveTypes(model, start, control) rmhsnoop(\dots, Wsim, Wclip, R, xcoords, ycoords, mlevels, mcodes, irep, itype, proptype, proplocn, propmark, propindx, numerator, denominator, panel.only) rmhSnoopEnv(Xinit, Wclip, R) \method{rmhmodel}{rmhmodel}(model, \dots) \method{rmhstart}{rmhstart}(start, \dots) \method{rmhstart}{list}(start, \dots) rmpoint.I.allim(n, f, types, nsim) rpoint.multi(n, f, fmax, marks, win, giveup, verbose, warn, nsim, drop) rthinEngine(X, P, \dots, nsim, drop, Pmax, na.zero, what, fatal, warn) runifpoispp(lambda, win, \dots, nsim, drop) runifpoisppOnLines(lambda, L, nsim, drop) spatstatClusterModelInfo(name, onlyPCP) spatstatClusterSimInfo(name) spatstatClusterSimModelMatch(name, verbose) spatstatRmhInfo(cifname) summarise.trend(trend, w, a) \method{summary}{rmhexpand}(object, \dots) thinjump(n, p) thinParents(X, P, Pmax) \method{update}{rmhstart}(object, \dots) validate.kappa.mu(kappa, mu, kappamax, mumax, win, expand, \dots, context) } \details{ These internal \pkg{spatstat.random} functions should not be called directly by the user. Their names and capabilities may change without warning from one version of \pkg{spatstat.random} to the next. } \value{ The return values of these functions are not documented, and may change without warning. } \keyword{internal} spatstat.random/man/rmhexpand.Rd0000644000176200001440000001273214243054775016444 0ustar liggesusers\name{rmhexpand} \alias{rmhexpand} \title{ Specify Simulation Window or Expansion Rule } \description{ Specify a spatial domain in which point process simulations will be performed. Alternatively, specify a rule which will be used to determine the simulation window. } \usage{ rmhexpand(x = NULL, ..., area = NULL, length = NULL, distance = NULL) } \arguments{ \item{x}{ Any kind of data determining the simulation window or the expansion rule. A window (object of class \code{"owin"}) specifying the simulation window, a numerical value specifying an expansion factor or expansion distance, a list containing one numerical value, an object of class \code{"rmhexpand"}, or \code{NULL}. } \item{\dots}{ Ignored. } \item{area}{ Area expansion factor. Incompatible with other arguments. } \item{length}{ Length expansion factor. Incompatible with other arguments. } \item{distance}{ Expansion distance (buffer width). Incompatible with other arguments. } } \details{ In the Metropolis-Hastings algorithm \code{\link{rmh}} for simulating spatial point processes, simulations are usually carried out on a spatial domain that is larger than the original window of the point process model, then subsequently clipped to the original window. The command \code{rmhexpand} can be used to specify the simulation window, or to specify a rule which will later be used to determine the simulation window from data. The arguments are all incompatible: at most one of them should be given. If the first argument \code{x} is given, it may be any of the following: \itemize{ \item a window (object of class \code{"owin"}) specifying the simulation window. \item an object of class \code{"rmhexpand"} specifying the expansion rule. \item a single numerical value, without attributes. This will be interpreted as the value of the argument \code{area}. \item either \code{c(area=v)} or \code{list(area=v)}, where \code{v} is a single numeric value. This will be interpreted as the value of the argument \code{area}. \item either \code{c(length=v)} or \code{list(length=v)}, where \code{v} is a single numeric value. This will be interpreted as the value of the argument \code{length}. \item either \code{c(distance=v)} or \code{list(distance=v)}, where \code{v} is a single numeric value. This will be interpreted as the value of the argument \code{distance}. \item \code{NULL}, meaning that the expansion rule is not yet determined. } If one of the arguments \code{area}, \code{length} or \code{distance} is given, then the simulation window is determined from the original data window as follows. \describe{ \item{area}{ The bounding box of the original data window will be extracted, and the simulation window will be a scalar dilation of this rectangle. The argument \code{area} should be a numerical value, greater than or equal to 1. It specifies the area expansion factor, i.e. the ratio of the area of the simulation window to the area of the original point process window's bounding box. } \item{length}{ The bounding box of the original data window will be extracted, and the simulation window will be a scalar dilation of this rectangle. The argument \code{length} should be a numerical value, greater than or equal to 1. It specifies the length expansion factor, i.e. the ratio of the width (height) of the simulation window to the width (height) of the original point process window's bounding box. } \item{distance}{ The argument \code{distance} should be a numerical value, greater than or equal to 0. It specifies the width of a buffer region around the original data window. If the original data window is a rectangle, then this window is extended by a margin of width equal to \code{distance} around all sides of the original rectangle. The result is a rectangle. If the original data window is not a rectangle, then morphological dilation is applied using \code{\link{dilation.owin}} so that a margin or buffer of width equal to \code{distance} is created around all sides of the original window. The result is a non-rectangular window, typically of a different shape. } } } \section{Undetermined expansion}{ If \code{expand=NULL}, this is interpreted to mean that the expansion rule is \dQuote{not yet decided}. Expansion will be decided later, by the simulation algorithm \code{\link{rmh}}. If the model cannot be expanded (for example if the covariate data in the model are not available on a larger domain) then expansion will not occur. If the model can be expanded, then if the point process model has a finite interaction range \code{r}, the default is \code{rmhexpand(distance=2*r)}, and otherwise \code{rmhexpand(area=2)}. } \value{ An object of class \code{"rmhexpand"} specifying the expansion rule. There is a \code{print} method for this class. } \author{\adrian and \rolf } \seealso{ \code{\link{expand.owin}} to apply the rule to a window. \code{\link{will.expand}} to test whether expansion will occur. \code{\link{rmh}}, \code{\link{rmhcontrol}} for background details. } \examples{ rmhexpand() rmhexpand(2) rmhexpand(1) rmhexpand(length=1.5) rmhexpand(distance=0.1) rmhexpand(letterR) } \keyword{spatial} \keyword{datagen} spatstat.random/man/clusterkernel.Rd0000644000176200001440000000257314374301321017325 0ustar liggesusers\name{clusterkernel} \alias{clusterkernel} \alias{clusterkernel.character} \title{ Extract Cluster Offspring Kernel } \description{ Given a cluster point process model, this command returns the probability density of the cluster offspring. } \usage{ clusterkernel(model, \dots) \method{clusterkernel}{character}(model, \dots) } \arguments{ \item{model}{ Cluster model. Either a fitted cluster or Cox model (object of class \code{"kppm"}), or a character string specifying the type of cluster model. } \item{\dots}{ Parameter values for the model, when \code{model} is a character string. } } \details{ Given a specification of a cluster point process model, this command returns a \code{function(x,y)} giving the two-dimensional probability density of the cluster offspring points assuming a cluster parent located at the origin. The function \code{clusterkernel} is generic, with methods for class \code{"character"} (described here) and \code{"kppm"} (described in \code{\link[spatstat.model]{clusterkernel.kppm}}). } \value{ A function in the \R language with arguments \code{x,y,\dots}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[spatstat.model]{clusterkernel.kppm}}), \code{\link{clusterfield}}, \code{\link[spatstat.model]{kppm}}. } \examples{ f <- clusterkernel("Thomas", kappa=10, scale=0.5) f(0.1, 0.2) } \keyword{spatial} spatstat.random/man/clusterfield.Rd0000644000176200001440000000716114374301321017126 0ustar liggesusers\name{clusterfield} \alias{clusterfield} \alias{clusterfield.character} \alias{clusterfield.function} \title{Field of clusters} \description{ Calculate the superposition of cluster kernels at the location of a point pattern. } \usage{ clusterfield(model, locations = NULL, \dots) \method{clusterfield}{character}(model, locations = NULL, \dots) \method{clusterfield}{function}(model, locations = NULL, \dots, mu = NULL) } \arguments{ \item{model}{ Cluster model. Either a fitted cluster model (object of class \code{"kppm"}), a character string specifying the type of cluster model, or a function defining the cluster kernel. See Details. } \item{locations}{ A point pattern giving the locations of the kernels. Defaults to the centroid of the observation window for the \code{"kppm"} method and to the center of a unit square otherwise. } \item{\dots}{ Additional arguments passed to \code{\link[spatstat.explore]{density.ppp}} or the cluster kernel. See Details. } \item{mu}{ Mean number of offspring per cluster. A single number or a pixel image. } } \details{ The function \code{clusterfield} is generic, with methods for \code{"character"} and \code{"function"} (described here) and a method for \code{"kppm"} (described in \code{\link[spatstat.model]{clusterfield.kppm}}). The calculations are performed by \code{\link[spatstat.explore]{density.ppp}} and \code{\dots} arguments are passed thereto for control over the pixel resolution etc. (These arguments are then passed on to \code{\link[spatstat.geom]{pixellate.ppp}} and \code{\link[spatstat.geom]{as.mask}}.) For the method \code{clusterfield.function}, the given kernel function should accept vectors of x and y coordinates as its first two arguments. Any additional arguments may be passed through the \code{\dots}. The method \code{clusterfield.function} also accepts the optional parameter \code{mu} (defaulting to 1) specifying the mean number of points per cluster (as a numeric) or the inhomogeneous reference cluster intensity (as an \code{"im"} object or a \code{function(x,y)}). The interpretation of \code{mu} is as explained in the simulation functions referenced in the See Also section below. For the method \code{clusterfield.character}, the argument \code{model} must be one of the following character strings: \code{model="Thomas"} for the Thomas process, \code{model="MatClust"} for the \Matern cluster process, \code{model="Cauchy"} for the Neyman-Scott cluster process with Cauchy kernel, or \code{model="VarGamma"} for the Neyman-Scott cluster process with Variance Gamma kernel. For all these models the parameter \code{scale} is required and passed through \code{\dots} as well as the parameter \code{nu} when \code{model="VarGamma"}. This method calls \code{clusterfield.function} so the parameter \code{mu} may also be passed through \code{\dots} and will be interpreted as explained above. } \value{ A pixel image (object of class \code{"im"}). } \seealso{ \code{\link[spatstat.model]{clusterfield.kppm}}. \code{\link[spatstat.explore]{density.ppp}} and \code{\link[spatstat.model]{kppm}}. Simulation algorithms for cluster models: \code{\link{rCauchy}} \code{\link{rMatClust}} \code{\link{rThomas}} \code{\link{rVarGamma}} } \examples{ # method for functions kernel <- function(x,y,scal) { r <- sqrt(x^2 + y^2) ifelse(r > 0, dgamma(r, shape=5, scale=scal)/(2 * pi * r), 0) } X <- runifpoint(10) clusterfield(kernel, X, scal=0.05) } \author{ \spatstatAuthors. } \keyword{spatial} spatstat.random/man/runifpointx.Rd0000644000176200001440000000245714243054775017046 0ustar liggesusers\name{runifpointx} \alias{runifpointx} \title{ Generate N Uniform Random Points in Any Dimensions } \description{ Generate a random point pattern containing \code{n} independent, uniform random points in any number of spatial dimensions. } \usage{ runifpointx(n, domain, nsim=1, drop=TRUE) } \arguments{ \item{n}{ Number of points to be generated. } \item{domain}{ Multi-dimensional box in which the process should be generated. An object of class \code{"boxx"}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a single point pattern. } } \value{ If \code{nsim = 1} and \code{drop=TRUE}, a point pattern (an object of class \code{"ppx"}). If \code{nsim > 1} or \code{drop=FALSE}, a list of such point patterns. } \details{ This function generates a pattern of \code{n} independent random points, uniformly distributed in the multi-dimensional box \code{domain}. } \seealso{ \code{\link{rpoisppx}}, \code{\link{ppx}}, \code{\link{boxx}} } \examples{ w <- boxx(x=c(0,1), y=c(0,1), z=c(0,1), t=c(0,3)) X <- runifpointx(50, w) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rHardcore.Rd0000644000176200001440000000711514243054775016366 0ustar liggesusers\name{rHardcore} \alias{rHardcore} \title{Perfect Simulation of the Hardcore Process} \description{ Generate a random pattern of points, a simulated realisation of the Hardcore process, using a perfect simulation algorithm. } \usage{ rHardcore(beta, R = 0, W = owin(), expand=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{beta}{ intensity parameter (a positive number). } \item{R}{ hard core distance (a non-negative number). } \item{W}{ window (object of class \code{"owin"}) in which to generate the random pattern. Currently this must be a rectangular window. } \item{expand}{ Logical. If \code{FALSE}, simulation is performed in the window \code{W}, which must be rectangular. If \code{TRUE} (the default), simulation is performed on a larger window, and the result is clipped to the original window \code{W}. Alternatively \code{expand} can be an object of class \code{"rmhexpand"} (see \code{\link[spatstat.random]{rmhexpand}}) determining the expansion method. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function generates a realisation of the Hardcore point process in the window \code{W} using a \sQuote{perfect simulation} algorithm. The Hardcore process is a model for strong spatial inhibition. Two points of the process are forbidden to lie closer than \code{R} units apart. The Hardcore process is the special case of the Strauss process (see \code{\link[spatstat.random]{rStrauss}}) with interaction parameter \eqn{\gamma}{gamma} equal to zero. The simulation algorithm used to generate the point pattern is \sQuote{dominated coupling from the past} as implemented by Berthelsen and \Moller (2002, 2003). This is a \sQuote{perfect simulation} or \sQuote{exact simulation} algorithm, so called because the output of the algorithm is guaranteed to have the correct probability distribution exactly (unlike the Metropolis-Hastings algorithm used in \code{\link[spatstat.random]{rmh}}, whose output is only approximately correct). There is a tiny chance that the algorithm will run out of space before it has terminated. If this occurs, an error message will be generated. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}). If \code{nsim > 1}, a list of point patterns. } \references{ Berthelsen, K.K. and \Moller, J. (2002) A primer on perfect simulation for spatial point processes. \emph{Bulletin of the Brazilian Mathematical Society} 33, 351-367. Berthelsen, K.K. and \Moller, J. (2003) Likelihood and non-parametric Bayesian MCMC inference for spatial point processes based on perfect simulation and path sampling. \emph{Scandinavian Journal of Statistics} 30, 549-564. \Moller, J. and Waagepetersen, R. (2003). \emph{Statistical Inference and Simulation for Spatial Point Processes.} Chapman and Hall/CRC. } \author{ \adrian, based on original code for the Strauss process by Kasper Klitgaard Berthelsen. } \examples{ X <- rHardcore(0.05,1.5,square(50)) } \seealso{ \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.random]{rStrauss}}, \code{\link[spatstat.random]{rStraussHard}}, \code{\link[spatstat.random]{rDiggleGratton}}. \code{\link[spatstat.random]{rDGS}}, \code{\link[spatstat.random]{rPenttinen}}. For fitting the model, see \code{\link[spatstat.model]{Hardcore}}. } \keyword{spatial} \keyword{datagen} spatstat.random/man/runifpoint3.Rd0000644000176200001440000000237114510473067016730 0ustar liggesusers\name{runifpoint3} \alias{runifpoint3} \title{ Generate N Uniform Random Points in Three Dimensions } \description{ Generate a random point pattern containing \code{n} independent, uniform random points in three dimensions. } \usage{ runifpoint3(n, domain = box3(), nsim=1, drop=TRUE) } \arguments{ \item{n}{ Number of points to be generated. } \item{domain}{ Three-dimensional box in which the process should be generated. An object of class \code{"box3"}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ If \code{nsim = 1} and \code{drop=TRUE}, a point pattern in three dimensions (an object of class \code{"pp3"}). If \code{nsim > 1}, a list of such point patterns. } \details{ This function generates \code{n} independent random points, uniformly distributed in the three-dimensional box \code{domain}. } \seealso{ \code{\link{rpoispp3}}, \code{\link{pp3}}, \code{\link{box3}} } \examples{ X <- runifpoint3(50) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} \concept{Three-dimensional} spatstat.random/man/rpoisppx.Rd0000644000176200001440000000307314243054775016340 0ustar liggesusers\name{rpoisppx} \alias{rpoisppx} \title{ Generate Poisson Point Pattern in Any Dimensions } \description{ Generate a random multi-dimensional point pattern using the homogeneous Poisson process. } \usage{ rpoisppx(lambda, domain, nsim=1, drop=TRUE) } \arguments{ \item{lambda}{ Intensity of the Poisson process. A single positive number. } \item{domain}{ Multi-dimensional box in which the process should be generated. An object of class \code{"boxx"}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a single point pattern. } } \value{ If \code{nsim = 1} and \code{drop=TRUE}, a point pattern (an object of class \code{"ppx"}). If \code{nsim > 1} or \code{drop=FALSE}, a list of such point patterns. } \details{ This function generates a realisation of the homogeneous Poisson process in multi dimensions, with intensity \code{lambda} (points per unit volume). The realisation is generated inside the multi-dimensional region \code{domain} which currently must be a rectangular box (object of class \code{"boxx"}). } \note{ The intensity \code{lambda} is the expected number of points \emph{per unit volume}. } \seealso{ \code{\link{runifpointx}}, \code{\link{ppx}}, \code{\link{boxx}} } \examples{ w <- boxx(x=c(0,1), y=c(0,1), z=c(0,1), t=c(0,3)) X <- rpoisppx(10, w) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rcellnumber.Rd0000644000176200001440000000312714243054774016765 0ustar liggesusers\name{rcellnumber} \alias{rcellnumber} \title{ Generate Random Numbers of Points for Cell Process } \description{ Generates random integers for the Baddeley-Silverman counterexample. } \usage{ rcellnumber(n, N = 10, mu=1) } \arguments{ \item{n}{ Number of random integers to be generated. } \item{N}{ Distributional parameter: the largest possible value (when \code{mu <= 1}). An integer greater than 1. } \item{mu}{ Mean of the distribution (equals the variance). Any positive real number. } } \details{ If \code{mu = 1} (the default), this function generates random integers which have mean and variance equal to 1, but which do not have a Poisson distribution. The random integers take the values \eqn{0}, \eqn{1} and \eqn{N} with probabilities \eqn{1/N}, \eqn{(N-2)/(N-1)} and \eqn{1/(N(N-1))} respectively. See Baddeley and Silverman (1984). If \code{mu} is another positive number, the random integers will have mean and variance equal to \code{mu}. They are obtained by generating the one-dimensional counterpart of the cell process and counting the number of points in the interval from \code{0} to \code{mu}. The maximum possible value of each random integer is \code{N * ceiling(mu)}. } \value{ An integer vector of length \code{n}. } \references{ Baddeley, A.J. and Silverman, B.W. (1984) A cautionary example on the use of second-order methods for analyzing point patterns. \emph{Biometrics} \bold{40}, 1089-1094. } \author{ \spatstatAuthors. } \seealso{ \code{\link{rcell}} } \examples{ rcellnumber(30, 3) } \keyword{datagen} spatstat.random/man/rmpoint.Rd0000644000176200001440000002547114243054775016152 0ustar liggesusers\name{rmpoint} \alias{rmpoint} \title{Generate N Random Multitype Points} \description{ Generate a random multitype point pattern with a fixed number of points, or a fixed number of points of each type. } \usage{ rmpoint(n, f=1, fmax=NULL, win=unit.square(), types, ptypes, \dots, giveup=1000, verbose=FALSE, nsim=1, drop=TRUE) } \arguments{ \item{n}{ Number of marked points to generate. Either a single number specifying the total number of points, or a vector specifying the number of points of each type. } \item{f}{ The probability density of the multitype points, usually un-normalised. Either a constant, a vector, a function \code{f(x,y,m, ...)}, a pixel image, a list of functions \code{f(x,y,...)} or a list of pixel images. } \item{fmax}{ An upper bound on the values of \code{f}. If missing, this number will be estimated. } \item{win}{ Window in which to simulate the pattern. Ignored if \code{f} is a pixel image or list of pixel images. } \item{types}{ All the possible types for the multitype pattern. } \item{ptypes}{ Optional vector of probabilities for each type. } \item{\dots}{ Arguments passed to \code{f} if it is a function. } \item{giveup}{ Number of attempts in the rejection method after which the algorithm should stop trying to generate new points. } \item{verbose}{ Flag indicating whether to report details of performance of the simulation algorithm. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This function generates random multitype point patterns consisting of a fixed number of points. Three different models are available: \describe{ \item{I. Random location and type:}{ If \code{n} is a single number and the argument \code{ptypes} is missing, then \code{n} independent, identically distributed random multitype points are generated. Their locations \code{(x[i],y[i])} and types \code{m[i]} have joint probability density proportional to \eqn{f(x,y,m)}. } \item{II. Random type, and random location given type:}{ If \code{n} is a single number and \code{ptypes} is given, then \code{n} independent, identically distributed random multitype points are generated. Their types \code{m[i]} have probability distribution \code{ptypes}. Given the types, the locations \code{(x[i],y[i])} have conditional probability density proportional to \eqn{f(x,y,m)}. } \item{III. Fixed types, and random location given type:}{ If \code{n} is a vector, then we generate \code{n[i]} independent, identically distributed random points of type \code{types[i]}. For points of type \eqn{m} the conditional probability density of location \eqn{(x,y)} is proportional to \eqn{f(x,y,m)}. } } Note that the density \code{f} is normalised in different ways in Model I and Models II and III. In Model I the normalised joint density is \eqn{g(x,y,m)=f(x,y,m)/Z} where \deqn{ Z = \sum_m \int\int \lambda(x,y,m) {\rm d}x \, {\rm d}y }{ Z = sum_[m] integral lambda(x,y,m) dx dy } while in Models II and III the normalised conditional density is \eqn{g(x,y\mid m) = f(x,y,m)/Z_m}{g(x,y|m) = f(x,y,m)/Z[m]} where \deqn{ Z_m = \int\int \lambda(x,y,m) {\rm d}x \, {\rm d}y. }{ Z[m] = integral lambda(x,y,m) dx dy. } In Model I, the marginal distribution of types is \eqn{p_m = Z_m/Z}{p[m] = Z[m]/Z}. The unnormalised density \code{f} may be specified in any of the following ways. \describe{ \item{single number:}{ If \code{f} is a single number, the conditional density of location given type is uniform. That is, the points of each type are uniformly distributed. In Model I, the marginal distribution of types is also uniform (all possible types have equal probability). } \item{vector:}{ If \code{f} is a numeric vector, the conditional density of location given type is uniform. That is, the points of each type are uniformly distributed. In Model I, the marginal distribution of types is proportional to the vector \code{f}. In Model II, the marginal distribution of types is \code{ptypes}, that is, the values in \code{f} are ignored. The argument \code{types} defaults to \code{names(f)}, or if that is null, \code{1:length(f)}. } \item{function:}{ If \code{f} is a function, it will be called in the form \code{f(x,y,m,\dots)} at spatial location \code{(x,y)} for points of type \code{m}. In Model I, the joint probability density of location and type is proportional to \code{f(x,y,m,\dots)}. In Models II and III, the conditional probability density of location \code{(x,y)} given type \code{m} is proportional to \code{f(x,y,m,\dots)}. The function \code{f} must work correctly with vectors \code{x}, \code{y} and \code{m}, returning a vector of function values. (Note that \code{m} will be a factor with levels \code{types}.) The value \code{fmax} must be given and must be an upper bound on the values of \code{f(x,y,m,\dots)} for all locations \code{(x, y)} inside the window \code{win} and all types \code{m}. The argument \code{types} must be given. } \item{list of functions:}{ If \code{f} is a list of functions, then the functions will be called in the form \code{f[[i]](x,y,\dots)} at spatial location \code{(x,y)} for points of type \code{types[i]}. In Model I, the joint probability density of location and type is proportional to \code{f[[m]](x,y,\dots)}. In Models II and III, the conditional probability density of location \code{(x,y)} given type \code{m} is proportional to \code{f[[m]](x,y,\dots)}. The function \code{f[[i]]} must work correctly with vectors \code{x} and \code{y}, returning a vector of function values. The value \code{fmax} must be given and must be an upper bound on the values of \code{f[[i]](x,y,\dots)} for all locations \code{(x, y)} inside the window \code{win}. The argument \code{types} defaults to \code{names(f)}, or if that is null, \code{1:length(f)}. } \item{pixel image:}{ If \code{f} is a pixel image object of class \code{"im"} (see \code{\link{im.object}}), the unnormalised density at a location \code{(x,y)} for points of any type is equal to the pixel value of \code{f} for the pixel nearest to \code{(x,y)}. In Model I, the marginal distribution of types is uniform. The argument \code{win} is ignored; the window of the pixel image is used instead. The argument \code{types} must be given. } \item{list of pixel images:}{ If \code{f} is a list of pixel images, then the image \code{f[[i]]} determines the density values of points of type \code{types[i]}. The argument \code{win} is ignored; the window of the pixel image is used instead. The argument \code{types} defaults to \code{names(f)}, or if that is null, \code{1:length(f)}. } } The implementation uses the rejection method. For Model I, \code{\link{rmpoispp}} is called repeatedly until \code{n} points have been generated. It gives up after \code{giveup} calls if there are still fewer than \code{n} points. For Model II, the types are first generated according to \code{ptypes}, then the locations of the points of each type are generated using \code{\link{rpoint}}. For Model III, the locations of the points of each type are generated using \code{\link{rpoint}}. } \seealso{ \code{\link{ppp.object}}, \code{\link{owin.object}} } \examples{ abc <- c("a","b","c") ##### Model I rmpoint(25, types=abc) rmpoint(25, 1, types=abc) # 25 points, equal probability for each type, uniformly distributed locations rmpoint(25, function(x,y,m) {rep(1, length(x))}, types=abc) # same as above rmpoint(25, list(function(x,y){rep(1, length(x))}, function(x,y){rep(1, length(x))}, function(x,y){rep(1, length(x))}), types=abc) # same as above rmpoint(25, function(x,y,m) { x }, types=abc) # 25 points, equal probability for each type, # locations nonuniform with density proportional to x rmpoint(25, function(x,y,m) { ifelse(m == "a", 1, x) }, types=abc) rmpoint(25, list(function(x,y) { rep(1, length(x)) }, function(x,y) { x }, function(x,y) { x }), types=abc) # 25 points, UNEQUAL probabilities for each type, # type "a" points uniformly distributed, # type "b" and "c" points nonuniformly distributed. ##### Model II rmpoint(25, 1, types=abc, ptypes=rep(1,3)/3) rmpoint(25, 1, types=abc, ptypes=rep(1,3)) # 25 points, equal probability for each type, # uniformly distributed locations rmpoint(25, function(x,y,m) {rep(1, length(x))}, types=abc, ptypes=rep(1,3)) # same as above rmpoint(25, list(function(x,y){rep(1, length(x))}, function(x,y){rep(1, length(x))}, function(x,y){rep(1, length(x))}), types=abc, ptypes=rep(1,3)) # same as above rmpoint(25, function(x,y,m) { x }, types=abc, ptypes=rep(1,3)) # 25 points, equal probability for each type, # locations nonuniform with density proportional to x rmpoint(25, function(x,y,m) { ifelse(m == "a", 1, x) }, types=abc, ptypes=rep(1,3)) # 25 points, EQUAL probabilities for each type, # type "a" points uniformly distributed, # type "b" and "c" points nonuniformly distributed. ###### Model III rmpoint(c(12, 8, 4), 1, types=abc) # 12 points of type "a", # 8 points of type "b", # 4 points of type "c", # each uniformly distributed rmpoint(c(12, 8, 4), function(x,y,m) { ifelse(m=="a", 1, x)}, types=abc) rmpoint(c(12, 8, 4), list(function(x,y) { rep(1, length(x)) }, function(x,y) { x }, function(x,y) { x }), types=abc) # 12 points of type "a", uniformly distributed # 8 points of type "b", nonuniform # 4 points of type "c", nonuniform ######### ## Randomising an existing point pattern: # same numbers of points of each type, uniform random locations (Model III) rmpoint(table(marks(demopat)), 1, win=Window(demopat)) # same total number of points, distribution of types estimated from X, # uniform random locations (Model II) rmpoint(npoints(demopat), 1, types=levels(marks(demopat)), win=Window(demopat), ptypes=table(marks(demopat))) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/runifpoint.Rd0000644000176200001440000000753714452153612016652 0ustar liggesusers\name{runifpoint} \alias{runifpoint} \title{Generate N Uniform Random Points} \description{ Generate a random point pattern containing \eqn{n} independent uniform random points. } \usage{ runifpoint(n, win=owin(c(0,1),c(0,1)), giveup=1000, warn=TRUE, \dots, nsim=1, drop=TRUE, ex=NULL) } \arguments{ \item{n}{ Number of points. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. (Alternatively a tessellation; see the section on tessellations). } \item{giveup}{ Number of attempts in the rejection method after which the algorithm should stop trying to generate new points. } \item{warn}{ Logical. Whether to issue a warning if \code{n} is very large. See Details. } \item{\dots}{Ignored.} \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{ex}{ Optional. A point pattern to use as the example. If \code{ex} is given and \code{n} and \code{win} are missing, then \code{n} and \code{win} will be calculated from the point pattern \code{ex}. } } \value{ A point pattern (an object of class \code{"ppp"}) or a list of point patterns. } \details{ This function generates \code{n} independent random points, uniformly distributed in the window \code{win}. (For nonuniform distributions, see \code{\link{rpoint}}.) The algorithm depends on the type of window, as follows: \itemize{ \item If \code{win} is a rectangle then \eqn{n} independent random points, uniformly distributed in the rectangle, are generated by assigning uniform random values to their cartesian coordinates. \item If \code{win} is a binary image mask, then a random sequence of pixels is selected (using \code{\link{sample}}) with equal probabilities. Then for each pixel in the sequence we generate a uniformly distributed random point in that pixel. \item If \code{win} is a polygonal window, the algorithm uses the rejection method. It finds a rectangle enclosing the window, generates points in this rectangle, and tests whether they fall in the desired window. It gives up when \code{giveup * n} tests have been performed without yielding \code{n} successes. } The algorithm for binary image masks is faster than the rejection method but involves discretisation. If \code{warn=TRUE} (the default), a warning will be issued if \code{n} is very large. The threshold is \code{\link{spatstat.options}("huge.npoints")}. This warning has no consequences, but it helps to trap a number of common errors. } \section{Tessellation}{ The argument \code{win} may be a tessellation (object of class \code{"tess"}, see \code{\link{tess}}). Then the specified number of points \code{n} will be randomly generated inside each tile of the tessellation. The argument \code{n} may be either a single integer, or an integer vector specifying the number of points to be generated in each individual tile. The result will be a point pattern in the window \code{as.owin(win)}. } \seealso{ \code{\link{ppp.object}}, \code{\link{owin.object}}, \code{\link{rpoispp}}, \code{\link{rpoint}} } \examples{ # 100 random points in the unit square pp <- runifpoint(100) # irregular window letterR # polygonal pp <- runifpoint(100, letterR) # binary image mask pp <- runifpoint(100, as.mask(letterR)) # randomising an existing point pattern runifpoint(npoints(cells), win=Window(cells)) runifpoint(ex=cells) # tessellation A <- quadrats(unit.square(), 2, 3) # different numbers of points in each cell X <- runifpoint(1:6, A) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rMosaicField.Rd0000644000176200001440000000277714510473067017023 0ustar liggesusers\name{rMosaicField} \alias{rMosaicField} \title{Mosaic Random Field} \description{ Generate a realisation of a random field which is piecewise constant on the tiles of a given tessellation. } \usage{ rMosaicField(X, rgen = function(n) { sample(0:1, n, replace = TRUE)}, ..., rgenargs=NULL) } \arguments{ \item{X}{ A tessellation (object of class \code{"tess"}). } \item{\dots}{ Arguments passed to \code{\link{as.mask}} determining the pixel resolution. } \item{rgen}{ Function that generates random values for the tiles of the tessellation. } \item{rgenargs}{ List containing extra arguments that should be passed to \code{rgen} (typically specifying parameters of the distribution of the values). } } \details{ This function generates a realisation of a random field which is piecewise constant on the tiles of the given tessellation \code{X}. The values in each tile are independent and identically distributed. } \value{ A pixel image (object of class \code{"im"}). } \author{\adrian and \rolf} \seealso{ \code{\link{rpoislinetess}}, \code{\link{rMosaicSet}} } \examples{ if(interactive()) { lambda <- 3 d <- 256 n <- 30 } else { lambda <- 1 d <- 32 n <- 5 } X <- rpoislinetess(lambda) plot(rMosaicField(X, runif, dimyx=d)) plot(rMosaicField(X, rnorm, rgenargs=list(mean=10, sd=2), dimyx=d)) Y <- dirichlet(runifpoint(n)) plot(rMosaicField(Y, rnorm, dimyx=d)) } \keyword{spatial} \keyword{datagen} spatstat.random/man/rmhstart.Rd0000644000176200001440000000701114243054775016314 0ustar liggesusers\name{rmhstart} \alias{rmhstart} \alias{rmhstart.default} \title{Determine Initial State for Metropolis-Hastings Simulation.} \description{ Builds a description of the initial state for the Metropolis-Hastings algorithm. } \usage{ rmhstart(start, \dots) \method{rmhstart}{default}(start=NULL, \dots, n.start=NULL, x.start=NULL) } \arguments{ \item{start}{An existing description of the initial state in some format. Incompatible with the arguments listed below. } \item{\dots}{There should be no other arguments.} \item{n.start}{ Number of initial points (to be randomly generated). Incompatible with \code{x.start}. } \item{x.start}{ Initial point pattern configuration. Incompatible with \code{n.start}. } } \value{ An object of class \code{"rmhstart"}, which is essentially a list of parameters describing the initial point pattern and (optionally) the initial state of the random number generator. There is a \code{print} method for this class, which prints a sensible description of the initial state. } \details{ Simulated realisations of many point process models can be generated using the Metropolis-Hastings algorithm implemented in \code{\link{rmh}}. This function \code{rmhstart} creates a full description of the initial state of the Metropolis-Hastings algorithm, \emph{including possibly the initial state of the random number generator}, for use in a subsequent call to \code{\link{rmh}}. It also checks that the initial state is valid. The initial state should be specified \bold{either} by the first argument \code{start} \bold{or} by the other arguments \code{n.start}, \code{x.start} etc. If \code{start} is a list, then it should have components named \code{n.start} or \code{x.start}, with the same interpretation as described below. The arguments are: \describe{ \item{n.start}{ The number of \dQuote{initial} points to be randomly (uniformly) generated in the simulation window \code{w}. Incompatible with \code{x.start}. For a multitype point process, \code{n.start} may be a vector (of length equal to the number of types) giving the number of points of each type to be generated. If expansion of the simulation window is selected (see the argument \code{expand} to \code{\link{rmhcontrol}}), then the actual number of starting points in the simulation will be \code{n.start} multiplied by the expansion factor (ratio of the areas of the expanded window and original window). For faster convergence of the Metropolis-Hastings algorithm, the value of \code{n.start} should be roughly equal to (an educated guess at) the expected number of points for the point process inside the window. } \item{x.start}{ Initial point pattern configuration. Incompatible with \code{n.start}. \code{x.start} may be a point pattern (an object of class \code{ppp}), or an object which can be coerced to this class by \code{\link{as.ppp}}, or a dataset containing vectors \code{x} and \code{y}. If \code{x.start} is specified, then expansion of the simulation window (the argument \code{expand} of \code{\link{rmhcontrol}}) is not permitted. } } The parameters \code{n.start} and \code{x.start} are \emph{incompatible}. } \seealso{ \code{\link{rmh}}, \code{\link{rmhcontrol}}, \code{\link{rmhmodel}} } \examples{ # 30 random points a <- rmhstart(n.start=30) a # a particular point pattern b <- rmhstart(x.start=cells) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/domain.rmhmodel.Rd0000644000176200001440000000312614243054774017527 0ustar liggesusers\name{domain.rmhmodel} \alias{domain.rmhmodel} \title{ Extract the Domain of any Spatial Object } \description{ Given a spatial object such as a point pattern, in any number of dimensions, this function extracts the spatial domain in which the object is defined. } \usage{ \method{domain}{rmhmodel}(X, \dots) } \arguments{ \item{X}{ A spatial object such as a point pattern (in any number of dimensions), line segment pattern or pixel image. } \item{\dots}{ Extra arguments. They are ignored by all the methods listed here. } } \details{ The function \code{\link[spatstat.geom]{domain}} is generic. For a spatial object \code{X} in any number of dimensions, \code{domain(X)} extracts the spatial domain in which \code{X} is defined. For a two-dimensional object \code{X}, typically \code{domain(X)} is the same as \code{Window(X)}. Exceptions occur for methods related to linear networks. } \value{ A spatial object representing the domain of \code{X}. Typically a window (object of class \code{"owin"}), a three-dimensional box (\code{"box3"}), a multidimensional box (\code{"boxx"}) or a linear network (\code{"linnet"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link[spatstat.geom]{domain}}, \code{\link[spatstat.geom]{domain.quadratcount}}, \code{\link[spatstat.model]{domain.ppm}}, \code{\link[spatstat.explore]{domain.quadrattest}}, \code{\link[spatstat.linnet]{domain.lpp}}. \code{\link{Window}}, \code{\link{Frame}}. } \examples{ domain(rmhmodel(cif='poisson', par=list(beta=1), w=square(2))) } \keyword{spatial} \keyword{manip} spatstat.random/man/spatstat.random-package.Rd0000644000176200001440000004372214360500334021157 0ustar liggesusers\name{spatstat.random-package} \alias{spatstat.random-package} \alias{spatstat.random} \docType{package} \title{The spatstat.random Package} \description{ The \pkg{spatstat.random} package belongs to the \pkg{spatstat} family of packages. It contains the functionality for generating random spatial patterns and simulation of random point processes. } \details{ \pkg{spatstat} is a family of \R packages for the statistical analysis of spatial data. Its main focus is the analysis of spatial patterns of points in two-dimensional space. This sub-package \pkg{spatstat.random} contains the functions that perform random generation of spatial patterns and simulation of random point processes: \itemize{ \item generation of random spatial patterns of points according to many simple rules (completely random patterns, random grids, systematic random points); \item randomised alteration of spatial patterns (thinning, random shifting, jittering, random labelling); \item generation of quasirandom patterns; \item direct simulation of random point processes (Poisson process, binomial process, cell process, simple sequential inhibition, \Matern inhibition models, log-Gaussian Cox processes; \item simulation of Neyman-Scott cluster processes (truncated direct algorithm, Brix-Kendall and hybrid algorithms) and product shot noise cluster processes; \item simulation of Gibbs point processes (Metropolis-Hastings birth-death-shift algorithm, perfect simulation/ dominated coupling from the past, alternating Gibbs sampler). } Some other types of spatial object are also supported: \itemize{ \item generation of random patterns of points in 3 dimensions; \item generation of random spatial patterns of line segments; \item generation of random tessellations; \item generation of random images (random noise, random mosaics). } (Functions for linear networks are in the separate sub-package \pkg{spatstat.linnet}.) } \section{Structure of the spatstat family}{ The \pkg{spatstat} family of packages is designed to support a complete statistical analysis of spatial data. It supports \itemize{ \item creation, manipulation and plotting of point patterns; \item exploratory data analysis; \item spatial random sampling; \item simulation of point process models; \item parametric model-fitting; \item non-parametric smoothing and regression; \item formal inference (hypothesis tests, confidence intervals); \item model diagnostics. } The orginal \pkg{spatstat} package grew to be very large. It has now been divided into several \bold{sub-packages}: \itemize{ \item \pkg{spatstat.utils} containing basic utilities \item \pkg{spatstat.sparse} containing linear algebra utilities \item \pkg{spatstat.data} containing datasets \item \pkg{spatstat.geom} containing geometrical objects and geometrical operations \item \pkg{spatstat.random} containing functionality for simulation and random generation \item \pkg{spatstat.explore} containing the main functionality for exploratory data analysis and nonparametric analysis \item \pkg{spatstat.model} containing the main functionality for parametric modelling and formal inference for spatial data \item \pkg{spatstat.linnet} containing functions for spatial data on a linear network \item \pkg{spatstat}, which simply loads the other sub-packages listed above, and provides documentation. } When you install \pkg{spatstat}, these sub-packages are also installed. Then if you load the \pkg{spatstat} package by typing \code{library(spatstat)}, the other sub-packages listed above will automatically be loaded or imported. For an overview of all the functions available in the sub-packages of \pkg{spatstat}, see the help file for \code{"spatstat-package"} in the \pkg{spatstat} package. Additionally there are several \bold{extension packages:} \itemize{ \item \pkg{spatstat.gui} for interactive graphics \item \pkg{spatstat.local} for local likelihood (including geographically weighted regression) \item \pkg{spatstat.Knet} for additional, computationally efficient code for linear networks \item \pkg{spatstat.sphere} (under development) for spatial data on a sphere, including spatial data on the earth's surface } The extension packages must be installed separately and loaded explicitly if needed. They also have separate documentation. } \section{Functionality in \pkg{spatstat.random}}{ Following is a list of the functionality provided in the \pkg{spatstat.random} package only. \bold{To simulate a random point pattern:} \tabular{ll}{ \code{\link[spatstat.random]{runifpoint}} \tab generate \eqn{n} independent uniform random points \cr \code{\link[spatstat.random]{rpoint}} \tab generate \eqn{n} independent random points \cr \code{\link[spatstat.random]{rmpoint}} \tab generate \eqn{n} independent multitype random points \cr \code{\link[spatstat.random]{rpoispp}} \tab simulate the (in)homogeneous Poisson point process \cr \code{\link[spatstat.random]{rmpoispp}} \tab simulate the (in)homogeneous multitype Poisson point process \cr \code{\link[spatstat.random]{runifdisc}} \tab generate \eqn{n} independent uniform random points in disc\cr \code{\link[spatstat.random]{rstrat}} \tab stratified random sample of points \cr \code{\link[spatstat.random]{rMaternI}} \tab simulate the \Matern Model I inhibition process\cr \code{\link[spatstat.random]{rMaternII}} \tab simulate the \Matern Model II inhibition process\cr \code{\link[spatstat.random]{rSSI}} \tab simulate Simple Sequential Inhibition process\cr \code{\link[spatstat.random]{rStrauss}} \tab simulate Strauss process (perfect simulation)\cr \code{\link[spatstat.random]{rHardcore}} \tab simulate Hard Core process (perfect simulation)\cr \code{\link[spatstat.random]{rStraussHard}} \tab simulate Strauss-hard core process (perfect simulation)\cr \code{\link[spatstat.random]{rDiggleGratton}} \tab simulate Diggle-Gratton process (perfect simulation)\cr \code{\link[spatstat.random]{rDGS}} \tab simulate Diggle-Gates-Stibbard process (perfect simulation)\cr \code{\link[spatstat.random]{rPenttinen}} \tab simulate Penttinen process (perfect simulation)\cr \code{\link[spatstat.random]{rNeymanScott}} \tab simulate a general Neyman-Scott process\cr \code{\link[spatstat.random]{rPoissonCluster}} \tab simulate a general Poisson cluster process\cr \code{\link[spatstat.random]{rMatClust}} \tab simulate the \Matern Cluster process\cr \code{\link[spatstat.random]{rThomas}} \tab simulate the Thomas process \cr \code{\link[spatstat.random]{rGaussPoisson}} \tab simulate the Gauss-Poisson cluster process\cr \code{\link[spatstat.random]{rCauchy}} \tab simulate Neyman-Scott Cauchy cluster process \cr \code{\link[spatstat.random]{rVarGamma}} \tab simulate Neyman-Scott Variance Gamma cluster process \cr \code{\link[spatstat.random]{rthin}} \tab random thinning \cr \code{\link[spatstat.random]{rcell}} \tab simulate the Baddeley-Silverman cell process \cr \code{\link[spatstat.random]{rmh}} \tab simulate Gibbs point process using Metropolis-Hastings \cr \code{\link[spatstat.random]{runifpointOnLines}} \tab generate \eqn{n} random points along specified line segments \cr \code{\link[spatstat.random]{rpoisppOnLines}} \tab generate Poisson random points along specified line segments } \bold{To randomly change an existing point pattern:} \tabular{ll}{ \code{\link[spatstat.random]{rshift}} \tab random shifting of points \cr \code{\link[spatstat.random]{rthin}} \tab random thinning \cr \code{\link[spatstat.random]{rlabel}} \tab random (re)labelling of a multitype point pattern \cr \code{\link[spatstat.random]{quadratresample}} \tab block resampling } See also \code{\link[spatstat.geom]{rjitter}} and \code{\link[spatstat.geom]{rexplode}} in the \pkg{spatstat.geom} package. \bold{Random pixel images:} An object of class \code{"im"} represents a pixel image. \tabular{ll}{ \code{\link[spatstat.random]{rnoise}} \tab random pixel noise } \bold{Line segment patterns} An object of class \code{"psp"} represents a pattern of straight line segments. \tabular{ll}{ \code{\link[spatstat.random]{rpoisline}} \tab generate a realisation of the Poisson line process inside a window } \bold{Tessellations} An object of class \code{"tess"} represents a tessellation. \tabular{ll}{ \code{\link[spatstat.random]{rpoislinetess}} \tab generate tessellation using Poisson line process } \bold{Three-dimensional point patterns} An object of class \code{"pp3"} represents a three-dimensional point pattern in a rectangular box. The box is represented by an object of class \code{"box3"}. \tabular{ll}{ \code{\link[spatstat.random]{runifpoint3}} \tab generate uniform random points in 3-D \cr \code{\link[spatstat.random]{rpoispp3}} \tab generate Poisson random points in 3-D \cr } \bold{Multi-dimensional space-time point patterns} An object of class \code{"ppx"} represents a point pattern in multi-dimensional space and/or time. \tabular{ll}{ \code{\link[spatstat.random]{runifpointx}} \tab generate uniform random points \cr \code{\link[spatstat.random]{rpoisppx}} \tab generate Poisson random points } \bold{Probability Distributions} \tabular{ll}{ \code{\link[spatstat.random]{rknn}} \tab theoretical distribution of nearest neighbour distance \cr \code{\link[spatstat.random]{dmixpois}} \tab mixed Poisson distribution \cr } \bold{Simulation} There are many ways to generate a random point pattern, line segment pattern, pixel image or tessellation in \pkg{spatstat}. \bold{Random point patterns:} \tabular{ll}{ \code{\link[spatstat.random]{runifpoint}} \tab generate \eqn{n} independent uniform random points \cr \code{\link[spatstat.random]{rpoint}} \tab generate \eqn{n} independent random points \cr \code{\link[spatstat.random]{rmpoint}} \tab generate \eqn{n} independent multitype random points \cr \code{\link[spatstat.random]{rpoispp}} \tab simulate the (in)homogeneous Poisson point process \cr \code{\link[spatstat.random]{rmpoispp}} \tab simulate the (in)homogeneous multitype Poisson point process \cr \code{\link[spatstat.random]{runifdisc}} \tab generate \eqn{n} independent uniform random points in disc\cr \code{\link[spatstat.random]{rstrat}} \tab stratified random sample of points \cr \code{\link[spatstat.random]{rMaternI}} \tab simulate the \Matern Model I inhibition process\cr \code{\link[spatstat.random]{rMaternII}} \tab simulate the \Matern Model II inhibition process\cr \code{\link[spatstat.random]{rSSI}} \tab simulate Simple Sequential Inhibition process\cr \code{\link[spatstat.random]{rHardcore}} \tab simulate hard core process (perfect simulation)\cr \code{\link[spatstat.random]{rStrauss}} \tab simulate Strauss process (perfect simulation)\cr \code{\link[spatstat.random]{rStraussHard}} \tab simulate Strauss-hard core process (perfect simulation)\cr \code{\link[spatstat.random]{rDiggleGratton}} \tab simulate Diggle-Gratton process (perfect simulation)\cr \code{\link[spatstat.random]{rDGS}} \tab simulate Diggle-Gates-Stibbard process (perfect simulation)\cr \code{\link[spatstat.random]{rPenttinen}} \tab simulate Penttinen process (perfect simulation)\cr \code{\link[spatstat.random]{rNeymanScott}} \tab simulate a general Neyman-Scott process\cr \code{\link[spatstat.random]{rMatClust}} \tab simulate the \Matern Cluster process\cr \code{\link[spatstat.random]{rThomas}} \tab simulate the Thomas process \cr \code{\link[spatstat.random]{rLGCP}} \tab simulate the log-Gaussian Cox process \cr \code{\link[spatstat.random]{rGaussPoisson}} \tab simulate the Gauss-Poisson cluster process\cr \code{\link[spatstat.random]{rCauchy}} \tab simulate Neyman-Scott process with Cauchy clusters \cr \code{\link[spatstat.random]{rVarGamma}} \tab simulate Neyman-Scott process with Variance Gamma clusters \cr \code{\link[spatstat.random]{rcell}} \tab simulate the Baddeley-Silverman cell process \cr \code{\link[spatstat.random]{runifpointOnLines}} \tab generate \eqn{n} random points along specified line segments \cr \code{\link[spatstat.random]{rpoisppOnLines}} \tab generate Poisson random points along specified line segments } \bold{Resampling a point pattern:} \tabular{ll}{ \code{\link[spatstat.random]{quadratresample}} \tab block resampling \cr \code{\link[spatstat.random]{rshift}} \tab random shifting of (subsets of) points\cr \code{\link[spatstat.random]{rthin}} \tab random thinning } \bold{Other random patterns:} \tabular{ll}{ \code{\link[spatstat.random]{rpoisline}} \tab simulate the Poisson line process within a window \cr \code{\link[spatstat.random]{rpoislinetess}} \tab generate random tessellation using Poisson line process \cr \code{\link[spatstat.random]{rMosaicSet}} \tab generate random set by selecting some tiles of a tessellation \cr \code{\link[spatstat.random]{rMosaicField}} \tab generate random pixel image by assigning random values in each tile of a tessellation } \bold{Resampling and randomisation procedures} You can build your own tests based on randomisation and resampling using the following capabilities: \tabular{ll}{ \code{\link[spatstat.random]{quadratresample}} \tab block resampling \cr \code{\link[spatstat.random]{rshift}} \tab random shifting of (subsets of) points\cr \code{\link[spatstat.random]{rthin}} \tab random thinning } } \section{Licence}{ This library and its documentation are usable under the terms of the "GNU General Public License", a copy of which is distributed with the package. } \author{ \spatstatAuthors. } \section{Acknowledgements}{ Kasper Klitgaard Berthelsen, Ya-Mei Chang, Tilman Davies, Ute Hahn, Abdollah Jalilian, Dominic Schuhmacher and Rasmus Waagepetersen made substantial contributions of code. For comments, corrections, bug alerts and suggestions, we thank Monsuru Adepeju, Corey Anderson, Ang Qi Wei, Ryan Arellano, Jens \ifelse{latex}{\out{{\AA}str{\" o}m}}{Astrom}, Robert Aue, Marcel Austenfeld, Sandro Azaele, Malissa Baddeley, Guy Bayegnak, Colin Beale, Melanie Bell, Thomas Bendtsen, Ricardo Bernhardt, Andrew Bevan, Brad Biggerstaff, Anders Bilgrau, Leanne Bischof, Christophe Biscio, Roger Bivand, Jose M. Blanco Moreno, Florent Bonneu, Jordan Brown, Ian Buller, Julian Burgos, Simon Byers, Ya-Mei Chang, Jianbao Chen, Igor Chernayavsky, Y.C. Chin, Bjarke Christensen, \ifelse{latex}{\out{Luc\'{\i{}}a}}{Lucia} Cobo Sanchez, Jean-Francois Coeurjolly, Kim Colyvas, Hadrien Commenges, Rochelle Constantine, Robin Corria Ainslie, Richard Cotton, Marcelino de la Cruz, Peter Dalgaard, Mario D'Antuono, Sourav Das, Peter Diggle, Patrick Donnelly, Ian Dryden, Stephen Eglen, Ahmed El-Gabbas, Belarmain Fandohan, Olivier Flores, David Ford, Peter Forbes, Shane Frank, Janet Franklin, Funwi-Gabga Neba, Oscar Garcia, Agnes Gault, Jonas Geldmann, Marc Genton, Shaaban Ghalandarayeshi, Jason Goldstick, Pavel Grabarnik, C. Graf, Ute Hahn, Andrew Hardegen, Martin \Bogsted Hansen, Martin Hazelton, Juha Heikkinen, Mandy Hering, Markus Herrmann, Maximilian Hesselbarth, Paul Hewson, Hamidreza Heydarian, Kurt Hornik, Philipp Hunziker, Jack Hywood, Ross Ihaka, \ifelse{latex}{\out{\u{C}enk I\c{c}\"{o}s}}{Cenk Icos}, Aruna Jammalamadaka, Robert John-Chandran, Devin Johnson, Mahdieh Khanmohammadi, Bob Klaver, Lily Kozmian-Ledward, Peter Kovesi, Mike Kuhn, Jeff Laake, Robert Lamb, \ifelse{latex}{\out{Fr\'{e}d\'{e}ric}}{Frederic} Lavancier, Tom Lawrence, Tomas Lazauskas, Jonathan Lee, George Leser, Angela Li, Li Haitao, George Limitsios, Andrew Lister, Nestor Luambua, Ben Madin, Martin Maechler, Kiran Marchikanti, Jeff Marcus, Robert Mark, Peter McCullagh, Monia Mahling, Jorge Mateu Mahiques, Ulf Mehlig, Frederico Mestre, Sebastian Wastl Meyer, Mi Xiangcheng, Lore De Middeleer, Robin Milne, Enrique Miranda, Jesper \Moller, Annie \ifelse{latex}{\out{Molli{\'e}}}{Mollie}, Ines Moncada, Mehdi Moradi, Virginia Morera Pujol, Erika Mudrak, Gopalan Nair, Nader Najari, Nicoletta Nava, Linda Stougaard Nielsen, Felipe Nunes, Jens Randel Nyengaard, Jens \Oehlschlaegel, Thierry Onkelinx, Sean O'Riordan, Evgeni Parilov, Jeff Picka, Nicolas Picard, Tim Pollington, Mike Porter, Sergiy Protsiv, Adrian Raftery, Ben Ramage, Pablo Ramon, Xavier Raynaud, Nicholas Read, Matt Reiter, Ian Renner, Tom Richardson, Brian Ripley, Ted Rosenbaum, Barry Rowlingson, Jason Rudokas, Tyler Rudolph, John Rudge, Christopher Ryan, Farzaneh Safavimanesh, Aila \Sarkka, Cody Schank, Katja Schladitz, Sebastian Schutte, Bryan Scott, Olivia Semboli, \ifelse{latex}{\out{Fran\c{c}ois S\'{e}m\'{e}curbe}}{Francois Semecurbe}, Vadim Shcherbakov, Shen Guochun, Shi Peijian, Harold-Jeffrey Ship, Tammy L Silva, Ida-Maria Sintorn, Yong Song, Malte Spiess, Mark Stevenson, Kaspar Stucki, Jan Sulavik, Michael Sumner, P. Surovy, Ben Taylor, Thordis Linda Thorarinsdottir, Leigh Torres, Berwin Turlach, Torben Tvedebrink, Kevin Ummer, Medha Uppala, Andrew van Burgel, Tobias Verbeke, Mikko Vihtakari, Alexendre Villers, Fabrice Vinatier, Maximilian Vogtland, Sasha Voss, Sven Wagner, Hao Wang, H. Wendrock, Jan Wild, Carl G. Witthoft, Selene Wong, Maxime Woringer, Luke Yates, Mike Zamboni and Achim Zeileis. } \keyword{spatial} \keyword{package} spatstat.random/man/macros/0000755000176200001440000000000014243056433015437 5ustar liggesusersspatstat.random/man/macros/defns.Rd0000644000176200001440000001167714510473067017044 0ustar liggesusers%% macro definitions for spatstat man pages %% Authors \newcommand{\adrian}{Adrian Baddeley \email{Adrian.Baddeley@curtin.edu.au}} \newcommand{\rolf}{Rolf Turner \email{rolfturner@posteo.net}} \newcommand{\ege}{Ege Rubak \email{rubak@math.aau.dk}} \newcommand{\spatstatAuthors}{\adrian, \rolf and \ege} \newcommand{\spatstatAuthorsComma}{\adrian, \rolf, \ege} %% Contributors with emails \newcommand{\pavel}{Pavel Grabarnik \email{pavel.grabar@issp.serpukhov.su}} \newcommand{\dominic}{Dominic Schuhmacher \email{dominic.schuhmacher@mathematik.uni-goettingen.de}, URL \code{http://dominic.schuhmacher.name/}} \newcommand{\wei}{Ang Qi Wei \email{aqw07398@hotmail.com}} \newcommand{\colette}{Marie-Colette van Lieshout \email{Marie-Colette.van.Lieshout@cwi.nl}} \newcommand{\rasmus}{Rasmus Plenge Waagepetersen \email{rw@math.auc.dk}} \newcommand{\abdollah}{Abdollah Jalilian \email{jalilian@razi.ac.ir}} \newcommand{\ottmar}{Ottmar Cronie \email{ottmar@chalmers.se}} \newcommand{\stephenEglen}{Stephen Eglen \email{S.J.Eglen@damtp.cam.ac.uk}} \newcommand{\mehdi}{Mehdi Moradi \email{m2.moradi@yahoo.com}} \newcommand{\yamei}{Ya-Mei Chang \email{yamei628@gmail.com}} \newcommand{\martinH}{Martin Hazelton \email{Martin.Hazelton@otago.ac.nz}} \newcommand{\tilman}{Tilman Davies \email{Tilman.Davies@otago.ac.nz}} % Names with accents \newcommand{\Bogsted}{\ifelse{latex}{\out{B\o gsted}}{Bogsted}} \newcommand{\Cramer}{\ifelse{latex}{\out{Cram\'er}}{Cramer}} \newcommand{\Francois}{\ifelse{latex}{\out{Fran\c{c}ois}}{Francois}} \newcommand{\Frederic}{\ifelse{latex}{\out{Fr{\'e}d{\'e}ric}}{Frederic}} \newcommand{\Hogmander}{\ifelse{latex}{\out{H{\"o}gmander}}{Hogmander}} \newcommand{\Jyvaskyla}{\ifelse{latex}{\out{Jyv\"askyl\"a}}{Jyvaskyla}} \newcommand{\Lucia}{\ifelse{latex}{\out{Luc\'{\i{}}a}}{Lucia}} \newcommand{\Matern}{\ifelse{latex}{\out{Mat\'ern}}{Matern}} \newcommand{\Moller}{\ifelse{latex}{\out{M\o ller}}{Moller}} \newcommand{\Oehlschlaegel}{\ifelse{latex}{\out{Oehlschl\"{a}gel}}{Oehlschlaegel}} \newcommand{\Prokesova}{\ifelse{latex}{\out{Proke\u{s}ov{\'{a}}}}{Prokesova}} \newcommand{\Sarkka}{\ifelse{latex}{\out{S\"{a}rkk\"{a}}}{Sarkka}} \newcommand{\Sanchez}{\ifelse{latex}{\out{S\'{a}nchez}}{Sanchez}} \newcommand{\Martin}{\ifelse{latex}{\out{Mart\'{\i}n}}{Martin}} \newcommand{\Dominguez}{\ifelse{latex}{\out{Dom\'{\i}nguez}}{Dominguez}} \newcommand{\Rodriguez}{\ifelse{latex}{\out{Rodr\'{\i}guez}}{Rodriguez}} \newcommand{\Gonzalez}{\ifelse{latex}{\out{Gonz\'{a}lez}}{Gonzalez}} %% List of all Gibbs interactions \newcommand{\GibbsInteractionsList}{\code{\link[spatstat.model]{AreaInter}}, \code{\link[spatstat.model]{BadGey}}, \code{\link[spatstat.model]{Concom}}, \code{\link[spatstat.model]{DiggleGatesStibbard}}, \code{\link[spatstat.model]{DiggleGratton}}, \code{\link[spatstat.model]{Fiksel}}, \code{\link[spatstat.model]{Geyer}}, \code{\link[spatstat.model]{Hardcore}}, \code{\link[spatstat.model]{HierHard}}, \code{\link[spatstat.model]{HierStrauss}}, \code{\link[spatstat.model]{HierStraussHard}}, \code{\link[spatstat.model]{Hybrid}}, \code{\link[spatstat.model]{LennardJones}}, \code{\link[spatstat.model]{MultiHard}}, \code{\link[spatstat.model]{MultiStrauss}}, \code{\link[spatstat.model]{MultiStraussHard}}, \code{\link[spatstat.model]{OrdThresh}}, \code{\link[spatstat.model]{Ord}}, \code{\link[spatstat.model]{Pairwise}}, \code{\link[spatstat.model]{PairPiece}}, \code{\link[spatstat.model]{Penttinen}}, \code{\link[spatstat.model]{Poisson}}, \code{\link[spatstat.model]{Saturated}}, \code{\link[spatstat.model]{SatPiece}}, \code{\link[spatstat.model]{Softcore}}, \code{\link[spatstat.model]{Strauss}}, \code{\link[spatstat.model]{StraussHard}} and \code{\link[spatstat.model]{Triplets}}} %% List of interactions recognised by RMH code \newcommand{\rmhInteractionsList}{\code{\link[spatstat.model]{AreaInter}}, \code{\link[spatstat.model]{BadGey}}, \code{\link[spatstat.model]{DiggleGatesStibbard}}, \code{\link[spatstat.model]{DiggleGratton}}, \code{\link[spatstat.model]{Fiksel}}, \code{\link[spatstat.model]{Geyer}}, \code{\link[spatstat.model]{Hardcore}}, \code{\link[spatstat.model]{Hybrid}}, \code{\link[spatstat.model]{LennardJones}}, \code{\link[spatstat.model]{MultiStrauss}}, \code{\link[spatstat.model]{MultiStraussHard}}, \code{\link[spatstat.model]{PairPiece}}, \code{\link[spatstat.model]{Penttinen}}, \code{\link[spatstat.model]{Poisson}}, \code{\link[spatstat.model]{Softcore}}, \code{\link[spatstat.model]{Strauss}}, \code{\link[spatstat.model]{StraussHard}} and \code{\link[spatstat.model]{Triplets}}} %% Frequent references \newcommand{\baddrubaturnbook}{Baddeley, A., Rubak, E. and Turner, R. (2015) \emph{Spatial Point Patterns: Methodology and Applications with R}. Chapman and Hall/CRC Press. } %% Citations of recent articles that will change rapidly \newcommand{\baddchangclustersim}{Baddeley, A. and Chang, Y.-M. (2023) Robust algorithms for simulating cluster point processes. \emph{Journal of Statistical Computation and Simulation}. In Press. DOI \code{10.1080/00949655.2023.2166045}.} spatstat.random/man/rLGCP.Rd0000644000176200001440000001621114514624426015356 0ustar liggesusers\name{rLGCP} \alias{rLGCP} \title{Simulate Log-Gaussian Cox Process} \description{ Generate a random point pattern, a realisation of the log-Gaussian Cox process. } \usage{ rLGCP(model=c("exponential", "gauss", "stable", "gencauchy", "matern"), mu = 0, param = NULL, \dots, win=NULL, saveLambda=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{model}{ character string (partially matched) giving the name of a covariance model for the Gaussian random field. } \item{mu}{ mean function of the Gaussian random field. Either a single number, a \code{function(x,y, ...)} or a pixel image (object of class \code{"im"}). } \item{param}{ List of parameters for the covariance. Standard arguments are \code{var} and \code{scale}. } \item{\dots}{ Additional parameters for the covariance, or arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"}. } \item{saveLambda}{ Logical. If \code{TRUE} (the default) then the simulated random intensity will also be saved, and returns as an attribute of the point pattern. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (object of class \code{"ppp"}) or a list of point patterns. Additionally, the simulated intensity function for each point pattern is returned as an attribute \code{"Lambda"} of the point pattern, if \code{saveLambda=TRUE}. } \details{ This function generates a realisation of a log-Gaussian Cox process (LGCP). This is a Cox point process in which the logarithm of the random intensity is a Gaussian random field with mean function \eqn{\mu} and covariance function \eqn{c(r)}. Conditional on the random intensity, the point process is a Poisson process with this intensity. The string \code{model} specifies the covariance function of the Gaussian random field, and the parameters of the covariance are determined by \code{param} and \code{\dots}. All models recognise the parameters \code{var} for the variance at distance zero, and \code{scale} for the scale parameter. Some models require additional parameters which are listed below. The available models are as follows: \describe{ \item{\code{model="exponential"}:}{ the exponential covariance function \deqn{C(r) = \sigma^2 \exp(-r/h)}{C(r) = sigma^2 * exp(-r/h)} where \eqn{\sigma^2} is the variance parameter \code{var}, and \eqn{h} is the scale parameter \code{scale}. } \item{\code{model="gauss"}:}{ the Gaussian covariance function \deqn{C(r) = \sigma^2 \exp(-(r/h)^2)}{C(r) = sigma^2 * exp(-(r/h)^2)} where \eqn{\sigma^2} is the variance parameter \code{var}, and \eqn{h} is the scale parameter \code{scale}. } \item{\code{model="stable"}:}{ the stable covariance function \deqn{ C(r) = \sigma^2 \exp(-(r/h)^\alpha) }{ C(r) = sigma^2 * exp(-(r/h)^alpha) } where \eqn{\sigma^2} is the variance parameter \code{var}, \eqn{h} is the scale parameter \code{scale}, and \eqn{\alpha} is the shape parameter \code{alpha}. The parameter \code{alpha} must be given, either as a stand-alone argument, or as an entry in the list \code{param}. } \item{\code{model="gencauchy"}:}{ the generalised Cauchy covariance function \deqn{ C(r) = \sigma^2 (1 + (x/h)^\alpha)^{-\beta/\alpha} }{ C(r) = sigma^2 * (1 + (x/h)^\alpha)^(-\beta/\alpha) } where \eqn{\sigma^2} is the variance parameter \code{var}, \eqn{h} is the scale parameter \code{scale}, and \eqn{\alpha} and \eqn{\beta} are the shape parameters \code{alpha} and \code{beta}. The parameters \code{alpha} and \code{beta} must be given, either as stand-alone arguments, or as entries in the list \code{param}. } \item{\code{model="matern"}:}{ the Whittle-\Matern covariance function \deqn{ C(r) = \sigma^2 \frac{1}{2^{\nu-1} \Gamma(\nu)} (\sqrt{2 \nu} \, r/h)^\nu K_\nu(\sqrt{2\nu}\, r/h) }{ C(r) = \sigma^2 * 2^(1-\nu) * \Gamma(\nu)^(-1) * (sqrt(2 *\nu) * r/h)^\nu * K[\nu](sqrt(2 * nu) * r/h) } where \eqn{\sigma^2} is the variance parameter \code{var}, \eqn{h} is the scale parameter \code{scale}, and \eqn{\nu} is the shape parameter \code{nu}. The parameter \code{nu} must be given, either as a stand-alone argument, or as an entry in the list \code{param}. } } The algorithm uses the circulant embedding technique to generate values of a Gaussian random field, with the specified mean function \code{mu} and the covariance specified by the arguments \code{model} and \code{param}, on the points of a regular grid. The exponential of this random field is taken as the intensity of a Poisson point process, and a realisation of the Poisson process is then generated by the function \code{\link[spatstat.random]{rpoispp}} in the \pkg{spatstat.random} package. If the simulation window \code{win} is missing or \code{NULL}, then it defaults to \code{Window(mu)} if \code{mu} is a pixel image, and it defaults to the unit square otherwise. The LGCP model can be fitted to data using \code{\link[spatstat.model]{kppm}}. } \section{Warning: new implementation}{ The simulation algorithm for \code{rLGCP} has been completely re-written in \pkg{spatstat.random} version \code{3.2-0} to avoid depending on the package \pkg{RandomFields} which is now defunct (and is sadly missed). It is no longer possible to replicate results that were obtained using \code{rLGCP} in previous versions of \pkg{spatstat.random}. The current code is a new implementation and should be considered vulnerable to new bugs. } \seealso{ \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rGaussPoisson}}, \code{\link[spatstat.random]{rNeymanScott}}. For fitting the model, see \code{\link[spatstat.model]{kppm}}, \code{\link[spatstat.model]{lgcp.estK}}. } \references{ \Moller, J., Syversveen, A. and Waagepetersen, R. (1998) Log Gaussian Cox Processes. \emph{Scandinavian Journal of Statistics} \bold{25}, 451--482. } \examples{ online <- interactive() # homogeneous LGCP with exponential covariance function X <- rLGCP("exp", 3, var=0.2, scale=.1) # inhomogeneous LGCP with Gaussian covariance function m <- as.im(function(x, y){5 - 1.5 * (x - 0.5)^2 + 2 * (y - 0.5)^2}, W=owin()) X <- rLGCP("gauss", m, var=0.15, scale =0.1) if(online) { plot(attr(X, "Lambda")) points(X) } # inhomogeneous LGCP with Matern covariance function X <- rLGCP("matern", function(x, y){ 1 - 0.4 * x}, var=2, scale=0.7, nu=0.5, win = owin(c(0, 10), c(0, 10))) if(online) plot(X) } \author{Abdollah Jalilian and Rasmus Waagepetersen. Modified by \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/runifpointOnLines.Rd0000644000176200001440000000376214243054775020146 0ustar liggesusers\name{runifpointOnLines} \alias{runifpointOnLines} \title{Generate N Uniform Random Points On Line Segments} \description{ Given a line segment pattern, generate a random point pattern consisting of \code{n} points uniformly distributed on the line segments. } \usage{ runifpointOnLines(n, L, nsim=1, drop=TRUE) } \arguments{ \item{n}{Number of points to generate.} \item{L}{Line segment pattern (object of class \code{"psp"}) on which the points should lie. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This command generates a point pattern consisting of \code{n} independent random points, each point uniformly distributed on the line segment pattern. This means that, for each random point, \itemize{ \item the probability of falling on a particular segment is proportional to the length of the segment; and \item given that the point falls on a particular segment, it has uniform probability density along that segment. } If \code{n} is a single integer, the result is an unmarked point pattern containing \code{n} points. If \code{n} is a vector of integers, the result is a marked point pattern, with \code{m} different types of points, where \code{m = length(n)}, in which there are \code{n[j]} points of type \code{j}. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}) with the same window as \code{L}. If \code{nsim > 1}, a list of point patterns. } \seealso{ \code{\link{psp}}, \code{\link{ppp}}, \code{\link{pointsOnLines}}, \code{\link{runifpoint}} } \examples{ X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) Y <- runifpointOnLines(20, X) plot(X, main="") plot(Y, add=TRUE) Z <- runifpointOnLines(c(5,5), X) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rjitter.psp.Rd0000644000176200001440000000433214243054775016737 0ustar liggesusers\name{rjitter.psp} \alias{rjitter.psp} \title{Random Perturbation of Line Segment Pattern} \description{ Randomly pertubs a spatial pattern of line segments by applying independent random displacements to the segment endpoints. } \usage{ \method{rjitter}{psp}(X, radius, \dots, clip=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{X}{ A point pattern on a linear network (object of class \code{"psp"}). } \item{radius}{ Scale of perturbations. A positive numerical value. Each point will be displaced by a random distance, with maximum displacement equal to this value. } \item{\dots}{ Ignored. } \item{clip}{ Logical value specifying what to do if segments cross the boundary of the window. See Details. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a spatial pattern of line segments (class \code{"psp"}) rather than a list of length 1 containing this pattern. } } \details{ The function \code{\link[spatstat.geom]{rjitter}} is generic. This function is the method for the class \code{"psp"} of line segment patterns. Each of the endpoints of each segment in \code{X} will be subjected to an independent random displacement. The displacement vectors are uniformly distributed in a circle of radius \code{radius}. If \code{clip=TRUE} (the default), segment endpoints are permitted to move to locations slightly outside the window of \code{X}, and the resulting segments will be clipped to the window. If \code{clip=FALSE}, segment endpoints are conditioned to fall inside the window. If \code{nsim=1} and \code{drop=TRUE}, the result is another spatial pattern of line segments (object of class \code{"psp"}). Otherwise, the result is a list of \code{nsim} line segment patterns. } \value{ A spatial pattern of line segments (object of class \code{"psp"}) or a list of such patterns. } \author{ \spatstatAuthors. } \seealso{ \code{\link[spatstat.geom]{rjitter}} for point patterns in two dimensions. } \examples{ E <- edges(letterR) Window(E) <- owin(c(1.9, 4.1), c(0.5, 3.5)) plot(rjitter(E, 0.1)) } \keyword{spatial} \keyword{datagen} spatstat.random/man/rMaternI.Rd0000644000176200001440000000455214243054775016200 0ustar liggesusers\name{rMaternI} \alias{rMaternI} \title{Simulate Matern Model I} \description{ Generate a random point pattern, a simulated realisation of the \Matern Model I inhibition process model. } \usage{ rMaternI(kappa, r, win = owin(c(0,1),c(0,1)), stationary=TRUE, \dots, nsim=1, drop=TRUE) } \arguments{ \item{kappa}{ Intensity of the Poisson process of proposal points. A single positive number. } \item{r}{ Inhibition distance. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. Alternatively a higher-dimensional box of class \code{"box3"} or \code{"boxx"}. } \item{stationary}{ Logical. Whether to start with a stationary process of proposal points (\code{stationary=TRUE}) or to generate the proposal points only inside the window (\code{stationary=FALSE}). } \item{\dots}{Ignored.} \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Each point pattern is normally an object of class \code{"ppp"}, but may be of class \code{"pp3"} or \code{"ppx"} depending on the window. } \details{ This algorithm generates one or more realisations of \Matern's Model I inhibition process inside the window \code{win}. The process is constructed by first generating a uniform Poisson point process of ``proposal'' points with intensity \code{kappa}. If \code{stationary = TRUE} (the default), the proposal points are generated in a window larger than \code{win} that effectively means the proposals are stationary. If \code{stationary=FALSE} then the proposal points are only generated inside the window \code{win}. A proposal point is then deleted if it lies within \code{r} units' distance of another proposal point. Otherwise it is retained. The retained points constitute \Matern's Model I. } \seealso{ \code{\link{rpoispp}}, \code{\link{rMatClust}} } \examples{ X <- rMaternI(20, 0.05) Y <- rMaternI(20, 0.05, stationary=FALSE) } \author{ \adrian , Ute Hahn, \rolf and \ege } \keyword{spatial} \keyword{datagen} spatstat.random/man/is.stationary.Rd0000644000176200001440000000471414243054774017265 0ustar liggesusers\name{is.stationary} \alias{is.stationary} \alias{is.stationary.rmhmodel} \alias{is.poisson} \alias{is.poisson.rmhmodel} \title{ Recognise Stationary and Poisson Point Process Models } \description{ Given a point process model (either a model that has been fitted to data, or a model specified by its parameters), determine whether the model is a stationary point process, and whether it is a Poisson point process. } \usage{ is.stationary(x) \method{is.stationary}{rmhmodel}(x) is.poisson(x) \method{is.poisson}{rmhmodel}(x) } \arguments{ \item{x}{ A fitted spatial point process model (object of class \code{"ppm"}, \code{"kppm"}, \code{"lppm"}, \code{"dppm"} or \code{"slrm"}) or a specification of a Gibbs point process model (object of class \code{"rmhmodel"}) or a similar object. } } \details{ The argument \code{x} represents a fitted spatial point process model or a similar object. \code{is.stationary(x)} returns \code{TRUE} if \code{x} represents a stationary point process, and \code{FALSE} if not. \code{is.poisson(x)} returns \code{TRUE} if \code{x} represents a Poisson point process, and \code{FALSE} if not. The functions \code{is.stationary} and \code{is.poisson} are generic, with methods for the classes \code{"ppm"} (Gibbs point process models), \code{"kppm"} (cluster or Cox point process models), \code{"slrm"} (spatial logistic regression models) and \code{"rmhmodel"} (model specifications for the Metropolis-Hastings algorithm). Additionally \code{is.stationary} has a method for classes \code{"detpointprocfamily"} and \code{"dppm"} (both determinantal point processes) and \code{is.poisson} has a method for class \code{"interact"} (interaction structures for Gibbs models). \code{is.poisson.kppm} will return \code{FALSE}, unless the model \code{x} is degenerate: either \code{x} has zero intensity so that its realisations are empty with probability 1, or it is a log-Gaussian Cox process where the log intensity has zero variance. \code{is.poisson.slrm} will always return \code{TRUE}, by convention. } \value{ A logical value. } \author{ \spatstatAuthors. } \seealso{ \code{\link{is.marked}} to determine whether a model is a marked point process. } \examples{ m <- rmhmodel(cif='strauss', par=list(beta=10, gamma=0.1, r=1)) is.stationary(m) is.poisson(m) is.poisson(rmhmodel(cif='strauss', par=list(beta=10, gamma=1, r=1))) } \keyword{spatial} \keyword{models} spatstat.random/man/rGaussPoisson.Rd0000644000176200001440000000427614243054775017301 0ustar liggesusers\name{rGaussPoisson} \alias{rGaussPoisson} \title{Simulate Gauss-Poisson Process} \description{ Generate a random point pattern, a simulated realisation of the Gauss-Poisson Process. } \usage{ rGaussPoisson(kappa, r, p2, win = owin(c(0,1),c(0,1)), \dots, nsim=1, drop=TRUE) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{r}{ Diameter of each cluster that consists of exactly 2 points. } \item{p2}{ Probability that a cluster contains exactly 2 points. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. } \item{\dots}{Ignored.} \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of the point pattern. See \code{\link{rNeymanScott}}. } \details{ This algorithm generates a realisation of the Gauss-Poisson point process inside the window \code{win}. The process is constructed by first generating a Poisson point process of parent points with intensity \code{kappa}. Then each parent point is either retained (with probability \code{1 - p2}) or replaced by a pair of points at a fixed distance \code{r} apart (with probability \code{p2}). In the case of clusters of 2 points, the line joining the two points has uniform random orientation. In this implementation, parent points are not restricted to lie in the window; the parent process is effectively the uniform Poisson process on the infinite plane. } \seealso{ \code{\link{rpoispp}}, \code{\link{rThomas}}, \code{\link{rMatClust}}, \code{\link{rNeymanScott}} } \examples{ pp <- rGaussPoisson(30, 0.07, 0.5) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoint.Rd0000644000176200001440000001220114243054775015760 0ustar liggesusers\name{rpoint} \alias{rpoint} \title{Generate N Random Points} \description{ Generate a random point pattern containing \eqn{n} independent, identically distributed random points with any specified distribution. } \usage{ rpoint(n, f, fmax=NULL, win=unit.square(), \dots, giveup=1000, warn=TRUE, verbose=FALSE, nsim=1, drop=TRUE, forcewin=FALSE) } \arguments{ \item{n}{ Number of points to generate. } \item{f}{ The probability density of the points, possibly un-normalised. Either a constant, a function \code{f(x,y,...)}, or a pixel image object. } \item{fmax}{ An upper bound on the values of \code{f}. If missing, this number will be estimated. } \item{win}{ Window in which to simulate the pattern. (Ignored if \code{f} is a pixel image, unless \code{forcewin=TRUE}). } \item{\dots}{ Arguments passed to the function \code{f}. } \item{giveup}{ Number of attempts in the rejection method after which the algorithm should stop trying to generate new points. } \item{warn}{ Logical value specifying whether to issue a warning if \code{n} is very large. See Details. } \item{verbose}{ Flag indicating whether to report details of performance of the simulation algorithm. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{forcewin}{ Logical. If \code{TRUE}, then simulations will be generated inside \code{win} in all cases. If \code{FALSE} (the default), the argument \code{win} is ignored when \code{f} is a pixel image. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This function generates \code{n} independent, identically distributed random points with common probability density proportional to \code{f}. The argument \code{f} may be \describe{ \item{a numerical constant:}{ uniformly distributed random points will be generated. } \item{a function:}{random points will be generated in the window \code{win} with probability density proportional to \code{f(x,y,...)} where \code{x} and \code{y} are the cartesian coordinates. The function \code{f} must accept two \emph{vectors} of coordinates \code{x,y} and return the corresponding vector of function values. Additional arguments \code{...} of any kind may be passed to the function. } \item{a pixel image:}{ if \code{f} is a pixel image (object of class \code{"im"}, see \code{\link{im.object}}) then random points will be generated with probability density proportional to the pixel values of \code{f}. To be precise, pixels are selected with probabilities proportional to the pixel values, and within each selected pixel, a point is generated with a uniform distribution inside the pixel. The window of the simulated point pattern is determined as follows. If \code{forcewin=FALSE} (the default) then the argument \code{win} is ignored, and the simulation window is the window of the pixel image, \code{Window(f)}. If \code{forcefit=TRUE} then the simulation window is \code{win}. } } The algorithm is as follows: \itemize{ \item If \code{f} is a constant, we invoke \code{\link{runifpoint}}. \item If \code{f} is a function, then we use the rejection method. Proposal points are generated from the uniform distribution. A proposal point \eqn{(x,y)} is accepted with probability \code{f(x,y,...)/fmax} and otherwise rejected. The algorithm continues until \code{n} points have been accepted. It gives up after \code{giveup * n} proposals if there are still fewer than \code{n} points. \item If \code{f} is a pixel image, then a random sequence of pixels is selected (using \code{\link{sample}}) with probabilities proportional to the pixel values of \code{f}. Then for each pixel in the sequence we generate a uniformly distributed random point in that pixel. } The algorithm for pixel images is more efficient than that for functions. If \code{warn=TRUE} (the default), a warning will be issued if \code{n} is very large. The threshold is \code{\link{spatstat.options}("huge.npoints")}. This warning has no consequences, but it helps to trap a number of common errors. } \seealso{ \code{\link{ppp.object}}, \code{\link{owin.object}}, \code{\link{runifpoint}} } \examples{ # 100 uniform random points in the unit square X <- rpoint(100) # 100 random points with probability density proportional to x^2 + y^2 X <- rpoint(100, function(x,y) { x^2 + y^2}, 1) # `fmax' may be omitted X <- rpoint(100, function(x,y) { x^2 + y^2}) # irregular window X <- rpoint(100, function(x,y) { x^2 + y^2}, win=letterR) # make a pixel image Z <- setcov(letterR) # 100 points with density proportional to pixel values X <- rpoint(100, Z) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/quadratresample.Rd0000644000176200001440000000464014252332033017631 0ustar liggesusers\name{quadratresample} \alias{quadratresample} \title{Resample a Point Pattern by Resampling Quadrats} \description{ Given a point pattern dataset, create a resampled point pattern by dividing the window into rectangular quadrats and randomly resampling the list of quadrats. } \usage{ quadratresample(X, nx, ny=nx, ..., replace = FALSE, nsamples = 1, verbose = (nsamples > 1)) } \arguments{ \item{X}{ A point pattern dataset (object of class \code{"ppp"}). } \item{nx,ny}{ Numbers of quadrats in the \eqn{x} and \eqn{y} directions. } \item{\dots}{Ignored.} \item{replace}{ Logical value. Specifies whether quadrats should be sampled with or without replacement. } \item{nsamples}{Number of randomised point patterns to be generated.} \item{verbose}{Logical value indicating whether to print progress reports.} } \details{ This command implements a very simple bootstrap resampling procedure for spatial point patterns \code{X}. The dataset \code{X} must be a point pattern (object of class \code{"ppp"}) and its observation window must be a rectangle. The window is first divided into \code{N = nx * ny} rectangular tiles (quadrats) of equal size and shape. To generate one resampled point pattern, a random sample of \code{N} quadrats is selected from the list of \code{N} quadrats, with replacement (if \code{replace=TRUE}) or without replacement (if \code{replace=FALSE}). The \eqn{i}th quadrat in the original dataset is then replaced by the \eqn{i}th sampled quadrat, after the latter is shifted so that it occupies the correct spatial position. The quadrats are then reconstituted into a point pattern inside the same window as \code{X}. If \code{replace=FALSE}, this procedure effectively involves a random permutation of the quadrats. The resulting resampled point pattern has the same number of points as \code{X}. If \code{replace=TRUE}, the number of points in the resampled point pattern is random. } \value{ A point pattern (if \code{nsamples = 1}) or a list of point patterns (if \code{nsamples > 1}). } \author{\adrian and \rolf } \seealso{ \code{\link[spatstat.geom]{quadrats}}, \code{\link[spatstat.geom]{quadratcount}}. See \code{\link[spatstat.explore]{varblock}} to estimate the variance of a summary statistic by block resampling. } \examples{ quadratresample(bei, 6, 3) } \keyword{spatial} \keyword{datagen} spatstat.random/man/default.rmhcontrol.Rd0000644000176200001440000000365414243054774020272 0ustar liggesusers\name{default.rmhcontrol} \alias{default.rmhcontrol} \title{Set Default Control Parameters for Metropolis-Hastings Algorithm.} \description{ For a Gibbs point process model (either a fitted model, or a model specified by its parameters), this command sets appropriate default values of the parameters controlling the iterative behaviour of the Metropolis-Hastings algorithm. } \usage{ default.rmhcontrol(model, w=NULL) } \arguments{ \item{model}{ A fitted point process model (object of class \code{"ppm"}) or a description of a Gibbs point process model (object of class \code{"rmhmodel"}). } \item{w}{ Optional. Window for the resulting simulated patterns. } } \value{ An object of class \code{"rmhcontrol"}. See \code{\link{rmhcontrol}}. } \details{ This function sets the values of the parameters controlling the iterative behaviour of the Metropolis-Hastings simulation algorithm. It uses default values that would be appropriate for the fitted point process model \code{model}. The expansion parameter \code{expand} is set to \code{\link{default.expand}(model, w)}. All other parameters revert to their defaults given in \code{\link{rmhcontrol.default}}. See \code{\link{rmhcontrol}} for the full list of control parameters. To override default parameters, use \code{\link{update.rmhcontrol}}. } \seealso{ \code{\link[spatstat.random]{rmhcontrol}}, \code{\link[spatstat.random]{update.rmhcontrol}}, \code{\link[spatstat.model]{ppm}}, \code{\link[spatstat.random]{default.expand}} } \examples{ if(require(spatstat.model)) { fit <- ppm(cells, ~1, Strauss(0.1)) default.rmhcontrol(fit) default.rmhcontrol(fit, w=square(2)) } m <- rmhmodel(cif='strauss', par=list(beta=100, gamma=0.5, r=0.1), w=unit.square()) default.rmhcontrol(m) default.rmhcontrol(m, w=square(2)) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/clusterradius.Rd0000644000176200001440000000671014374301321017331 0ustar liggesusers\name{clusterradius} \alias{clusterradius} \alias{clusterradius.character} \title{ Compute or Extract Effective Range of Cluster Kernel } \description{ Given a cluster point process model, this command returns a value beyond which the the probability density of the cluster offspring is neglible. } \usage{ clusterradius(model, \dots) \method{clusterradius}{character}(model, \dots, thresh = NULL, precision = FALSE) } \arguments{ \item{model}{ Cluster model. Either a fitted cluster or Cox model (object of class \code{"kppm"}), or a character string specifying the type of cluster model. } \item{\dots}{ Parameter values for the model, when \code{model} is a character string. } \item{thresh}{ Numerical threshold relative to the cluster kernel value at the origin (parent location) determining when the cluster kernel will be considered neglible. A sensible default is provided. } \item{precision}{ Logical. If \code{precision=TRUE} the precision of the calculated range is returned as an attribute to the range. See details. } } \details{ Given a cluster model this function by default returns the effective range of the model with the given parameters as used in spatstat. For the \Matern cluster model (see e.g. \code{\link[spatstat.random]{rMatClust}}) this is simply the finite radius of the offsring density given by the paramter \code{scale} irrespective of other options given to this function. The remaining models in spatstat have infinite theoretical range, and an effective finite value is given as follows: For the Thomas model (see e.g. \code{\link[spatstat.random]{rThomas}} the default is \code{4*scale} where scale is the scale or standard deviation parameter of the model. If \code{thresh} is given the value is instead found as described for the other models below. For the Cauchy model (see e.g. \code{\link[spatstat.random]{rCauchy}}) and the Variance Gamma (Bessel) model (see e.g. \code{\link[spatstat.random]{rVarGamma}}) the value of \code{thresh} defaults to 0.001, and then this is used to compute the range numerically as follows. If \eqn{k(x,y)=k_0(r)}{k(x,y)=k0(r)} with \eqn{r=\sqrt(x^2+y^2)}{r=sqrt(x^2+y^2)} denotes the isotropic cluster kernel then \eqn{f(r) = 2 \pi r k_0(r)}{f(r) = 2 \pi r k0(r)} is the density function of the offspring distance from the parent. The range is determined as the value of \eqn{r} where \eqn{f(r)} falls below \code{thresh} times \eqn{k_0(r)}{k0(r)}. If \code{precision=TRUE} the precision related to the chosen range is returned as an attribute. Here the precision is defined as the polar integral of the kernel from distance 0 to the calculated range. Ideally this should be close to the value 1 which would be obtained for the true theretical infinite range. } \value{ A positive numeric. Additionally, the precision related to this range value is returned as an attribute \code{"prec"}, if \code{precision=TRUE}. } \author{\spatstatAuthors.} \seealso{ \code{\link{clusterkernel}}, \code{\link[spatstat.model]{kppm}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rThomas}}, \code{\link[spatstat.random]{rCauchy}}, \code{\link[spatstat.random]{rVarGamma}}, \code{\link[spatstat.random]{rNeymanScott}}. } \examples{ clusterradius("Thomas", scale = .1) clusterradius("Thomas", scale = .1, thresh = 0.001) clusterradius("VarGamma", scale = .1, nu = 2, precision = TRUE) } \keyword{spatial} spatstat.random/man/default.expand.Rd0000644000176200001440000001035114243054774017352 0ustar liggesusers\name{default.expand} \alias{default.expand} \title{Default Expansion Rule for Simulation of Model} \description{ Defines the default expansion window or expansion rule for simulation of a point process model. } \usage{ default.expand(object, m=2, epsilon=1e-6, w=Window(object)) } \arguments{ \item{object}{ A point process model (object of class \code{"ppm"} or \code{"rmhmodel"}). } \item{m}{ A single numeric value. The window will be expanded by a distance \code{m * reach(object)} along each side. } \item{epsilon}{ Threshold argument passed to \code{\link[spatstat.random]{reach}} to determine \code{reach(object)}. } \item{w}{ Optional. The un-expanded window in which the model is defined. The resulting simulated point patterns will lie in this window. } } \value{ A window expansion rule (object of class \code{"rmhexpand"}). } \details{ This function computes a default value for the expansion rule (the argument \code{expand} in \code{\link[spatstat.random]{rmhcontrol}}) given a fitted point process model \code{object}. This default is used by \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.model]{simulate.ppm}}, \code{\link[spatstat.explore]{envelope}}, \code{\link[spatstat.model]{qqplot.ppm}}, and other functions. Suppose we wish to generate simulated realisations of a fitted point process model inside a window \code{w}. It is advisable to first simulate the pattern on a larger window, and then clip it to the original window \code{w}. This avoids edge effects in the simulation. It is called \emph{expansion} of the simulation window. Accordingly, for the Metropolis-Hastings simulation algorithm \code{\link[spatstat.random]{rmh}}, the algorithm control parameters specified by \code{\link[spatstat.random]{rmhcontrol}} include an argument \code{expand} that determines the expansion of the simulation window. The function \code{default.expand} determines the default expansion rule for a fitted point process model \code{object}. If the model is Poisson, then no expansion is necessary. No expansion is performed by default, and \code{default.expand} returns a rule representing no expansion. The simulation window is the original window \code{w = Window(object)}. If the model depends on external covariates (i.e.\ covariates other than the Cartesian covariates \code{x} and \code{y} and the \code{marks}) then no expansion is feasible, in general, because the spatial domain of the covariates is not guaranteed to be large enough. \code{default.expand} returns a rule representing no expansion. The simulation window is the original window \code{w = Window(object)}. If the model depends on the Cartesian covariates \code{x} and \code{y}, it would be feasible to expand the simulation window, and this was the default for \pkg{spatstat} version 1.24-1 and earlier. However this sometimes produces artefacts (such as an empty point pattern) or memory overflow, because the fitted trend, extrapolated outside the original window of the data, may become very large. In \pkg{spatstat} version 1.24-2 and later, the default rule is \emph{not} to expand if the model depends on \code{x} or \code{y}. Again \code{default.expand} returns a rule representing no expansion. Otherwise, expansion will occur. The original window \code{w = Window(object)} is expanded by a distance \code{m * rr}, where \code{rr} is the interaction range of the model, computed by \code{\link[spatstat.random]{reach}}. If \code{w} is a rectangle then each edge of \code{w} is displaced outward by distance \code{m * rr}. If \code{w} is not a rectangle then \code{w} is dilated by distance \code{m * rr} using \code{\link[spatstat.geom]{dilation}}. } \seealso{ \code{\link[spatstat.random]{rmhexpand}}, \code{\link[spatstat.random]{rmhcontrol}}, \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.explore]{envelope}}, \code{\link[spatstat.model]{qqplot.ppm}} } \examples{ if(require(spatstat.model)) { fit <- ppm(cells ~1, Strauss(0.07)) default.expand(fit) } mod <- rmhmodel(cif="strauss", par=list(beta=100, gamma=0.5, r=0.07)) default.expand(mod) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rknn.Rd0000644000176200001440000000365114243054775015426 0ustar liggesusers\name{rknn} \alias{dknn} \alias{pknn} \alias{qknn} \alias{rknn} \title{ Theoretical Distribution of Nearest Neighbour Distance } \description{ Density, distribution function, quantile function and random generation for the random distance to the \eqn{k}th nearest neighbour in a Poisson point process in \eqn{d} dimensions. } \usage{ dknn(x, k = 1, d = 2, lambda = 1) pknn(q, k = 1, d = 2, lambda = 1) qknn(p, k = 1, d = 2, lambda = 1) rknn(n, k = 1, d = 2, lambda = 1) } \arguments{ \item{x,q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{number of observations to be generated.} \item{k}{order of neighbour.} \item{d}{dimension of space.} \item{lambda}{intensity of Poisson point process.} } \details{ In a Poisson point process in \eqn{d}-dimensional space, let the random variable \eqn{R} be the distance from a fixed point to the \eqn{k}-th nearest random point, or the distance from a random point to the \eqn{k}-th nearest other random point. Then \eqn{R^d} has a Gamma distribution with shape parameter \eqn{k} and rate \eqn{\lambda * \alpha}{lambda * alpha} where \eqn{\alpha}{alpha} is a constant (equal to the volume of the unit ball in \eqn{d}-dimensional space). See e.g. Cressie (1991, page 61). These functions support calculation and simulation for the distribution of \eqn{R}. } \value{ A numeric vector: \code{dknn} returns the probability density, \code{pknn} returns cumulative probabilities (distribution function), \code{qknn} returns quantiles, and \code{rknn} generates random deviates. } \references{ Cressie, N.A.C. (1991) \emph{Statistics for spatial data}. John Wiley and Sons, 1991. } \author{\adrian and \rolf } \examples{ x <- seq(0, 5, length=20) densities <- dknn(x, k=3, d=2) cdfvalues <- pknn(x, k=3, d=2) randomvalues <- rknn(100, k=3, d=2) deciles <- qknn((1:9)/10, k=3, d=2) } \keyword{spatial} \keyword{distribution} spatstat.random/man/rNeymanScott.Rd0000644000176200001440000002322514353202050017062 0ustar liggesusers\name{rNeymanScott} \alias{rNeymanScott} \title{Simulate Neyman-Scott Process} \description{ Generate a random point pattern, a realisation of the Neyman-Scott cluster process. } \usage{ rNeymanScott(kappa, expand, rcluster, win = unit.square(), \dots, nsim=1, drop=TRUE, nonempty=TRUE, saveparents=TRUE, kappamax=NULL, mumax=NULL) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{expand}{ Size of the expansion of the simulation window for generating parent points. A single non-negative number. } \item{rcluster}{ A function which generates random clusters, or other data specifying the random cluster mechanism. See Details. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link[spatstat.geom]{as.owin}}. } \item{\dots}{ Arguments passed to \code{rcluster}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{nonempty}{ Logical. If \code{TRUE} (the default), a more efficient algorithm is used, in which parents are generated conditionally on having at least one offspring point. If \code{FALSE}, parents are generated even if they have no offspring. Both choices are valid; the default is recommended unless you need to simulate all the parent points for some other purpose. } \item{saveparents}{ Logical value indicating whether to save the locations of the parent points as an attribute. } \item{kappamax}{ Optional. Upper bound on the values of \code{kappa} when \code{kappa} is a function or pixel image. } \item{mumax}{ Optional. Upper bound on the values of \code{mu} when \code{mu=rcluster[[1]]} is a function or pixel image. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of this point pattern: see Details. } \details{ This algorithm generates a realisation of the general Neyman-Scott process, with the cluster mechanism given by the function \code{rcluster}. First, the algorithm generates a Poisson point process of \dQuote{parent} points with intensity \code{kappa} in an expanded window as explained below. Here \code{kappa} may be a single positive number, a function \code{kappa(x,y)}, or a pixel image object of class \code{"im"} (see \code{\link[spatstat.geom]{im.object}}). See \code{\link[spatstat.random]{rpoispp}} for details. Second, each parent point is replaced by a random cluster of points. These clusters are combined together to yield a single point pattern, and the restriction of this pattern to the window \code{win} is then returned as the result of \code{rNeymanScott}. The expanded window consists of \code{\link[spatstat.geom]{as.rectangle}(win)} extended by the amount \code{expand} in each direction. The size of the expansion is saved in the attribute \code{"expand"} and may be extracted by \code{attr(X, "expand")} where \code{X} is the generated point pattern. The argument \code{rcluster} specifies the cluster mechanism. It may be either: \itemize{ \item A \code{function} which will be called to generate each random cluster (the offspring points of each parent point). The function should expect to be called in the form \code{rcluster(x0,y0,\dots)} for a parent point at a location \code{(x0,y0)}. The return value of \code{rcluster} should specify the coordinates of the points in the cluster; it may be a list containing elements \code{x,y}, or a point pattern (object of class \code{"ppp"}). If it is a marked point pattern then the result of \code{rNeymanScott} will be a marked point pattern. \item A \code{list(mu, f)} where \code{mu} specifies the mean number of offspring points in each cluster, and \code{f} generates the random displacements (vectors pointing from the parent to the offspring). In this case, the number of offspring in a cluster is assumed to have a Poisson distribution, implying that the Neyman-Scott process is also a Cox process. The first element \code{mu} should be either a single nonnegative number (interpreted as the mean of the Poisson distribution of cluster size) or a pixel image or a \code{function(x,y)} giving a spatially varying mean cluster size (interpreted in the sense of Waagepetersen, 2007). The second element \code{f} should be a function that will be called once in the form \code{f(n)} to generate \code{n} independent and identically distributed displacement vectors (i.e. as if there were a cluster of size \code{n} with a parent at the origin \code{(0,0)}). The function should return a point pattern (object of class \code{"ppp"}) or something acceptable to \code{\link[grDevices]{xy.coords}} that specifies the coordinates of \code{n} points. } If required, the intermediate stages of the simulation (the parents and the individual clusters) can also be extracted from the return value of \code{rNeymanScott} through the attributes \code{"parents"} and \code{"parentid"}. The attribute \code{"parents"} is the point pattern of parent points. The attribute \code{"parentid"} is an integer vector specifying the parent for each of the points in the simulated pattern. Neyman-Scott models where \code{kappa} is a single number and \code{rcluster = list(mu,f)} can be fitted to data using the function \code{\link[spatstat.model]{kppm}}. } \section{Inhomogeneous Neyman-Scott Processes}{ There are several different ways of specifying a spatially inhomogeneous Neyman-Scott process: \itemize{ \item The point process of parent points can be inhomogeneous. If the argument \code{kappa} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is taken as specifying the intensity function of an inhomogeneous Poisson process according to which the parent points are generated. \item The number of points in a typical cluster can be spatially varying. If the argument \code{rcluster} is a list of two elements \code{mu, f} and the first entry \code{mu} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then \code{mu} is interpreted as the reference intensity for offspring points, in the sense of Waagepetersen (2007). For a given parent point, the offspring constitute a Poisson process with intensity function equal to \code{mu(x, y) * g(x-x0, y-y0)} where \code{g} is the probability density of the offspring displacements generated by the function \code{f}. Equivalently, clusters are first generated with a constant expected number of points per cluster: the constant is \code{mumax}, the maximum of \code{mu}. Then the offspring are randomly \emph{thinned} (see \code{\link[spatstat.random]{rthin}}) with spatially-varying retention probabilities given by \code{mu/mumax}. \item The entire mechanism for generating a cluster can be dependent on the location of the parent point. If the argument \code{rcluster} is a function, then the cluster associated with a parent point at location \code{(x0,y0)} will be generated by calling \code{rcluster(x0, y0, \dots)}. The behaviour of this function could depend on the location \code{(x0,y0)} in any fashion. } Note that if \code{kappa} is an image, the spatial domain covered by this image must be large enough to include the \emph{expanded} window in which the parent points are to be generated. This requirement means that \code{win} must be small enough so that the expansion of \code{as.rectangle(win)} is contained in the spatial domain of \code{kappa}. As a result, one may wind up having to simulate the process in a window smaller than what is really desired. In the first two cases, the intensity of the Neyman-Scott process is equal to \code{kappa * mu} if at least one of \code{kappa} or \code{mu} is a single number, and is otherwise equal to an integral involving \code{kappa}, \code{mu} and \code{f}. } \seealso{ \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rThomas}}, \code{\link[spatstat.random]{rGaussPoisson}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rCauchy}}, \code{\link[spatstat.random]{rVarGamma}} } \examples{ # each cluster consist of 10 points in a disc of radius 0.2 nclust <- function(x0, y0, radius, n) { return(runifdisc(n, radius, centre=c(x0, y0))) } plot(rNeymanScott(10, 0.2, nclust, radius=0.2, n=5)) # multitype Neyman-Scott process (each cluster is a multitype process) nclust2 <- function(x0, y0, radius, n, types=c("a", "b")) { X <- runifdisc(n, radius, centre=c(x0, y0)) M <- sample(types, n, replace=TRUE) marks(X) <- M return(X) } plot(rNeymanScott(15,0.1,nclust2, radius=0.1, n=5)) } \references{ Neyman, J. and Scott, E.L. (1958) A statistical approach to problems of cosmology. \emph{Journal of the Royal Statistical Society, Series B} \bold{20}, 1--43. Waagepetersen, R. (2007) An estimating function approach to inference for inhomogeneous Neyman-Scott processes. \emph{Biometrics} \bold{63}, 252--258. } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rDGS.Rd0000644000176200001440000000756014243054775015260 0ustar liggesusers\name{rDGS} \alias{rDGS} \title{Perfect Simulation of the Diggle-Gates-Stibbard Process} \description{ Generate a random pattern of points, a simulated realisation of the Diggle-Gates-Stibbard process, using a perfect simulation algorithm. } \usage{ rDGS(beta, rho, W = owin(), expand=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{beta}{ intensity parameter (a positive number). } \item{rho}{ interaction range (a non-negative number). } \item{W}{ window (object of class \code{"owin"}) in which to generate the random pattern. } \item{expand}{ Logical. If \code{FALSE}, simulation is performed in the window \code{W}, which must be rectangular. If \code{TRUE} (the default), simulation is performed on a larger window, and the result is clipped to the original window \code{W}. Alternatively \code{expand} can be an object of class \code{"rmhexpand"} (see \code{\link[spatstat.random]{rmhexpand}}) determining the expansion method. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function generates a realisation of the Diggle-Gates-Stibbard point process in the window \code{W} using a \sQuote{perfect simulation} algorithm. Diggle, Gates and Stibbard (1987) proposed a pairwise interaction point process in which each pair of points separated by a distance \eqn{d} contributes a factor \eqn{e(d)} to the probability density, where \deqn{ e(d) = \sin^2\left(\frac{\pi d}{2\rho}\right) }{ e(d) = sin^2((pi * d)/(2 * rho)) } for \eqn{d < \rho}{d < rho}, and \eqn{e(d)} is equal to 1 for \eqn{d \ge \rho}{d >= rho}. The simulation algorithm used to generate the point pattern is \sQuote{dominated coupling from the past} as implemented by Berthelsen and \Moller (2002, 2003). This is a \sQuote{perfect simulation} or \sQuote{exact simulation} algorithm, so called because the output of the algorithm is guaranteed to have the correct probability distribution exactly (unlike the Metropolis-Hastings algorithm used in \code{\link[spatstat.random]{rmh}}, whose output is only approximately correct). There is a tiny chance that the algorithm will run out of space before it has terminated. If this occurs, an error message will be generated. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}). If \code{nsim > 1}, a list of point patterns. } \references{ Berthelsen, K.K. and \Moller, J. (2002) A primer on perfect simulation for spatial point processes. \emph{Bulletin of the Brazilian Mathematical Society} 33, 351-367. Berthelsen, K.K. and \Moller, J. (2003) Likelihood and non-parametric Bayesian MCMC inference for spatial point processes based on perfect simulation and path sampling. \emph{Scandinavian Journal of Statistics} 30, 549-564. Diggle, P.J., Gates, D.J., and Stibbard, A. (1987) A nonparametric estimator for pairwise-interaction point processes. Biometrika \bold{74}, 763 -- 770. \emph{Scandinavian Journal of Statistics} \bold{21}, 359--373. \Moller, J. and Waagepetersen, R. (2003). \emph{Statistical Inference and Simulation for Spatial Point Processes.} Chapman and Hall/CRC. } \author{ \adrian, based on original code for the Strauss process by Kasper Klitgaard Berthelsen. } \examples{ X <- rDGS(50, 0.05) Z <- rDGS(50, 0.03, nsim=2) } \seealso{ \code{\link[spatstat.random]{rmh}}, \code{\link[spatstat.model]{DiggleGatesStibbard}}. \code{\link[spatstat.random]{rStrauss}}, \code{\link[spatstat.random]{rHardcore}}, \code{\link[spatstat.random]{rStraussHard}}, \code{\link[spatstat.random]{rDiggleGratton}}, \code{\link[spatstat.random]{rPenttinen}}. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rThomas.Rd0000644000176200001440000002715014363567167016102 0ustar liggesusers\name{rThomas} \alias{rThomas} \title{Simulate Thomas Process} \description{ Generate a random point pattern, a simulated realisation of the Thomas cluster process. } \usage{ rThomas(kappa, scale, mu, win = square(1), nsim=1, drop=TRUE, \dots, algorithm=c("BKBC", "naive"), nonempty=TRUE, poisthresh=1e-6, expand = 4*scale, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL, sigma) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{scale}{ Cluster size. Standard deviation of random displacement (along each coordinate axis) of a point from its cluster centre. A single positive number. } \item{mu}{ Mean number of points per cluster (a single positive number) or reference intensity for the cluster points (a function or a pixel image). } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link[spatstat.geom]{as.owin}}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{\dots}{ Passed to \code{\link[spatstat.random]{clusterfield}} to control the image resolution when \code{saveLambda=TRUE}. } \item{algorithm}{ String (partially matched) specifying the simulation algorithm. See Details. } \item{nonempty}{ Logical. If \code{TRUE} (the default), a more efficient algorithm is used, in which parents are generated conditionally on having at least one offspring point in the window. If \code{FALSE}, parents are generated even if they have no offspring in the window. The default is recommended unless you need to simulate all the parent points for some other purpose. } \item{poisthresh}{ Numerical threshold below which the model will be treated as a Poisson process. See Details. } \item{expand}{ Window expansion distance. A single number. The distance by which the original window will be expanded in order to generate parent points. Has a sensible default. } \item{saveparents}{ Logical value indicating whether to save the locations of the parent points as an attribute. } \item{saveLambda}{ Logical. If \code{TRUE} then the random intensity corresponding to the simulated parent points will also be calculated and saved, and returns as an attribute of the point pattern. } \item{kappamax}{ Optional. Numerical value which is an upper bound for the values of \code{kappa}, when \code{kappa} is a pixel image or a function. } \item{mumax}{ Optional. Numerical value which is an upper bound for the values of \code{mu}, when \code{mu} is a pixel image or a function. } \item{sigma}{ Deprecated. Equivalent to \code{scale}. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of this point pattern (see \code{\link[spatstat.random]{rNeymanScott}}). Furthermore, the simulated intensity function is returned as an attribute \code{"Lambda"}, if \code{saveLambda=TRUE}. } \details{ This algorithm generates a realisation of the (`modified') Thomas process, a special case of the Neyman-Scott process, inside the window \code{win}. In the simplest case, where \code{kappa} and \code{mu} are single numbers, the cluster process is formed by first generating a uniform Poisson point process of \dQuote{parent} points with intensity \code{kappa}. Then each parent point is replaced by a random cluster of \dQuote{offspring} points, the number of points per cluster being Poisson (\code{mu}) distributed, and their positions being isotropic Gaussian displacements from the cluster parent location. The resulting point pattern is a realisation of the classical \dQuote{stationary Thomas process} generated inside the window \code{win}. This point process has intensity \code{kappa * mu}. Note that, for correct simulation of the model, the parent points are not restricted to lie inside the window \code{win}; the parent process is effectively the uniform Poisson process on the infinite plane. The algorithm can also generate spatially inhomogeneous versions of the Thomas process: \itemize{ \item The parent points can be spatially inhomogeneous. If the argument \code{kappa} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is taken as specifying the intensity function of an inhomogeneous Poisson process that generates the parent points. \item The offspring points can be inhomogeneous. If the argument \code{mu} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is interpreted as the reference density for offspring points, in the sense of Waagepetersen (2007). For a given parent point, the offspring constitute a Poisson process with intensity function equal to \code{mu * f}, where \code{f} is the Gaussian probability density centred at the parent point. Equivalently we first generate, for each parent point, a Poisson (\code{mumax}) random number of offspring (where \eqn{M} is the maximum value of \code{mu}) with independent Gaussian displacements from the parent location, and then randomly thin the offspring points, with retention probability \code{mu/M}. \item Both the parent points and the offspring points can be spatially inhomogeneous, as described above. } Note that if \code{kappa} is a pixel image, its domain must be larger than the window \code{win}. This is because an offspring point inside \code{win} could have its parent point lying outside \code{win}. In order to allow this, the simulation algorithm first expands the original window \code{win} by a distance \code{expand} and generates the Poisson process of parent points on this larger window. If \code{kappa} is a pixel image, its domain must contain this larger window. The intensity of the Thomas process is \code{kappa * mu} if either \code{kappa} or \code{mu} is a single number. In the general case the intensity is an integral involving \code{kappa}, \code{mu} and \code{f}. If the pair correlation function of the model is very close to that of a Poisson process, deviating by less than \code{poisthresh}, then the model is approximately a Poisson process, and will be simulated as a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Simulation Algorithm}{ Two simulation algorithms are implemented. \itemize{ \item The \emph{naive} algorithm generates the cluster process by directly following the description given above. First the window \code{win} is expanded by a distance equal to \code{expand}. Then the parent points are generated in the expanded window according to a Poisson process with intensity \code{kappa}. Then each parent point is replaced by a finite cluster of offspring points as described above. The naive algorithm is used if \code{algorithm="naive"} or if \code{nonempty=FALSE}. \item The \emph{BKBC} algorithm, proposed by Baddeley and Chang (2023), is a modification of the algorithm of Brix and Kendall (2002). Parents are generated in the infinite plane, subject to the condition that they have at least one offspring point inside the window \code{win}. The BKBC algorithm is used when \code{algorithm="BKBC"} (the default) and \code{nonempty=TRUE} (the default). } The naive algorithm becomes very slow when \code{scale} is large, while the BKBC algorithm is uniformly fast (Baddeley and Chang, 2023). If \code{saveparents=TRUE}, then the simulated point pattern will have an attribute \code{"parents"} containing the coordinates of the parent points, and an attribute \code{"parentid"} mapping each offspring point to its parent. If \code{nonempty=TRUE} (the default), then parents are generated subject to the condition that they have at least one offspring point in the window \code{win}. \code{nonempty=FALSE}, then parents without offspring will be included; this option is not available in the \emph{BKBC} algorithm. Note that if \code{kappa} is a pixel image, its domain must be larger than the window \code{win}. This is because an offspring point inside \code{win} could have its parent point lying outside \code{win}. In order to allow this, the naive simulation algorithm first expands the original window \code{win} by a distance equal to \code{expand} and generates the Poisson process of parent points on this larger window. If \code{kappa} is a pixel image, its domain must contain this larger window. If the pair correlation function of the model is very close to that of a Poisson process, with maximum deviation less than \code{poisthresh}, then the model is approximately a Poisson process. This is detected by the naive algorithm which then simulates a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Fitting cluster models to data}{ The Thomas model with homogeneous parents (i.e. where \code{kappa} is a single number) where the offspring are either homogeneous or inhomogeneous (\code{mu} is a single number, a function or pixel image) can be fitted to point pattern data using \code{\link[spatstat.model]{kppm}}, or fitted to the inhomogeneous \eqn{K} function using \code{\link[spatstat.model]{thomas.estK}} or \code{\link[spatstat.model]{thomas.estpcf}}. Currently \pkg{spatstat} does not support fitting the Thomas cluster process model with inhomogeneous parents. A Thomas cluster process model fitted by \code{\link[spatstat.model]{kppm}} can be simulated automatically using \code{\link[spatstat.model]{simulate.kppm}} (which invokes \code{rThomas} to perform the simulation). } \seealso{ \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rCauchy}}, \code{\link[spatstat.random]{rVarGamma}}, \code{\link[spatstat.random]{rNeymanScott}}, \code{\link[spatstat.random]{rGaussPoisson}}. For fitting the model, see \code{\link[spatstat.model]{kppm}}, \code{\link[spatstat.model]{clusterfit}}. } \references{ \baddchangclustersim Brix, A. and Kendall, W.S. (2002) Simulation of cluster point processes without edge effects. \emph{Advances in Applied Probability} \bold{34}, 267--280. Diggle, P. J., Besag, J. and Gleaves, J. T. (1976) Statistical analysis of spatial point patterns by means of distance methods. \emph{Biometrics} \bold{32} 659--667. Thomas, M. (1949) A generalisation of Poisson's binomial limit for use in ecology. \emph{Biometrika} \bold{36}, 18--25. Waagepetersen, R. (2007) An estimating function approach to inference for inhomogeneous Neyman-Scott processes. \emph{Biometrics} \bold{63}, 252--258. } \examples{ #homogeneous X <- rThomas(10, 0.2, 5) #inhomogeneous Z <- as.im(function(x,y){ 5 * exp(2 * x - 1) }, owin()) Y <- rThomas(10, 0.2, Z) } \author{ \adrian, \rolf and \yamei. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoislinetess.Rd0000644000176200001440000000276514510473067017362 0ustar liggesusers\name{rpoislinetess} \alias{rpoislinetess} \title{Poisson Line Tessellation} \description{ Generate a tessellation delineated by the lines of the Poisson line process } \usage{ rpoislinetess(lambda, win = owin()) } \arguments{ \item{lambda}{ Intensity of the Poisson line process. A positive number. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. Currently, the window must be a rectangle. } } \details{ This algorithm generates a realisation of the uniform Poisson line process, and divides the window \code{win} into tiles separated by these lines. The argument \code{lambda} must be a positive number. It controls the intensity of the process. The expected number of lines intersecting a convex region of the plane is equal to \code{lambda} times the perimeter length of the region. The expected total length of the lines crossing a region of the plane is equal to \code{lambda * pi} times the area of the region. } \value{ A tessellation (object of class \code{"tess"}). Also has an attribute \code{"lines"} containing the realisation of the Poisson line process, as an object of class \code{"infline"}. } \author{\adrian and \rolf } \seealso{ \code{\link{rpoisline}} to generate the lines only. } \examples{ X <- rpoislinetess(3) plot(as.im(X), main="rpoislinetess(3)") plot(X, add=TRUE) } \keyword{spatial} \keyword{datagen} \concept{Tessellation} spatstat.random/man/rthin.Rd0000644000176200001440000000656014352250326015573 0ustar liggesusers\name{rthin} \alias{rthin} \title{Random Thinning} \description{ Applies independent random thinning to a point pattern or segment pattern. } \usage{ rthin(X, P, \dots, nsim=1, drop=TRUE) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"} or \code{"lpp"} or \code{"pp3"} or \code{"ppx"}) or line segment pattern (object of class \code{"psp"}) that will be thinned. } \item{P}{ Data giving the retention probabilities, i.e. the probability that each point or line in \code{X} will be retained. Either a single number, or a vector of numbers, or a \code{function(x,y)} in the \R language, or a function object (class \code{"funxy"} or \code{"linfun"}), or a pixel image (object of class \code{"im"} or \code{"linim"}). } \item{\dots}{ Additional arguments passed to \code{P}, if it is a function. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ An object of the same kind as \code{X} if \code{nsim=1}, or a list of such objects if \code{nsim > 1}. } \details{ In a random thinning operation, each point of the point pattern \code{X} is randomly either deleted or retained (i.e. not deleted). The result is a point pattern, consisting of those points of \code{X} that were retained. Independent random thinning means that the retention/deletion of each point is independent of other points. The argument \code{P} determines the probability of \bold{retaining} each point. It may be \describe{ \item{a single number,}{so that each point will be retained with the same probability \code{P}; } \item{a vector of numbers,}{so that the \code{i}th point of \code{X} will be retained with probability \code{P[i]}; } \item{a function \code{P(x,y)},}{so that a point at a location \code{(x,y)} will be retained with probability \code{P(x,y)}; } \item{an object of class \code{"funxy"} or \code{"linfun"},}{so that points in the pattern \code{X} will be retained with probabilities \code{P(X)}; } \item{a pixel image,}{containing values of the retention probability for all locations in a region encompassing the point pattern. } } If \code{P} is a function \code{P(x,y)}, it should be \sQuote{vectorised}, that is, it should accept vector arguments \code{x,y} and should yield a numeric vector of the same length. The function may have extra arguments which are passed through the \code{\dots} argument. } \section{Reproducibility}{ The algorithm for random thinning was changed in \pkg{spatstat} version \code{1.42-3}. Set \code{spatstat.options(fastthin=FALSE)} to use the previous, slower algorithm, if it is desired to reproduce results obtained with earlier versions. } \examples{ plot(redwood, main="thinning") # delete 20\% of points Y <- rthin(redwood, 0.8) points(Y, col="green", cex=1.4) # function f <- function(x,y) { ifelse(x < 0.4, 1, 0.5) } Y <- rthin(redwood, f) # pixel image Z <- as.im(f, Window(redwood)) Y <- rthin(redwood, Z) # thin other kinds of patterns E <- rthin(osteo$pts[[1]], 0.6) L <- rthin(copper$Lines, 0.5) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} \keyword{manip}spatstat.random/man/update.rmhcontrol.Rd0000644000176200001440000000210414243054775020116 0ustar liggesusers\name{update.rmhcontrol} \alias{update.rmhcontrol} \title{Update Control Parameters of Metropolis-Hastings Algorithm} \description{ \code{update} method for class \code{"rmhcontrol"}. } \usage{ \method{update}{rmhcontrol}(object, \dots) } \arguments{ \item{object}{ Object of class \code{"rmhcontrol"} containing control parameters for a Metropolis-Hastings algorithm. } \item{\dots}{ Arguments to be updated in the new call to \code{\link{rmhcontrol}}. } } \details{ This is a method for the generic function \code{\link{update}} for the class \code{"rmhcontrol"}. An object of class \code{"rmhcontrol"} describes a set of control parameters for the Metropolis-Hastings simulation algorithm. See \code{\link{rmhcontrol}}). \code{update.rmhcontrol} will modify the parameters specified by \code{object} according to the new arguments given. } \value{ Another object of class \code{"rmhcontrol"}. } \examples{ a <- rmhcontrol(expand=1) update(a, expand=2) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} \keyword{models} spatstat.random/man/runifdisc.Rd0000644000176200001440000000346714243054775016451 0ustar liggesusers\name{runifdisc} \alias{runifdisc} \title{Generate N Uniform Random Points in a Disc} \description{ Generate a random point pattern containing \eqn{n} independent uniform random points in a circular disc. } \usage{ runifdisc(n, radius=1, centre=c(0,0), ..., nsim=1, drop=TRUE) } \arguments{ \item{n}{ Number of points. } \item{radius}{Radius of the circle.} \item{centre}{Coordinates of the centre of the circle.} \item{\dots}{ Arguments passed to \code{\link{disc}} controlling the accuracy of approximation to the circle. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This function generates \code{n} independent random points, uniformly distributed in a circular disc. It is faster (for a circular window) than the general code used in \code{\link{runifpoint}}. To generate random points in an ellipse, first generate points in a circle using \code{runifdisc}, then transform to an ellipse using \code{\link{affine}}, as shown in the examples. To generate random points in other windows, use \code{\link{runifpoint}}. To generate non-uniform random points, use \code{\link{rpoint}}. } \seealso{ \code{\link{disc}}, \code{\link{runifpoint}}, \code{\link{rpoint}} } \examples{ # 100 random points in the unit disc plot(runifdisc(100)) # 42 random points in the ellipse with major axis 3 and minor axis 1 X <- runifdisc(42) Y <- affine(X, mat=diag(c(3,1))) plot(Y) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rStrauss.Rd0000644000176200001440000001157014243054775016303 0ustar liggesusers\name{rStrauss} \alias{rStrauss} \title{Perfect Simulation of the Strauss Process} \description{ Generate a random pattern of points, a simulated realisation of the Strauss process, using a perfect simulation algorithm. } \usage{ rStrauss(beta, gamma = 1, R = 0, W = owin(), expand=TRUE, nsim=1, drop=TRUE) } \arguments{ \item{beta}{ intensity parameter (a positive number). } \item{gamma}{ interaction parameter (a number between 0 and 1, inclusive). } \item{R}{ interaction radius (a non-negative number). } \item{W}{ window (object of class \code{"owin"}) in which to generate the random pattern. } \item{expand}{ Logical. If \code{FALSE}, simulation is performed in the window \code{W}, which must be rectangular. If \code{TRUE} (the default), simulation is performed on a larger window, and the result is clipped to the original window \code{W}. Alternatively \code{expand} can be an object of class \code{"rmhexpand"} (see \code{\link{rmhexpand}}) determining the expansion method. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function generates a realisation of the Strauss point process in the window \code{W} using a \sQuote{perfect simulation} algorithm. The Strauss process (Strauss, 1975; Kelly and Ripley, 1976) is a model for spatial inhibition, ranging from a strong `hard core' inhibition to a completely random pattern according to the value of \code{gamma}. The Strauss process with interaction radius \eqn{R} and parameters \eqn{\beta}{beta} and \eqn{\gamma}{gamma} is the pairwise interaction point process with probability density \deqn{ f(x_1,\ldots,x_n) = \alpha \beta^{n(x)} \gamma^{s(x)} }{ f(x_1,\ldots,x_n) = alpha . beta^n(x) gamma^s(x) } where \eqn{x_1,\ldots,x_n}{x[1],\ldots,x[n]} represent the points of the pattern, \eqn{n(x)} is the number of points in the pattern, \eqn{s(x)} is the number of distinct unordered pairs of points that are closer than \eqn{R} units apart, and \eqn{\alpha}{alpha} is the normalising constant. Intuitively, each point of the pattern contributes a factor \eqn{\beta}{beta} to the probability density, and each pair of points closer than \eqn{r} units apart contributes a factor \eqn{\gamma}{gamma} to the density. The interaction parameter \eqn{\gamma}{gamma} must be less than or equal to \eqn{1} in order that the process be well-defined (Kelly and Ripley, 1976). This model describes an ``ordered'' or ``inhibitive'' pattern. If \eqn{\gamma=1}{gamma=1} it reduces to a Poisson process (complete spatial randomness) with intensity \eqn{\beta}{beta}. If \eqn{\gamma=0}{gamma=0} it is called a ``hard core process'' with hard core radius \eqn{R/2}, since no pair of points is permitted to lie closer than \eqn{R} units apart. The simulation algorithm used to generate the point pattern is \sQuote{dominated coupling from the past} as implemented by Berthelsen and \Moller (2002, 2003). This is a \sQuote{perfect simulation} or \sQuote{exact simulation} algorithm, so called because the output of the algorithm is guaranteed to have the correct probability distribution exactly (unlike the Metropolis-Hastings algorithm used in \code{\link{rmh}}, whose output is only approximately correct). There is a tiny chance that the algorithm will run out of space before it has terminated. If this occurs, an error message will be generated. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}). If \code{nsim > 1}, a list of point patterns. } \references{ Berthelsen, K.K. and \Moller, J. (2002) A primer on perfect simulation for spatial point processes. \emph{Bulletin of the Brazilian Mathematical Society} 33, 351-367. Berthelsen, K.K. and \Moller, J. (2003) Likelihood and non-parametric Bayesian MCMC inference for spatial point processes based on perfect simulation and path sampling. \emph{Scandinavian Journal of Statistics} 30, 549-564. Kelly, F.P. and Ripley, B.D. (1976) On Strauss's model for clustering. \emph{Biometrika} \bold{63}, 357--360. \Moller, J. and Waagepetersen, R. (2003). \emph{Statistical Inference and Simulation for Spatial Point Processes.} Chapman and Hall/CRC. Strauss, D.J. (1975) A model for clustering. \emph{Biometrika} \bold{62}, 467--475. } \author{ Kasper Klitgaard Berthelsen, adapted for \pkg{spatstat} by \adrian } \examples{ X <- rStrauss(0.05,0.2,1.5,square(50)) } \seealso{ \code{\link{rmh}}, \code{\link{Strauss}}, \code{\link{rHardcore}}, \code{\link{rStraussHard}}, \code{\link{rDiggleGratton}}, \code{\link{rDGS}}, \code{\link{rPenttinen}}. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rmh.default.Rd0000644000176200001440000006522214252332033016653 0ustar liggesusers\name{rmh.default} \alias{rmh.default} \title{Simulate Point Process Models using the Metropolis-Hastings Algorithm.} \description{ Generates a random point pattern, simulated from a chosen point process model, using the Metropolis-Hastings algorithm. } \usage{ \method{rmh}{default}(model, start=NULL, control=default.rmhcontrol(model), \dots, nsim=1, drop=TRUE, saveinfo=TRUE, verbose=TRUE, snoop=FALSE) } \arguments{ \item{model}{Data specifying the point process model that is to be simulated. } \item{start}{Data determining the initial state of the algorithm. } \item{control}{Data controlling the iterative behaviour and termination of the algorithm. } \item{\dots}{ Further arguments passed to \code{\link{rmhcontrol}} or to trend functions in \code{model}. } \item{nsim}{ Number of simulated point patterns that should be generated. } \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a single point pattern. } \item{saveinfo}{ Logical value indicating whether to save auxiliary information. } \item{verbose}{ Logical value indicating whether to print progress reports. } \item{snoop}{ Logical. If \code{TRUE}, activate the visual debugger. } } \value{ A point pattern (an object of class \code{"ppp"}, see \code{\link{ppp.object}}) or a list of point patterns. The returned value has an attribute \code{info} containing modified versions of the arguments \code{model}, \code{start}, and \code{control} which together specify the exact simulation procedure. The \code{info} attribute can be printed (and is printed automatically by \code{\link{summary.ppp}}). For computational efficiency, the \code{info} attribute can be omitted by setting \code{saveinfo=FALSE}. The value of \code{\link[base:Random]{.Random.seed}} at the start of the simulations is also saved and returned as an attribute \code{seed}. If the argument \code{track=TRUE} was given (see \code{\link{rmhcontrol}}), the transition history of the algorithm is saved, and returned as an attribute \code{history}. The transition history is a data frame containing a factor \code{proposaltype} identifying the proposal type (Birth, Death or Shift) and a logical vector \code{accepted} indicating whether the proposal was accepted. The data frame also has columns \code{numerator}, \code{denominator} which give the numerator and denominator of the Hastings ratio for the proposal. If the argument \code{nsave} was given (see \code{\link{rmhcontrol}}), the return value has an attribute \code{saved} which is a list of point patterns, containing the intermediate states of the algorithm. } \details{ This function generates simulated realisations from any of a range of spatial point processes, using the Metropolis-Hastings algorithm. It is the default method for the generic function \code{\link{rmh}}. This function executes a Metropolis-Hastings algorithm with birth, death and shift proposals as described in Geyer and \Moller (1994). The argument \code{model} specifies the point process model to be simulated. It is either a list, or an object of class \code{"rmhmodel"}, with the following components: \describe{ \item{cif}{A character string specifying the choice of interpoint interaction for the point process. } \item{par}{ Parameter values for the conditional intensity function. } \item{w}{ (Optional) window in which the pattern is to be generated. An object of class \code{"owin"}, or data acceptable to \code{\link{as.owin}}. } \item{trend}{ Data specifying the spatial trend in the model, if it has a trend. This may be a function, a pixel image (of class \code{"im"}), (or a list of functions or images if the model is multitype). If the trend is a function or functions, any auxiliary arguments \code{...} to \code{rmh.default} will be passed to these functions, which should be of the form \code{function(x, y, ...)}. } \item{types}{ List of possible types, for a multitype point process. } } For full details of these parameters, see \code{\link{rmhmodel.default}}. The argument \code{start} determines the initial state of the Metropolis-Hastings algorithm. It is either \code{NULL}, or an object of class \code{"rmhstart"}, or a list with the following components: \describe{ \item{n.start}{ Number of points in the initial point pattern. A single integer, or a vector of integers giving the numbers of points of each type in a multitype point pattern. Incompatible with \code{x.start}. } \item{x.start}{ Initial point pattern configuration. Incompatible with \code{n.start}. \code{x.start} may be a point pattern (an object of class \code{"ppp"}), or data which can be coerced to this class by \code{\link{as.ppp}}, or an object with components \code{x} and \code{y}, or a two-column matrix. In the last two cases, the window for the pattern is determined by \code{model$w}. In the first two cases, if \code{model$w} is also present, then the final simulated pattern will be clipped to the window \code{model$w}. } } For full details of these parameters, see \code{\link{rmhstart}}. The third argument \code{control} controls the simulation procedure (including \emph{conditional simulation}), iterative behaviour, and termination of the Metropolis-Hastings algorithm. It is either \code{NULL}, or a list, or an object of class \code{"rmhcontrol"}, with components: \describe{ \item{p}{The probability of proposing a ``shift'' (as opposed to a birth or death) in the Metropolis-Hastings algorithm. } \item{q}{The conditional probability of proposing a death (rather than a birth) given that birth/death has been chosen over shift. } \item{nrep}{The number of repetitions or iterations to be made by the Metropolis-Hastings algorithm. It should be large. } \item{expand}{ Either a numerical expansion factor, or a window (object of class \code{"owin"}). Indicates that the process is to be simulated on a larger domain than the original data window \code{w}, then clipped to \code{w} when the algorithm has finished. The default is to expand the simulation window if the model is stationary and non-Poisson (i.e. it has no trend and the interaction is not Poisson) and not to expand in all other cases. If the model has a trend, then in order for expansion to be feasible, the trend must be given either as a function, or an image whose bounding box is large enough to contain the expanded window. } \item{periodic}{A logical scalar; if \code{periodic} is \code{TRUE} we simulate a process on the torus formed by identifying opposite edges of a rectangular window. } \item{ptypes}{A vector of probabilities (summing to 1) to be used in assigning a random type to a new point. } \item{fixall}{A logical scalar specifying whether to condition on the number of points of each type. } \item{nverb}{An integer specifying how often ``progress reports'' (which consist simply of the number of repetitions completed) should be printed out. If nverb is left at 0, the default, the simulation proceeds silently. } \item{x.cond}{If this argument is present, then \emph{conditional simulation} will be performed, and \code{x.cond} specifies the conditioning points and the type of conditioning. } \item{nsave,nburn}{ If these values are specified, then intermediate states of the simulation algorithm will be saved every \code{nsave} iterations, after an initial burn-in period of \code{nburn} iterations. } \item{track}{ Logical flag indicating whether to save the transition history of the simulations. } } For full details of these parameters, see \code{\link{rmhcontrol}}. The control parameters can also be given in the \code{\dots} arguments. } \section{Conditional Simulation}{ There are several kinds of conditional simulation. \itemize{ \item Simulation \emph{conditional upon the number of points}, that is, holding the number of points fixed. To do this, set \code{control$p} (the probability of a shift) equal to 1. The number of points is then determined by the starting state, which may be specified either by setting \code{start$n.start} to be a scalar, or by setting the initial pattern \code{start$x.start}. \item In the case of multitype processes, it is possible to simulate the model \emph{conditionally upon the number of points of each type}, i.e. holding the number of points of each type to be fixed. To do this, set \code{control$p} equal to 1 and \code{control$fixall} to be \code{TRUE}. The number of points is then determined by the starting state, which may be specified either by setting \code{start$n.start} to be an integer vector, or by setting the initial pattern \code{start$x.start}. \item Simulation \emph{conditional on the configuration observed in a sub-window}, that is, requiring that, inside a specified sub-window \eqn{V}, the simulated pattern should agree with a specified point pattern \eqn{y}.To do this, set \code{control$x.cond} to equal the specified point pattern \eqn{y}, making sure that it is an object of class \code{"ppp"} and that the window \code{Window(control$x.cond)} is the conditioning window \eqn{V}. \item Simulation \emph{conditional on the presence of specified points}, that is, requiring that the simulated pattern should include a specified set of points. This is simulation from the Palm distribution of the point process given a pattern \eqn{y}. To do this, set \code{control$x.cond} to be a \code{data.frame} containing the coordinates (and marks, if appropriate) of the specified points. } For further information, see \code{\link{rmhcontrol}}. Note that, when we simulate conditionally on the number of points, or conditionally on the number of points of each type, no expansion of the window is possible. } \section{Visual Debugger}{ If \code{snoop = TRUE}, an interactive debugger is activated. On the current plot device, the debugger displays the current state of the Metropolis-Hastings algorithm together with the proposed transition to the next state. Clicking on this graphical display (using the left mouse button) will re-centre the display at the clicked location. Surrounding this graphical display is an array of boxes representing different actions. Clicking on one of the action boxes (using the left mouse button) will cause the action to be performed. Debugger actions include: \itemize{ \item Zooming in or out \item Panning (shifting the field of view) left, right, up or down \item Jumping to the next iteration \item Skipping 10, 100, 1000, 10000 or 100000 iterations \item Jumping to the next Birth proposal (etc) \item Changing the fate of the proposal (i.e. changing whether the proposal is accepted or rejected) \item Dumping the current state and proposal to a file \item Printing detailed information at the terminal \item Exiting the debugger (so that the simulation algorithm continues without further interruption). } Right-clicking the mouse will also cause the debugger to exit. } \references{ Baddeley, A. and Turner, R. (2000) Practical maximum pseudolikelihood for spatial point patterns. \emph{Australian and New Zealand Journal of Statistics} \bold{42}, 283 -- 322. Diggle, P. J. (2003) \emph{Statistical Analysis of Spatial Point Patterns} (2nd ed.) Arnold, London. Diggle, P.J. and Gratton, R.J. (1984) Monte Carlo methods of inference for implicit statistical models. \emph{Journal of the Royal Statistical Society, series B} \bold{46}, 193 -- 212. Diggle, P.J., Gates, D.J., and Stibbard, A. (1987) A nonparametric estimator for pairwise-interaction point processes. Biometrika \bold{74}, 763 -- 770. Geyer, C.J. and \Moller, J. (1994) Simulation procedures and likelihood inference for spatial point processes. \emph{Scandinavian Journal of Statistics} \bold{21}, 359--373. Geyer, C.J. (1999) Likelihood Inference for Spatial Point Processes. Chapter 3 in O.E. Barndorff-Nielsen, W.S. Kendall and M.N.M. Van Lieshout (eds) \emph{Stochastic Geometry: Likelihood and Computation}, Chapman and Hall / CRC, Monographs on Statistics and Applied Probability, number 80. Pages 79--140. } \section{Warnings}{ There is never a guarantee that the Metropolis-Hastings algorithm has converged to its limiting distribution. If \code{start$x.start} is specified then \code{expand} is set equal to 1 and simulation takes place in \code{Window(x.start)}. Any specified value for \code{expand} is simply ignored. The presence of both a component \code{w} of \code{model} and a non-null value for \code{Window(x.start)} makes sense ONLY if \code{w} is contained in \code{Window(x.start)}. For multitype processes make sure that, even if there is to be no trend corresponding to a particular type, there is still a component (a NULL component) for that type, in the list. } \seealso{ \code{\link{rmh}}, \code{\link[spatstat.model]{rmh.ppm}}, \code{\link{rStrauss}}, \code{\link{ppp}}, \code{\link[spatstat.model]{ppm}} Interactions: \rmhInteractionsList. } \section{Other models}{ In theory, any finite point process model can be simulated using the Metropolis-Hastings algorithm, provided the conditional intensity is uniformly bounded. In practice, the list of point process models that can be simulated using \code{rmh.default} is limited to those that have been implemented in the package's internal C code. More options will be added in the future. Note that the \code{lookup} conditional intensity function permits the simulation (in theory, to any desired degree of approximation) of any pairwise interaction process for which the interaction depends only on the distance between the pair of points. } \section{Reproducible simulations}{ If the user wants the simulation to be exactly reproducible (e.g. for a figure in a journal article, where it is useful to have the figure consistent from draft to draft) then the state of the random number generator should be set before calling \code{rmh.default}. This can be done either by calling \code{\link[base:Random]{set.seed}} or by assigning a value to \code{\link[base:Random]{.Random.seed}}. In the examples below, we use \code{\link[base:Random]{set.seed}}. If a simulation has been performed and the user now wants to repeat it exactly, the random seed should be extracted from the simulated point pattern \code{X} by \code{seed <- attr(x, "seed")}, then assigned to the system random nunber state by \code{.Random.seed <- seed} before calling \code{rmh.default}. } \examples{ if(interactive()) { nr <- 1e5 nv <- 5000 ns <- 200 } else { nr <- 20 nv <- 5 ns <- 20 oldopt <- spatstat.options() spatstat.options(expand=1.05) } set.seed(961018) # Strauss process. mod01 <- list(cif="strauss",par=list(beta=2,gamma=0.2,r=0.7), w=c(0,10,0,10)) X1.strauss <- rmh(model=mod01,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X1.strauss) # Strauss process, conditioning on n = 42: X2.strauss <- rmh(model=mod01,start=list(n.start=42), control=list(p=1,nrep=nr,nverb=nv)) # Tracking algorithm progress: # (a) saving intermediate states: X <- rmh(model=mod01,start=list(n.start=ns), control=list(nrep=nr, nsave=nr/5, nburn=nr/2)) Saved <- attr(X, "saved") plot(Saved) # (b) inspecting transition history: X <- rmh(model=mod01,start=list(n.start=ns), control=list(nrep=nr, track=TRUE)) History <- attr(X, "history") head(History) # Hard core process: mod02 <- list(cif="hardcore",par=list(beta=2,hc=0.7),w=c(0,10,0,10)) X3.hardcore <- rmh(model=mod02,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X3.hardcore) # Strauss process equal to pure hardcore: mod02s <- list(cif="strauss",par=list(beta=2,gamma=0,r=0.7),w=c(0,10,0,10)) X3.strauss <- rmh(model=mod02s,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Strauss process in a polygonal window. x <- c(0.55,0.68,0.75,0.58,0.39,0.37,0.19,0.26,0.42) y <- c(0.20,0.27,0.68,0.99,0.80,0.61,0.45,0.28,0.33) mod03 <- list(cif="strauss",par=list(beta=2000,gamma=0.6,r=0.07), w=owin(poly=list(x=x,y=y))) X4.strauss <- rmh(model=mod03,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X4.strauss) # Strauss process in a polygonal window, conditioning on n = 80. X5.strauss <- rmh(model=mod03,start=list(n.start=ns), control=list(p=1,nrep=nr,nverb=nv)) # Strauss process, starting off from X4.strauss, but with the # polygonal window replace by a rectangular one. At the end, # the generated pattern is clipped to the original polygonal window. xxx <- X4.strauss Window(xxx) <- as.owin(c(0,1,0,1)) X6.strauss <- rmh(model=mod03,start=list(x.start=xxx), control=list(nrep=nr,nverb=nv)) # Strauss with hardcore: mod04 <- list(cif="straush",par=list(beta=2,gamma=0.2,r=0.7,hc=0.3), w=c(0,10,0,10)) X1.straush <- rmh(model=mod04,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Another Strauss with hardcore (with a perhaps surprising result): mod05 <- list(cif="straush",par=list(beta=80,gamma=0.36,r=45,hc=2.5), w=c(0,250,0,250)) X2.straush <- rmh(model=mod05,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Pure hardcore (identical to X3.strauss). mod06 <- list(cif="straush",par=list(beta=2,gamma=1,r=1,hc=0.7), w=c(0,10,0,10)) X3.straush <- rmh(model=mod06,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Soft core: w <- c(0,10,0,10) mod07 <- list(cif="sftcr",par=list(beta=0.8,sigma=0.1,kappa=0.5), w=c(0,10,0,10)) X.sftcr <- rmh(model=mod07,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.sftcr) # Area-interaction process: mod42 <- rmhmodel(cif="areaint",par=list(beta=2,eta=1.6,r=0.7), w=c(0,10,0,10)) X.area <- rmh(model=mod42,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.area) # Triplets process modtrip <- list(cif="triplets",par=list(beta=2,gamma=0.2,r=0.7), w=c(0,10,0,10)) X.triplets <- rmh(model=modtrip, start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.triplets) # Multitype Strauss: beta <- c(0.027,0.008) gmma <- matrix(c(0.43,0.98,0.98,0.36),2,2) r <- matrix(c(45,45,45,45),2,2) mod08 <- list(cif="straussm",par=list(beta=beta,gamma=gmma,radii=r), w=c(0,250,0,250)) X1.straussm <- rmh(model=mod08,start=list(n.start=ns), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv)) if(interactive()) plot(X1.straussm) # Multitype Strauss conditioning upon the total number # of points being 80: X2.straussm <- rmh(model=mod08,start=list(n.start=ns), control=list(p=1,ptypes=c(0.75,0.25),nrep=nr, nverb=nv)) # Conditioning upon the number of points of type 1 being 60 # and the number of points of type 2 being 20: X3.straussm <- rmh(model=mod08,start=list(n.start=c(60,20)), control=list(fixall=TRUE,p=1,ptypes=c(0.75,0.25), nrep=nr,nverb=nv)) # Multitype Strauss hardcore: rhc <- matrix(c(9.1,5.0,5.0,2.5),2,2) mod09 <- list(cif="straushm",par=list(beta=beta,gamma=gmma, iradii=r,hradii=rhc),w=c(0,250,0,250)) X.straushm <- rmh(model=mod09,start=list(n.start=ns), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv)) # Multitype Strauss hardcore with trends for each type: beta <- c(0.27,0.08) tr3 <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } # log quadratic trend tr4 <- function(x,y){x <- x/250; y <- y/250; exp(-0.6*x+0.5*y)} # log linear trend mod10 <- list(cif="straushm",par=list(beta=beta,gamma=gmma, iradii=r,hradii=rhc),w=c(0,250,0,250), trend=list(tr3,tr4)) X1.straushm.trend <- rmh(model=mod10,start=list(n.start=ns), control=list(ptypes=c(0.75,0.25), nrep=nr,nverb=nv)) if(interactive()) plot(X1.straushm.trend) # Multitype Strauss hardcore with trends for each type, given as images: bigwin <- square(250) i1 <- as.im(tr3, bigwin) i2 <- as.im(tr4, bigwin) mod11 <- list(cif="straushm",par=list(beta=beta,gamma=gmma, iradii=r,hradii=rhc),w=bigwin, trend=list(i1,i2)) X2.straushm.trend <- rmh(model=mod11,start=list(n.start=ns), control=list(ptypes=c(0.75,0.25),expand=1, nrep=nr,nverb=nv)) # Diggle, Gates, and Stibbard: mod12 <- list(cif="dgs",par=list(beta=3600,rho=0.08),w=c(0,1,0,1)) X.dgs <- rmh(model=mod12,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.dgs) # Diggle-Gratton: mod13 <- list(cif="diggra", par=list(beta=1800,kappa=3,delta=0.02,rho=0.04), w=square(1)) X.diggra <- rmh(model=mod13,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.diggra) # Fiksel: modFik <- list(cif="fiksel", par=list(beta=180,r=0.15,hc=0.07,kappa=2,a= -1.0), w=square(1)) X.fiksel <- rmh(model=modFik,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.fiksel) # Geyer: mod14 <- list(cif="geyer",par=list(beta=1.25,gamma=1.6,r=0.2,sat=4.5), w=c(0,10,0,10)) X1.geyer <- rmh(model=mod14,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X1.geyer) # Geyer; same as a Strauss process with parameters # (beta=2.25,gamma=0.16,r=0.7): mod15 <- list(cif="geyer",par=list(beta=2.25,gamma=0.4,r=0.7,sat=10000), w=c(0,10,0,10)) X2.geyer <- rmh(model=mod15,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) mod16 <- list(cif="geyer",par=list(beta=8.1,gamma=2.2,r=0.08,sat=3)) X3.geyer <- rmh(model=mod16,start=list(x.start=redwood), control=list(periodic=TRUE,nrep=nr,nverb=nv)) # Geyer, starting from the redwood data set, simulating # on a torus, and conditioning on n: X4.geyer <- rmh(model=mod16,start=list(x.start=redwood), control=list(p=1,periodic=TRUE,nrep=nr,nverb=nv)) # Lookup (interaction function h_2 from page 76, Diggle (2003)): r <- seq(from=0,to=0.2,length=101)[-1] # Drop 0. h <- 20*(r-0.05) h[r<0.05] <- 0 h[r>0.10] <- 1 mod17 <- list(cif="lookup",par=list(beta=4000,h=h,r=r),w=c(0,1,0,1)) X.lookup <- rmh(model=mod17,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) if(interactive()) plot(X.lookup) # Strauss with trend tr <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } beta <- 0.3 gmma <- 0.5 r <- 45 modStr <- list(cif="strauss",par=list(beta=beta,gamma=gmma,r=r), w=square(250), trend=tr) X1.strauss.trend <- rmh(model=modStr,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Baddeley-Geyer r <- seq(0,0.2,length=8)[-1] gmma <- c(0.5,0.6,0.7,0.8,0.7,0.6,0.5) mod18 <- list(cif="badgey",par=list(beta=4000, gamma=gmma,r=r,sat=5), w=square(1)) X1.badgey <- rmh(model=mod18,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) mod19 <- list(cif="badgey", par=list(beta=4000, gamma=gmma,r=r,sat=1e4), w=square(1)) set.seed(1329) X2.badgey <- rmh(model=mod18,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Check: h <- ((prod(gmma)/cumprod(c(1,gmma)))[-8])^2 hs <- stepfun(r,c(h,1)) mod20 <- list(cif="lookup",par=list(beta=4000,h=hs),w=square(1)) set.seed(1329) X.check <- rmh(model=mod20,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # X2.badgey and X.check will be identical. mod21 <- list(cif="badgey",par=list(beta=300,gamma=c(1,0.4,1), r=c(0.035,0.07,0.14),sat=5), w=square(1)) X3.badgey <- rmh(model=mod21,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Same result as Geyer model with beta=300, gamma=0.4, r=0.07, # sat = 5 (if seeds and control parameters are the same) # Or more simply: mod22 <- list(cif="badgey", par=list(beta=300,gamma=0.4,r=0.07, sat=5), w=square(1)) X4.badgey <- rmh(model=mod22,start=list(n.start=ns), control=list(nrep=nr,nverb=nv)) # Same again --- i.e. the BadGey model includes the Geyer model. # Illustrating scalability. if(FALSE) { M1 <- rmhmodel(cif="strauss",par=list(beta=60,gamma=0.5,r=0.04),w=owin()) set.seed(496) X1 <- rmh(model=M1,start=list(n.start=300)) M2 <- rmhmodel(cif="strauss",par=list(beta=0.6,gamma=0.5,r=0.4), w=owin(c(0,10),c(0,10))) set.seed(496) X2 <- rmh(model=M2,start=list(n.start=300)) chk <- affine(X1,mat=diag(c(10,10))) all.equal(chk,X2,check.attributes=FALSE) # Under the default spatstat options the foregoing all.equal() # will yield TRUE. Setting spatstat.options(scalable=FALSE) and # re-running the code will reveal differences between X1 and X2. } if(!interactive()) spatstat.options(oldopt) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rshift.Rd0000644000176200001440000000300714243054775015750 0ustar liggesusers\name{rshift} \alias{rshift} \title{Random Shift} \description{ Randomly shifts the points of a point pattern or line segment pattern. Generic. } \usage{ rshift(X, \dots) } \arguments{ \item{X}{Pattern to be subjected to a random shift. A point pattern (class \code{"ppp"}), a line segment pattern (class \code{"psp"}) or an object of class \code{"splitppp"}. } \item{\dots}{ Arguments controlling the generation of the random shift vector, or specifying which parts of the pattern will be shifted. } } \value{ An object of the same type as \code{X}. } \details{ This operation applies a random shift (vector displacement) to the points in a point pattern, or to the segments in a line segment pattern. The argument \code{X} may be \itemize{ \item a point pattern (an object of class \code{"ppp"}) \item a line segment pattern (an object of class \code{"psp"}) \item an object of class \code{"splitppp"} (basically a list of point patterns, obtained from \code{\link{split.ppp}}). } The function \code{rshift} is generic, with methods for the three classes \code{"ppp"}, \code{"psp"} and \code{"splitppp"}. See the help pages for these methods, \code{\link{rshift.ppp}}, \code{\link{rshift.psp}} and \code{\link{rshift.splitppp}}, for further information. } \seealso{ \code{\link{rshift.ppp}}, \code{\link{rshift.psp}}, \code{\link{rshift.splitppp}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rnoise.Rd0000644000176200001440000000342214243054775015751 0ustar liggesusers\name{rnoise} \alias{rnoise} \title{ Random Pixel Noise } \description{ Generate a pixel image whose pixel values are random numbers following a specified probability distribution. } \usage{ rnoise(rgen = runif, w = square(1), \dots) } \arguments{ \item{rgen}{ Random generator for the pixel values. A function in the \R language. } \item{w}{ Window (region or pixel raster) in which to generate the image. Any data acceptable to \code{\link{as.mask}}. } \item{\dots}{ Arguments, matched by name, to be passed to \code{rgen} to specify the parameters of the probability distribution, or passed to \code{\link{as.mask}} to control the pixel resolution. } } \details{ The argument \code{w} could be a window (class \code{"owin"}), a pixel image (class \code{"im"}) or other data. It is first converted to a binary mask by \code{\link{as.mask}} using any relevant arguments in \code{\dots}. Then each pixel inside the window (i.e. with logical value \code{TRUE} in the mask) is assigned a random numerical value by calling the function \code{rgen}. The function \code{rgen} would typically be one of the standard random variable generators like \code{\link{runif}} (uniformly distributed random values) or \code{\link{rnorm}} (Gaussian random values). Its first argument \code{n} is the number of values to be generated. Other arguments to \code{rgen} must be matched by name. } \value{ A pixel image (object of class \code{"im"}). } \author{ \adrian \rolf and \ege } \seealso{ \code{\link{as.mask}}, \code{\link{as.im}}, \code{\link[stats]{Distributions}}. } \examples{ plot(rnoise(), main="Uniform noise") plot(rnoise(rnorm, dimyx=32, mean=2, sd=1), main="White noise") } \keyword{spatial} \keyword{datagen} spatstat.random/man/dpakes.Rd0000644000176200001440000000457314331654773015733 0ustar liggesusers\name{dpakes} \alias{dpakes} \alias{ppakes} \alias{qpakes} \alias{rpakes} \title{ Pakes distribution } \description{ Probability density, cumulative distribution function, quantile function, and random generation for the Pakes distribution. } \usage{ dpakes(x, zeta) ppakes(q, zeta) qpakes(p, zeta) rpakes(n, zeta) } \arguments{ \item{x,q}{ Numeric vector of quantiles. } \item{p}{Numeric vector of probabilities} \item{n}{Number of observations.} \item{zeta}{ Mean of distribution. A single, non-negative, numeric value. } } \details{ These functions concern the probability distribution of the random variable \deqn{ X = \sum_{n=1}^\infty \prod_{j=1}^n U_j^{1/\zeta} }{ X = sum_[n=1]^[infty] prod_[j=1]^[n] U[j]^(1/zeta) } where \eqn{U_1, U_2, \ldots}{U[1], U[2], ...} are independent random variables uniformly distributed on \eqn{[0,1]} and \eqn{\zeta}{zeta} is a parameter. This distribution arises in many contexts. For example, for a homogeneous Poisson point process in two-dimensional space with intensity \eqn{\lambda}{lambda}, the standard Gaussian kernel estimator of intensity with bandwidth \eqn{\sigma}, evaluated at any fixed location \eqn{u}, has the same distribution as \eqn{(\lambda/\zeta) X}{(lambda/zeta) * X} where \eqn{\zeta = 2 \pi \lambda\sigma^2}{zeta = 2 * pi * lambda * sigma^2}. Following the usual convention, \code{dpakes} computes the probability density, \code{ppakes} the cumulative distribution function, and \code{qpakes} the quantile function, and \code{rpakes} generates random variates with this distribution. The computation is based on a recursive integral equation for the cumulative distribution function, due to Professor Tony Pakes, presented in Baddeley, Moller and Pakes (2008). The solution uses the fact that the random variable satisfies the distributional equivalence \deqn{ X \equiv U^{1/\zeta} (1 + X) }{ X == U^(1/zeta) * (1+X) } where \eqn{U} is uniformly distributed on \eqn{[0,1]} and independent of \eqn{X}. } \value{ A numeric vector. } \references{ Baddeley, A., Moller, J. and Pakes, A.G. (2008) Properties of residuals for spatial point processes, \emph{Annals of the Institute of Statistical Mathematics} \bold{60}, 627--649. } \author{ Adrian Baddeley. } \examples{ curve(dpakes(x, 1.5), to=4) rpakes(3, 1.5) } \keyword{distribution} spatstat.random/man/rSSI.Rd0000644000176200001440000001111314243054775015266 0ustar liggesusers\name{rSSI} \alias{rSSI} \title{Simulate Simple Sequential Inhibition} \description{ Generate a random point pattern, a realisation of the Simple Sequential Inhibition (SSI) process. } \usage{ rSSI(r, n=Inf, win = square(1), giveup = 1000, x.init=NULL, ..., f=NULL, fmax=NULL, nsim=1, drop=TRUE) } \arguments{ \item{r}{ Inhibition distance. } \item{n}{ Maximum number of points allowed. If \code{n} is finite, stop when the \emph{total} number of points in the point pattern reaches \code{n}. If \code{n} is infinite (the default), stop only when it is apparently impossible to add any more points. See \bold{Details}. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. The default window is the unit square, unless \code{x.init} is specified, when the default window is the window of \code{x.init}. } \item{giveup}{ Number of rejected proposals after which the algorithm should terminate. } \item{x.init}{ Optional. Initial configuration of points. A point pattern (object of class \code{"ppp"}). The pattern returned by \code{rSSI} consists of this pattern together with the points added via simple sequential inhibition. See \bold{Details}. } \item{\dots}{Ignored.} \item{f,fmax}{ Optional arguments passed to \code{\link{rpoint}} to specify a non-uniform probability density for the random points. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This algorithm generates one or more realisations of the Simple Sequential Inhibition point process inside the window \code{win}. Starting with an empty window (or with the point pattern \code{x.init} if specified), the algorithm adds points one-by-one. Each new point is generated uniformly in the window and independently of preceding points. If the new point lies closer than \code{r} units from an existing point, then it is rejected and another random point is generated. The algorithm terminates when either \describe{ \item{(a)}{ the desired number \code{n} of points is reached, or } \item{(b)}{ the current point configuration has not changed for \code{giveup} iterations, suggesting that it is no longer possible to add new points. } } If \code{n} is infinite (the default) then the algorithm terminates only when (b) occurs. The result is sometimes called a \emph{Random Sequential Packing}. Note that argument \code{n} specifies the maximum permitted \bold{total} number of points in the pattern returned by \code{rSSI()}. If \code{x.init} is not \code{NULL} then the number of points that are \emph{added} is at most \code{n - npoints(x.init)} if \code{n} is finite. Thus if \code{x.init} is not \code{NULL} then argument \code{n} must be at least as large as \code{npoints(x.init)}, otherwise an error is given. If \code{n==npoints(x.init)} then a warning is given and the call to \code{rSSI()} has no real effect; \code{x.init} is returned. There is no requirement that the points of \code{x.init} be at a distance at least \code{r} from each other. All of the \emph{added} points will be at a distance at least \code{r} from each other and from any point of \code{x.init}. The points will be generated inside the window \code{win} and the result will be a point pattern in the same window. The default window is the unit square, \code{win = square(1)}, unless \code{x.init} is specified, when the default is \code{win=Window(x.init)}, the window of \code{x.init}. If both \code{win} and \code{x.init} are specified, and if the two windows are different, then a warning will be issued. Any points of \code{x.init} lying outside \code{win} will be removed, with a warning. } \seealso{ \code{\link{rpoispp}}, \code{\link{rMaternI}}, \code{\link{rMaternII}}. } \examples{ Vinf <- rSSI(0.07) V100 <- rSSI(0.07, 100) X <- runifpoint(100) Y <- rSSI(0.03,142,x.init=X) # Y consists of X together with # 42 added points. plot(Y, main="rSSI") plot(X,add=TRUE,chars=20,cols="red") ## inhomogeneous Z <- rSSI(0.07, 50, f=function(x,y){x}) plot(Z) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoisline.Rd0000644000176200001440000000276014243054775016462 0ustar liggesusers\name{rpoisline} \alias{rpoisline} \title{Generate Poisson Random Line Process} \description{ Generate a random pattern of line segments obtained from the Poisson line process. } \usage{ rpoisline(lambda, win=owin()) } \arguments{ \item{lambda}{ Intensity of the Poisson line process. A positive number. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. } } \value{ A line segment pattern (an object of class \code{"psp"}). The result also has an attribute called \code{"lines"} (an object of class \code{"infline"} specifying the original infinite random lines) and an attribute \code{"linemap"} (an integer vector mapping the line segments to their parent lines). } \details{ This algorithm generates a realisation of the uniform Poisson line process, and clips it to the window \code{win}. The argument \code{lambda} must be a positive number. It controls the intensity of the process. The expected number of lines intersecting a convex region of the plane is equal to \code{lambda} times the perimeter length of the region. The expected total length of the lines crossing a region of the plane is equal to \code{lambda * pi} times the area of the region. } \seealso{ \code{\link{psp}} } \examples{ # uniform Poisson line process with intensity 10, # clipped to the unit square rpoisline(10) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/ragsAreaInter.Rd0000644000176200001440000000603514243054774017203 0ustar liggesusers\name{ragsAreaInter} \alias{ragsAreaInter} \title{ Alternating Gibbs Sampler for Area-Interaction Process } \description{ Generate a realisation of the area-interaction process using the alternating Gibbs sampler. Applies only when the interaction parameter \eqn{eta} is greater than 1. } \usage{ ragsAreaInter(beta, eta, r, \dots, win = NULL, bmax = NULL, periodic = FALSE, ncycles = 100) } \arguments{ \item{beta}{ First order trend. A number, a pixel image (object of class \code{"im"}), or a \code{function(x,y)}. } \item{eta}{ Interaction parameter (canonical form) as described in the help for \code{\link[spatstat.model]{AreaInter}}. A number greater than 1. } \item{r}{ Disc radius in the model. A number greater than 1. } \item{\dots}{ Additional arguments for \code{beta} if it is a function. } \item{win}{ Simulation window. An object of class \code{"owin"}. (Ignored if \code{beta} is a pixel image.) } \item{bmax}{ Optional. The maximum possible value of \code{beta}, or a number larger than this. } \item{periodic}{ Logical value indicating whether to treat opposite sides of the simulation window as being the same, so that points close to one side may interact with points close to the opposite side. Feasible only when the window is a rectangle. } \item{ncycles}{ Number of cycles of the alternating Gibbs sampler to be performed. } } \details{ This function generates a simulated realisation of the area-interaction process (see \code{\link[spatstat.model]{AreaInter}}) using the alternating Gibbs sampler (see \code{\link[spatstat.random]{rags}}). It exploits a mathematical relationship between the (unmarked) area-interaction process and the two-type hard core process (Baddeley and Van Lieshout, 1995; Widom and Rowlinson, 1970). This relationship only holds when the interaction parameter \code{eta} is greater than 1 so that the area-interaction process is clustered. The parameters \code{beta,eta} are the canonical parameters described in the help for \code{\link[spatstat.model]{AreaInter}}. The first order trend \code{beta} may be a constant, a function, or a pixel image. The simulation window is determined by \code{beta} if it is a pixel image, and otherwise by the argument \code{win} (the default is the unit square). } \value{ A point pattern (object of class \code{"ppp"}). } \references{ Baddeley, A.J. and Van Lieshout, M.N.M. (1995). Area-interaction point processes. \emph{Annals of the Institute of Statistical Mathematics} \bold{47} (1995) 601--619. Widom, B. and Rowlinson, J.S. (1970). New model for the study of liquid-vapor phase transitions. \emph{The Journal of Chemical Physics} \bold{52} (1970) 1670--1684. } \author{ \adrian. } \seealso{ \code{\link[spatstat.random]{rags}}, \code{\link[spatstat.random]{ragsMultiHard}} \code{\link[spatstat.model]{AreaInter}} } \examples{ plot(ragsAreaInter(100, 2, 0.07, ncycles=15)) } \keyword{spatial} \keyword{datagen} spatstat.random/man/rVarGamma.Rd0000644000176200001440000002757314356430614016337 0ustar liggesusers\name{rVarGamma} \alias{rVarGamma} \title{Simulate Neyman-Scott Point Process with Variance Gamma cluster kernel} \description{ Generate a random point pattern, a simulated realisation of the Neyman-Scott process with Variance Gamma (Bessel) cluster kernel. } \usage{ rVarGamma(kappa, scale, mu, nu, win = square(1), nsim=1, drop=TRUE, \dots, algorithm=c("BKBC", "naive"), nonempty=TRUE, thresh = 0.001, poisthresh=1e-6, expand = NULL, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL) } \arguments{ \item{kappa}{ Intensity of the Poisson process of cluster centres. A single positive number, a function, or a pixel image. } \item{scale}{ Scale parameter for cluster kernel. Determines the size of clusters. A single positive number, in the same units as the spatial coordinates. } \item{mu}{ Mean number of points per cluster (a single positive number) or reference intensity for the cluster points (a function or a pixel image). } \item{nu}{ Shape parameter for the cluster kernel. A number greater than -1. } \item{win}{ Window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link[spatstat.geom]{as.owin}}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{\dots}{ Passed to \code{\link[spatstat.random]{clusterfield}} to control the image resolution when \code{saveLambda=TRUE}, and to \code{\link[spatstat.random]{clusterradius}} when \code{expand} is missing or \code{NULL}. } \item{algorithm}{ String (partially matched) specifying the simulation algorithm. See Details. } \item{nonempty}{ Logical. If \code{TRUE} (the default), a more efficient algorithm is used, in which parents are generated conditionally on having at least one offspring point. If \code{FALSE}, parents are generated even if they have no offspring. Both choices are valid; the default is recommended unless you need to simulate all the parent points for some other purpose. } \item{thresh}{ Threshold relative to the cluster kernel value at the origin (parent location) determining when the cluster kernel will be treated as zero for simulation purposes. Will be overridden by argument \code{expand} if that is given. } \item{poisthresh}{ Numerical threshold below which the model will be treated as a Poisson process. See Details. } \item{expand}{ Window expansion distance. A single number. The distance by which the original window will be expanded in order to generate parent points. Has a sensible default, determined by calling \code{\link[spatstat.random]{clusterradius}} with the numeric threshold value given in \code{thresh}. } \item{saveparents}{ Logical value indicating whether to save the locations of the parent points as an attribute. } \item{saveLambda}{ Logical. If \code{TRUE} then the random intensity corresponding to the simulated parent points will also be calculated and saved, and returns as an attribute of the point pattern. } \item{kappamax}{ Optional. Numerical value which is an upper bound for the values of \code{kappa}, when \code{kappa} is a pixel image or a function. } \item{mumax}{ Optional. Numerical value which is an upper bound for the values of \code{mu}, when \code{mu} is a pixel image or a function. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. Additionally, some intermediate results of the simulation are returned as attributes of this point pattern (see \code{\link[spatstat.random]{rNeymanScott}}). Furthermore, the simulated intensity function is returned as an attribute \code{"Lambda"}, if \code{saveLambda=TRUE}. } \details{ This algorithm generates a realisation of the Neyman-Scott process with Variance Gamma (Bessel) cluster kernel, inside the window \code{win}. The process is constructed by first generating a Poisson point process of ``parent'' points with intensity \code{kappa}. Then each parent point is replaced by a random cluster of points, the number of points in each cluster being random with a Poisson (\code{mu}) distribution, and the points being placed independently and uniformly according to a Variance Gamma kernel. Note that, for correct simulation of the model, the parent points are not restricted to lie inside the window \code{win}; the parent process is effectively the uniform Poisson process on the infinite plane. The shape of the kernel is determined by the dimensionless index \code{nu}. This is the parameter \eqn{nu^\prime}{nu'} (nu-prime) \eqn{\nu^\prime = \alpha/2-1}{nu' = alpha/2 - 1} appearing in equation (12) on page 126 of Jalilian et al (2013). The scale of the kernel is determined by the argument \code{scale}, which is the parameter \eqn{\eta}{eta} appearing in equations (12) and (13) of Jalilian et al (2013). It is expressed in units of length (the same as the unit of length for the window \code{win}). The algorithm can also generate spatially inhomogeneous versions of the cluster process: \itemize{ \item The parent points can be spatially inhomogeneous. If the argument \code{kappa} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is taken as specifying the intensity function of an inhomogeneous Poisson process that generates the parent points. \item The offspring points can be inhomogeneous. If the argument \code{mu} is a \code{function(x,y)} or a pixel image (object of class \code{"im"}), then it is interpreted as the reference density for offspring points, in the sense of Waagepetersen (2006). } If the pair correlation function of the model is very close to that of a Poisson process, deviating by less than \code{poisthresh}, then the model is approximately a Poisson process, and will be simulated as a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Simulation Algorithm}{ Two simulation algorithms are implemented. \itemize{ \item The \emph{naive} algorithm generates the cluster process by directly following the description given above. First the window \code{win} is expanded by a distance equal to \code{expand}. Then the parent points are generated in the expanded window according to a Poisson process with intensity \code{kappa}. Then each parent point is replaced by a finite cluster of offspring points as described above. The naive algorithm is used if \code{algorithm="naive"} or if \code{nonempty=FALSE}. \item The \emph{BKBC} algorithm, proposed by Baddeley and Chang (2023), is a modification of the algorithm of Brix and Kendall (2002). Parents are generated in the infinite plane, subject to the condition that they have at least one offspring point inside the window \code{win}. The BKBC algorithm is used when \code{algorithm="BKBC"} (the default) and \code{nonempty=TRUE} (the default). } The naive algorithm becomes very slow when \code{scale} is large, while the BKBC algorithm is uniformly fast (Baddeley and Chang, 2023). If \code{saveparents=TRUE}, then the simulated point pattern will have an attribute \code{"parents"} containing the coordinates of the parent points, and an attribute \code{"parentid"} mapping each offspring point to its parent. If \code{nonempty=TRUE} (the default), then parents are generated subject to the condition that they have at least one offspring point in the window \code{win}. \code{nonempty=FALSE}, then parents without offspring will be included; this option is not available in the \emph{BKBC} algorithm. Note that if \code{kappa} is a pixel image, its domain must be larger than the window \code{win}. This is because an offspring point inside \code{win} could have its parent point lying outside \code{win}. In order to allow this, the naive simulation algorithm first expands the original window \code{win} by a distance equal to \code{expand} and generates the Poisson process of parent points on this larger window. If \code{kappa} is a pixel image, its domain must contain this larger window. If the pair correlation function of the model is very close to that of a Poisson process, with maximum deviation less than \code{poisthresh}, then the model is approximately a Poisson process. This is detected by the naive algorithm which then simulates a Poisson process with intensity \code{kappa * mu}, using \code{\link[spatstat.random]{rpoispp}}. This avoids computations that would otherwise require huge amounts of memory. } \section{Fitting cluster models to data}{ The Variance-Gamma cluster model with homogeneous parents (i.e. where \code{kappa} is a single number) where the offspring are either homogeneous or inhomogeneous (\code{mu} is a single number, a function or pixel image) can be fitted to point pattern data using \code{\link[spatstat.model]{kppm}}, or fitted to the inhomogeneous \eqn{K} function using \code{\link[spatstat.model]{vargamma.estK}} or \code{\link[spatstat.model]{vargamma.estpcf}}. Currently \pkg{spatstat} does not support fitting the Variance-Gamma cluster process model with inhomogeneous parents. A Variance-Gamma cluster process model fitted by \code{\link[spatstat.model]{kppm}} can be simulated automatically using \code{\link[spatstat.model]{simulate.kppm}} (which invokes \code{rVarGamma} to perform the simulation). } \section{Warning}{ The argument \code{nu} is the parameter \eqn{\nu^\prime}{nu'} (nu-prime) \eqn{\nu^\prime = \alpha/2-1}{nu' = alpha/2 - 1} appearing in equation (12) on page 126 of Jalilian et al (2013). This is different from the parameter called \eqn{\nu}{nu} appearing in equation(14) on page 127 of Jalilian et al (2013), defined by \eqn{\nu = \alpha-1}{nu = alpha - 1}. This has been a frequent source of confusion. } \seealso{ \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rMatClust}}, \code{\link[spatstat.random]{rThomas}}, \code{\link[spatstat.random]{rCauchy}}, \code{\link[spatstat.random]{rNeymanScott}}, \code{\link[spatstat.random]{rGaussPoisson}}. For fitting the model, see \code{\link[spatstat.model]{kppm}}, \code{\link[spatstat.model]{clusterfit}}, \code{\link[spatstat.model]{vargamma.estK}}, \code{\link[spatstat.model]{vargamma.estpcf}}. } \examples{ # homogeneous X <- rVarGamma(kappa=5, scale=2, mu=5, nu=-1/4) # inhomogeneous ff <- function(x,y){ exp(2 - 3 * abs(x)) } fmax <- exp(2) Z <- as.im(ff, W= owin()) Y <- rVarGamma(kappa=5, scale=2, mu=Z, nu=0) YY <- rVarGamma(kappa=ff, scale=2, mu=3, nu=0, kappamax=fmax) } \references{ \baddchangclustersim Brix, A. and Kendall, W.S. (2002) Simulation of cluster point processes without edge effects. \emph{Advances in Applied Probability} \bold{34}, 267--280. Jalilian, A., Guan, Y. and Waagepetersen, R. (2013) Decomposition of variance for spatial Cox processes. \emph{Scandinavian Journal of Statistics} \bold{40}, 119-137. Waagepetersen, R. (2007) An estimating function approach to inference for inhomogeneous Neyman-Scott processes. \emph{Biometrics} \bold{63}, 252--258. } \author{ Original algorithm by Abdollah Jalilian and Rasmus Waagepetersen. Adapted for \pkg{spatstat} by \adrian. Brix-Kendall-Baddeley-Chang algorithm implemented by \adrian and \yamei. } \keyword{spatial} \keyword{datagen} spatstat.random/man/rtemper.Rd0000644000176200001440000000557714364103051016127 0ustar liggesusers\name{rtemper} \alias{rtemper} \title{ Simulated Annealing or Simulated Tempering for Gibbs Point Processes } \description{ Performs simulated annealing or simulated tempering for a Gibbs point process model using a specified annealing schedule. } \usage{ rtemper(model, invtemp, nrep, \dots, track=FALSE, start = NULL, verbose = FALSE) } \arguments{ \item{model}{ A Gibbs point process model: a fitted Gibbs point process model (object of class \code{"ppm"}), or any data acceptable to \code{\link{rmhmodel}}. } \item{invtemp}{ A numeric vector of positive numbers. The sequence of values of inverse temperature that will be used. } \item{nrep}{ An integer vector of the same length as \code{invtemp}. The value \code{nrep[i]} specifies the number of steps of the Metropolis-Hastings algorithm that will be performed at inverse temperature \code{invtemp[i]}. } \item{start}{ Initial starting state for the simulation. Any data acceptable to \code{\link{rmhstart}}. } \item{track}{ Logical flag indicating whether to save the transition history of the simulations. } \item{\dots}{ Additional arguments passed to \code{\link{rmh.default}}. } \item{verbose}{ Logical value indicating whether to print progress reports. } } \details{ The Metropolis-Hastings simulation algorithm \code{\link{rmh}} is run for \code{nrep[1]} steps at inverse temperature \code{invtemp[1]}, then for \code{nrep[2]} steps at inverse temperature \code{invtemp[2]}, and so on. Setting the inverse temperature to a value \eqn{\alpha}{alpha} means that the probability density of the Gibbs model, \eqn{f(x)}, is replaced by \eqn{g(x) = C\, f(x)^\alpha}{g(x) = C f(x)^alpha} where \eqn{C} is a normalising constant depending on \eqn{\alpha}{alpha}. Larger values of \eqn{\alpha}{alpha} exaggerate the high and low values of probability density, while smaller values of \eqn{\alpha}{alpha} flatten out the probability density. For example if the original \code{model} is a Strauss process, the modified model is close to a hard core process for large values of inverse temperature, and close to a Poisson process for small values of inverse temperature. } \value{ A point pattern (object of class \code{"ppp"}). If \code{track=TRUE}, the result also has an attribute \code{"history"} which is a data frame with columns \code{proposaltype}, \code{accepted}, \code{numerator} and \code{denominator}, as described in \code{\link{rmh.default}}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{rmh.default}}, \code{\link{rmh}}. } \examples{ stra <- rmhmodel(cif="strauss", par=list(beta=2,gamma=0.2,r=0.7), w=square(10)) nr <- if(interactive()) 1e5 else 1e3 Y <- rtemper(stra, c(1, 2, 4, 8), nr * (1:4), verbose=TRUE, track=TRUE) } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoisppOnLines.Rd0000644000176200001440000000742614243054775017446 0ustar liggesusers\name{rpoisppOnLines} \alias{rpoisppOnLines} \title{Generate Poisson Point Pattern on Line Segments} \description{ Given a line segment pattern, generate a Poisson random point pattern on the line segments. } \usage{ rpoisppOnLines(lambda, L, lmax = NULL, \dots, nsim=1, drop=TRUE) } \arguments{ \item{lambda}{Intensity of the Poisson process. A single number, a \code{function(x,y)}, a pixel image (object of class \code{"im"}), or a vector of numbers, a list of functions, or a list of images. } \item{L}{Line segment pattern (object of class \code{"psp"}) on which the points should be generated. } \item{lmax}{ Optional upper bound (for increased computational efficiency). A known upper bound for the values of \code{lambda}, if \code{lambda} is a function or a pixel image. That is, \code{lmax} should be a number which is known to be greater than or equal to all values of \code{lambda}. } \item{\dots}{Additional arguments passed to \code{lambda} if it is a function. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This command generates a Poisson point process on the one-dimensional system of line segments in \code{L}. The result is a point pattern consisting of points lying on the line segments in \code{L}. The number of random points falling on any given line segment follows a Poisson distribution. The patterns of points on different segments are independent. The intensity \code{lambda} is the expected number of points per unit \bold{length} of line segment. It may be constant, or it may depend on spatial location. In order to generate an unmarked Poisson process, the argument \code{lambda} may be a single number, or a \code{function(x,y)}, or a pixel image (object of class \code{"im"}). In order to generate a \emph{marked} Poisson process, \code{lambda} may be a numeric vector, a list of functions, or a list of images, each entry giving the intensity for a different mark value. If \code{lambda} is not numeric, then the (Lewis-Shedler) rejection method is used. The rejection method requires knowledge of \code{lmax}, the maximum possible value of \code{lambda}. This should be either a single number, or a numeric vector of the same length as \code{lambda}. If \code{lmax} is not given, it will be computed approximately, by sampling many values of \code{lambda}. If \code{lmax} is given, then it \bold{must} be larger than any possible value of \code{lambda}, otherwise the results of the algorithm will be incorrect. } \value{ If \code{nsim = 1}, a point pattern (object of class \code{"ppp"}) in the same window as \code{L}. If \code{nsim > 1}, a list of such point patterns. } \seealso{ \code{\link{psp}}, \code{\link{ppp}}, \code{\link{runifpointOnLines}}, \code{\link{rpoispp}} } \examples{ live <- interactive() L <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) if(live) plot(L, main="") # uniform intensity Y <- rpoisppOnLines(4, L) if(live) plot(Y, add=TRUE, pch="+") # uniform MARKED process with types 'a' and 'b' Y <- rpoisppOnLines(c(a=4, b=5), L) if(live) { plot(L, main="") plot(Y, add=TRUE, pch="+") } # intensity is a function Y <- rpoisppOnLines(function(x,y){ 10 * x^2}, L, 10) if(live) { plot(L, main="") plot(Y, add=TRUE, pch="+") } # intensity is an image Z <- as.im(function(x,y){10 * sqrt(x+y)}, unit.square()) Y <- rpoisppOnLines(Z, L, 15) if(live) { plot(L, main="") plot(Y, add=TRUE, pch="+") } } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rcell.Rd0000644000176200001440000000664314243054774015562 0ustar liggesusers\name{rcell} \alias{rcell} \title{Simulate Baddeley-Silverman Cell Process} \description{ Generates a random point pattern, a simulated realisation of the Baddeley-Silverman cell process model. } \usage{ rcell(win=square(1), nx=NULL, ny=nx, \dots, dx=NULL, dy=dx, N=10, nsim=1, drop=TRUE) } \arguments{ \item{win}{ A window. An object of class \code{\link[spatstat.geom]{owin}}, or data in any format acceptable to \code{\link[spatstat.geom]{as.owin}()}. } \item{nx}{ Number of columns of cells in the window. Incompatible with \code{dx}. } \item{ny}{ Number of rows of cells in the window. Incompatible with \code{dy}. } \item{\dots}{Ignored.} \item{dx}{ Width of the cells. Incompatible with \code{nx}. } \item{dy}{ Height of the cells. Incompatible with \code{ny}. } \item{N}{ Integer. Distributional parameter: the maximum number of random points in each cell. Passed to \code{\link[spatstat.random]{rcellnumber}}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This function generates a simulated realisation of the \dQuote{cell process} (Baddeley and Silverman, 1984), a random point process with the same second-order properties as the uniform Poisson process. In particular, the \eqn{K} function of this process is identical to the \eqn{K} function of the uniform Poisson process (aka Complete Spatial Randomness). The same holds for the pair correlation function and all other second-order properties. The cell process is a counterexample to the claim that the \eqn{K} function completely characterises a point pattern. A cell process is generated by dividing space into equal rectangular tiles. In each tile, a random number of random points is placed. By default, there are either \eqn{0}, \eqn{1} or \eqn{10} points, with probabilities \eqn{1/10}, \eqn{8/9} and \eqn{1/90} respectively. The points within a tile are independent and uniformly distributed in that tile, and the numbers of points in different tiles are independent random integers. The tile width is determined either by the number of columns \code{nx} or by the horizontal spacing \code{dx}. The tile height is determined either by the number of rows \code{ny} or by the vertical spacing \code{dy}. The cell process is then generated in these tiles. The random numbers of points are generated by \code{\link[spatstat.random]{rcellnumber}}. Some of the resulting random points may lie outside the window \code{win}: if they do, they are deleted. The result is a point pattern inside the window \code{win}. } \seealso{ \code{\link{rcellnumber}}, \code{\link{rstrat}}, \code{\link{rsyst}}, \code{\link{runifpoint}}, \code{\link[spatstat.explore]{Kest}} } \examples{ X <- rcell(nx=15) plot(X) if(require(spatstat.explore)) { plot(Kest(X)) } } \references{ Baddeley, A.J. and Silverman, B.W. (1984) A cautionary example on the use of second-order methods for analyzing point patterns. \emph{Biometrics} \bold{40}, 1089-1094. } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rpoispp3.Rd0000644000176200001440000000304214510473067016223 0ustar liggesusers\name{rpoispp3} \alias{rpoispp3} \title{ Generate Poisson Point Pattern in Three Dimensions } \description{ Generate a random three-dimensional point pattern using the homogeneous Poisson process. } \usage{ rpoispp3(lambda, domain = box3(), nsim=1, drop=TRUE) } \arguments{ \item{lambda}{ Intensity of the Poisson process. A single positive number. } \item{domain}{ Three-dimensional box in which the process should be generated. An object of class \code{"box3"}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ If \code{nsim = 1} and \code{drop=TRUE}, a point pattern in three dimensions (an object of class \code{"pp3"}). If \code{nsim > 1}, a list of such point patterns. } \details{ This function generates a realisation of the homogeneous Poisson process in three dimensions, with intensity \code{lambda} (points per unit volume). The realisation is generated inside the three-dimensional region \code{domain} which currently must be a rectangular box (object of class \code{"box3"}). } \note{ The intensity \code{lambda} is the expected number of points \emph{per unit volume}. } \seealso{ \code{\link{runifpoint3}}, \code{\link{pp3}}, \code{\link{box3}} } \examples{ X <- rpoispp3(50) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} \concept{Three-dimensional} spatstat.random/man/rMosaicSet.Rd0000644000176200001440000000276014504720405016515 0ustar liggesusers\name{rMosaicSet} \alias{rMosaicSet} \title{Mosaic Random Set} \description{ Generate a random set by taking a random selection of tiles of a given tessellation. } \usage{ rMosaicSet(X, p=0.5) } \arguments{ \item{X}{ A tessellation (object of class \code{"tess"}). } \item{p}{ Probability of including a given tile. A number strictly between 0 and 1. } } \details{ Given a tessellation \code{X}, this function randomly selects some of the tiles of \code{X}, including each tile with probability \eqn{p} independently of the other tiles. The selected tiles are then combined to form a set in the plane. One application of this is Switzer's (1965) example of a random set which has a Markov property. It is constructed by generating \code{X} according to a Poisson line tessellation (see \code{\link{rpoislinetess}}). } \value{ A window (object of class \code{"owin"}). } \references{ Switzer, P. A random set process in the plane with a Markovian property. \emph{Annals of Mathematical Statistics} \bold{36} (1965) 1859--1863. } \author{\adrian and \rolf} \seealso{ \code{\link{rpoislinetess}}, \code{\link{rMosaicField}} } \examples{ if(interactive()) { lambda <- 3 n <- 30 } else { lambda <- 1 n <- 5 } # Switzer's random set X <- rpoislinetess(lambda) plot(rMosaicSet(X, 0.5), col="green", border=NA) # another example Y <- dirichlet(runifpoint(n)) plot(rMosaicSet(Y, 0.4)) } \keyword{spatial} \keyword{datagen} spatstat.random/man/rmhmodel.default.Rd0000644000176200001440000005147414243054775017716 0ustar liggesusers\name{rmhmodel.default} \alias{rmhmodel.default} \title{Build Point Process Model for Metropolis-Hastings Simulation.} \description{ Builds a description of a point process model for use in simulating the model by the Metropolis-Hastings algorithm. } \usage{ \method{rmhmodel}{default}(..., cif=NULL, par=NULL, w=NULL, trend=NULL, types=NULL) } \arguments{ \item{\dots}{Ignored.} \item{cif}{Character string specifying the choice of model} \item{par}{Parameters of the model} \item{w}{Spatial window in which to simulate} \item{trend}{Specification of the trend in the model} \item{types}{A vector of factor levels defining the possible marks, for a multitype process. } } \value{ An object of class \code{"rmhmodel"}, which is essentially a list of parameter values for the model. There is a \code{print} method for this class, which prints a sensible description of the model chosen. } \details{ The generic function \code{\link{rmhmodel}} takes a description of a point process model in some format, and converts it into an object of class \code{"rmhmodel"} so that simulations of the model can be generated using the Metropolis-Hastings algorithm \code{\link{rmh}}. This function \code{rmhmodel.default} is the default method. It builds a description of the point process model from the simple arguments listed. The argument \code{cif} is a character string specifying the choice of interpoint interaction for the point process. The current options are \describe{ \item{\code{'areaint'}}{Area-interaction process.} \item{\code{'badgey'}}{Baddeley-Geyer (hybrid Geyer) process.} \item{\code{'dgs'}}{Diggle, Gates and Stibbard (1987) process} \item{\code{'diggra'}}{Diggle and Gratton (1984) process} \item{\code{'fiksel'}}{Fiksel double exponential process (Fiksel, 1984).} \item{\code{'geyer'}}{Saturation process (Geyer, 1999).} \item{\code{'hardcore'}}{Hard core process} \item{\code{'lennard'}}{Lennard-Jones process} \item{\code{'lookup'}}{General isotropic pairwise interaction process, with the interaction function specified via a ``lookup table''.} \item{\code{'multihard'}}{Multitype hardcore process} \item{\code{'penttinen'}}{The Penttinen process} \item{\code{'strauss'}}{The Strauss process} \item{\code{'straush'}}{The Strauss process with hard core} \item{\code{'sftcr'}}{The Softcore process} \item{\code{'straussm'}}{ The multitype Strauss process} \item{\code{'straushm'}}{Multitype Strauss process with hard core} \item{\code{'triplets'}}{Triplets process (Geyer, 1999).} } It is also possible to specify a \emph{hybrid} of these interactions in the sense of Baddeley et al (2013). In this case, \code{cif} is a character vector containing names from the list above. For example, \code{cif=c('strauss', 'geyer')} would specify a hybrid of the Strauss and Geyer models. The argument \code{par} supplies parameter values appropriate to the conditional intensity function being invoked. For the interactions listed above, these parameters are: \describe{ \item{areaint:}{ (Area-interaction process.) A \bold{named} list with components \code{beta,eta,r} which are respectively the ``base'' intensity, the scaled interaction parameter and the interaction radius. } \item{badgey:}{ (Baddeley-Geyer process.) A \bold{named} list with components \code{beta} (the ``base'' intensity), \code{gamma} (a vector of non-negative interaction parameters), \code{r} (a vector of interaction radii, of the same length as \code{gamma}, in \emph{increasing} order), and \code{sat} (the saturation parameter(s); this may be a scalar, or a vector of the same length as \code{gamma} and \code{r}; all values should be at least 1). Note that because of the presence of ``saturation'' the \code{gamma} values are permitted to be larger than 1. } \item{dgs:}{ (Diggle, Gates, and Stibbard process. See Diggle, Gates, and Stibbard (1987)) A \bold{named} list with components \code{beta} and \code{rho}. This process has pairwise interaction function equal to \deqn{ e(t) = \sin^2\left(\frac{\pi t}{2\rho}\right) }{ e(t) = sin^2((pi * t)/(2 * rho)) } for \eqn{t < \rho}{t < rho}, and equal to 1 for \eqn{t \ge \rho}{t >= rho}. } \item{diggra:}{ (Diggle-Gratton process. See Diggle and Gratton (1984) and Diggle, Gates and Stibbard (1987).) A \bold{named} list with components \code{beta}, \code{kappa}, \code{delta} and \code{rho}. This process has pairwise interaction function \eqn{e(t)} equal to 0 for \eqn{t < \delta}{t < delta}, equal to \deqn{ \left(\frac{t-\delta}{\rho-\delta}\right)^\kappa }{ ((t-delta)/(rho-delta))^kappa } for \eqn{\delta \le t < \rho}{delta <= t < rho}, and equal to 1 for \eqn{t \ge \rho}{t >= rho}. Note that here we use the symbol \eqn{\kappa}{kappa} where Diggle, Gates, and Stibbard use \eqn{\beta}{beta} since we reserve the symbol \eqn{\beta}{beta} for an intensity parameter. } \item{fiksel:}{ (Fiksel double exponential process, see Fiksel (1984)) A \bold{named} list with components \code{beta}, \code{r}, \code{hc}, \code{kappa} and \code{a}. This process has pairwise interaction function \eqn{e(t)} equal to 0 for \eqn{t < hc}, equal to \deqn{ \exp(a \exp(- \kappa t)) }{ exp(a * exp( - kappa * t)) } for \eqn{hc \le t < r}{hc <= t < r}, and equal to 1 for \eqn{t \ge r}{t >= r}. } \item{geyer:}{ (Geyer's saturation process. See Geyer (1999).) A \bold{named} list with components \code{beta}, \code{gamma}, \code{r}, and \code{sat}. The components \code{beta}, \code{gamma}, \code{r} are as for the Strauss model, and \code{sat} is the ``saturation'' parameter. The model is Geyer's ``saturation'' point process model, a modification of the Strauss process in which we effectively impose an upper limit (\code{sat}) on the number of neighbours which will be counted as close to a given point. Explicitly, a saturation point process with interaction radius \eqn{r}, saturation threshold \eqn{s}, and parameters \eqn{\beta}{beta} and \eqn{\gamma}{gamma}, is the point process in which each point \eqn{x_i}{x[i]} in the pattern \eqn{X} contributes a factor \deqn{\beta \gamma^{\min(s, t(x_i,X))}}{beta gamma^min(s,t(x[i],X))} to the probability density of the point pattern, where \eqn{t(x_i,X)}{t(x[i],X)} denotes the number of ``\eqn{r}-close neighbours'' of \eqn{x_i}{x[i]} in the pattern \eqn{X}. If the saturation threshold \eqn{s} is infinite, the Geyer process reduces to a Strauss process with interaction parameter \eqn{\gamma^2}{gamma^2} rather than \eqn{\gamma}{gamma}. } \item{hardcore:}{ (Hard core process.) A \bold{named} list with components \code{beta} and \code{hc} where \code{beta} is the base intensity and \code{hc} is the hard core distance. This process has pairwise interaction function \eqn{e(t)} equal to 1 if \eqn{t > hc} and 0 if \eqn{t <= hc}. } \item{lennard:}{ (Lennard-Jones process.) A \bold{named} list with components \code{sigma} and \code{epsilon}, where \code{sigma} is the characteristic diameter and \code{epsilon} is the well depth. See \code{\link[spatstat.model]{LennardJones}} for explanation. } \item{multihard:}{ (Multitype hard core process.) A \bold{named} list with components \code{beta} and \code{hradii}, where \code{beta} is a vector of base intensities for each type of point, and \code{hradii} is a matrix of hard core radii between each pair of types. } \item{penttinen:}{ (Penttinen process.) A \bold{named} list with components \code{beta,gamma,r} which are respectively the ``base'' intensity, the pairwise interaction parameter, and the disc radius. Note that \code{gamma} must be less than or equal to 1. See \code{\link[spatstat.model]{Penttinen}} for explanation. (Note that there is also an algorithm for perfect simulation of the Penttinen process, \code{\link{rPenttinen}}) } \item{strauss:}{ (Strauss process.) A \bold{named} list with components \code{beta,gamma,r} which are respectively the ``base'' intensity, the pairwise interaction parameter and the interaction radius. Note that \code{gamma} must be less than or equal to 1. (Note that there is also an algorithm for perfect simulation of the Strauss process, \code{\link{rStrauss}}) } \item{straush:}{ (Strauss process with hardcore.) A \bold{named} list with entries \code{beta,gamma,r,hc} where \code{beta}, \code{gamma}, and \code{r} are as for the Strauss process, and \code{hc} is the hardcore radius. Of course \code{hc} must be less than \code{r}. } \item{sftcr:}{ (Softcore process.) A \bold{named} list with components \code{beta,sigma,kappa}. Again \code{beta} is a ``base'' intensity. The pairwise interaction between two points \eqn{u \neq v}{u != v} is \deqn{ \exp \left \{ - \left ( \frac{\sigma}{||u-v||} \right )^{2/\kappa} \right \} }{-(sigma/||u-v||)^(2/kappa)} Note that it is necessary that \eqn{0 < \kappa < 1}{0 < kappa <1}. } \item{straussm:}{ (Multitype Strauss process.) A \bold{named} list with components \itemize{ \item \code{beta}: A vector of ``base'' intensities, one for each possible type. \item \code{gamma}: A \bold{symmetric} matrix of interaction parameters, with \eqn{\gamma_{ij}}{gamma_ij} pertaining to the interaction between type \eqn{i} and type \eqn{j}. \item \code{radii}: A \bold{symmetric} matrix of interaction radii, with entries \eqn{r_{ij}}{r_ij} pertaining to the interaction between type \eqn{i} and type \eqn{j}. } } \item{straushm:}{ (Multitype Strauss process with hardcore.) A \bold{named} list with components \code{beta} and \code{gamma} as for \code{straussm} and \bold{two} ``radii'' components: \itemize{ \item \code{iradii}: the interaction radii \item \code{hradii}: the hardcore radii } which are both symmetric matrices of nonnegative numbers. The entries of \code{hradii} must be less than the corresponding entries of \code{iradii}. } \item{triplets:}{ (Triplets process.) A \bold{named} list with components \code{beta,gamma,r} which are respectively the ``base'' intensity, the triplet interaction parameter and the interaction radius. Note that \code{gamma} must be less than or equal to 1. } \item{lookup:}{ (Arbitrary pairwise interaction process with isotropic interaction.) A \bold{named} list with components \code{beta}, \code{r}, and \code{h}, or just with components \code{beta} and \code{h}. This model is the pairwise interaction process with an isotropic interaction given by any chosen function \eqn{H}. Each pair of points \eqn{x_i, x_j}{x[i], x[j]} in the point pattern contributes a factor \eqn{H(d(x_i, x_j))}{H(d(x[i],x[j]))} to the probability density, where \eqn{d} denotes distance and \eqn{H} is the pair interaction function. The component \code{beta} is a (positive) scalar which determines the ``base'' intensity of the process. In this implementation, \eqn{H} must be a step function. It is specified by the user in one of two ways. \itemize{ \item \bold{as a vector of values:} If \code{r} is present, then \code{r} is assumed to give the locations of jumps in the function \eqn{H}, while the vector \code{h} gives the corresponding values of the function. Specifically, the interaction function \eqn{H(t)} takes the value \code{h[1]} for distances \eqn{t} in the interval \code{[0, r[1])}; takes the value \code{h[i]} for distances \eqn{t} in the interval \code{[r[i-1], r[i])} where \eqn{i = 2,\ldots, n}{i = 2, ..., n}; and takes the value 1 for \eqn{t \ge r[n]}{t >= r[n]}. Here \eqn{n} denotes the length of \code{r}. The components \code{r} and \code{h} must be numeric vectors of equal length. The \code{r} values must be strictly positive, and sorted in increasing order. The entries of \code{h} must be non-negative. If any entry of \code{h} is greater than 1, then the entry \code{h[1]} must be 0 (otherwise the specified process is non-existent). Greatest efficiency is achieved if the values of \code{r} are equally spaced. [\bold{Note:} The usage of \code{r} and \code{h} has \emph{changed} from the previous usage in \pkg{spatstat} versions 1.4-7 to 1.5-1, in which ascending order was not required, and in which the first entry of \code{r} had to be 0.] \item \bold{as a stepfun object:} If \code{r} is absent, then \code{h} must be an object of class \code{"stepfun"} specifying a step function. Such objects are created by \code{\link{stepfun}}. The stepfun object \code{h} must be right-continuous (which is the default using \code{\link{stepfun}}.) The values of the step function must all be nonnegative. The values must all be less than 1 unless the function is identically zero on some initial interval \eqn{[0,r)}. The rightmost value (the value of \code{h(t)} for large \code{t}) must be equal to 1. Greatest efficiency is achieved if the jumps (the ``knots'' of the step function) are equally spaced. } } } For a hybrid model, the argument \code{par} should be a list, of the same length as \code{cif}, such that \code{par[[i]]} is a list of the parameters required for the interaction \code{cif[i]}. See the Examples. The optional argument \code{trend} determines the spatial trend in the model, if it has one. It should be a function or image (or a list of such, if the model is multitype) to provide the value of the trend at an arbitrary point. \describe{ \item{trend given as a function:}{A trend function may be a function of any number of arguments, but the first two must be the \eqn{x,y} coordinates of a point. Auxiliary arguments may be passed to the \code{trend} function at the time of simulation, via the \code{\dots} argument to \code{\link{rmh}}. The function \bold{must} be \bold{vectorized}. That is, it must be capable of accepting vector valued \code{x} and \code{y} arguments. Put another way, it must be capable of calculating the trend value at a number of points, simultaneously, and should return the \bold{vector} of corresponding trend values. } \item{trend given as an image:}{ An image (see \code{\link{im.object}}) provides the trend values at a grid of points in the observation window and determines the trend value at other points as the value at the nearest grid point. } } Note that the trend or trends must be \bold{non-negative}; no checking is done for this. The optional argument \code{w} specifies the window in which the pattern is to be generated. If specified, it must be in a form which can be coerced to an object of class \code{owin} by \code{\link{as.owin}}. The optional argument \code{types} specifies the possible types in a multitype point process. If the model being simulated is multitype, and \code{types} is not specified, then this vector defaults to \code{1:ntypes} where \code{ntypes} is the number of types. } \references{ Baddeley, A., Turner, R., Mateu, J. and Bevan, A. (2013) Hybrids of Gibbs point process models and their implementation. \emph{Journal of Statistical Software} \bold{55}:11, 1--43. \code{DOI: 10.18637/jss.v055.i11} Diggle, P. J. (2003) \emph{Statistical Analysis of Spatial Point Patterns} (2nd ed.) Arnold, London. Diggle, P.J. and Gratton, R.J. (1984) Monte Carlo methods of inference for implicit statistical models. \emph{Journal of the Royal Statistical Society, series B} \bold{46}, 193 -- 212. Diggle, P.J., Gates, D.J., and Stibbard, A. (1987) A nonparametric estimator for pairwise-interaction point processes. Biometrika \bold{74}, 763 -- 770. \emph{Scandinavian Journal of Statistics} \bold{21}, 359--373. Fiksel, T. (1984) Estimation of parameterized pair potentials of marked and non-marked Gibbsian point processes. \emph{Electronische Informationsverabeitung und Kybernetika} \bold{20}, 270--278. Geyer, C.J. (1999) Likelihood Inference for Spatial Point Processes. Chapter 3 in O.E. Barndorff-Nielsen, W.S. Kendall and M.N.M. Van Lieshout (eds) \emph{Stochastic Geometry: Likelihood and Computation}, Chapman and Hall / CRC, Monographs on Statistics and Applied Probability, number 80. Pages 79--140. } \section{Warnings in Respect of ``lookup''}{ For the \code{lookup} cif, the entries of the \code{r} component of \code{par} must be \emph{strictly positive} and sorted into ascending order. Note that if you specify the \code{lookup} pairwise interaction function via \code{\link{stepfun}()} the arguments \code{x} and \code{y} which are passed to \code{stepfun()} are slightly different from \code{r} and \code{h}: \code{length(y)} is equal to \code{1+length(x)}; the final entry of \code{y} must be equal to 1 --- i.e. this value is explicitly supplied by the user rather than getting tacked on internally. The step function returned by \code{stepfun()} must be right continuous (this is the default behaviour of \code{stepfun()}) otherwise an error is given. } \seealso{ \code{\link{rmh}}, \code{\link{rmhcontrol}}, \code{\link{rmhstart}}, \code{\link[spatstat.model]{ppm}}, \rmhInteractionsList. } \examples{ # Strauss process: mod01 <- rmhmodel(cif="strauss",par=list(beta=2,gamma=0.2,r=0.7), w=c(0,10,0,10)) mod01 # The above could also be simulated using 'rStrauss' # Strauss with hardcore: mod04 <- rmhmodel(cif="straush",par=list(beta=2,gamma=0.2,r=0.7,hc=0.3), w=owin(c(0,10),c(0,5))) # Hard core: mod05 <- rmhmodel(cif="hardcore",par=list(beta=2,hc=0.3), w=square(5)) # Soft core: w <- square(10) mod07 <- rmhmodel(cif="sftcr", par=list(beta=0.8,sigma=0.1,kappa=0.5), w=w) # Penttinen process: modpen <- rmhmodel(cif="penttinen",par=list(beta=2,gamma=0.6,r=1), w=c(0,10,0,10)) # Area-interaction process: mod42 <- rmhmodel(cif="areaint",par=list(beta=2,eta=1.6,r=0.7), w=c(0,10,0,10)) # Baddeley-Geyer process: mod99 <- rmhmodel(cif="badgey",par=list(beta=0.3, gamma=c(0.2,1.8,2.4),r=c(0.035,0.07,0.14),sat=5), w=unit.square()) # Multitype Strauss: beta <- c(0.027,0.008) gmma <- matrix(c(0.43,0.98,0.98,0.36),2,2) r <- matrix(c(45,45,45,45),2,2) mod08 <- rmhmodel(cif="straussm", par=list(beta=beta,gamma=gmma,radii=r), w=square(250)) # specify types mod09 <- rmhmodel(cif="straussm", par=list(beta=beta,gamma=gmma,radii=r), w=square(250), types=c("A", "B")) # Multitype Hardcore: rhc <- matrix(c(9.1,5.0,5.0,2.5),2,2) mod08hard <- rmhmodel(cif="multihard", par=list(beta=beta,hradii=rhc), w=square(250), types=c("A", "B")) # Multitype Strauss hardcore with trends for each type: beta <- c(0.27,0.08) ri <- matrix(c(45,45,45,45),2,2) rhc <- matrix(c(9.1,5.0,5.0,2.5),2,2) tr3 <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } # log quadratic trend tr4 <- function(x,y){x <- x/250; y <- y/250; exp(-0.6*x+0.5*y)} # log linear trend mod10 <- rmhmodel(cif="straushm",par=list(beta=beta,gamma=gmma, iradii=ri,hradii=rhc),w=c(0,250,0,250), trend=list(tr3,tr4)) # Triplets process: mod11 <- rmhmodel(cif="triplets",par=list(beta=2,gamma=0.2,r=0.7), w=c(0,10,0,10)) # Lookup (interaction function h_2 from page 76, Diggle (2003)): r <- seq(from=0,to=0.2,length=101)[-1] # Drop 0. h <- 20*(r-0.05) h[r<0.05] <- 0 h[r>0.10] <- 1 mod17 <- rmhmodel(cif="lookup",par=list(beta=4000,h=h,r=r),w=c(0,1,0,1)) # hybrid model modhy <- rmhmodel(cif=c('strauss', 'geyer'), par=list(list(beta=100,gamma=0.5,r=0.05), list(beta=1, gamma=0.7,r=0.1, sat=2)), w=square(1)) modhy } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/rlabel.Rd0000644000176200001440000000677214243054775015726 0ustar liggesusers\name{rlabel} \alias{rlabel} \title{Random Re-Labelling of Point Pattern} \description{ Randomly allocates marks to a point pattern, or permutes the existing marks, or resamples from the existing marks. } \usage{ rlabel(X, labels=marks(X), permute=TRUE, group=NULL, \dots, nsim=1, drop=TRUE) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}, \code{"lpp"}, \code{"pp3"} or \code{"ppx"}) or line segment pattern (object of class \code{"psp"}). } \item{labels}{ Vector of values from which the new marks will be drawn at random. Defaults to the vector of existing marks. } \item{permute}{ Logical value indicating whether to generate new marks by randomly permuting \code{labels} or by drawing a random sample with replacement. } \item{group}{ Optional. A factor, or other data dividing the points into groups. Random relabelling will be performed separately within each group. See Details. } \item{\dots}{Additional arguments passed to \code{\link{cut.ppp}} to determine the grouping factor, when \code{group} is given. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ If \code{nsim = 1} and \code{drop=TRUE}, a marked point pattern (of the same class as \code{X}). If \code{nsim > 1}, a list of point patterns. } \details{ This very simple function allocates random marks to an existing point pattern \code{X}. It is useful for hypothesis testing purposes. (The function can also be applied to line segment patterns.) In the simplest case, the command \code{rlabel(X)} yields a point pattern obtained from \code{X} by randomly permuting the marks of the points. If \code{permute=TRUE}, then \code{labels} should be a vector of length equal to the number of points in \code{X}. The result of \code{rlabel} will be a point pattern with locations given by \code{X} and marks given by a random permutation of \code{labels} (i.e. a random sample without replacement). If \code{permute=FALSE}, then \code{labels} may be a vector of any length. The result of \code{rlabel} will be a point pattern with locations given by \code{X} and marks given by a random sample from \code{labels} (with replacement). The argument \code{group} specifies that the points are divided into several different groups, and that the random labelling shall be performed separately on each group. The arguments \code{group} and \code{\dots} are passed to \code{\link{cut.ppp}} to determine the grouping. Thus \code{group} could be a \code{factor}, or the name of a column of marks in \code{X}, or a tessellation, or a factor-valued pixel image, etc. } \seealso{ \code{\link{marks<-}} to assign arbitrary marks. } \examples{ amacrine # Randomly permute the marks "on" and "off" # Result always has 142 "off" and 152 "on" Y <- rlabel(amacrine) # randomly allocate marks "on" and "off" # with probabilities p(off) = 0.48, p(on) = 0.52 Y <- rlabel(amacrine, permute=FALSE) # randomly allocate marks "A" and "B" with equal probability Y <- rlabel(cells, labels=factor(c("A", "B")), permute=FALSE) # divide the window into tiles and # randomly permute the marks within each tile Z <- rlabel(amacrine, group=quadrats(Window(amacrine), 4, 3)) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.random/man/as.owin.rmhmodel.Rd0000644000176200001440000001457614510473067017646 0ustar liggesusers\name{as.owin.rmhmodel} \alias{as.owin.rmhmodel} \title{Convert Data To Class owin} \description{ Converts data specifying an observation window in any of several formats, into an object of class \code{"owin"}. } \usage{ \method{as.owin}{rmhmodel}(W, \dots, fatal=FALSE) } \arguments{ \item{W}{ Data specifying an observation window, in any of several formats described under \emph{Details} below. } \item{fatal}{ Logical value determining what to do if the data cannot be converted to an observation window. See Details. } \item{\dots}{Ignored.} } \value{ An object of class \code{"owin"} (see \code{\link{owin.object}}) specifying an observation window. } \details{ The class \code{"owin"} is a way of specifying the observation window for a point pattern. See \code{\link{owin.object}} for an overview. The generic function \code{as.owin} converts data in any of several formats into an object of class \code{"owin"} for use by the \pkg{spatstat} package. The function \code{as.owin} is generic, with methods for different classes of objects, and a default method. The argument \code{W} may be \itemize{ \item an object of class \code{"owin"} \item a structure with entries \code{xrange}, \code{yrange} specifying the \eqn{x} and \eqn{y} dimensions of a rectangle \item a structure with entries named \code{xmin}, \code{xmax}, \code{ymin}, \code{ymax} (in any order) specifying the \eqn{x} and \eqn{y} dimensions of a rectangle. This will accept objects of class \code{bbox} in the \code{sf} package. \item a numeric vector of length 4 (interpreted as \code{(xmin, xmax, ymin, ymax)} in that order) specifying the \eqn{x} and \eqn{y} dimensions of a rectangle \item a structure with entries named \code{xl}, \code{xu}, \code{yl}, \code{yu} (in any order) specifying the \eqn{x} and \eqn{y} dimensions of a rectangle as \code{(xmin, xmax) = (xl, xu)} and \code{(ymin, ymax) = (yl, yu)}. This will accept objects of class \code{spp} used in the Venables and Ripley \pkg{spatial} package. \item an object of class \code{"ppp"} representing a point pattern. In this case, the object's \code{window} structure will be extracted. \item an object of class \code{"psp"} representing a line segment pattern. In this case, the object's \code{window} structure will be extracted. \item an object of class \code{"tess"} representing a tessellation. In this case, the object's \code{window} structure will be extracted. \item an object of class \code{"quad"} representing a quadrature scheme. In this case, the window of the \code{data} component will be extracted. \item an object of class \code{"im"} representing a pixel image. In this case, a window of type \code{"mask"} will be returned, with the same pixel raster coordinates as the image. An image pixel value of \code{NA}, signifying that the pixel lies outside the window, is transformed into the logical value \code{FALSE}, which is the corresponding convention for window masks. \item an object of class \code{"ppm"}, \code{"kppm"}, \code{"slrm"} or \code{"dppm"} representing a fitted point process model. In this case, if \code{from="data"} (the default), \code{as.owin} extracts the original point pattern data to which the model was fitted, and returns the observation window of this point pattern. If \code{from="covariates"} then \code{as.owin} extracts the covariate images to which the model was fitted, and returns a binary mask window that specifies the pixel locations. \item an object of class \code{"lpp"} representing a point pattern on a linear network. In this case, \code{as.owin} extracts the linear network and returns a window containing this network. \item an object of class \code{"lppm"} representing a fitted point process model on a linear network. In this case, \code{as.owin} extracts the linear network and returns a window containing this network. \item A \code{data.frame} with exactly three columns. Each row of the data frame corresponds to one pixel. Each row contains the \eqn{x} and \eqn{y} coordinates of a pixel, and a logical value indicating whether the pixel lies inside the window. \item A \code{data.frame} with exactly two columns. Each row of the data frame contains the \eqn{x} and \eqn{y} coordinates of a pixel that lies inside the window. \item an object of class \code{"distfun"}, \code{"nnfun"} or \code{"funxy"} representing a function of spatial location, defined on a spatial domain. The spatial domain of the function will be extracted. \item an object of class \code{"rmhmodel"} representing a point process model that can be simulated using \code{\link{rmh}}. The window (spatial domain) of the model will be extracted. The window may be \code{NULL} in some circumstances (indicating that the simulation window has not yet been determined). This is not treated as an error, because the argument \code{fatal} defaults to \code{FALSE} for this method. \item an object of class \code{"layered"} representing a list of spatial objects. See \code{\link{layered}}. In this case, \code{as.owin} will be applied to each of the objects in the list, and the union of these windows will be returned. \item an object of another suitable class from another package. For full details, see \code{vignette('shapefiles')}. } If the argument \code{W} is not in one of these formats and cannot be converted to a window, then an error will be generated (if \code{fatal=TRUE}) or a value of \code{NULL} will be returned (if \code{fatal=FALSE}). When \code{W} is a data frame, the argument \code{step} can be used to specify the pixel grid spacing; otherwise, the spacing will be guessed from the data. } \seealso{ \code{\link[spatstat.geom]{as.owin}}, \code{\link[spatstat.model]{as.owin.ppm}}, \code{\link[spatstat.linnet]{as.owin.lpp}}. \code{\link{owin.object}}, \code{\link{owin}}. Additional methods for \code{as.owin} may be provided by other packages outside the \pkg{spatstat} family. } \examples{ m <- rmhmodel(cif='poisson', par=list(beta=1), w=square(2)) as.owin(m) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.random/man/rmhmodel.list.Rd0000644000176200001440000001151614243054775017236 0ustar liggesusers\name{rmhmodel.list} \alias{rmhmodel.list} \title{Define Point Process Model for Metropolis-Hastings Simulation.} \description{ Given a list of parameters, builds a description of a point process model for use in simulating the model by the Metropolis-Hastings algorithm. } \usage{ \method{rmhmodel}{list}(model, ...) } \arguments{ \item{model}{A list of parameters. See Details.} \item{\dots}{ Optional list of additional named parameters. } } \value{ An object of class \code{"rmhmodel"}, which is essentially a validated list of parameter values for the model. There is a \code{print} method for this class, which prints a sensible description of the model chosen. } \details{ The generic function \code{\link{rmhmodel}} takes a description of a point process model in some format, and converts it into an object of class \code{"rmhmodel"} so that simulations of the model can be generated using the Metropolis-Hastings algorithm \code{\link{rmh}}. This function \code{rmhmodel.list} is the method for lists. The argument \code{model} should be a named list of parameters of the form \code{list(cif, par, w, trend, types)} where \code{cif} and \code{par} are required and the others are optional. For details about these components, see \code{\link{rmhmodel.default}}. The subsequent arguments \code{\dots} (if any) may also have these names, and they will take precedence over elements of the list \code{model}. } \references{ Diggle, P. J. (2003) \emph{Statistical Analysis of Spatial Point Patterns} (2nd ed.) Arnold, London. Diggle, P.J. and Gratton, R.J. (1984) Monte Carlo methods of inference for implicit statistical models. \emph{Journal of the Royal Statistical Society, series B} \bold{46}, 193 -- 212. Diggle, P.J., Gates, D.J., and Stibbard, A. (1987) A nonparametric estimator for pairwise-interaction point processes. Biometrika \bold{74}, 763 -- 770. \emph{Scandinavian Journal of Statistics} \bold{21}, 359--373. Geyer, C.J. (1999) Likelihood Inference for Spatial Point Processes. Chapter 3 in O.E. Barndorff-Nielsen, W.S. Kendall and M.N.M. Van Lieshout (eds) \emph{Stochastic Geometry: Likelihood and Computation}, Chapman and Hall / CRC, Monographs on Statistics and Applied Probability, number 80. Pages 79--140. } \seealso{ \code{\link{rmhmodel}}, \code{\link{rmhmodel.default}}, \code{\link[spatstat.model]{rmhmodel.ppm}}, \code{\link{rmh}}, \code{\link{rmhcontrol}}, \code{\link{rmhstart}}, \code{\link[spatstat.model]{ppm}}, \code{\link[spatstat.model]{Strauss}}, \code{\link[spatstat.model]{Softcore}}, \code{\link[spatstat.model]{StraussHard}}, \code{\link[spatstat.model]{MultiStrauss}}, \code{\link[spatstat.model]{MultiStraussHard}}, \code{\link[spatstat.model]{DiggleGratton}}, \code{\link[spatstat.model]{PairPiece}} } \examples{ # Strauss process: mod01 <- list(cif="strauss",par=list(beta=2,gamma=0.2,r=0.7), w=c(0,10,0,10)) mod01 <- rmhmodel(mod01) # Strauss with hardcore: mod04 <- list(cif="straush",par=list(beta=2,gamma=0.2,r=0.7,hc=0.3), w=owin(c(0,10),c(0,5))) mod04 <- rmhmodel(mod04) # Soft core: w <- square(10) mod07 <- list(cif="sftcr", par=list(beta=0.8,sigma=0.1,kappa=0.5), w=w) mod07 <- rmhmodel(mod07) # Multitype Strauss: beta <- c(0.027,0.008) gmma <- matrix(c(0.43,0.98,0.98,0.36),2,2) r <- matrix(c(45,45,45,45),2,2) mod08 <- list(cif="straussm", par=list(beta=beta,gamma=gmma,radii=r), w=square(250)) mod08 <- rmhmodel(mod08) # specify types mod09 <- rmhmodel(list(cif="straussm", par=list(beta=beta,gamma=gmma,radii=r), w=square(250), types=c("A", "B"))) # Multitype Strauss hardcore with trends for each type: beta <- c(0.27,0.08) ri <- matrix(c(45,45,45,45),2,2) rhc <- matrix(c(9.1,5.0,5.0,2.5),2,2) tr3 <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } # log quadratic trend tr4 <- function(x,y){x <- x/250; y <- y/250; exp(-0.6*x+0.5*y)} # log linear trend mod10 <- list(cif="straushm",par=list(beta=beta,gamma=gmma, iradii=ri,hradii=rhc),w=c(0,250,0,250), trend=list(tr3,tr4)) mod10 <- rmhmodel(mod10) # Lookup (interaction function h_2 from page 76, Diggle (2003)): r <- seq(from=0,to=0.2,length=101)[-1] # Drop 0. h <- 20*(r-0.05) h[r<0.05] <- 0 h[r>0.10] <- 1 mod17 <- list(cif="lookup",par=list(beta=4000,h=h,r=r),w=c(0,1,0,1)) mod17 <- rmhmodel(mod17) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.random/man/indefinteg.Rd0000644000176200001440000000410314243054774016562 0ustar liggesusers\name{indefinteg} \alias{indefinteg} \title{ Indefinite Integral } \description{ Computes the indefinite integral of the given function. } \usage{ indefinteg(f, x, \dots, method=c("trapezoid", "quadrature"), lower=min(x), nfine=8192) } \arguments{ \item{f}{ an \R function taking a numeric first argument and returning a numeric vector of the same length. } \item{x}{ Vector of values of the argument for which the indefinite integral should be evaluated. } \item{\dots}{ additional arguments to be passed to \code{f}. } \item{method}{ String (partially matched) specifying how to compute the integrals. } \item{lower}{ Lower limit of integration. A single number. } \item{nfine}{ Number of sub-intervals to use for computation if \code{method='trapezoid'}. } } \details{ The indefinite integral of the given function \code{f} is computed numerically at each of the desired values \code{x}. The lower limit of integration is taken to be \code{min(x)}. The result is a numeric vector \code{y} of the same length as \code{x}, with entries \deqn{ y_i = \int_{\mbox{lower}}^{x_i} f(t) dt }{ y[i] = integral[lower]^(x[i]) f(t) dt } If \code{method='trapezoid'} (the default), the integrals are computed rapidly using the trapezoid rule. If \code{method='quadrature'} the integrals are computed accurately but much more slowly, using the numerical quadrature routine \code{\link[stats]{integrate}}. If \code{method='trapezoid'} the function \code{f} is first evaluated on a finer grid of values of the function argument. The fine grid contains \code{nfine} sample points. The values of the indefinite integral on the fine grid are computed using the trapezoidal approximation. Finally the values of the indefinite integral are extracted at the desired argument values \code{x}. } \value{ Numeric vector of the same length as \code{x}. } \author{ \adrian. } \seealso{ \code{\link[stats]{integrate}} } \examples{ curve(indefinteg(sin, x), to=pi) } \keyword{math} spatstat.random/DESCRIPTION0000644000176200001440000000657114570061662015122 0ustar liggesusersPackage: spatstat.random Version: 3.2-3 Date: 2024-02-29 Title: Random Generation Functionality for the 'spatstat' Family Authors@R: c(person("Adrian", "Baddeley", role = c("aut", "cre", "cph"), email = "Adrian.Baddeley@curtin.edu.au", comment = c(ORCID="0000-0001-9499-8382")), person("Rolf", "Turner", role = c("aut", "cph"), email="rolfturner@posteo.net", comment=c(ORCID="0000-0001-5521-5218")), person("Ege", "Rubak", role = c("aut", "cph"), email = "rubak@math.aau.dk", comment=c(ORCID="0000-0002-6675-533X")), person("Tilman", "Davies", role = c("aut", "cph"), comment=c(ORCID="0000-0003-0565-1825")), person("Kasper", "Klitgaard Berthelsen", role = c("ctb", "cph")), person("David", "Bryant", role = c("ctb", "cph")), person("Ya-Mei", "Chang", role = c("ctb", "cph"), email = "yamei628@gmail.com"), person("Ute", "Hahn", role = "ctb"), person("Abdollah", "Jalilian", role = "ctb"), person("Dominic", "Schuhmacher", role = c("ctb", "cph")), person("Rasmus", "Plenge Waagepetersen", role = c("ctb", "cph"))) Maintainer: Adrian Baddeley Depends: R (>= 3.5.0), spatstat.data (>= 3.0), spatstat.geom (>= 3.2-9), stats, utils, methods, grDevices Imports: spatstat.utils (>= 3.0-2) Suggests: spatial, spatstat.linnet (>= 3.0), spatstat.explore, spatstat.model, spatstat (>= 3.0), gsl Description: Functionality for random generation of spatial data in the 'spatstat' family of packages. Generates random spatial patterns of points according to many simple rules (complete spatial randomness, Poisson, binomial, random grid, systematic, cell), randomised alteration of patterns (thinning, random shift, jittering), simulated realisations of random point processes including simple sequential inhibition, Matern inhibition models, Neyman-Scott cluster processes (using direct, Brix-Kendall, or hybrid algorithms), log-Gaussian Cox processes, product shot noise cluster processes and Gibbs point processes (using Metropolis-Hastings birth-death-shift algorithm, alternating Gibbs sampler, or coupling-from-the-past perfect simulation). Also generates random spatial patterns of line segments, random tessellations, and random images (random noise, random mosaics). Excludes random generation on a linear network, which is covered by the separate package 'spatstat.linnet'. License: GPL (>= 2) URL: http://spatstat.org/ NeedsCompilation: yes ByteCompile: true BugReports: https://github.com/spatstat/spatstat.random/issues Packaged: 2024-02-29 07:50:19 UTC; adrian Author: Adrian Baddeley [aut, cre, cph] (), Rolf Turner [aut, cph] (), Ege Rubak [aut, cph] (), Tilman Davies [aut, cph] (), Kasper Klitgaard Berthelsen [ctb, cph], David Bryant [ctb, cph], Ya-Mei Chang [ctb, cph], Ute Hahn [ctb], Abdollah Jalilian [ctb], Dominic Schuhmacher [ctb, cph], Rasmus Plenge Waagepetersen [ctb, cph] Repository: CRAN Date/Publication: 2024-02-29 11:00:02 UTC spatstat.random/tests/0000755000176200001440000000000014570033473014544 5ustar liggesusersspatstat.random/tests/Random.R0000644000176200001440000001061014567023173016107 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.random #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.random) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' tests/randoms.R #' Further tests of random generation code #' $Revision: 1.18 $ $Date: 2024/02/26 05:43:36 $ local({ if(FULLTEST) { #' cases not covered in examples A <- runifdisc(6, nsim=2) A <- runifpoispp(5, nsim=2) A <- runifpoispp(0, nsim=2) A <- rSSI(0.05, 6, nsim=2) A <- rSSI(0.05, 10, win=square(c(-0.5, 1.5)), x.init=A[[1]], nsim=2) A <- rstrat(nx=4, nsim=2) A <- rcell(square(1), nx=5, nsim=2) } if(ALWAYS) { # involves C code etc A <- rthin(cells, P=0.5, nsim=2) A <- rthin(cells, runif(42)) A <- rthin(cells[FALSE], P=0.5, nsim=2) } f <- function(x,y) { 10*x } Z <- as.im(f, square(1)) if(ALWAYS) { A <- rpoint(n=6, f=f, fmax=10, nsim=2) A <- rpoint(n=6, f=Z, fmax=10, nsim=2) A <- rpoint(n=0, f=f, fmax=10, nsim=2) A <- rpoint(n=0, f=Z, fmax=10, nsim=2) op <- spatstat.options(fastpois=FALSE) A <- runifpoispp(5, nsim=2) A <- rpoispp(Z) spatstat.options(op) } if(FULLTEST) { b3 <- box3(c(0,1)) b4 <- boxx(c(0,1), c(0,1), c(0,1), c(0,1)) b5 <- c(0, 2, 0, 2) X <- rMaternInhibition(2, kappa=20, r=0.1, win=b3) Y <- rMaternInhibition(2, kappa=20, r=0.1, win=b4) Y <- rMaternInhibition(2, kappa=20, r=0.1, win=b5, nsim=2) X <- rSSI(0.05, 6) Y <- rSSI(0.05, 6, x.init=X) # no extra points Z <- rlabel(finpines) } f1 <- function(x,y){(x^2 + y^3)/10} f2 <- function(x,y){(x^3 + y^2)/10} ZZ <- solist(A=as.im(f1, letterR), B=as.im(f2, letterR)) g <- function(x,y,m){(10+as.integer(m)) * (x^2 + y^3)} if(FULLTEST) { XX <- rmpoispp(ZZ, nsim=3) YY <- rmpoint(10, f=ZZ, nsim=3) UU <- rmpoint(10, f=ZZ[[1]], types=letters[1:2]) VV <- rpoint.multi(10, f=g, marks=factor(sample(letters[1:3], 10, replace=TRUE)), nsim=3) } if(ALWAYS) { # depends on C code L <- edges(letterR) E <- runifpoisppOnLines(5, L) G <- rpoisppOnLines(ZZ, L) G2 <- rpoisppOnLines(list(A=f1, B=f2), L, lmax=max(sapply(ZZ, max))) } if(FULLTEST) { #' cluster models + bells + whistles X <- rThomas(10, 0.2, 5, saveLambda=TRUE) if(is.null(attr(X, "Lambda"))) stop("rThomas did not save Lambda image") Y <- rThomas(0, 0.2, 5, saveLambda=TRUE) if(is.null(attr(Y, "Lambda"))) stop("rThomas did not save Lambda image when kappa=0") X <- rMatClust(10, 0.05, 4, saveLambda=TRUE) X <- rCauchy(30, 0.01, 5, saveLambda=TRUE) X <- rVarGamma(30, 2, 5, nu=0.02, saveLambda=TRUE) Z <- as.im(function(x,y){ 5 * exp(2 * x - 1) }, owin()) Y <- rThomas(10, 0.2, Z, saveLambda=TRUE) Y <- rMatClust(10, 0.05, Z, saveLambda=TRUE) Y <- rCauchy(30, 0.01, Z, saveLambda=TRUE) Y <- rVarGamma(30, 2, Z, nu=0.02, saveLambda=TRUE) #' inhomogeneous Moo <- as.im(function(x,y) { 10 * x }, unit.square()) X <- rMatClust(10, 0.2, Moo) } if(FULLTEST) { #' perfect simulation code infrastructure expandwinPerfect(letterR, 2, 3) #' trivial cases of random generators for ppx B4 <- boxx(0:1, 0:1, 0:1, 0:1) Z0 <- runifpointx(0, domain=B4, nsim=2) Z1 <- runifpointx(1, domain=B4, nsim=2) } }) local({ if(ALWAYS) { #' Bug in rLGCP spotted by Tilman Davies X <- rLGCP("matern", function(x,y) { 1 - 0.4* y }, var=2, scale=0.7, nu=0.5, win = square(10), dimyx=c(32,64)) } if(FULLTEST) { ## Bug in rGRFcircembed ## when handling incompatible data for 'mu' and 'win' win <- owin(c(0, 3), c(0, 3)) npix <- 300 spatstat.options(npixel = npix) beta0 <- 3 beta1 <- 0 sigma2x <- 0.2 range <- 1.2 nu <- 1 set.seed(7) x0 <- seq(0, 3, length=npix) y0 <- seq(0, 3, length=npix) gridcov <- outer(x0, y0, function(x,y) cos(x) - sin(y - 2)) MU <- im(beta0 + beta1 * gridcov, xcol = x0, yrow = y0) lg.s.c <- rLGCP('matern', mu=MU, var = sigma2x, scale = range / sqrt(8), nu = 1, win = win) } }) reset.spatstat.options() spatstat.random/tests/RMH.R0000644000176200001440000007371214325152137015324 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.random #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.random) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) # # tests/rmhAux.R # # $Revision: 1.2 $ $Date: 2020/05/01 02:42:58 $ # # For interactions which maintain 'auxiliary data', # verify that the auxiliary data are correctly updated. # # To do this we run rmh with nsave=1 so that the point pattern state # is saved after every iteration, then the algorithm is restarted, # and the auxiliary data are re-initialised. The final state must agree with # the result of simulation without saving. # ---------------------------------------------------- if(ALWAYS) { # involves C code local({ # Geyer: mod <- list(cif="geyer", par=list(beta=1.25,gamma=1.6,r=0.2,sat=4.5), w=square(10)) set.seed(42) X.nosave <- rmh(model=mod, start=list(n.start=50), control=list(nrep=1e3, periodic=FALSE, expand=1)) set.seed(42) X.save <- rmh(model=mod, start=list(n.start=50), control=list(nrep=1e3, periodic=FALSE, expand=1, nburn=0, nsave=1, pstage="start")) #' Need to set pstage='start' so that proposals are generated #' at the start of the procedure in both cases. stopifnot(npoints(X.save) == npoints(X.nosave)) stopifnot(max(nncross(X.save, X.nosave)$dist) == 0) stopifnot(max(nncross(X.nosave, X.save)$dist) == 0) }) } ## ## tests/rmhBasic.R ## ## $Revision: 1.23 $ $Date: 2020/05/01 02:42:58 $ # # Test examples for rmh.default # run to reasonable length # and with tests for validity added # ---------------------------------------------------- local({ if(!exists("nr") || is.null(nr)) nr <- 1000 nrlong <- 2e3 spatstat.options(expand=1.05) if(ALWAYS) { ## fundamental C code ## Strauss process. mod01 <- list(cif="strauss", par=list(beta=2,gamma=0.2,r=0.7), w=c(0,10,0,10)) X1.strauss <- rmh(model=mod01, start=list(n.start=80), control=list(nrep=nr)) X1.strauss2 <- rmh(model=mod01, start=list(n.start=80), control=list(nrep=nr, periodic=FALSE)) ## Strauss process, conditioning on n = 80: X2.strauss <- rmh(model=mod01,start=list(n.start=80), control=list(p=1,nrep=nr)) stopifnot(npoints(X2.strauss) == 80) ## test tracking mechanism X1.strauss <- rmh(model=mod01,start=list(n.start=80), control=list(nrep=nr), track=TRUE) X2.strauss <- rmh(model=mod01,start=list(n.start=80), control=list(p=1,nrep=nr), track=TRUE) ## Hard core process: mod02 <- list(cif="hardcore",par=list(beta=2,hc=0.7),w=c(0,10,0,10)) X3.hardcore <- rmh(model=mod02,start=list(n.start=60), control=list(nrep=nr)) X3.hardcore2 <- rmh(model=mod02,start=list(n.start=60), control=list(nrep=nr, periodic=FALSE)) ## Strauss process equal to pure hardcore: mod02 <- list(cif="strauss",par=list(beta=2,gamma=0,r=0.7),w=c(0,10,0,10)) X3.strauss <- rmh(model=mod02,start=list(n.start=60), control=list(nrep=nr)) ## Strauss process in a polygonal window. x <- c(0.55,0.68,0.75,0.58,0.39,0.37,0.19,0.26,0.42) y <- c(0.20,0.27,0.68,0.99,0.80,0.61,0.45,0.28,0.33) mod03 <- list(cif="strauss",par=list(beta=2000,gamma=0.6,r=0.07), w=owin(poly=list(x=x,y=y))) X4.strauss <- rmh(model=mod03,start=list(n.start=90), control=list(nrep=nr)) ## Strauss process in a polygonal window, conditioning on n = 42. X5.strauss <- rmh(model=mod03,start=list(n.start=42), control=list(p=1,nrep=nr)) stopifnot(npoints(X5.strauss) == 42) ## Strauss process, starting off from X4.strauss, but with the ## polygonal window replace by a rectangular one. At the end, ## the generated pattern is clipped to the original polygonal window. xxx <- X4.strauss xxx$window <- as.owin(c(0,1,0,1)) X6.strauss <- rmh(model=mod03,start=list(x.start=xxx), control=list(nrep=nr)) ## Strauss with hardcore: mod04 <- list(cif="straush",par=list(beta=2,gamma=0.2,r=0.7,hc=0.3), w=c(0,10,0,10)) X1.straush <- rmh(model=mod04,start=list(n.start=70), control=list(nrep=nr)) X1.straush2 <- rmh(model=mod04,start=list(n.start=70), control=list(nrep=nr, periodic=FALSE)) ## Another Strauss with hardcore (with a perhaps surprising result): mod05 <- list(cif="straush",par=list(beta=80,gamma=0.36,r=45,hc=2.5), w=c(0,250,0,250)) X2.straush <- rmh(model=mod05,start=list(n.start=250), control=list(nrep=nr)) ## Pure hardcore (identical to X3.strauss). mod06 <- list(cif="straush",par=list(beta=2,gamma=1,r=1,hc=0.7), w=c(0,10,0,10)) X3.straush <- rmh(model=mod06,start=list(n.start=60), control=list(nrep=nr)) ## Fiksel modFik <- list(cif="fiksel", par=list(beta=180,r=0.15,hc=0.07,kappa=2,a= -1.0), w=square(1)) X.fiksel <- rmh(model=modFik,start=list(n.start=10), control=list(nrep=nr)) X.fiksel2 <- rmh(model=modFik,start=list(n.start=10), control=list(nrep=nr,periodic=FALSE)) ## Penttinen process: modpen <- rmhmodel(cif="penttinen",par=list(beta=2,gamma=0.6,r=1), w=c(0,10,0,10)) X.pen <- rmh(model=modpen,start=list(n.start=10), control=list(nrep=nr)) X.pen2 <- rmh(model=modpen,start=list(n.start=10), control=list(nrep=nr, periodic=FALSE)) ## equivalent to hardcore modpen$par$gamma <- 0 X.penHard <- rmh(model=modpen,start=list(n.start=3), control=list(nrep=nr)) ## Area-interaction, inhibitory mod.area <- list(cif="areaint", par=list(beta=2,eta=0.5,r=0.5), w=square(10)) X.area <- rmh(model=mod.area,start=list(n.start=60), control=list(nrep=nr)) X.areaE <- rmh(model=mod.area,start=list(n.start=60), control=list(nrep=nr, periodic=FALSE)) ## Area-interaction, clustered mod.area2 <- list(cif="areaint", par=list(beta=2,eta=1.5,r=0.5), w=square(10)) X.area2 <- rmh(model=mod.area2,start=list(n.start=60), control=list(nrep=nr)) ## Area-interaction close to hard core set.seed(42) mod.area0 <- list(cif="areaint",par=list(beta=2,eta=1e-300,r=0.35), w=square(10)) X.area0 <- rmh(model=mod.area0,start=list(x.start=X3.hardcore), control=list(nrep=nrlong)) stopifnot(nndist(X.area0) > 0.6) ## Soft core: w <- c(0,10,0,10) mod07 <- list(cif="sftcr",par=list(beta=0.8,sigma=0.1,kappa=0.5), w=c(0,10,0,10)) X.sftcr <- rmh(model=mod07,start=list(n.start=70), control=list(nrep=nr)) X.sftcr2 <- rmh(model=mod07,start=list(n.start=70), control=list(nrep=nr, periodic=FALSE)) ## Diggle, Gates, and Stibbard: mod12 <- list(cif="dgs",par=list(beta=3600,rho=0.08),w=c(0,1,0,1)) X.dgs <- rmh(model=mod12,start=list(n.start=300), control=list(nrep=nr)) X.dgs2 <- rmh(model=mod12,start=list(n.start=300), control=list(nrep=nr, periodic=FALSE)) ## Diggle-Gratton: mod13 <- list(cif="diggra", par=list(beta=1800,kappa=3,delta=0.02,rho=0.04), w=square(1)) X.diggra <- rmh(model=mod13,start=list(n.start=300), control=list(nrep=nr)) X.diggra2 <- rmh(model=mod13,start=list(n.start=300), control=list(nrep=nr, periodic=FALSE)) ## Geyer: mod14 <- list(cif="geyer",par=list(beta=1.25,gamma=1.6,r=0.2,sat=4.5), w=c(0,10,0,10)) X1.geyer <- rmh(model=mod14,start=list(n.start=200), control=list(nrep=nr)) ## Geyer; same as a Strauss process with parameters ## (beta=2.25,gamma=0.16,r=0.7): mod15 <- list(cif="geyer",par=list(beta=2.25,gamma=0.4,r=0.7,sat=10000), w=c(0,10,0,10)) X2.geyer <- rmh(model=mod15,start=list(n.start=200), control=list(nrep=nr)) X2.geyer2 <- rmh(model=mod15,start=list(n.start=200), control=list(nrep=nr, periodic=FALSE)) mod16 <- list(cif="geyer",par=list(beta=8.1,gamma=2.2,r=0.08,sat=3)) X3.geyer <- rmh(model=mod16,start=list(x.start=redwood), control=list(periodic=TRUE,nrep=nr)) X3.geyer2 <- rmh(model=mod16,start=list(x.start=redwood), control=list(periodic=FALSE,nrep=nr)) ## Geyer, starting from the redwood data set, simulating ## on a torus, and conditioning on n: X4.geyer <- rmh(model=mod16,start=list(x.start=redwood), control=list(p=1,periodic=TRUE,nrep=nr)) ## Lookup (interaction function h_2 from page 76, Diggle (2003)): r <- seq(from=0,to=0.2,length=101)[-1] # Drop 0. h <- 20*(r-0.05) h[r<0.05] <- 0 h[r>0.10] <- 1 mod17 <- list(cif="lookup",par=list(beta=4000,h=h,r=r),w=c(0,1,0,1)) X.lookup <- rmh(model=mod17,start=list(n.start=100), control=list(nrep=nr, periodic=TRUE)) X.lookup2 <- rmh(model=mod17,start=list(n.start=100), control=list(nrep=nr, expand=1, periodic=FALSE)) ## irregular mod17x <- mod17 mod17x$par$r <- 0.05*sqrt(mod17x$par$r/0.05) X.lookupX <- rmh(model=mod17x,start=list(n.start=100), control=list(nrep=nr, periodic=TRUE)) X.lookupX2 <- rmh(model=mod17x,start=list(n.start=100), control=list(nrep=nr, expand=1, periodic=FALSE)) ## Strauss with trend tr <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } beta <- 0.3 gmma <- 0.5 r <- 45 tr3 <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } ## log quadratic trend mod17 <- list(cif="strauss", par=list(beta=beta,gamma=gmma,r=r),w=c(0,250,0,250), trend=tr3) X1.strauss.trend <- rmh(model=mod17,start=list(n.start=90), control=list(nrep=nr)) #' trend is an image mod18 <- mod17 mod18$trend <- as.im(mod18$trend, square(10)) X1.strauss.trendim <- rmh(model=mod18,start=list(n.start=90), control=list(nrep=nr)) } if(FULLTEST) { #'..... Test other code blocks ................. #' argument passing to rmhcontrol X1S <- rmh(model=mod01, control=NULL, nrep=nr) X1f <- rmh(model=mod01, fixall=TRUE, nrep=nr) # issues a warning } if(ALWAYS) { #' nsim > 1 Xlist <- rmh(model=mod01,start=list(n.start=80), control=list(nrep=nr), nsim=2) #' Condition on contents of window XX <- Xlist[[1]] YY <- XX[square(2)] XXwindow <- rmh(model=mod01, start=list(n.start=80), control=list(nrep=nr, x.cond=YY)) XXwindowTrend <- rmh(model=mod17, start=list(n.start=80), control=list(nrep=nr, x.cond=YY)) #' Palm conditioning XXpalm <- rmh(model=mod01,start=list(n.start=80), control=list(nrep=nr, x.cond=coords(YY))) XXpalmTrend <- rmh(model=mod17,start=list(n.start=80), control=list(nrep=nr, x.cond=coords(YY))) #' nsave, nburn chq <- function(X) { Xname <- deparse(substitute(X)) A <- attr(X, "saved") if(length(A) == 0) stop(paste(Xname, "did not include a saved list of patterns")) return("ok") } XXburn <- rmh(model=mod01,start=list(n.start=80), verbose=FALSE, control=list(nrep=nr, nsave=500, nburn=100)) chq(XXburn) XXburnTrend <- rmh(model=mod17,start=list(n.start=80), verbose=FALSE, control=list(nrep=nr, nsave=500, nburn=100)) chq(XXburnTrend) XXburn0 <- rmh(model=mod01,start=list(n.start=80), verbose=FALSE, control=list(nrep=nr, nsave=500, nburn=0)) chq(XXburn0) XXsaves <- rmh(model=mod01,start=list(n.start=80), verbose=FALSE, control=list(nrep=nr, nsave=c(500, 200))) chq(XXsaves) XXsaves0 <- rmh(model=mod01,start=list(n.start=80), verbose=FALSE, control=list(nrep=nr, nsave=c(500, 200), nburn=0)) chq(XXsaves0) } if(FULLTEST) { #' code blocks for various interactions, not otherwise tested rr <- seq(0,0.2,length=8)[-1] gmma <- c(0.5,0.6,0.7,0.8,0.7,0.6,0.5) mod18 <- list(cif="badgey",par=list(beta=4000, gamma=gmma,r=rr,sat=5), w=square(1)) Xbg <- rmh(model=mod18,start=list(n.start=20), control=list(nrep=1e4, periodic=TRUE)) Xbg2 <- rmh(model=mod18,start=list(n.start=20), control=list(nrep=1e4, periodic=FALSE)) #' supporting classes rs <- rmhstart() print(rs) rs <- rmhstart(x.start=cells) print(rs) rc <- rmhcontrol(x.cond=as.list(as.data.frame(cells))) print(rc) rc <- rmhcontrol(x.cond=as.data.frame(cells)[FALSE, , drop=FALSE]) print(rc) rc <- rmhcontrol(nsave=100, ptypes=c(0.7, 0.3), x.cond=amacrine) print(rc) rc <- rmhcontrol(ptypes=c(0.7, 0.3), x.cond=as.data.frame(amacrine)) print(rc) } }) reset.spatstat.options() ## ## tests/rmhErrors.R ## ## $Revision: 1.6 $ $Date: 2020/05/01 02:42:58 $ ## # Things which should cause an error if(ALWAYS) { local({ if(!exists("nv")) nv <- 0 if(!exists("nr")) nr <- 1e3 ## Strauss with zero intensity and p = 1 mod0S <- list(cif="strauss",par=list(beta=0,gamma=0.6,r=0.7), w = square(3)) out <- try(X0S <- rmh(model=mod0S,start=list(n.start=80), control=list(p=1,nrep=nr,nverb=nv),verbose=FALSE)) if(!inherits(out, "try-error")) stop("Error not trapped (Strauss with zero intensity and p = 1) in tests/rmhErrors.R") }) } # # tests/rmhExpand.R # # test decisions about expansion of simulation window # # $Revision: 1.9 $ $Date: 2022/10/23 01:17:33 $ # local({ if(FULLTEST) { ## rmhexpand class a <- summary(rmhexpand(area=2)) print(a) b <- summary(rmhexpand(length=4)) print(b) print(summary(rmhexpand(distance=2))) print(summary(rmhexpand(square(2)))) } }) # # tests/rmhMulti.R # # tests of rmh.default, running multitype point processes # # $Revision: 1.17 $ $Date: 2022/01/05 02:07:32 $ local({ if(!exists("nr")) nr <- 2e3 if(!exists("nv")) nv <- 0 spatstat.options(expand=1.05) if(FULLTEST) { ## Multitype Poisson modp2 <- list(cif="poisson", par=list(beta=2), types=letters[1:3], w = square(10)) Xp2 <- rmh(modp2, start=list(n.start=0), control=list(p=1)) ## Multinomial Xp2fix <- rmh(modp2, start=list(n.start=c(10,20,30)), control=list(fixall=TRUE, p=1)) Xp2fixr <- rmh(modp2, start=list(x.start=Xp2fix), control=list(fixall=TRUE, p=1)) } if(ALWAYS) { ## Gibbs models => C code ## Multitype Strauss: beta <- c(0.027,0.008) gmma <- matrix(c(0.43,0.98,0.98,0.36),2,2) r <- matrix(c(45,45,45,45),2,2) mod08 <- list(cif="straussm",par=list(beta=beta,gamma=gmma,radii=r), w=c(0,250,0,250)) X1.straussm <- rmh(model=mod08,start=list(n.start=80), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv)) ## Multitype Strauss equivalent to hard core: mod08hard <- mod08 mod08hard$par$gamma[] <- 0 X1.straussm.Hard <- rmh(model=mod08hard,start=list(n.start=20), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv), periodic=FALSE) X1.straussmP.Hard <- rmh(model=mod08hard,start=list(n.start=20), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv), periodic=TRUE) ## Multitype Strauss conditioning upon the total number ## of points being 80: X2.straussm <- rmh(model=mod08,start=list(n.start=80), control=list(p=1,ptypes=c(0.75,0.25),nrep=nr, nverb=nv)) stopifnot(X2.straussm$n == 80) ## Conditioning upon the number of points of type 1 being 60 ## and the number of points of type 2 being 20: X3.straussm <- rmh(model=mod08,start=list(n.start=c(60,20)), control=list(fixall=TRUE,p=1,ptypes=c(0.75,0.25), nrep=nr,nverb=nv)) stopifnot(all(table(X3.straussm$marks) == c(60,20))) ## Multitype hardcore: rhc <- matrix(c(9.1,5.0,5.0,2.5),2,2) mod087 <- list(cif="multihard",par=list(beta=5*beta,hradii=rhc), w=square(12)) cheque <- function(X, r) { Xname <- deparse(substitute(X)) nn <- minnndist(X, by=marks(X)) print(nn) if(!all(nn >= r, na.rm=TRUE)) stop(paste(Xname, "violates hard core constraint"), call.=FALSE) return(invisible(NULL)) } #' make an initial state that violates hard core #' (cannot use 'x.start' here because it disables thinning) #' and check that result satisfies hard core set.seed(19171025) X.multihard.close <- rmh(model=mod087,start=list(n.start=100), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv), periodic=FALSE) cheque(X.multihard.close, rhc) X.multihard.closeP <- rmh(model=mod087,start=list(n.start=100), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv, periodic=TRUE)) cheque(X.multihard.closeP, rhc) ## Multitype Strauss hardcore: mod09 <- list(cif="straushm", par=list(beta=5*beta,gamma=gmma, iradii=r,hradii=rhc),w=square(12)) X.straushm <- rmh(model=mod09,start=list(n.start=100), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv), periodic=FALSE) X.straushmP <- rmh(model=mod09,start=list(n.start=100), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv, periodic=TRUE)) ## Multitype Strauss hardcore equivalent to multitype hardcore: mod09hard <- mod09 mod09hard$par$gamma[] <- 0 X.straushm.hard <- rmh(model=mod09hard,start=list(n.start=15), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv, periodic=FALSE)) X.straushmP.hard <- rmh(model=mod09hard,start=list(n.start=15), control=list(ptypes=c(0.75,0.25),nrep=nr,nverb=nv), periodic=TRUE) ## Multitype Strauss hardcore with trends for each type: beta <- c(0.27,0.08) tr3 <- function(x,y){x <- x/250; y <- y/250; exp((6*x + 5*y - 18*x^2 + 12*x*y - 9*y^2)/6) } # log quadratic trend tr4 <- function(x,y){x <- x/250; y <- y/250; exp(-0.6*x+0.5*y)} # log linear trend mod10 <- list(cif="straushm", par=list(beta=beta,gamma=gmma, iradii=r,hradii=rhc),w=c(0,250,0,250), trend=list(tr3,tr4)) X1.straushm.trend <- rmh(model=mod10,start=list(n.start=350), control=list(ptypes=c(0.75,0.25), nrep=nr,nverb=nv)) ## Multitype Strauss hardcore with trends for each type, given as images: bigwin <- square(250) i1 <- as.im(tr3, bigwin) i2 <- as.im(tr4, bigwin) mod11 <- list(cif="straushm",par=list(beta=beta,gamma=gmma, iradii=r,hradii=rhc),w=bigwin, trend=list(i1,i2)) X2.straushm.trend <- rmh(model=mod11,start=list(n.start=350), control=list(ptypes=c(0.75,0.25),expand=1, nrep=nr,nverb=nv)) #' nsave, nburn chq <- function(X) { Xname <- deparse(substitute(X)) A <- attr(X, "saved") if(length(A) == 0) stop(paste(Xname, "did not include a saved list of patterns")) return("ok") } XburnMS <- rmh(model=mod08,start=list(n.start=80), verbose=FALSE, control=list(ptypes=c(0.75,0.25), nrep=nr,nsave=500, nburn=100)) chq(XburnMS) XburnMStrend <- rmh(model=mod10,start=list(n.start=350), verbose=FALSE, control=list(ptypes=c(0.75,0.25), nrep=nr,nsave=500, nburn=100)) chq(XburnMStrend) ####################################################################### ############ checks on distribution of output ####################### ####################################################################### checkp <- function(p, context, testname, failmessage, pcrit=0.01) { if(missing(failmessage)) failmessage <- paste("output failed", testname) if(p < pcrit) warning(paste(context, ",", failmessage), call.=FALSE) cat(paste("\n", context, ",", testname, "has p-value", signif(p,4), "\n")) } ## Multitype Strauss code; output is multitype Poisson beta <- 100 * c(1,1) ri <- matrix(0.07, 2, 2) gmma <- matrix(1, 2, 2) # no interaction tr1 <- function(x,y){ rep(1, length(x)) } tr2 <- function(x,y){ rep(2, length(x)) } mod <- rmhmodel(cif="straussm", par=list(beta=beta,gamma=gmma,radii=ri), w=owin(), trend=list(tr1,tr2)) X <- rmh(mod, start=list(n.start=0), control=list(nrep=1e6)) ## The model is Poisson with intensity 100 for type 1 and 200 for type 2. ## Total number of points is Poisson (300) ## Marks are i.i.d. with P(type 1) = 1/3, P(type 2) = 2/3. ## Test whether the total intensity looks right ## p <- ppois(X$n, 300) p.val <- 2 * min(p, 1-p) checkp(p.val, "In multitype Poisson simulation", "test whether total number of points has required mean value") ## Test whether the mark distribution looks right ta <- table(X$marks) cat("Frequencies of marks:") print(ta) checkp(chisq.test(ta, p = c(1,2)/3)$p.value, "In multitype Poisson simulation", "chi-squared goodness-of-fit test for mark distribution (1/3, 2/3)") ##### #### multitype Strauss code; fixall=TRUE; #### output is multinomial process with nonuniform locations #### the.context <- "In nonuniform multinomial simulation" beta <- 100 * c(1,1) ri <- matrix(0.07, 2, 2) gmma <- matrix(1, 2, 2) # no interaction tr1 <- function(x,y){ ifelse(x < 0.5, 0, 2) } tr2 <- function(x,y){ ifelse(y < 0.5, 1, 3) } ## cdf of these distributions Fx1 <- function(x) { ifelse(x < 0.5, 0, ifelse(x < 1, 2 * x - 1, 1)) } Fy2 <- function(y) { ifelse(y < 0, 0, ifelse(y < 0.5, y/2, ifelse(y < 1, (1/2 + 3 * (y-1/2))/2, 1))) } mod <- rmhmodel(cif="straussm", par=list(beta=beta,gamma=gmma,radii=ri), w=owin(), trend=list(tr1,tr2)) X <- rmh(mod, start=list(n.start=c(50,50)), control=list(nrep=1e6, expand=1, p=1, fixall=TRUE)) ## The model is Poisson ## Mean number of type 1 points = 100 ## Mean number of type 2 points = 200 ## Total intensity = 300 ## Marks are i.i.d. with P(type 1) = 1/3, P(type 2) = 2/3 ## Test whether the coordinates look OK Y <- split(X) X1 <- Y[[names(Y)[1]]] X2 <- Y[[names(Y)[2]]] checkp(ks.test(X1$y, "punif")$p.value, the.context, "Kolmogorov-Smirnov test of uniformity of y coordinates of type 1 points") if(any(X1$x < 0.5)) { stop(paste(the.context, ",", "x-coordinates of type 1 points are IMPOSSIBLE"), call.=FALSE) } else { checkp(ks.test(Fx1(X1$x), "punif")$p.value, the.context, "Kolmogorov-Smirnov test of uniformity of transformed x coordinates of type 1 points") } checkp(ks.test(X2$x, "punif")$p.value, the.context, "Kolmogorov-Smirnov test of uniformity of x coordinates of type 2 points") checkp(ks.test(Fy2(X2$y), "punif")$p.value, the.context, "Kolmogorov-Smirnov test of uniformity of transformed y coordinates of type 2 points") } }) reset.spatstat.options() # # tests/rmhWeird.R # # $Revision: 1.5 $ $Date: 2022/01/05 02:08:29 $ # # Test strange boundary cases in rmh.default local({ if(!exists("nv")) nv <- 0 if(!exists("nr")) nr <- 2e3 if(FULLTEST) { ## Poisson process cat("Poisson\n") modP <- list(cif="poisson",par=list(beta=10), w = square(3)) XP <- rmh(model = modP, start = list(n.start=25), control=list(nrep=nr,nverb=nv)) } if(ALWAYS) { ## Poisson process case of Strauss cat("\nPoisson case of Strauss\n") modPS <- list(cif="strauss",par=list(beta=10,gamma=1,r=0.7), w = square(3)) XPS <- rmh(model=modPS, start=list(n.start=25), control=list(nrep=nr,nverb=nv)) ## Strauss with zero intensity cat("\nStrauss with zero intensity\n") mod0S <- list(cif="strauss", par=list(beta=0,gamma=0.6,r=0.7), w = square(3)) X0S <- rmh(model=mod0S,start=list(n.start=80), control=list(nrep=nr,nverb=nv)) stopifnot(X0S$n == 0) } if(FULLTEST) { ## Poisson with zero intensity cat("\nPoisson with zero intensity\n") mod0P <- list(cif="poisson",par=list(beta=0), w = square(3)) X0P <- rmh(model = mod0P, start = list(n.start=25), control=list(nrep=nr,nverb=nv)) ## Poisson conditioned on zero points cat("\nPoisson conditioned on zero points\n") modp <- list(cif="poisson", par=list(beta=2), w = square(10)) Xp <- rmh(modp, start=list(n.start=0), control=list(p=1, nrep=nr)) stopifnot(Xp$n == 0) ## Multitype Poisson conditioned on zero points cat("\nMultitype Poisson conditioned on zero points\n") modp2 <- list(cif="poisson", par=list(beta=2), types=letters[1:3], w = square(10)) Xp2 <- rmh(modp2, start=list(n.start=0), control=list(p=1, nrep=nr)) stopifnot(is.marked(Xp2)) stopifnot(Xp2$n == 0) ## Multitype Poisson conditioned on zero points of each type cat("\nMultitype Poisson conditioned on zero points of each type\n") Xp2fix <- rmh(modp2, start=list(n.start=c(0,0,0)), control=list(p=1, fixall=TRUE, nrep=nr)) stopifnot(is.marked(Xp2fix)) stopifnot(Xp2fix$n == 0) } }) # # 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.default ............................ modH <- list(cif=c("strauss","geyer"), par=list(list(beta=50,gamma=0.5, r=0.1), list(beta=1, gamma=0.7, r=0.2, sat=2)), w = square(1)) rmodH <- rmhmodel(modH) rmodH reach(rmodH) # test handling of Poisson components modHP <- list(cif=c("poisson","strauss"), par=list(list(beta=5), list(beta=10,gamma=0.5, r=0.1)), w = square(1)) rmodHP <- rmhmodel(modHP) rmodHP reach(rmodHP) modPP <- list(cif=c("poisson","poisson"), par=list(list(beta=5), list(beta=10)), w = square(1)) rmodPP <- rmhmodel(modPP) rmodPP reach(rmodPP) }) } #' #' 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 ## define a model and prepare to simulate W <- Window(amacrine) t1 <- as.im(function(x,y){exp(8.2+0.22*x)}, W) t2 <- as.im(function(x,y){exp(8.3+0.22*x)}, W) model <- rmhmodel(cif="strauss", trend=solist(off=t1, on=t2), par=list(gamma=0.47, r=R, beta=c(off=1, on=1))) 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) }) } spatstat.random/src/0000755000176200001440000000000014531531157014170 5ustar liggesusersspatstat.random/src/constants.h0000755000176200001440000000074714325152137016366 0ustar liggesusers/* constants.h Ensure that required constants are defined (Insurance against flaky installations) $Revision: 1.2 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifndef M_PI #define M_PI 3.141592653589793 #endif #ifndef M_PI_2 #define M_PI_2 1.570796326794897 #endif #ifndef M_2_PI #define M_2_PI (2.0/M_PI) #endif #ifndef M_2PI #define M_2PI 6.283185307179586 #endif spatstat.random/src/rthin.c0000755000176200001440000000362514325152137015467 0ustar liggesusers#include #include #include /* rthin.c Select from the integers 1:n with probability p by simulating geometric(p) jumps between selected integers $Revision: 1.2 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ SEXP thinjumpequal(SEXP n, SEXP p, SEXP guess) { int N; double P; int *w; /* temporary storage for selected integers */ int nw, nwmax; int i, j, k; double log1u, log1p; /* R object return value */ SEXP Out; /* external storage pointer */ int *OutP; /* protect R objects from garbage collector */ PROTECT(p = AS_NUMERIC(p)); PROTECT(n = AS_INTEGER(n)); PROTECT(guess = AS_INTEGER(guess)); /* Translate arguments from R to C */ N = *(INTEGER_POINTER(n)); P = *(NUMERIC_POINTER(p)); nwmax = *(INTEGER_POINTER(guess)); /* Allocate space for result */ w = (int *) R_alloc(nwmax, sizeof(int)); /* set up */ GetRNGstate(); log1p = -log(1.0 - P); /* main loop */ i = 0; /* last selected element of 1...N */ nw = 0; /* number of selected elements */ while(i <= N) { log1u = exp_rand(); /* an exponential rv is equivalent to -log(1-U) */ j = (int) ceil(log1u/log1p); /* j is geometric(p) */ i += j; if(nw >= nwmax) { /* overflow; allocate more space */ w = (int *) S_realloc((char *) w, 2 * nwmax, nwmax, sizeof(int)); nwmax = 2 * nwmax; } /* add 'i' to output vector */ w[nw] = i; ++nw; } /* The last saved 'i' could have exceeded 'N' */ /* For efficiency we don't check this in the loop */ if(nw > 0 && w[nw-1] > N) --nw; PutRNGstate(); /* create result vector */ PROTECT(Out = NEW_INTEGER(nw)); /* copy results into output */ OutP = INTEGER_POINTER(Out); for(k = 0; k < nw; k++) OutP[k] = w[k]; UNPROTECT(4); return(Out); } spatstat.random/src/rthomas.h0000644000176200001440000003043614364101623016017 0ustar liggesusers/* rthomas.h $Revision: 1.3 $ $Date: 2023/01/25 00:59:28 $ Generate realisation of stationary Thomas cluster process in a disc D Baddeley-Chang hybrid algorithm This file is included multiple times in rthomas.c Macros used: FNAME name of C function BUGGER activate debugging code SAVEPARENTS save coordinates of parents, and map from offspring to parents Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #define RUNIF01 runif((double) 0.0, (double) 1.0) #define RUNIFPOS runif(DBL_EPSILON, (double) 1.0) #define PNORM(X, MEAN, SD) pnorm(X, MEAN, SD, (int) 1, (int) 0) #define RTRUNCPOIS(MU) (int) qpois(runif(exp(-(MU)), (double) 1.0), MU, (int) 1, (int) 0) #define MPLUSPLUS(R) \ lambda * M_PI * rD * rD * inv2sig2 * ( \ rD2 + \ 2.0 * sigma2 * (1 - exp(-inv2sig2 * ((R)-rD) * ((R)-rD))) + \ 2.0 * rD * sigr2pi * ( PNORM((R)-rD, (double) 0.0, sigma) - 0.5 )) SEXP FNAME(SEXP KAPPA, SEXP MU, SEXP CLUSTERSCALE, SEXP DISCRADIUS, SEXP INFLATE ) { /* generic inputs */ double kappa, mu, scale, rD, inflate; /* generic outputs */ double *xo, *yo; /* offspring locations */ SEXP Sout, Sxo, Syo; double *xoffspring, *yoffspring; #ifdef SAVEPARENTS double *xp, *yp; /* parent locations */ int *ip; /* map from offspring to parents */ SEXP Sxp, Syp, Sip; double *xparent, *yparent; int *parentid; #endif /* quantities/variables used in generic algorithm */ double rE, rD2, rE2, areaD; double rhoplus, rhoplusplus, muplus; double lambda, kappadag, edag, Minf, MrE, diffM, p0; double rpi, xpi, ypi, mi, roj, xoj, yoj, theta, dx, dy; int NoMax, Npmax, newmax, no, i, j, k, n, m; double rhi, rlo, rtry, mhi, mtry, tmp; double dxD, ktrue, kdom; #ifdef SAVEPARENTS int np, added, ipcurrent; #endif /* model parameters (for readability) */ double sigma, sigma2; /* model-specific quantities */ double inv2sig2, B, sigr2pi; PROTECT(KAPPA = AS_NUMERIC(KAPPA)); PROTECT(MU = AS_NUMERIC(MU)); PROTECT(CLUSTERSCALE = AS_NUMERIC(CLUSTERSCALE)); PROTECT(DISCRADIUS = AS_NUMERIC(DISCRADIUS)); PROTECT(INFLATE = AS_NUMERIC(INFLATE)); /* That's 5 protected */ #define NINPUTS 5 GetRNGstate(); /* get values */ kappa = *(NUMERIC_POINTER(KAPPA)); mu = *(NUMERIC_POINTER(MU)); scale = *(NUMERIC_POINTER(CLUSTERSCALE)); rD = *(NUMERIC_POINTER(DISCRADIUS)); inflate = *(NUMERIC_POINTER(INFLATE)); #ifdef BUGGER Rprintf("INPUT: kappa = %lf, mu = %lf, scale = %lf\n", kappa, mu, scale); Rprintf("rD = %lf, inflate = %lf\n", rD, inflate); #endif /* inflation */ rE = inflate * rD; /* model-specific translation of inputs */ sigma = scale; /* calculate some constants */ lambda = kappa * mu; /* intensity of cluster process */ kappadag = kappa * (1 - exp(-mu)); /* intensity of parents which have offspring anywhere */ p0 = exp(-mu); /* P(X == 0) where X ~ Pois(mu) */ rD2 = rD * rD; rE2 = rE * rE; areaD = M_PI * rD2; /* model-specific constants */ sigma2 = sigma * sigma; sigr2pi = sigma * sqrt(2.0 * M_PI); inv2sig2 = 1.0/(2.0 * sigma2); B = inv2sig2/M_PI; /* A = mu * rD2 * inv2sig2; */ /* rDE = rE - rD; */ /* superdominating intensity */ Minf = lambda * M_PI * rD2 * inv2sig2 * (rD2 + 2.0 * sigma2 + rD * sigr2pi); MrE = MPLUSPLUS(rE); #ifdef BUGGER Rprintf("Minf = %lf, MrE = %lf\n", Minf, MrE); #endif /* Guess amount of storage required */ NoMax = (int) ceil(2.0 * M_PI * lambda * rD2); if(NoMax < 2048) NoMax = 2048; xo = (double *) R_alloc(NoMax, sizeof(double)); yo = (double *) R_alloc(NoMax, sizeof(double)); no = 0; #ifdef SAVEPARENTS ip = (int *) R_alloc(NoMax, sizeof(int)); xp = (double *) R_alloc(NoMax, sizeof(double)); yp = (double *) R_alloc(NoMax, sizeof(double)); np = 0; #endif /* ----------- parents inside E ------------------- */ edag = M_PI * rE2 * kappadag; tmp = rpois(edag); n = (tmp > 2147483647.0) ? 2147483647 : ((int) tmp); #ifdef BUGGER Rprintf("Expect %lf parents inside E\n", edag); Rprintf("Generated %d parents inside E\n", n); #endif if(n > 0) { for(i = 0; i < n; i++) { R_CheckUserInterrupt(); /* generate parent position uniform in E */ rpi = rE * sqrt(RUNIF01); theta = M_2PI * RUNIF01; xpi = rpi * cos(theta); ypi = rpi * sin(theta); #ifdef SAVEPARENTS added = 0; #endif /* number of offspring of parent i: zero truncated Poisson (mu) */ m = (int) qpois(runif(p0, (double) 1.0), mu, (int) 1, (int) 0); #ifdef BUGGER Rprintf("Generating %d offspring of parent %d\n", m, i); #endif /* generate offspring positions */ for(j = 0; j < m; j++) { /* model specific: displacement radius (Box-Muller) */ roj = sigma * sqrt( - 2.0 * log(RUNIFPOS)); theta = M_2PI * RUNIF01; xoj = xpi + roj * cos(theta); yoj = ypi + roj * sin(theta); if(xoj * xoj + yoj * yoj < rD2) { /* offspring point will be retained */ #ifdef SAVEPARENTS if(added == 0) { #ifdef BUGGER Rprintf("\tAdding proposed parent %d to result, as parent %d\n", i, np); #endif /* add parent point */ xp[np] = xpi; yp[np] = ypi; ipcurrent = np; np++; added = 1; } #endif /* add offspring point */ #ifdef BUGGER Rprintf("\t\tAdding offspring %d to result\n", j); #endif xo[no] = xoj; yo[no] = yoj; #ifdef SAVEPARENTS ip[no] = ipcurrent; #endif no++; /* check data overflow */ if(no > NoMax) { #ifdef BUGGER Rprintf("OVERFLOW\n"); #endif newmax = 2 * NoMax; xo = (double *) S_realloc((char *) xo, newmax, NoMax, sizeof(double)); yo = (double *) S_realloc((char *) yo, newmax, NoMax, sizeof(double)); #ifdef SAVEPARENTS xp = (double *) S_realloc((char *) xp, newmax, NoMax, sizeof(double)); yp = (double *) S_realloc((char *) yp, newmax, NoMax, sizeof(double)); ip = (int *) S_realloc((char *) ip, newmax, NoMax, sizeof(int)); #endif NoMax = newmax; } } } } } #ifdef BUGGER Rprintf("\n\nRunning total %d parents, %d offspring\n\n", np, no); #endif /* ----------- parents outside E ------------------- */ diffM = Minf - MrE; if(diffM < 0.0) diffM = 0.0; #ifdef BUGGER Rprintf("Expect %lf super-dominating parents outside E\n", diffM); #endif /* Generate super-parents in descending order of distance */ /* Generate values of 'mi' in descending order using unit rate Poisson process */ mi = Minf; /* Ensure we don't get trapped */ Npmax = (int) ceil(diffM + 10.0 * sqrt(diffM)); #ifdef BUGGER Rprintf("Npmax = %d\n", Npmax); #endif for(i = 0; i < Npmax; i++) { R_CheckUserInterrupt(); mi = mi - rexp((double) 1.0); if(mi <= MrE) break; #ifdef BUGGER Rprintf("Generated mi = %lf\n", mi); #endif /* determine upper bound on solution of M(r) = mi */ if(i == 0) { rhi = 2 * rE; for(k = 0; k < 256; k++) { mhi = MPLUSPLUS(rhi); if(mhi > mi) break; rhi = 2.0 * rhi; } } else { /* use previous value of rhi */ mhi = MPLUSPLUS(rhi); } /* solve M(r) = mi */ if(mhi <= mi) { /* numerical problem - failed to find upper bound */ rpi = rhi; #ifdef BUGGER Rprintf("\tFailed to find upper bound on radius\n"); #endif } else { #ifdef BUGGER Rprintf("\tSeeking solution to Mplusplus(r) = mi on [%lf, %lf]\n", rE, rhi); #endif rlo = rE; /* mlo = MrE; */ for(k = 0; k < 512; k++) { rtry = (rlo + rhi)/2.0; mtry = MPLUSPLUS(rtry); if(fabs(mtry - mi) < 0.000001) break; if(mtry > mi) { rhi = rtry; } else { rlo = rtry; } } rpi = rtry; } #ifdef BUGGER Rprintf("\tUsing rpi = %lf\n", rpi); #endif /* compute intensities at this parent */ dxD = rpi - rD; if(dxD < 0.0) dxD = 0.0; /* model specific */ /* dominating kernel (for this parent, for offspring in D) */ kdom = B * exp(-inv2sig2 * dxD * dxD); /* expected number of offspring using dominating kernel */ muplus = mu * areaD * kdom; /* intensity of dominating parents */ rhoplus = kappa * (1 - exp(-muplus)); /* intensity of super-dominating parents */ rhoplusplus = kappa * muplus; #ifdef BUGGER Rprintf("\tmuplus = %lf; rhoplus = %lf; rhoplusplus = %lf\n", muplus, rhoplus, rhoplusplus); #endif /* THIN PARENTS TO ACHIEVE DOMINATING INTENSITY */ if(rhoplusplus * RUNIF01 < rhoplus) { /* accepted */ #ifdef BUGGER Rprintf("\tSuper-parent %d is accepted as a dominating parent\n", i); #endif /* make coordinates */ theta = M_2PI * RUNIF01; xpi = rpi * cos(theta); ypi = rpi * sin(theta); /* offspring */ #ifdef SAVEPARENTS added = 0; #endif /* number of dominating offspring */ /* zero truncated Poisson (muplus) */ m = RTRUNCPOIS(muplus); #ifdef BUGGER Rprintf("\tGenerated %d offspring of dominating parent\n", m); #endif if(m > 0) { for(j = 0; j < m; j++) { /* generate dominating offspring uniformly in D */ roj = rD * sqrt(RUNIF01); theta = M_2PI * RUNIF01; xoj = roj * cos(theta); yoj = roj * sin(theta); /* thin according to true kernel */ dx = xoj - xpi; dy = yoj - ypi; /* model specific */ /* true kernel: k(u|x) = 2Dgaussian(u-x) */ ktrue = B * exp(-inv2sig2 * (dx * dx + dy * dy)); #ifdef BUGGER Rprintf("\t\tRetain offspring %d with probability %lf\n", j, ktrue/kdom); #endif if(RUNIF01 * kdom < ktrue) { /* offspring will be retained */ #ifdef SAVEPARENTS if(added == 0) { /* add parent point */ #ifdef BUGGER Rprintf("\t\tAdding proposed parent %d to the output list as parent %d\n", i, np); #endif xp[np] = xpi; yp[np] = ypi; ipcurrent = np; np++; added = 1; } #endif /* add offspring point */ xo[no] = xoj; yo[no] = yoj; #ifdef SAVEPARENTS ip[no] = ipcurrent; #endif no++; #ifdef BUGGER Rprintf("\t\t\tAdded offspring %d to the output list\n", j); #endif /* check data overflow */ if(no > NoMax) { #ifdef BUGGER Rprintf("OVERFLOW\n"); #endif newmax = 2 * NoMax; xo = (double *) S_realloc((char *) xo, newmax, NoMax, sizeof(double)); yo = (double *) S_realloc((char *) yo, newmax, NoMax, sizeof(double)); #ifdef SAVEPARENTS xp = (double *) S_realloc((char *) xp, newmax, NoMax, sizeof(double)); yp = (double *) S_realloc((char *) yp, newmax, NoMax, sizeof(double)); ip = (int *) S_realloc((char *) ip, newmax, NoMax, sizeof(int)); #endif NoMax = newmax; } } /* thinning on kernel */ } /* loop over offspring j */ } } /* thinning superparent */ } /* loop over superparents */ #ifdef BUGGER #ifdef SAVEPARENTS Rprintf("Final total %d parents, %d offspring\n", np, no); #else Rprintf("Final total %d offspring\n", no); #endif #endif /* copy to result */ /* create output list */ #ifdef SAVEPARENTS #define NOUT 5 #else #define NOUT 2 #endif PROTECT(Sout = NEW_LIST(NOUT)); /* create vector entries in output list */ PROTECT(Sxo = NEW_NUMERIC(no)); PROTECT(Syo = NEW_NUMERIC(no)); #ifdef SAVEPARENTS PROTECT(Sxp = NEW_NUMERIC(np)); PROTECT(Syp = NEW_NUMERIC(np)); PROTECT(Sip = NEW_INTEGER(no)); #endif #define NPROTECTED (NINPUTS + 1 + NOUT) /* create pointers to output vectors */ xoffspring = NUMERIC_POINTER(Sxo); yoffspring = NUMERIC_POINTER(Syo); #ifdef SAVEPARENTS xparent = NUMERIC_POINTER(Sxp); yparent = NUMERIC_POINTER(Syp); parentid = INTEGER_POINTER(Sip); #endif /* copy */ #ifdef SAVEPARENTS for(i = 0; i < np; i++) { xparent[i] = xp[i]; yparent[i] = yp[i]; } #endif for(j = 0; j < no; j++) { xoffspring[j] = xo[j]; yoffspring[j] = yo[j]; #ifdef SAVEPARENTS parentid[j] = ip[j] + 1; #endif } SET_VECTOR_ELT(Sout, 0, Sxo); SET_VECTOR_ELT(Sout, 1, Syo); #ifdef SAVEPARENTS SET_VECTOR_ELT(Sout, 2, Sxp); SET_VECTOR_ELT(Sout, 3, Syp); SET_VECTOR_ELT(Sout, 4, Sip); #endif PutRNGstate(); UNPROTECT(NPROTECTED); return(Sout); } #undef NINPUTS #undef NOUT #undef NPROTECTED #undef RUNIF01 #undef RUNIFPOS #undef PNORM #undef RTRUNCPOIS #undef MPLUSPLUS spatstat.random/src/lookup.c0000755000176200001440000001224014325152137015645 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" /* Conditional intensity function for a general pairwise interaction process with the pairwise interaction function given by a ``lookup table'', passed through the par argument. */ /* For debugging code, insert the line: #define DEBUG 1 */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Lookup { int nlook; int equisp; double delta; double rmax; double r2max; double *h; /* values of pair interaction */ double *r; /* r values if not equally spaced */ double *r2; /* r^2 values if not equally spaced */ double *period; int per; } Lookup; /* initialiser function */ Cdata *lookupinit(State state, Model model, Algor algo) { int i, nlook; double ri; Lookup *lookup; lookup = (Lookup *) R_alloc(1, sizeof(Lookup)); /* Interpret model parameters*/ lookup->nlook = nlook = model.ipar[0]; lookup->equisp = (model.ipar[1] > 0); lookup->delta = model.ipar[2]; lookup->rmax = model.ipar[3]; lookup->r2max = pow(lookup->rmax, 2); /* periodic boundary conditions? */ lookup->period = model.period; lookup->per = (model.period[0] > 0.0); /* If the r-values are equispaced only the h vector is included in ``par'' after ``rmax''; the entries of h then consist of h[0] = par[5], h[1] = par[6], ..., h[k-1] = par[4+k], ..., h[nlook-1] = par[4+nlook]. If the r-values are NOT equispaced then the individual r values are needed and these are included as r[0] = par[5+nlook], r[1] = par[6+nlook], ..., r[k-1] = par[4+nlook+k], ..., r[nlook-1] = par[4+2*nlook]. */ lookup->h = (double *) R_alloc((size_t) nlook, sizeof(double)); for(i = 0; i < nlook; i++) lookup->h[i] = model.ipar[4+i]; if(!(lookup->equisp)) { lookup->r = (double *) R_alloc((size_t) nlook, sizeof(double)); lookup->r2 = (double *) R_alloc((size_t) nlook, sizeof(double)); for(i = 0; i < nlook; i++) { ri = lookup->r[i] = model.ipar[4+nlook+i]; lookup->r2[i] = ri * ri; } } #ifdef DEBUG Rprintf("Exiting lookupinit: nlook=%d, equisp=%d\n", nlook, lookup->equisp); #endif return((Cdata *) lookup); } /* conditional intensity evaluator */ double lookupcif(Propo prop, State state, Cdata *cdata) { int npts, nlook, k, kk, ix, ixp1, j; double *x, *y; double u, v; double r2max, d2, d, delta, cifval, ux, vy; Lookup *lookup; lookup = (Lookup *) cdata; r2max = lookup->r2max; delta = lookup->delta; nlook = lookup->nlook; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; cifval = 1.0; if(npts == 0) return(cifval); ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(lookup->equisp) { /* equispaced r values */ if(lookup->per) { /* periodic distance */ /* Rprintf("Lookup equispaced table, periodic distance\n"); */ if(ix > 0) { for(j=0; j < ix; j++) { d = sqrt(dist2(u,v,x[j],y[j],lookup->period)); k = floor(d/delta); if(k < nlook) { if(k < 0) k = 0; cifval *= lookup->h[k]; } } } if(ixp1 < npts) { for(j=ixp1; jperiod)); k = floor(d/delta); if(k < nlook) { if(k < 0) k = 0; cifval *= lookup->h[k]; } } } } else { /* Euclidean distance */ /* Rprintf("Lookup equispaced table, Euclidean distance\n"); */ if(ix > 0) { for(j=0; j < ix; j++) { d = hypot(u - x[j], v-y[j]); k = floor(d/delta); if(k < nlook) { if(k < 0) k = 0; cifval *= lookup->h[k]; } } } if(ixp1 < npts) { for(j=ixp1; jh[k]; } } } } } else { /* non-equispaced r values */ if(lookup->per) { /* periodic distance */ /* Rprintf("Lookup non-equispaced table, periodic distance\n"); */ if(ix > 0) { for(j=0; j < ix; j++) { d2 = dist2(u,v,x[j],y[j],lookup->period); if(d2 < r2max) { for(kk = 0; kk < nlook && lookup->r2[kk] <= d2; kk++) ; k = (kk == 0) ? 0 : kk-1; cifval *= lookup->h[k]; } } } if(ixp1 < npts) { for(j=ixp1; jperiod); if(d2 < r2max) { for(kk = 0; kk < nlook && lookup->r2[kk] <= d2; kk++) ; k = (kk == 0) ? 0 : kk-1; cifval *= lookup->h[k]; } } } } else { /* Euclidean distance */ /* Rprintf("Lookup non-equispaced table, Euclidean distance\n"); */ if(ix > 0) { for(j=0; j < ix; j++) { ux = u - x[j]; vy = v - y[j]; d2 = ux * ux + vy * vy; if(d2 < r2max) { for(kk = 0; kk < nlook && lookup->r2[kk] <= d2; kk++) ; k = (kk == 0) ? 0 : kk-1; cifval *= lookup->h[k]; } } } if(ixp1 < npts) { for(j=ixp1; jr2[kk] <= d2; kk++) ; k = (kk == 0) ? 0 : kk-1; cifval *= lookup->h[k]; } } } } } return cifval; } Cifns LookupCifns = { &lookupinit, &lookupcif, (updafunptr) NULL, NO}; spatstat.random/src/rmatclus.c0000644000176200001440000000132114356000564016161 0ustar liggesusers/* rmatclus.c $Revision: 1.1 $ $Date: 2023/01/06 10:48:51 $ Generate realisation of stationary Matern cluster process in a disc D Baddeley-Chang hybrid algorithm Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include /* disable debugging code */ #undef BUGGER /* macros used */ #undef FNAME #undef SAVEPARENTS /* return offspring, parents and offspring-parent map */ #define FNAME rmatclusAll #define SAVEPARENTS #include "rmatclus.h" #undef FNAME #undef SAVEPARENTS /* return offspring only */ #define FNAME rmatclusOff #undef SAVEPARENTS #include "rmatclus.h" spatstat.random/src/getcif.c0000755000176200001440000000320114531531170015567 0ustar liggesusers#include #include "methas.h" extern Cifns AreaIntCifns, BadGeyCifns, DgsCifns, DiggraCifns, FikselCifns, GeyerCifns, HardcoreCifns, LennardCifns, LookupCifns, SoftcoreCifns, StraussCifns, StraussHardCifns, MultiStraussCifns, MultiStraussHardCifns, MultiHardCifns, TripletsCifns, PenttinenCifns; Cifns NullCifns = NULL_CIFNS; typedef struct CifPair { char *name; Cifns *p; } CifPair; CifPair CifTable[] = { {"areaint", &AreaIntCifns}, {"badgey", &BadGeyCifns}, {"dgs", &DgsCifns}, {"diggra", &DiggraCifns}, {"geyer", &GeyerCifns}, {"fiksel", &FikselCifns}, {"hardcore", &HardcoreCifns}, {"lookup", &LookupCifns}, {"lennard", &LennardCifns}, {"multihard", &MultiHardCifns}, {"penttinen", &PenttinenCifns}, {"sftcr", &SoftcoreCifns}, {"strauss", &StraussCifns}, {"straush", &StraussHardCifns}, {"straussm", &MultiStraussCifns}, {"straushm", &MultiStraussHardCifns}, {"triplets", &TripletsCifns}, {(char *) NULL, (Cifns *) NULL} }; Cifns getcif(char *cifname) { int i; CifPair cp; for(i = 0; CifTable[i].name; i++) { cp = CifTable[i]; if(strcmp(cifname, cp.name) == 0) return(*(cp.p)); } error("Unrecognised cif name; bailing out.\n"); /* control never passes to here, but compilers don't know that */ return(NullCifns); } /* R interface function, to check directly whether cif is recognised */ void knownCif(char** cifname, int* answer) { int i; CifPair cp; for(i = 0; CifTable[i].name; i++) { cp = CifTable[i]; if(strcmp(*cifname, cp.name) == 0) { *answer = 1; return; } } *answer = 0; return; } spatstat.random/src/rthomas.c0000644000176200001440000000131414356000564016006 0ustar liggesusers/* rthomas.c $Revision: 1.1 $ $Date: 2023/01/06 10:48:01 $ Generate realisation of stationary Thomas cluster process in a disc D Baddeley-Chang hybrid algorithm Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include /* disable debugging code */ #undef BUGGER /* macros used */ #undef FNAME #undef SAVEPARENTS /* return offspring, parents and offspring-parent map */ #define FNAME rthomasAll #define SAVEPARENTS #include "rthomas.h" #undef FNAME #undef SAVEPARENTS /* return offspring only */ #define FNAME rthomasOff #undef SAVEPARENTS #include "rthomas.h" spatstat.random/src/mhv1.h0000755000176200001440000000055214164500132015210 0ustar liggesusers/* mhv1.h marked or unmarked simulation Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef MH_MARKED if(marked) { /* marked process */ #define MH_MARKED YES #include "mhv2.h" #undef MH_MARKED } else { /* unmarked process */ #define MH_MARKED NO #include "mhv2.h" #undef MH_MARKED } spatstat.random/src/mhsnoopdef.h0000755000176200001440000000121214325152137016500 0ustar liggesusers/* mhsnoopdef.h Define structure 'Snoop' containing visual debugger parameters and state $Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifndef R_INTERNALS_H_ #include #endif typedef struct Snoop { int active; /* true or false */ int nextstop; /* jump to iteration number 'nextstop' */ int nexttype; /* jump to the next proposal of type 'nexttype' */ SEXP env; /* environment for exchanging data with R */ SEXP expr; /* callback expression for visual debugger */ } Snoop; #define NO_TYPE -1 spatstat.random/src/rcauchy.h0000644000176200001440000003104414364101623015774 0ustar liggesusers/* rcauchy.h $Revision: 1.3 $ $Date: 2023/01/25 01:00:42 $ Generate realisation of stationary Cluster cluster process in a disc D Baddeley-Chang hybrid algorithm Parameter: scale = sqrt(eta2)/2 eta2 = 4 * scale^2 This file is included multiple times in rcauchy.c Macros used: FNAME name of C function BUGGER activate debugging code SAVEPARENTS save coordinates of parents, and map from offspring to parents Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #define RUNIF01 runif((double) 0.0, (double) 1.0) #define RUNIFPOS runif(DBL_EPSILON, (double) 1.0) #define RTRUNCPOIS(MU) (int) qpois(runif(exp(-(MU)), (double) 1.0), MU, (int) 1, (int) 0) #define DISTD(R) ((R) - rD) /* model-specific */ /* radial cumulative integral of superdominating intensity */ #define MPLUSPLUS(R) \ lambda * M_PI * rD * rD * ( \ rD2/(2.0*scale2) + \ 1.0 + \ (rD * DISTD(R)/scale2 - 1)/sqrt(1.0 + DISTD(R) * DISTD(R)/scale2) \ ) SEXP FNAME(SEXP KAPPA, SEXP MU, SEXP CLUSTERSCALE, SEXP DISCRADIUS, SEXP INFLATE ) { /* generic inputs */ double kappa, mu, scale, rD, inflate; /* generic outputs */ double *xo, *yo; /* offspring locations */ SEXP Sout, Sxo, Syo; double *xoffspring, *yoffspring; #ifdef SAVEPARENTS double *xp, *yp; /* parent locations */ int *ip; /* map from offspring to parents */ SEXP Sxp, Syp, Sip; double *xparent, *yparent; int *parentid; #endif /* quantities/variables used in generic algorithm */ double rE, rD2, rE2, areaD; double rhoplus, rhoplusplus, muplus; double lambda, kappadag, edag, Minf, MrE, diffM, p0; double rpi, xpi, ypi, mi, roj, xoj, yoj, theta, dx, dy, d2; int NoMax, Npmax, newmax, no, i, j, k, n, m; double rhi, rlo, rtry, mhi, mtry, tmp; double dxD, ktrue, kdom; #ifdef SAVEPARENTS int np, added, ipcurrent; #endif /* model parameters (for readability) */ /* model-specific quantities */ double scale2, gammascale, rd2ons2; double inv2ps2, g; PROTECT(KAPPA = AS_NUMERIC(KAPPA)); PROTECT(MU = AS_NUMERIC(MU)); PROTECT(CLUSTERSCALE = AS_NUMERIC(CLUSTERSCALE)); PROTECT(DISCRADIUS = AS_NUMERIC(DISCRADIUS)); PROTECT(INFLATE = AS_NUMERIC(INFLATE)); /* That's 5 protected */ #define NINPUTS 5 GetRNGstate(); /* get values */ kappa = *(NUMERIC_POINTER(KAPPA)); mu = *(NUMERIC_POINTER(MU)); scale = *(NUMERIC_POINTER(CLUSTERSCALE)); rD = *(NUMERIC_POINTER(DISCRADIUS)); inflate = *(NUMERIC_POINTER(INFLATE)); #ifdef BUGGER Rprintf("INPUT: kappa = %lf, mu = %lf, scale = %lf\n", kappa, mu, scale); Rprintf("rD = %lf, inflate = %lf\n", rD, inflate); #endif /* inflation */ rE = inflate * rD; /* model-specific translation of inputs */ /* calculate some constants */ lambda = kappa * mu; /* intensity of cluster process */ kappadag = kappa * (1 - exp(-mu)); /* intensity of parents which have offspring anywhere */ p0 = exp(-mu); /* P(X == 0) where X ~ Pois(mu) */ rD2 = rD * rD; rE2 = rE * rE; areaD = M_PI * rD2; /* rDE = rE - rD; */ /* model-specific constants */ scale2 = scale * scale; /* eta2 = 4.0 * scale2; */ gammascale = 2.0/scale2; /* gamma distribution parameter, scale=1/rate */ rd2ons2 = rD2/scale2; inv2ps2 = 1.0/(M_2PI * scale2); /* superdominating intensity */ Minf = lambda * M_PI * rD2 * (1 + sqrt(rd2ons2) + rd2ons2/2.0); MrE = MPLUSPLUS(rE); #ifdef BUGGER Rprintf("Minf = %lf, MrE = %lf\n", Minf, MrE); #endif /* Guess amount of storage required */ NoMax = (int) ceil(2.0 * M_PI * lambda * rD2); if(NoMax < 2048) NoMax = 2048; xo = (double *) R_alloc(NoMax, sizeof(double)); yo = (double *) R_alloc(NoMax, sizeof(double)); no = 0; #ifdef SAVEPARENTS xp = (double *) R_alloc(NoMax, sizeof(double)); yp = (double *) R_alloc(NoMax, sizeof(double)); ip = (int *) R_alloc(NoMax, sizeof(int)); np = 0; #endif /* ----------- parents inside E ------------------- */ edag = M_PI * rE2 * kappadag; tmp = rpois(edag); n = (tmp > 2147483647.0) ? 2147483647 : ((int) tmp); #ifdef BUGGER Rprintf("Expect %lf parents inside E\n", edag); Rprintf("Generating %d parents inside E\n", n); #endif if(n > 0) { for(i = 0; i < n; i++) { R_CheckUserInterrupt(); /* generate parent position uniform in E */ rpi = rE * sqrt(RUNIF01); theta = M_2PI * RUNIF01; xpi = rpi * cos(theta); ypi = rpi * sin(theta); #ifdef SAVEPARENTS added = 0; #endif /* number of offspring of parent i: zero truncated Poisson (mu) */ m = (int) qpois(runif(p0, (double) 1.0), mu, (int) 1, (int) 0); #ifdef BUGGER Rprintf("Generating %d offspring of parent %d\n", m, i); #endif /* generate offspring positions */ for(j = 0; j < m; j++) { /* model specific: displacement radius */ roj = sqrt(-2.0 * log(RUNIFPOS)/rgamma((double) 0.5, gammascale)); theta = M_2PI * RUNIF01; xoj = xpi + roj * cos(theta); yoj = ypi + roj * sin(theta); if(xoj * xoj + yoj * yoj < rD2) { /* offspring point will be retained */ #ifdef SAVEPARENTS if(added == 0) { #ifdef BUGGER Rprintf("\tAdding proposed parent %d to result, as parent %d\n", i, np); #endif /* add parent point */ xp[np] = xpi; yp[np] = ypi; ipcurrent = np; np++; added = 1; } #endif /* add offspring point */ #ifdef BUGGER Rprintf("\t\tAdding offspring %d to result\n", j); #endif xo[no] = xoj; yo[no] = yoj; #ifdef SAVEPARENTS ip[no] = ipcurrent; #endif no++; /* check data overflow */ if(no > NoMax) { #ifdef BUGGER Rprintf("OVERFLOW\n"); #endif newmax = 2 * NoMax; xo = (double *) S_realloc((char *) xo, newmax, NoMax, sizeof(double)); yo = (double *) S_realloc((char *) yo, newmax, NoMax, sizeof(double)); #ifdef SAVEPARENTS xp = (double *) S_realloc((char *) xp, newmax, NoMax, sizeof(double)); yp = (double *) S_realloc((char *) yp, newmax, NoMax, sizeof(double)); ip = (int *) S_realloc((char *) ip, newmax, NoMax, sizeof(int)); #endif NoMax = newmax; } } } } } #ifdef BUGGER #ifdef SAVEPARENTS Rprintf("\n\nRunning total: %d parents, %d offspring\n\n", np, no); #else Rprintf("\n\nRunning total: %d offspring\n\n", no); #endif #endif /* ----------- parents outside E ------------------- */ diffM = Minf - MrE; if(diffM < 0.0) diffM = 0.0; #ifdef BUGGER Rprintf("Expect %lf super-dominating parents outside E\n", diffM); #endif /* Generate super-parents in descending order of distance */ /* Generate values of 'mi' in descending order using unit rate Poisson process */ mi = Minf; /* Ensure we don't get trapped */ Npmax = (int) ceil(diffM + 10.0 * sqrt(diffM)); #ifdef BUGGER Rprintf("Npmax = %d\n", Npmax); #endif for(i = 0; i < Npmax; i++) { R_CheckUserInterrupt(); mi = mi - rexp((double) 1.0); if(mi <= MrE) break; #ifdef BUGGER Rprintf("Generated mi = %lf\n", mi); #endif /* determine upper bound on solution of M(r) = mi */ if(i == 0) { rhi = 2 * rE; for(k = 0; k < 256; k++) { mhi = MPLUSPLUS(rhi); if(mhi > mi) break; rhi = 2.0 * rhi; } } else { /* use previous value of rhi */ mhi = MPLUSPLUS(rhi); } /* solve M(r) = mi */ if(mhi <= mi) { /* numerical problem - failed to find upper bound */ rpi = rhi; #ifdef BUGGER Rprintf("\tFailed to find upper bound on radius\n"); #endif } else { #ifdef BUGGER Rprintf("\tSeeking solution to Mplusplus(r) = mi on [%lf, %lf]\n", rE, rhi); #endif rlo = rE; /* mlo = MrE; */ for(k = 0; k < 512; k++) { rtry = (rlo + rhi)/2.0; mtry = MPLUSPLUS(rtry); if(fabs(mtry - mi) < 0.000001) break; if(mtry > mi) { rhi = rtry; } else { rlo = rtry; } } rpi = rtry; } #ifdef BUGGER Rprintf("\tUsing rpi = %lf\n", rpi); #endif /* compute intensities at this parent */ dxD = rpi - rD; if(dxD < 0.0) dxD = 0.0; /* model specific */ /* dominating kernel (for this parent, for offspring in D) */ g = 1.0 + dxD * dxD/scale2; kdom = inv2ps2/(g * sqrt(g)); /* expected number of offspring using dominating kernel */ muplus = mu * areaD * kdom; /* intensity of dominating parents */ rhoplus = kappa * (1 - exp(-muplus)); /* intensity of super-dominating parents */ rhoplusplus = kappa * muplus; #ifdef BUGGER Rprintf("\tmuplus = %lf; rhoplus = %lf; rhoplusplus = %lf\n", muplus, rhoplus, rhoplusplus); #endif /* THIN PARENTS TO ACHIEVE DOMINATING INTENSITY */ if(rhoplusplus * RUNIF01 < rhoplus) { /* accepted */ #ifdef BUGGER Rprintf("\tSuper-parent %d is accepted as a dominating parent\n", i); #endif /* make coordinates */ theta = M_2PI * RUNIF01; xpi = rpi * cos(theta); ypi = rpi * sin(theta); /* offspring */ #ifdef SAVEPARENTS added = 0; #endif /* number of dominating offspring */ /* zero truncated Poisson (muplus) */ m = RTRUNCPOIS(muplus); #ifdef BUGGER Rprintf("\tGenerated %d offspring of dominating parent\n", m); #endif if(m > 0) { for(j = 0; j < m; j++) { /* generate dominating offspring uniformly in D */ roj = rD * sqrt(RUNIF01); theta = M_2PI * RUNIF01; xoj = roj * cos(theta); yoj = roj * sin(theta); /* thin according to true kernel */ dx = xoj - xpi; dy = yoj - ypi; d2 = dx * dx + dy * dy; /* model specific */ /* true kernel: k(u|x) */ g = 1.0 + d2/scale2; ktrue = inv2ps2/(g * sqrt(g)); #ifdef BUGGER Rprintf("\t\tRetain offspring %d with probability %lf\n", j, ktrue/kdom); #endif if(RUNIF01 * kdom < ktrue) { /* offspring will be retained */ #ifdef SAVEPARENTS if(added == 0) { /* add parent point */ #ifdef BUGGER Rprintf("\t\tAdding proposed parent %d to the output list as parent %d\n", i, np); #endif xp[np] = xpi; yp[np] = ypi; ipcurrent = np; np++; added = 1; } #endif /* add offspring point */ xo[no] = xoj; yo[no] = yoj; #ifdef SAVEPARENTS ip[no] = ipcurrent; #endif no++; #ifdef BUGGER Rprintf("\t\t\tAdded offspring %d to the output list\n", j); #endif /* check data overflow */ if(no > NoMax) { #ifdef BUGGER Rprintf("OVERFLOW\n"); #endif newmax = 2 * NoMax; xo = (double *) S_realloc((char *) xo, newmax, NoMax, sizeof(double)); yo = (double *) S_realloc((char *) yo, newmax, NoMax, sizeof(double)); #ifdef SAVEPARENTS xp = (double *) S_realloc((char *) xp, newmax, NoMax, sizeof(double)); yp = (double *) S_realloc((char *) yp, newmax, NoMax, sizeof(double)); ip = (int *) S_realloc((char *) ip, newmax, NoMax, sizeof(int)); #endif NoMax = newmax; } } /* thinning on kernel */ } /* loop over offspring */ } } /* thinning superparent */ } /* loop over superparents */ #ifdef BUGGER #ifdef SAVEPARENTS Rprintf("Final total %d parents, %d offspring\n", np, no); #else Rprintf("Final total %d offspring\n", no); #endif #endif /* copy to result */ /* create output list */ #ifdef SAVEPARENTS #define NOUT 5 #else #define NOUT 2 #endif PROTECT(Sout = NEW_LIST(NOUT)); /* create vector entries in output list */ PROTECT(Sxo = NEW_NUMERIC(no)); PROTECT(Syo = NEW_NUMERIC(no)); #ifdef SAVEPARENTS PROTECT(Sxp = NEW_NUMERIC(np)); PROTECT(Syp = NEW_NUMERIC(np)); PROTECT(Sip = NEW_INTEGER(no)); #endif #define NPROTECTED (NINPUTS + 1 + NOUT) /* create pointers to output vectors */ xoffspring = NUMERIC_POINTER(Sxo); yoffspring = NUMERIC_POINTER(Syo); #ifdef SAVEPARENTS xparent = NUMERIC_POINTER(Sxp); yparent = NUMERIC_POINTER(Syp); parentid = INTEGER_POINTER(Sip); #endif /* copy */ #ifdef SAVEPARENTS for(i = 0; i < np; i++) { xparent[i] = xp[i]; yparent[i] = yp[i]; } #endif for(j = 0; j < no; j++) { xoffspring[j] = xo[j]; yoffspring[j] = yo[j]; #ifdef SAVEPARENTS parentid[j] = ip[j] + 1; #endif } SET_VECTOR_ELT(Sout, 0, Sxo); SET_VECTOR_ELT(Sout, 1, Syo); #ifdef SAVEPARENTS SET_VECTOR_ELT(Sout, 2, Sxp); SET_VECTOR_ELT(Sout, 3, Syp); SET_VECTOR_ELT(Sout, 4, Sip); #endif PutRNGstate(); UNPROTECT(NPROTECTED); return(Sout); } #undef NINPUTS #undef NOUT #undef NPROTECTED #undef RUNIF01 #undef RUNIFPOS #undef RTRUNCPOIS #undef DISTD #undef MPLUSPLUS spatstat.random/src/PerfectStraussHard.h0000755000176200001440000001303214325152137020115 0ustar liggesusers // ..................... Strauss-Hardcore process .......................... // $Revision: 1.5 $ $Date: 2020/05/12 03:33:08 $ class StraussHardProcess : public PointProcess { public: double beta, gamma, H, R, Hsquared, Rsquared; StraussHardProcess(double xmin, double xmax, double ymin, double ymax, double b, double g, double Ri, double Hc); ~StraussHardProcess(){} void NewEvent(double *x, double *y, char *InWindow); void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP); double Interaction(double dsquared); // void CalcBeta(long int xsidepomm, long int ysidepomm, // double *betapomm); // void CheckBeta(long int xsidepomm, long int ysidepomm, // double *betapomm); // double lnCondInt(struct Point2 *TempCell, Point2Pattern *p2p); // void Beta(struct Point2 *TempCell); // void CalcBeta(Point2Pattern *p2p); }; StraussHardProcess::StraussHardProcess(double xmin, double xmax, double ymin, double ymax, double b, double g, double Ri, double Hc) : PointProcess(xmin, xmax, ymin, ymax){ beta = b; gamma = g; R = Ri; H = Hc; Rsquared = R * R; Hsquared = H * H; InteractionRange = R; TotalBirthRate = beta*(xmax-xmin)*(ymax-ymin); } double StraussHardProcess::Interaction(double dsquared) { if(dsquared >= Rsquared) return(1.0); if(dsquared >= Hsquared) return(gamma); return(0.0); } void StraussHardProcess::NewEvent(double *x, double *y, char *InWindow) { double Xdim, Ydim; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; *x = slumptal()*Xdim+Xmin; *y = slumptal()*Ydim+Ymin; *InWindow = 1; } void StraussHardProcess::GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP) { int i; double xtemp, ytemp, L, Xdim, Ydim; struct Point *TempPoint; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; L = beta*Xdim*Ydim; *GeneratedPoints = poisson(L); *LivingPoints = *GeneratedPoints; for (i=1; i<=*GeneratedPoints ; i++){ //Rprintf("Generating StraussHardProcess Poisson 3\n"); //scanf("%f",&f1); xtemp = slumptal()*Xdim+Xmin; ytemp = slumptal()*Ydim+Ymin; // //Rprintf("Generating StraussHardProcess Poisson 3.2\n"); TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = i; TempPoint->R = slumptal(); //Rprintf("Generating StraussHardProcess Poisson 3.6\n"); TempPoint->next = headPoint->next; headPoint->next = TempPoint; *NoP = *NoP + 1; } } // ........................... Interface to R .......................... extern "C" { SEXP PerfectStraussHard(SEXP beta, SEXP gamma, SEXP r, SEXP hc, SEXP xrange, SEXP yrange) { // input parameters double Beta, Gamma, R, H, Xmin, Xmax, Ymin, Ymax; double *Xrange, *Yrange; // internal int xcells, ycells; long int StartTime, EndTime; // output int noutmax; SEXP xout, yout, nout, out; double *xx, *yy; int *nn; // protect arguments from garbage collector PROTECT(beta = AS_NUMERIC(beta)); PROTECT(gamma = AS_NUMERIC(gamma)); PROTECT(r = AS_NUMERIC(r)); PROTECT(hc = AS_NUMERIC(hc)); PROTECT(xrange = AS_NUMERIC(xrange)); PROTECT(yrange = AS_NUMERIC(yrange)); // that's 6 protected objects // extract arguments // model parameters Beta = *(NUMERIC_POINTER(beta)); Gamma = *(NUMERIC_POINTER(gamma)); R = *(NUMERIC_POINTER(r)); H = *(NUMERIC_POINTER(hc)); // window Xrange = NUMERIC_POINTER(xrange); Xmin = Xrange[0]; Xmax = Xrange[1]; Yrange = NUMERIC_POINTER(yrange); Ymin = Yrange[0]; Ymax = Yrange[1]; // compute cell array size xcells = (int) floor((Xmax-Xmin)/ R); if(xcells > 9) { xcells = 9; } else if(xcells < 1) { xcells = 1; } ycells = (int) floor((Ymax-Ymin)/ R); if(ycells > 9) { ycells = 9; } else if(ycells < 1) { ycells = 1; } #ifdef DBGS Rprintf("xcells %d ycells %d\n",xcells,ycells); Rprintf("Initialising\n"); #endif // Initialise StraussHard point process StraussHardProcess ExampleProcess(Xmin,Xmax,Ymin,Ymax, Beta, Gamma, R, H); // Initialise point pattern Point2Pattern ExamplePattern(Xmin,Xmax,Ymin,Ymax, xcells, ycells); // parameters: min x, max x, min y, max y, "cells" in x and y direction // used for speeding up neighbour counting, 9 is max here #ifdef DBGS Rprintf("Initialisation complete\n"); #endif // Synchronise random number generator GetRNGstate(); // Initialise perfect sampler Sampler PerfectSampler(&ExampleProcess); // Perform perfect sampling PerfectSampler.Sim(&ExamplePattern, &StartTime, &EndTime); // Synchronise random number generator PutRNGstate(); // Get upper estimate of number of points noutmax = ExamplePattern.UpperCount() + 1; // Allocate space for output PROTECT(xout = NEW_NUMERIC(noutmax)); PROTECT(yout = NEW_NUMERIC(noutmax)); PROTECT(nout = NEW_INTEGER(1)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); nn = INTEGER_POINTER(nout); // copy data into output storage ExamplePattern.Return(xx, yy, nn, noutmax); // pack up into output list PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, nout); // return UNPROTECT(10); // 6 arguments plus xout, yout, nout, out return(out); } } spatstat.random/src/init.c0000644000176200001440000000354214567023173015306 0ustar liggesusers /* Native symbol registration table for spatstat.core package Automatically generated - do not edit this file! */ #include "proto.h" #include #include #include // for NULL #include /* See proto.h for declarations for the native routines registered below. */ static const R_CMethodDef CEntries[] = { {"knownCif", (DL_FUNC) &knownCif, 2}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"PerfectDGS", (DL_FUNC) &PerfectDGS, 4}, {"PerfectDiggleGratton", (DL_FUNC) &PerfectDiggleGratton, 6}, {"PerfectHardcore", (DL_FUNC) &PerfectHardcore, 4}, {"PerfectPenttinen", (DL_FUNC) &PerfectPenttinen, 5}, {"PerfectStrauss", (DL_FUNC) &PerfectStrauss, 5}, {"PerfectStraussHard", (DL_FUNC) &PerfectStraussHard, 6}, {"rcauchyAll", (DL_FUNC) &rcauchyAll, 5}, {"rcauchyOff", (DL_FUNC) &rcauchyOff, 5}, {"rmatclusAll", (DL_FUNC) &rmatclusAll, 5}, {"rmatclusOff", (DL_FUNC) &rmatclusOff, 5}, {"RrnzpoisDalgaard", (DL_FUNC) &RrnzpoisDalgaard, 2}, {"RrnzpoisHarding", (DL_FUNC) &RrnzpoisHarding, 2}, {"RrtruncpoisDalgaard", (DL_FUNC) &RrtruncpoisDalgaard, 3}, {"RrtruncpoisHarding", (DL_FUNC) &RrtruncpoisHarding, 3}, {"rthomasAll", (DL_FUNC) &rthomasAll, 5}, {"rthomasOff", (DL_FUNC) &rthomasOff, 5}, {"thinjumpequal", (DL_FUNC) &thinjumpequal, 3}, {"xmethas", (DL_FUNC) &xmethas, 25}, {NULL, NULL, 0} }; void R_init_spatstat_random(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } spatstat.random/src/lennard.c0000755000176200001440000000700714325152137015764 0ustar liggesusers#include #include #include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Lennard-Jones process */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Lennard { double sigma; double epsilon; double sigma2; /* sigma^2 */ double foureps; /* 4 * epsilon */ double d2min; /* minimum value of d^2 which yields nonzero intensity */ double d2max; /* maximum value of d^2 which has nontrivial contribution */ double *period; int per; } Lennard; /* MAXEXP is intended to be the largest x such that exp(-x) != 0 although the exact value is not needed */ #define MAXEXP (-log(DBL_MIN)) #define MINEXP (log(1.001)) /* initialiser function */ Cdata *lennardinit(State state, Model model, Algor algo) { Lennard *lennard; double sigma2, foureps, minfrac, maxfrac; lennard = (Lennard *) R_alloc(1, sizeof(Lennard)); /* Interpret model parameters*/ lennard->sigma = model.ipar[0]; lennard->epsilon = model.ipar[1]; lennard->period = model.period; /* constants */ lennard->sigma2 = sigma2 = pow(lennard->sigma, 2); lennard->foureps = foureps = 4 * lennard->epsilon; /* thresholds where the interaction becomes trivial */ minfrac = pow(foureps/MAXEXP, (double) 1.0/6.0); if(minfrac > 0.5) minfrac = 0.5; maxfrac = pow(foureps/MINEXP, (double) 1.0/3.0); if(maxfrac < 2.0) maxfrac = 2.0; lennard->d2min = sigma2 * minfrac; lennard->d2max = sigma2 * maxfrac; /* periodic boundary conditions? */ lennard->per = (model.period[0] > 0.0); return((Cdata *) lennard); } /* conditional intensity evaluator */ double lennardcif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double d2, ratio6, pairsum, cifval; double sigma2, d2max, d2min; double *period; Lennard *lennard; DECLARE_CLOSE_D2_VARS; lennard = (Lennard *) cdata; sigma2 = lennard->sigma2; d2max = lennard->d2max; d2min = lennard->d2min; period = lennard->period; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; cifval = 1.0; if(npts == 0) return(cifval); pairsum = 0; ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(lennard->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],period,d2max,d2)) { if(d2 < d2min) { cifval = 0.0; return cifval; } ratio6 = pow(sigma2/d2, 3); pairsum += ratio6 * (1.0 - ratio6); } } } if(ixp1 < npts) { for(j=ixp1; j 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], d2max, d2)) { if(d2 < lennard->d2min) { cifval = 0.0; return cifval; } ratio6 = pow(sigma2/d2, 3); pairsum += ratio6 * (1.0 - ratio6); } } } if(ixp1 < npts) { for(j=ixp1; jd2min) { cifval = 0.0; return cifval; } ratio6 = pow(sigma2/d2, 3); pairsum += ratio6 * (1.0 - ratio6); } } } } cifval *= exp(lennard->foureps * pairsum); return cifval; } Cifns LennardCifns = { &lennardinit, &lennardcif, (updafunptr) NULL, NO}; spatstat.random/src/dist2.h0000755000176200001440000000451314325152137015372 0ustar liggesusers/* dist2.h External declarations for the functions defined in dist2.c and In-line cpp macros for similar purposes $Revision: 1.20 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ double dist2(double u, double v, double x, double y, double *period); double dist2either(double u, double v, double x, double y, double *period); int dist2thresh(double u, double v, double x, double y, double *period, double r2); int dist2Mthresh(double u, double v, double x, double y, double *period, double r2); /* Efficient macros to test closeness of points */ /* These variables must be declared (note: some files e.g. straush.c use 'RESIDUE' explicitly) */ #define DECLARE_CLOSE_VARS \ register double DX, DY, DXP, DYP, RESIDUE #define DECLARE_CLOSE_D2_VARS \ register double DX, DY, DXP, DYP, DX2 #define CLOSE(U,V,X,Y,R2) \ ((DX = X - U), \ (RESIDUE = R2 - DX * DX), \ ((RESIDUE > 0.0) && \ ((DY = Y - V), \ (RESIDUE = RESIDUE - DY * DY), \ (RESIDUE > 0.0)))) #define CLOSE_D2(U,V,X,Y,R2,D2) \ ((DX = X - U), \ (DX2 = DX * DX), \ (DX2 < R2) && (((DY = Y - V), \ (D2 = DX2 + DY * DY), \ (D2 < R2)))) /* The following calculates X mod P, but it works only if X \in [-P, P] so that X is the difference between two values that lie in an interval of length P */ #define CLOSE_PERIODIC(U,V,X,Y,PERIOD,R2) \ ((DX = X - U), \ (DX = (DX < 0.0) ? -DX : DX), \ (DXP = (PERIOD)[0] - DX), \ (DX = (DX < DXP) ? DX : DXP), \ (RESIDUE = R2 - DX * DX), \ ((RESIDUE > 0.0) && ((DY = Y - V), \ (DY = (DY < 0.0) ? -DY : DY), \ (DYP = (PERIOD)[1] - DY), \ (DY = (DY < DYP) ? DY : DYP), \ (RESIDUE = RESIDUE - DY * DY), \ (RESIDUE > 0.0) ))) #define CLOSE_PERIODIC_D2(U,V,X,Y,PERIOD,R2,D2) \ ((DX = X - U), \ (DX = (DX < 0.0) ? -DX : DX), \ (DXP = (PERIOD)[0] - DX), \ (DX = (DX < DXP) ? DX : DXP), \ (D2 = DX * DX), \ ((D2 < R2) && ((DY = Y - V), \ (DY = (DY < 0.0) ? -DY : DY), \ (DYP = (PERIOD)[1] - DY), \ (DY = (DY < DYP) ? DY : DYP), \ (D2 += DY * DY), \ (D2 < R2) ))) spatstat.random/src/multihard.c0000755000176200001440000000725114325152137016333 0ustar liggesusers#include #include #include "methas.h" #include "dist2.h" /* for debugging code, include #define DEBUG 1 */ /* Conditional intensity computation for Multitype Hardcore process */ /* NOTE: types (marks) are numbered from 0 to ntypes-1 */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct MultiHard { int ntypes; double *hc; /* hc[i,j] = hc[j+ntypes*i] for i,j = 0... ntypes-1 */ double *hc2; /* squared radii */ double range2; /* square of interaction range */ double *period; int per; } MultiHard; /* initialiser function */ Cdata *multihardinit(State state, Model model, Algor algo) { int i, j, ntypes, n2; double h, h2, range2; MultiHard *multihard; multihard = (MultiHard *) R_alloc(1, sizeof(MultiHard)); multihard->ntypes = ntypes = model.ntypes; n2 = ntypes * ntypes; #ifdef DEBUG Rprintf("initialising space for %d types\n", ntypes); #endif /* Allocate space for parameters */ multihard->hc = (double *) R_alloc((size_t) n2, sizeof(double)); /* Allocate space for transformed parameters */ multihard->hc2 = (double *) R_alloc((size_t) n2, sizeof(double)); /* Copy and process model parameters*/ range2 = 0.0; for(i = 0; i < ntypes; i++) { for(j = 0; j < ntypes; j++) { h = model.ipar[i + j*ntypes]; h2 = h * h; MAT(multihard->hc, i, j, ntypes) = h; MAT(multihard->hc2, i, j, ntypes) = h2; if(range2 < h2) range2 = h2; } } multihard->range2 = range2; /* periodic boundary conditions? */ multihard->period = model.period; multihard->per = (model.period[0] > 0.0); #ifdef DEBUG Rprintf("end initialiser\n"); #endif return((Cdata *) multihard); } /* conditional intensity evaluator */ double multihardcif(Propo prop, State state, Cdata *cdata) { int npts, ntypes, ix, ixp1, j, mrk, mrkj; int *marks; double *x, *y; double u, v; double d2, range2, cifval; double *period; MultiHard *multihard; DECLARE_CLOSE_D2_VARS; multihard = (MultiHard *) cdata; range2 = multihard->range2; period = multihard->period; u = prop.u; v = prop.v; mrk = prop.mrk; ix = prop.ix; x = state.x; y = state.y; marks = state.marks; npts = state.npts; #ifdef DEBUG Rprintf("computing cif: u=%lf, v=%lf, mrk=%d\n", u, v, mrk); #endif cifval = 1.0; if(npts == 0) return(cifval); ntypes = multihard->ntypes; #ifdef DEBUG Rprintf("scanning data\n"); #endif ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(multihard->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],period,range2,d2)) { mrkj = marks[j]; if(d2 < MAT(multihard->hc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } } } } if(ixp1 < npts) { for(j=ixp1; jhc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } } } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], range2, d2)) { mrkj = marks[j]; if(d2 < MAT(multihard->hc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } } } } if(ixp1 < npts) { for(j=ixp1; jhc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } } } } } #ifdef DEBUG Rprintf("returning positive cif\n"); #endif return cifval; } Cifns MultiHardCifns = { &multihardinit, &multihardcif, (updafunptr) NULL, YES}; spatstat.random/src/sftcr.c0000755000176200001440000000426014325152137015460 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Soft Core process */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Softcore { double sigma; double kappa; double nook; /* -1/kappa */ double stok; /* sigma^(2/kappa) */ double *period; int per; } Softcore; /* initialiser function */ Cdata *sftcrinit(State state, Model model, Algor algo) { Softcore *softcore; softcore = (Softcore *) R_alloc(1, sizeof(Softcore)); /* Interpret model parameters*/ softcore->sigma = model.ipar[0]; softcore->kappa = model.ipar[1]; softcore->period = model.period; /* constants */ softcore->nook = -1/softcore->kappa; softcore->stok = pow(softcore->sigma, 2/softcore->kappa); /* periodic boundary conditions? */ softcore->per = (model.period[0] > 0.0); return((Cdata *) softcore); } /* conditional intensity evaluator */ double sftcrcif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double d2, pairsum, cifval, nook, stok; Softcore *softcore; softcore = (Softcore *) cdata; nook = softcore->nook; stok = softcore->stok; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; cifval = 1.0; if(npts == 0) return(cifval); pairsum = 0; ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(softcore->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { d2 = dist2(u,v,x[j],y[j],softcore->period); pairsum += pow(d2, nook); } } if(ixp1 < npts) { for(j=ixp1; jperiod); pairsum += pow(d2, nook); } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { d2 = pow(u - x[j],2) + pow(v-y[j],2); pairsum += pow(d2, nook); } } if(ixp1 < npts) { for(j=ixp1; j #include #include #include "methas.h" #include "mhsnoopdef.h" /* mhsnoop.c $Revision: 1.12 $ $Date: 2022/11/02 11:02:26 $ support for visual debugger in RMH Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ /* To switch on debugging code, insert the line: #define MH_DEBUG YES To switch off debugging code, insert the line: #define MH_DEBUG NO */ #ifndef MH_DEBUG #define MH_DEBUG NO #endif void initmhsnoop(Snoop *s, SEXP env) { s->active = isEnvironment(env); s->nextstop = 0; /* stop at iteration 0 */ s->nexttype = NO_TYPE; /* deactivated */ if(s->active) { s->env = env; s->expr = findVar(install("callbackexpr"), env); } else { s->env = s->expr = R_NilValue; } } void mhsnoop(Snoop *s, int irep, Algor *algo, State *state, Propo *prop, double numer, double denom, int *itype) { SEXP e; int npts, j, proptype, fateMH, fateUser; /* passed from C to R before debugger */ SEXP Sirep, Sx, Sy, Sm, Sproptype, Sproplocn, Spropmark, Spropindx; SEXP Snumer, Sdenom, Sitype; double *Px, *Py, *Pproplocn; int *Pm; /* passed from R to C after debugger */ SEXP Sinxt, Stnxt, SitypeUser; #if MH_DEBUG Rprintf("mhsnoop called at iteration %d\n", irep); #endif if(!(s->active)) return; #if MH_DEBUG Rprintf("mhsnoop is active\n"); #endif /* execute when the simulation reaches the next stopping time */ if(s->nextstop >= 0) { /* specified iteration number 'nextstop' or later */ if(irep < s->nextstop) return; } else if(s->nexttype >= 0) { /* specified proposal type 'nexttype' */ if(prop->itype != s->nexttype) return; } else { /* no stopping rule - skip all */ return; } #if MH_DEBUG Rprintf("debug triggered\n"); #endif /* environment for communication with R */ e = s->env; /* copy data to R */ /* copy iteration number */ PROTECT(Sirep = NEW_INTEGER(1)); *(INTEGER_POINTER(Sirep)) = irep; setVar(install("irep"), Sirep, e); UNPROTECT(1); /* copy (x,y) coordinates */ npts = state->npts; PROTECT(Sx = NEW_NUMERIC(npts)); PROTECT(Sy = NEW_NUMERIC(npts)); Px = NUMERIC_POINTER(Sx); Py = NUMERIC_POINTER(Sy); for(j = 0; j < npts; j++) { Px[j] = state->x[j]; Py[j] = state->y[j]; } setVar(install("xcoords"), Sx, e); setVar(install("ycoords"), Sy, e); UNPROTECT(2); /* copy marks */ if(state->ismarked) { PROTECT(Sm = NEW_INTEGER(npts)); Pm = INTEGER_POINTER(Sm); for(j = 0; j < npts; j++) { Pm[j] = state->marks[j]; } setVar(install("mcodes"), Sm, e); UNPROTECT(1); } /* proposal type */ PROTECT(Sproptype = NEW_INTEGER(1)); *(INTEGER_POINTER(Sproptype)) = proptype = prop->itype; setVar(install("proptype"), Sproptype, e); UNPROTECT(1); /* proposal coordinates */ PROTECT(Sproplocn = NEW_NUMERIC(2)); Pproplocn = NUMERIC_POINTER(Sproplocn); Pproplocn[0] = prop->u; Pproplocn[1] = prop->v; setVar(install("proplocn"), Sproplocn, e); UNPROTECT(1); /* proposal mark value */ if(state->ismarked) { PROTECT(Spropmark = NEW_INTEGER(1)); *(INTEGER_POINTER(Spropmark)) = prop->mrk; setVar(install("propmark"), Spropmark, e); UNPROTECT(1); } /* proposal point index */ PROTECT(Spropindx = NEW_INTEGER(1)); *(INTEGER_POINTER(Spropindx)) = prop->ix; setVar(install("propindx"), Spropindx, e); UNPROTECT(1); /* Metropolis-Hastings numerator and denominator */ PROTECT(Snumer = NEW_NUMERIC(1)); PROTECT(Sdenom = NEW_NUMERIC(1)); *(NUMERIC_POINTER(Snumer)) = numer; *(NUMERIC_POINTER(Sdenom)) = denom; setVar(install("numerator"), Snumer, e); setVar(install("denominator"), Sdenom, e); UNPROTECT(2); /* tentative outcome of proposal (0 = reject, other=accept) */ PROTECT(Sitype = NEW_INTEGER(1)); *(INTEGER_POINTER(Sitype)) = fateMH = *itype; setVar(install("itype"), Sitype, e); UNPROTECT(1); /* ..... call visual debugger */ #if MH_DEBUG Rprintf("executing [callback]\n"); #endif eval(s->expr, s->env); #if MH_DEBUG Rprintf("exited [callback]\n"); #endif /* update outcome of proposal */ SitypeUser = findVar(install("itype"), e); fateUser = *(INTEGER_POINTER(SitypeUser)); if(fateUser != fateMH) *itype = fateUser; #if MH_DEBUG Rprintf("Returned itype = %d\n", fateUser); if(fateUser == fateMH) { if(fateMH == REJECT) { Rprintf("Confirmed: Proposal rejected\n"); } else { Rprintf("Confirmed: Proposal accepted\n"); } } else { if(fateUser == REJECT) { Rprintf("User changed fate of proposal to REJECTED\n"); } else { Rprintf("User changed fate of proposal to ACCEPTED\n"); } } Rprintf("Assigned itype = %d\n", *itype); #endif /* update stopping time */ Sinxt = findVar(install("inxt"), e); s->nextstop = *(INTEGER_POINTER(Sinxt)); Stnxt = findVar(install("tnxt"), e); s->nexttype = *(INTEGER_POINTER(Stnxt)); #if MH_DEBUG if(s->nextstop >= 0) Rprintf("Next stop: iteration %d\n", s->nextstop); if(s->nexttype >= 0) { if(s->nexttype == BIRTH) Rprintf("Next stop: first birth proposal\n"); if(s->nexttype == DEATH) Rprintf("Next stop: first death proposal\n"); if(s->nexttype == SHIFT) Rprintf("Next stop: first shift proposal\n"); } Rprintf("Exiting mhsnoop\n"); #endif return; } spatstat.random/src/PerfectHardcore.h0000755000176200001440000001150314325152137017402 0ustar liggesusers // ........................... Hardcore process .......................... // $Revision: 1.6 $ $Date: 2020/05/12 03:31:48 $ class HardcoreProcess : public PointProcess { public: double beta, R, Rsquared; HardcoreProcess(double xmin, double xmax, double ymin, double ymax, double b, double Ri); ~HardcoreProcess(){} void NewEvent(double *x, double *y, char *InWindow); void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP); double Interaction(double dsquared); }; HardcoreProcess::HardcoreProcess(double xmin, double xmax, double ymin, double ymax, double b, double Ri) : PointProcess(xmin, xmax, ymin, ymax){ beta = b; R = Ri; Rsquared = R * R; InteractionRange = R; TotalBirthRate = beta*(xmax-xmin)*(ymax-ymin); } double HardcoreProcess::Interaction(double dsquared) { double rtn; rtn = 1; if(dsquared < Rsquared) rtn = 0; return(rtn); } void HardcoreProcess::NewEvent(double *x, double *y, char *InWindow) { double Xdim, Ydim; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; *x = slumptal()*Xdim+Xmin; *y = slumptal()*Ydim+Ymin; *InWindow = 1; } void HardcoreProcess::GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP) { int i; double xtemp, ytemp, L, Xdim, Ydim; struct Point *TempPoint; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; L = beta*Xdim*Ydim; *GeneratedPoints = poisson(L); *LivingPoints = *GeneratedPoints; for (i=1; i<=*GeneratedPoints ; i++){ //Rprintf("Generating HardcoreProcess Poisson 3\n"); //scanf("%f",&f1); xtemp = slumptal()*Xdim+Xmin; ytemp = slumptal()*Ydim+Ymin; // //Rprintf("Generating HardcoreProcess Poisson 3.2\n"); TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = i; TempPoint->R = slumptal(); //Rprintf("Generating HardcoreProcess Poisson 3.6\n"); TempPoint->next = headPoint->next; headPoint->next = TempPoint; *NoP = *NoP + 1; } } // ........................... Interface to R .......................... extern "C" { SEXP PerfectHardcore(SEXP beta, SEXP r, SEXP xrange, SEXP yrange) { // input parameters double Beta, R, Xmin, Xmax, Ymin, Ymax; double *Xrange, *Yrange; // internal int xcells, ycells; long int StartTime, EndTime; // output int noutmax; SEXP xout, yout, nout, out; double *xx, *yy; int *nn; // protect arguments from garbage collector PROTECT(beta = AS_NUMERIC(beta)); PROTECT(r = AS_NUMERIC(r)); PROTECT(xrange = AS_NUMERIC(xrange)); PROTECT(yrange = AS_NUMERIC(yrange)); // that's 4 protected objects // extract arguments // model parameters Beta = *(NUMERIC_POINTER(beta)); R = *(NUMERIC_POINTER(r)); // window Xrange = NUMERIC_POINTER(xrange); Xmin = Xrange[0]; Xmax = Xrange[1]; Yrange = NUMERIC_POINTER(yrange); Ymin = Yrange[0]; Ymax = Yrange[1]; // compute cell array size xcells = (int) floor((Xmax-Xmin)/ R); if(xcells > 9) { xcells = 9; } else if(xcells < 1) { xcells = 1; } ycells = (int) floor((Ymax-Ymin)/ R); if(ycells > 9) { ycells = 9; } else if(ycells < 1) { ycells = 1; } #ifdef DBGS Rprintf("xcells %d ycells %d\n",xcells,ycells); Rprintf("Initialising\n"); #endif // Initialise Hardcore point process HardcoreProcess ExampleProcess(Xmin,Xmax,Ymin,Ymax, Beta, R); // Initialise point pattern Point2Pattern ExamplePattern(Xmin,Xmax,Ymin,Ymax, xcells, ycells); // parameters: min x, max x, min y, max y, "cells" in x and y direction // used for speeding up neighbour counting, 9 is max here #ifdef DBGS Rprintf("Initialisation complete\n"); #endif // Synchronise random number generator GetRNGstate(); // Initialise perfect sampler Sampler PerfectSampler(&ExampleProcess); // Perform perfect sampling PerfectSampler.Sim(&ExamplePattern, &StartTime, &EndTime); // Synchronise random number generator PutRNGstate(); // Get upper estimate of number of points noutmax = ExamplePattern.UpperCount() + 1; // Allocate space for output PROTECT(xout = NEW_NUMERIC(noutmax)); PROTECT(yout = NEW_NUMERIC(noutmax)); PROTECT(nout = NEW_INTEGER(1)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); nn = INTEGER_POINTER(nout); // copy data into output storage ExamplePattern.Return(xx, yy, nn, noutmax); // pack up into output list PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, nout); // return UNPROTECT(8); // 4 arguments plus xout, yout, nout, out return(out); } } spatstat.random/src/diggra.c0000755000176200001440000000626214325152137015600 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Diggle-Gratton process */ /* Conditional intensity function for a pairwise interaction point process with interaction function as given by e(t) = 0 for t < delta = (t-delta)/(rho-delta)^kappa for delta <= t < rho = 1 for t >= rho (See page 767 of Diggle, Gates, and Stibbard, Biometrika vol. 74, 1987, pages 763 -- 770.) */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Diggra { double kappa; double delta; double rho; double delta2; /* delta^2 */ double rho2; /* rho^2 */ double fac; /* 1/(rho-delta) */ double *period; int per; } Diggra; /* initialiser function */ Cdata *diggrainit(State state, Model model, Algor algo) { Diggra *diggra; diggra = (Diggra *) R_alloc(1, sizeof(Diggra)); /* Interpret model parameters*/ diggra->kappa = model.ipar[0]; diggra->delta = model.ipar[1]; diggra->rho = model.ipar[2]; diggra->period = model.period; /* constants */ diggra->delta2 = pow(diggra->delta, 2); diggra->rho2 = pow(diggra->rho, 2); diggra->fac = 1/(diggra->rho - diggra->delta); /* periodic boundary conditions? */ diggra->per = (model.period[0] > 0.0); return((Cdata *) diggra); } /* conditional intensity evaluator */ double diggracif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double d2, pairprod, cifval; double rho2, delta, delta2, fac; double *period; DECLARE_CLOSE_D2_VARS; Diggra *diggra; diggra = (Diggra *) cdata; period = diggra->period; rho2 = diggra->rho2; delta = diggra->delta; delta2 = diggra->delta2; fac = diggra->fac; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; cifval = pairprod = 1.0; if(npts == 0) return(cifval); ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(diggra->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],period,rho2,d2)) { if(d2 < delta2) { cifval = 0.0; return(cifval); } else { pairprod *= fac * (sqrt(d2)-delta); } } } } if(ixp1 < npts) { for(j=ixp1; j 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], rho2, d2)) { if(d2 <= delta2) { cifval = 0.0; return(cifval); } else { pairprod *= fac * (sqrt(d2)-delta); } } } } if(ixp1 < npts) { for(j=ixp1; jkappa); return cifval; } Cifns DiggraCifns = { &diggrainit, &diggracif, (updafunptr) NULL, NO}; spatstat.random/src/geyer.c0000755000176200001440000002342114531531170015447 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" #undef MH_DEBUG /* Conditional intensity function for a Geyer saturation process. */ typedef struct Geyer { /* model parameters */ double gamma; double r; double s; /* transformations of the parameters */ double r2; double loggamma; int hard; /* periodic distance */ double *period; int per; /* auxiliary counts */ int *aux; #ifdef MH_DEBUG int *freshaux; int prevtype; #endif } Geyer; Cdata *geyerinit(State state, Model model, Algor algo) { int i, j, n1; Geyer *geyer; double r2; double *period; DECLARE_CLOSE_VARS; geyer = (Geyer *) R_alloc(1, sizeof(Geyer)); /* Interpret model parameters*/ geyer->gamma = model.ipar[0]; geyer->r = model.ipar[1]; /* not squared any more */ geyer->s = model.ipar[2]; geyer->r2 = geyer->r * geyer->r; #ifdef MHDEBUG Rprintf("Initialising Geyer gamma=%lf, r=%lf, sat=%lf\n", geyer->gamma, geyer->r, geyer->s); #endif /* is the model numerically equivalent to hard core ? */ geyer->hard = (geyer->gamma < DBL_EPSILON); geyer->loggamma = (geyer->hard) ? 0 : log(geyer->gamma); /* periodic boundary conditions? */ geyer->period = model.period; geyer->per = (model.period[0] > 0.0); /* allocate storage for auxiliary counts */ geyer->aux = (int *) R_alloc((size_t) state.npmax, sizeof(int)); #ifdef MH_DEBUG geyer->freshaux = (int *) R_alloc((size_t) state.npmax, sizeof(int)); geyer->prevtype = -42; #endif r2 = geyer->r2; /* Initialise auxiliary counts */ for(i = 0; i < state.npmax; i++) geyer->aux[i] = 0; if(geyer->per) { /* periodic */ period = geyer->period; if(state.npts > 1) { n1 = state.npts - 1; for(i = 0; i < n1; i++) { for(j = i+1; j < state.npts; j++) { if(CLOSE_PERIODIC(state.x[i], state.y[i], state.x[j], state.y[j], period, r2)) { geyer->aux[i] += 1; geyer->aux[j] += 1; } } } } } else { /* Euclidean distance */ if(state.npts > 1) { n1 = state.npts - 1; for(i = 0; i < n1; i++) { for(j = i+1; j < state.npts; j++) { if(CLOSE(state.x[i], state.y[i], state.x[j], state.y[j], r2)) { geyer->aux[i] += 1; geyer->aux[j] += 1; } } } } } return((Cdata *) geyer); } double geyercif(Propo prop, State state, Cdata *cdata) { int ix, j, npts, tee; double u, v, r2, s; double w, a, b, f, cifval; double *x, *y; int *aux; double *period; Geyer *geyer; DECLARE_CLOSE_VARS; geyer = (Geyer *) cdata; npts = state.npts; if(npts==0) return ((double) 1.0); x = state.x; y = state.y; u = prop.u; v = prop.v; ix = prop.ix; r2 = geyer->r2; s = geyer->s; period = geyer->period; aux = geyer->aux; /* tee = neighbour count at the point in question; w = sum of changes in (saturated) neighbour counts at other points */ tee = w = 0.0; if(prop.itype == BIRTH) { if(geyer->per) { /* periodic distance */ for(j=0; j 1) /* j is not saturated after addition of (u,v) */ w = w + 1; /* addition of (u,v) increases count by 1 */ else if(f > 0) /* j becomes saturated by addition of (u,v) */ w = w + f; } } } else { /* Euclidean distance */ for(j=0; j 1) /* j is not saturated after addition of (u,v) */ w = w + 1; /* addition of (u,v) increases count by 1 */ else if(f > 0) /* j becomes saturated by addition of (u,v) */ w = w + f; } } } } else if(prop.itype == DEATH) { tee = aux[ix]; if(geyer->per) { /* Periodic distance */ for(j=0; j 0) /* j is not saturated */ w = w + 1; /* deletion of 'ix' decreases count by 1 */ else { f = f+1; if(f > 0) { /* j is not saturated after deletion of 'ix' (s must be fractional) */ w = w + f; } } } } } else { /* Euclidean distance */ for(j=0; j 0) /* j was not saturated */ w = w + 1; /* deletion of 'ix' decreases count by 1 */ else { f = f+1; if(f > 0) { /* j is not saturated after deletion of 'ix' (s must be fractional) */ w = w + f; } } } } } } else if(prop.itype == SHIFT) { /* Compute the cif at the new point, not the ratio of new/old */ if(geyer->per) { /* Periodic distance */ for(j=0; j= b) w = w + 1; } } } else { /* Euclidean distance */ for(j=0; j= b) w = w + 1; } } } } w = w + ((tee < s) ? tee : s); if(geyer->hard) { if(tee > 0) cifval = 0.0; else cifval = 1.0; } else cifval = exp(geyer->loggamma*w); return cifval; } void geyerupd(State state, Propo prop, Cdata *cdata) { /* Declare other variables */ int ix, npts, j; int oldclose, newclose; double u, v, xix, yix, r2; double *x, *y; int *aux; double *period; Geyer *geyer; #ifdef MH_DEBUG int *freshaux; int i; int oc, nc; #endif DECLARE_CLOSE_VARS; geyer = (Geyer *) cdata; period = geyer->period; aux = geyer->aux; r2 = geyer->r2; x = state.x; y = state.y; npts = state.npts; #ifdef MH_DEBUG /* ........................ debugging cross-check ................ */ /* recompute 'aux' values afresh */ freshaux = geyer->freshaux; for(i = 0; i < state.npts; i++) freshaux[i] = 0; if(geyer->per) { /* periodic */ for(i = 0; i < state.npts; i++) { for(j = 0; j < state.npts; j++) { if(i == j) continue; if(CLOSE_PERIODIC(state.x[i], state.y[i], state.x[j], state.y[j], period, r2)) freshaux[i] += 1; } } } else { /* Euclidean distance */ for(i = 0; i < state.npts; i++) { for(j = 0; j < state.npts; j++) { if(i == j) continue; if(CLOSE(state.x[i], state.y[i], state.x[j], state.y[j], r2)) freshaux[i] += 1; } } } /* Check agreement with 'aux' */ for(j = 0; j < state.npts; j++) { if(aux[j] != freshaux[j]) { Rprintf("\n\taux[%d] = %d, freshaux[%d] = %d\n", j, aux[j], j, freshaux[j]); Rprintf("\tnpts = %d\n", state.npts); Rprintf("\tperiod = (%lf, %lf)\n", period[0], period[1]); if(geyer->prevtype == BIRTH) error("updaux failed after BIRTH"); if(geyer->prevtype == DEATH) error("updaux failed after DEATH"); if(geyer->prevtype == SHIFT) error("updaux failed after SHIFT"); error("updaux failed at start"); } } /* OK. Record type of this transition */ geyer->prevtype = prop.itype; /* ................ end debug cross-check ................ */ #endif if(prop.itype == BIRTH) { /* Birth */ u = prop.u; v = prop.v; /* initialise auxiliary counter for new point */ aux[npts] = 0; /* update all auxiliary counters */ if(geyer->per) { /* periodic distance */ for(j=0; j < npts; j++) { if(CLOSE_PERIODIC(u,v,x[j],y[j],period,r2)) { aux[j] += 1; aux[npts] += 1; } } } else { /* Euclidean distance */ for(j=0; j < npts; j++) { if(CLOSE(u,v,x[j],y[j],r2)) { aux[j] += 1; aux[npts] += 1; } } } } else if(prop.itype == DEATH) { /* Death */ ix = prop.ix; u = x[ix]; v = y[ix]; /* decrement auxiliary counter for each point */ if(geyer->per) { /* periodic distance */ for(j=0; j= ix) aux[j-1] = aux[j]; } } else { /* Euclidean distance */ for(j=0; j= ix) aux[j-1] = aux[j]; } } } else if(prop.itype == SHIFT) { /* Shift */ u = prop.u; v = prop.v; ix = prop.ix; xix = x[ix]; yix = y[ix]; /* recompute auxiliary counter for point 'ix' */ aux[ix] = 0; /* update auxiliary counters for other points */ if(geyer->per) { for(j=0; j #include #include "methas.h" #include "dist2.h" /* for debugging code, include #define DEBUG 1 */ /* Conditional intensity computation for Multitype Strauss hardcore process */ /* NOTE: types (marks) are numbered from 0 to ntypes-1 */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct MultiStraussHard { int ntypes; double *gamma; /* gamma[i,j] = gamma[i+ntypes*j] for i,j = 0... ntypes-1 */ double *rad; /* rad[i,j] = rad[j+ntypes*i] for i,j = 0... ntypes-1 */ double *hc; /* hc[i,j] = hc[j+ntypes*i] for i,j = 0... ntypes-1 */ double *rad2; /* squared radii */ double *hc2; /* squared radii */ double *rad2hc2; /* r^2 - h^2 */ double range2; /* square of interaction range */ double *loggamma; /* logs of gamma[i,j] */ double *period; int *hard; /* hard[i,j] = 1 if gamma[i,j] ~~ 0 */ int *kount; /* space for kounting pairs of each type */ int per; } MultiStraussHard; /* initialiser function */ Cdata *straushminit(State state, Model model, Algor algo) { int i, j, ntypes, n2, hard; double g, r, h, r2, h2, logg, range2; MultiStraussHard *multistrausshard; multistrausshard = (MultiStraussHard *) R_alloc(1, sizeof(MultiStraussHard)); multistrausshard->ntypes = ntypes = model.ntypes; n2 = ntypes * ntypes; #ifdef DEBUG Rprintf("initialising space for %d types\n", ntypes); #endif /* Allocate space for parameters */ multistrausshard->gamma = (double *) R_alloc((size_t) n2, sizeof(double)); multistrausshard->rad = (double *) R_alloc((size_t) n2, sizeof(double)); multistrausshard->hc = (double *) R_alloc((size_t) n2, sizeof(double)); /* Allocate space for transformed parameters */ multistrausshard->rad2 = (double *) R_alloc((size_t) n2, sizeof(double)); multistrausshard->hc2 = (double *) R_alloc((size_t) n2, sizeof(double)); multistrausshard->rad2hc2 = (double *) R_alloc((size_t) n2, sizeof(double)); multistrausshard->loggamma = (double *) R_alloc((size_t) n2, sizeof(double)); multistrausshard->hard = (int *) R_alloc((size_t) n2, sizeof(int)); /* Allocate scratch space for counts of each pair of types */ multistrausshard->kount = (int *) R_alloc((size_t) n2, sizeof(int)); /* Copy and process model parameters*/ /* ipar will contain n^2 values of gamma, then n^2 values of r, then n^2 values of h */ range2 = 0.0; for(i = 0; i < ntypes; i++) { for(j = 0; j < ntypes; j++) { g = model.ipar[ i + j*ntypes]; r = model.ipar[ n2 + i + j*ntypes]; h = model.ipar[2*n2 + i + j*ntypes]; r2 = r * r; h2 = h * h; hard = (g < DBL_EPSILON); logg = (hard) ? 0 : log(g); MAT(multistrausshard->gamma, i, j, ntypes) = g; MAT(multistrausshard->rad, i, j, ntypes) = r; MAT(multistrausshard->hc, i, j, ntypes) = h; MAT(multistrausshard->rad2, i, j, ntypes) = r2; MAT(multistrausshard->hc2, i, j, ntypes) = h2; MAT(multistrausshard->rad2hc2, i, j, ntypes) = r2-h2; MAT(multistrausshard->hard, i, j, ntypes) = hard; MAT(multistrausshard->loggamma, i, j, ntypes) = logg; if(r2 > range2) range2 = r2; } } multistrausshard->range2 = range2; /* periodic boundary conditions? */ multistrausshard->period = model.period; multistrausshard->per = (model.period[0] > 0.0); #ifdef DEBUG Rprintf("end initialiser\n"); #endif return((Cdata *) multistrausshard); } /* conditional intensity evaluator */ double straushmcif(Propo prop, State state, Cdata *cdata) { int npts, ntypes, kount, ix, ixp1, j, mrk, mrkj, m1, m2; int *marks; double *x, *y; double u, v, lg; double d2, cifval; double range2; double *period; MultiStraussHard *multistrausshard; DECLARE_CLOSE_D2_VARS; multistrausshard = (MultiStraussHard *) cdata; range2 = multistrausshard->range2; period = multistrausshard->period; u = prop.u; v = prop.v; mrk = prop.mrk; ix = prop.ix; x = state.x; y = state.y; marks = state.marks; npts = state.npts; #ifdef DEBUG Rprintf("computing cif: u=%lf, v=%lf, mrk=%d\n", u, v, mrk); #endif cifval = 1.0; if(npts == 0) return(cifval); ntypes = multistrausshard->ntypes; #ifdef DEBUG Rprintf("initialising pair counts\n"); #endif /* initialise pair counts */ for(m1 = 0; m1 < ntypes; m1++) for(m2 = 0; m2 < ntypes; m2++) MAT(multistrausshard->kount, m1, m2, ntypes) = 0; /* compile pair counts */ #ifdef DEBUG Rprintf("compiling pair counts\n"); #endif ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(multistrausshard->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],period,range2,d2)) { mrkj = marks[j]; if(d2 < MAT(multistrausshard->rad2, mrk, mrkj, ntypes)) { if(d2 < MAT(multistrausshard->hc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } MAT(multistrausshard->kount, mrk, mrkj, ntypes)++; } } } } if(ixp1 < npts) { for(j=ixp1; jrad2, mrk, mrkj, ntypes)) { if(d2 < MAT(multistrausshard->hc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } MAT(multistrausshard->kount, mrk, mrkj, ntypes)++; } } } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], range2, d2)) { mrkj = marks[j]; if(d2 < MAT(multistrausshard->rad2, mrk, mrkj, ntypes)) { if(d2 < MAT(multistrausshard->hc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } MAT(multistrausshard->kount, mrk, mrkj, ntypes)++; } } } } if(ixp1 < npts) { for(j=ixp1; jrad2, mrk, mrkj, ntypes)) { if(d2 < MAT(multistrausshard->hc2, mrk, mrkj, ntypes)) { cifval = 0.0; return(cifval); } MAT(multistrausshard->kount, mrk, mrkj, ntypes)++; } } } } } #ifdef DEBUG Rprintf("multiplying cif factors\n"); #endif /* multiply cif value by pair potential */ for(m1 = 0; m1 < ntypes; m1++) { for(m2 = 0; m2 < ntypes; m2++) { kount = MAT(multistrausshard->kount, m1, m2, ntypes); if(MAT(multistrausshard->hard, m1, m2, ntypes)) { if(kount > 0) { cifval = 0.0; return(cifval); } } else { lg = MAT(multistrausshard->loggamma, m1, m2, ntypes); cifval *= exp(lg * kount); } } } #ifdef DEBUG Rprintf("returning positive cif\n"); #endif return cifval; } Cifns MultiStraussHardCifns = { &straushminit, &straushmcif, (updafunptr) NULL, YES}; spatstat.random/src/proto.h0000644000176200001440000000262514567023173015514 0ustar liggesusers#include #include /* Prototype declarations for all native routines in spatstat.core package Automatically generated - do not edit! */ /* Functions invoked by .C */ void knownCif(char **, int *); /* Functions invoked by .Call */ SEXP thinjumpequal(SEXP, SEXP, SEXP); SEXP rcauchyAll(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP rcauchyOff(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP rmatclusAll(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP rmatclusOff(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP xmethas(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP xmethas(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP PerfectStrauss(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP PerfectHardcore(SEXP, SEXP, SEXP, SEXP); SEXP PerfectStraussHard(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP PerfectDiggleGratton(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP PerfectDGS(SEXP, SEXP, SEXP, SEXP); SEXP PerfectPenttinen(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP rthomasAll(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP rthomasOff(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP RrnzpoisHarding(SEXP, SEXP); SEXP RrnzpoisDalgaard(SEXP, SEXP); SEXP RrtruncpoisHarding(SEXP, SEXP, SEXP); SEXP RrtruncpoisDalgaard(SEXP, SEXP, SEXP); spatstat.random/src/yesno.h0000755000176200001440000000011614164500132015466 0ustar liggesusers/* yesno.h */ #ifndef YES #define YES (0 == 0) #define NO (!YES) #endif spatstat.random/src/Perfect.cc0000755000176200001440000005765114164500132016077 0ustar liggesusers// Debug switch // #define DBGS #include #include #include #include #include #include #include #include #include // #include // FILE *out; // File i/o is deprecated in R implementation #ifdef DBGS #define CHECK(PTR,MESSAGE) if(((void *) PTR) == ((void *) NULL)) error(MESSAGE) #define CLAMP(X, LOW, HIGH, XNAME) \ if((X) > (HIGH)) { \ Rprintf("Value of %s exceeds upper limit %d\n", XNAME, HIGH); \ X = HIGH; \ } else if((X) < (LOW)) { \ Rprintf("Value of %s is below %d\n", XNAME, LOW); \ X = LOW; \ } #else #define CHECK(PTR,MESSAGE) #define CLAMP(X, LOW, HIGH, XNAME) \ if((X) > (HIGH)) X = HIGH; else if((X) < (LOW)) X = LOW; #endif // ......................................... // memory allocation // using R_alloc #define ALLOCATE(TYPE) (TYPE *) R_alloc(1, sizeof(TYPE)) #define FREE(PTR) // Alternative using Calloc and Free // #define ALLOCATE(TYPE) (TYPE *) Calloc(1, sizeof(TYPE)) // #define FREE(PTR) Free(PTR) void R_CheckUserInterrupt(void); struct Point{ long int No; float X; float Y; float R; struct Point *next; }; struct Point2{ long int No; float X; float Y; char InLower[2]; double Beta; double TempBeta; struct Point2 *next; }; struct Point3{ char Case; char XCell; char YCell; struct Point3 *next; }; // const float Pi=3.141593; double slumptal(void){ return(runif((double) 0.0, (double) 1.0)); } long int poisson(double lambda){ return((long int)rpois(lambda)); } // ........................... Point patterns .......................... class Point2Pattern { public: long int UpperLiving[2]; long int MaxXCell, MaxYCell, NoP; double XCellDim, YCellDim, Xmin, Xmax, Ymin, Ymax; struct Point2 *headCell[10][10],*dummyCell; char DirX[10], DirY[10]; Point2Pattern(double xmin, double xmax, double ymin, double ymax, long int mxc, long int myc){ long int i,j; UpperLiving[0] = 0; UpperLiving[1] = 0; Xmin = xmin; Xmax = xmax; Ymin = ymin; Ymax = ymax; DirX[1] = 1; DirY[1] = 0; DirX[2] = 1; DirY[2] = -1; DirX[3] = 0; DirY[3] = -1; DirX[4] = -1; DirY[4] = -1; DirX[5] = -1; DirY[5] = 0; DirX[6] = -1; DirY[6] = 1; DirX[7] = 0; DirY[7] = 1; DirX[8] = 1; DirY[8] = 1; NoP = 0; // dummyCell = ALLOCATE(struct Point2); // dummyCell->next = dummyCell; dummyCell->No = 0; MaxXCell = mxc; MaxYCell = myc; if(MaxXCell>9) MaxXCell = 9; if(MaxYCell>9) MaxYCell = 9; for(i=0;i<=MaxXCell;i++){ for(j=0;j<=MaxYCell;j++){ // headCell[i][j] = ALLOCATE(struct Point2); // headCell[i][j]->next=dummyCell; } } XCellDim = (Xmax-Xmin)/((double)(MaxXCell+1)); YCellDim = (Ymax-Ymin)/((double)(MaxYCell+1)); }; ~Point2Pattern(){} // void Print(); void Return(double *X, double *Y, int *num, int maxnum); long int Count(); long int UpperCount(); void Empty(); void Clean(); // void DumpToFile(char FileName[100]); // void ReadFromFile(char FileName[100]); }; // void Point2Pattern::Print(){ // long int i,j,k; // k = 0; // struct Point2 *TempCell; // for(i=0;i<=MaxXCell;i++){ // for(j=0;j<=MaxYCell;j++){ // //Rprintf("%d %d:\n",i,j); // TempCell = headCell[i][j]->next; // CHECK(TempCell, "internal error: TempCell is null in Print()"); // while(TempCell->next != TempCell){ // k++; // Rprintf("%f %f %ld %ld %ld=%d %ld=%d UL0 %d UL1 %d %f\n", // TempCell->X,TempCell->Y,k, // TempCell->No, // i,int(TempCell->X/XCellDim), // j,int(TempCell->Y/YCellDim), // TempCell->InLower[0],TempCell->InLower[1], // TempCell->Beta); // TempCell = TempCell->next; // CHECK(TempCell, "internal error: TempCell is null in Print() loop"); // } // } // } // Rprintf("Printed %ld points.\n",k); // } void Point2Pattern::Return(double *X, double *Y, int *num, int maxnum){ long int i,j,k; k =0; *num = 0; #ifdef DBGS Rprintf("executing Return()\n"); #endif if(UpperLiving[0]<=maxnum){ struct Point2 *TempCell; for(i=0;i<=MaxXCell;i++){ for(j=0;j<=MaxYCell;j++){ #ifdef DBGS // Rprintf("%d %d:\n",i,j); #endif TempCell = headCell[i][j]->next; CHECK(TempCell, "internal error: TempCell is null in Return()"); while(TempCell->next != TempCell){ X[k] = TempCell->X; Y[k] = TempCell->Y; k++; TempCell = TempCell->next; CHECK(TempCell, "internal error: TempCell is null in Return() loop"); } } } *num = k; } else { *num = -1; } } long int Point2Pattern::Count(){ long int i,j,k; k = 0; struct Point2 *TempCell; for(i=0;i<=MaxXCell;i++){ for(j=0;j<=MaxYCell;j++){ // Rprintf("%d %d:\n",i,j); TempCell = headCell[i][j]->next; CHECK(TempCell, "internal error: TempCell is null in Count()"); while(TempCell->next != TempCell){ k++; TempCell = TempCell->next; CHECK(TempCell, "internal error: TempCell is null in Count() loop"); } } } //Rprintf("Printed %d points.\n",k); return(k); } // a quick (over)estimate of the number of points in the pattern, // for storage allocation long int Point2Pattern::UpperCount(){ return(UpperLiving[0]); } void Point2Pattern::Empty(){ struct Point2 *TempCell, *TempCell2; long int i,j; #ifdef DBGS long int k; k=0; Rprintf("executing Empty()\n"); #endif for(i=0; i<=this->MaxXCell; i++){ for(j=0; j<=this->MaxYCell; j++){ TempCell = headCell[i][j]->next; CHECK(TempCell, "internal error: TempCell is null in Empty()"); while(TempCell!=TempCell->next){ #ifdef DBGS // k++; Rprintf("%d %d %d\n",i,j,k); #endif TempCell2 = TempCell->next; FREE(TempCell); TempCell = TempCell2; CHECK(TempCell, "internal error: TempCell is null in Empty() loop"); } headCell[i][j]->next = dummyCell; } } } void Point2Pattern::Clean(){ struct Point2 *TempCell, *TempCell2; long int i,j; #ifdef DBGS Rprintf("executing Clean()\n"); #endif for(i=0; i<=MaxXCell; i++){ for(j=0; j<=MaxYCell; j++){ TempCell = headCell[i][j]; CHECK(TempCell, "internal error: TempCell is null in Clean()"); TempCell2 = headCell[i][j]->next; CHECK(TempCell2, "internal error: TempCell2 is null in Clean()"); while(TempCell2!=TempCell2->next){ TempCell2->No = 0; if(TempCell2->InLower[0]==0){ TempCell->next = TempCell2->next; FREE(TempCell2); TempCell2 = TempCell->next; CHECK(TempCell2, "internal error: TempCell2 is null in Clean() loop A"); } else{ TempCell2 = TempCell2->next; TempCell = TempCell->next; CHECK(TempCell, "internal error: TempCell is null in Clean() loop B"); CHECK(TempCell2, "internal error: TempCell2 is null in Clean() loop B"); } } } } } //void Point2Pattern::DumpToFile(char FileName[100]){ // FILE *out; // long int i,j; // out = fopen(FileName,"w"); // struct Point2 *TempCell; // for(i=0;i<=MaxXCell;i++){ // for(j=0;j<=MaxYCell;j++){ // //Rprintf("%d %d:\n",i,j); // TempCell = headCell[i][j]->next; // while(TempCell->next != TempCell){ // fprintf(out,"%f\t%f\t%ld\n", // TempCell->X,TempCell->Y,TempCell->No); // TempCell = TempCell->next; // } // } //} //fclose(out); //} //void Point2Pattern::ReadFromFile(char FileName[100]){ // FILE *out; //long int k,XCell,YCell; //float f1,xs,ys; //out = fopen(FileName,"r"); //struct Point2 *TempCell; //k=0; //while(feof(out)==0){ // k++; // fscanf(out,"%f%f\n",&xs,&ys); // //Rprintf("%f %f\n",xs,ys); // // // TempCell = ALLOCATE(struct Point2); // // // TempCell->No = k; // TempCell->X = xs; // TempCell->Y = ys; // TempCell->InLower[0] = 1; // TempCell->InLower[1] = 1; // // f1 = (xs-Xmin)/XCellDim; XCell = int(f1); // if(XCell>MaxXCell) XCell = MaxXCell; // f1 = (ys-Ymin)/YCellDim; YCell = int(f1); // if(YCell>MaxYCell) YCell = MaxYCell; // // TempCell->next = headCell[XCell][YCell]->next; // headCell[XCell][YCell]->next = TempCell; // //} //fclose(out); //Rprintf("%ld points loaded.\n",k); // //} // ........................... Point processes .......................... // ...................... (stationary, pairwise interaction) ............ class PointProcess { public: double Xmin, Xmax, Ymin, Ymax, TotalBirthRate, InteractionRange; PointProcess(double xmin, double xmax, double ymin, double ymax){ Xmin = xmin; Xmax = xmax; Ymin = ymin; Ymax = ymax; } virtual ~PointProcess(){} virtual void NewEvent(double *x, double *y, char *InWindow)=0; virtual void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP)=0; virtual double Interaction(double dsquared)=0; // virtual void CalcBeta(long int xsidepomm, long int ysidepomm, // double *betapomm){ // Rprintf("Define CalcBeta...\n"); // } // virtual void CheckBeta(long int xsidepomm, long int ysidepomm, // double *betapomm){ //Rprintf("Define CheckBeta...\n"); //} // virtual double lnCondInt(struct Point2 *TempCell, Point2Pattern *p2p) //{ return(0.0);}; // virtual double lnDens(Point2Pattern *p2p); // virtual void Beta(struct Point2 *TempCell){ // TempCell->Beta = 0; // Rprintf("Define Beta...\n");}; }; //double PointProcess::lnDens(Point2Pattern *p2p){ //// double f1; //long int xco,yco,xc,yc,fx,tx,fy,ty,ry,rx; //double dy,dx, lnDens,dst2; //struct Point2 *TempCell, *TempCell2; // //dx = (Xmax-Xmin)/(double(p2p->MaxXCell+1)); //dy = (Ymax-Ymin)/(double(p2p->MaxYCell+1)); //rx = int(InteractionRange/dx+1.0); //ry = int(InteractionRange/dy+1.0); // // //Rprintf("1:%f 2:%f 3:%d 4:%d 5:%f 6:%f\n",dx,dy,rx,ry, // // this->InteractionRange,InteractionRange); // //Rprintf("mx:%d my:%d\n",p2p->MaxXCell,p2p->MaxYCell); // // lnDens = 0; // // //Rprintf("lnDens: %f (0)\n",lnDens); // // for(xc = 0; xc <= p2p->MaxXCell; xc++){ // for(yc = 0; yc <= p2p->MaxYCell; yc++){ // //if(xc==1) Rprintf("%d %d\n",xc,yc); // CHECK(p2p->headCell[xc][yc], // "internal error: p2p->headCell[xc][yc] is null in lnDens()"); // TempCell = p2p->headCell[xc][yc]->next; // CHECK(TempCell, "internal error: TempCell is null in lnDens()"); // while(TempCell != TempCell->next){ // lnDens += log(TempCell->Beta); // //Rprintf("lnDens: %f (1) %d %d %d %d Beta %f\n",lnDens,xc,yc, // // p2p->MaxXCell,p2p->MaxYCell,TempCell->Beta); // //if(lnDens<(-100000)){Rprintf("%f",lnDens); scanf("%f",&f1);} // if(InteractionRange>0){ // if((xc+rx)<=p2p->MaxXCell) tx=xc+rx; else tx = p2p->MaxXCell; // if((yc+ry)<=p2p->MaxYCell) ty=yc+ry; else ty = p2p->MaxYCell; // if((xc-rx)>=0) fx=xc-rx; else fx = 0; // if((yc-ry)>=0) fy=yc-ry; else fy = 0; // for(xco = fx; xco <= tx; xco++){ // for(yco = fy; yco <= ty; yco++){ // //if(xc==1) Rprintf("%d %d %d %d %d %d\n",xco,yco,fx,tx,fy,ty); // CHECK(p2p->headCell[xco][yco], // "internal error: p2p->headCell[xco][yco] is null in lnDens() loop"); // TempCell2 = p2p->headCell[xco][yco]->next; // CHECK(TempCell2, // "internal error: TempCell2 is null in lnDens() loop A"); // while(TempCell2!=TempCell2->next){ // if(TempCell2 != TempCell){ // dst2 = pow(TempCell->X-TempCell2->X,2)+ // pow(TempCell->Y-TempCell2->Y,2); // lnDens += log(Interaction(dst2)); // } // TempCell2 = TempCell2->next; // CHECK(TempCell2, // "internal error: TempCell2 is null in lnDens() loop B"); // } // } // } // //Rprintf("lnDens: %f\n",lnDens); // } // TempCell = TempCell->next; // CHECK(TempCell, // "internal error: TempCell is null in lnDens() at end"); // } // } // } // return(lnDens); // //} // ........................... Sampler .......................... class Sampler{ public: PointProcess *PP; Point2Pattern *P2P; long int GeneratedPoints, LivingPoints, NoP; //long int UpperLiving[2]; Sampler(PointProcess *p){ PP = p;} ~Sampler(){} void Sim(Point2Pattern *p2p, long int *ST, long int *ET); long int BirthDeath(long int TimeStep, struct Point *headLiving, struct Point *headDeleted, struct Point3 *headTransition); // WAS: Sampler::Forward void Forward(long int TS, long int TT, char TX, char TY, struct Point *Proposal, long int *DDD); }; void Sampler::Forward(long int TS, long int TT, char TX, char TY, struct Point *Proposal, long int *DDD){ long int XCell, YCell, DirectionN; double dtmp2,dtmpx,dtmpy, tmpR, TempGamma[2], TempI; struct Point2 *TempCell, *TempCell2; float f1; /* Birth */ if(TT==1){ f1 = (Proposal->X-P2P->Xmin)/P2P->XCellDim; XCell = int(f1); CLAMP(XCell, 0, P2P->MaxXCell, "XCell"); f1 = (Proposal->Y-P2P->Ymin)/P2P->YCellDim; YCell = int(f1); CLAMP(YCell, 0, P2P->MaxYCell, "YCell"); // TempCell = ALLOCATE(struct Point2); // TempCell->No = Proposal->No; TempCell->X = Proposal->X; TempCell->Y = Proposal->Y; tmpR = Proposal->R; TempCell->next = P2P->headCell[XCell][YCell]->next; P2P->headCell[XCell][YCell]->next = TempCell; TempCell->InLower[0]=0; TempCell->InLower[1]=0; TempGamma[0] = 1.0; TempGamma[1] = 1.0; /*same cell*/ TempCell2 = TempCell->next; CHECK(TempCell2, "internal error: TempCell2 is null in Forward() birth case"); while(TempCell2 != TempCell2->next){ dtmpx = TempCell->X - TempCell2->X; dtmpy = TempCell->Y - TempCell2->Y; dtmp2 = dtmpx*dtmpx+dtmpy*dtmpy; TempI = PP->Interaction(dtmp2); if(TempCell2->InLower[0]==1) TempGamma[0] = TempGamma[0]*TempI; if(TempCell2->InLower[1]==1) TempGamma[1] = TempGamma[1]*TempI; TempCell2=TempCell2->next; CHECK(TempCell2, "internal error: TempCell2 is null in Forward() birth case loop"); } /*eight other cells*/ for(DirectionN=1;DirectionN<=8;DirectionN++){ if(((XCell+P2P->DirX[DirectionN])>=0) && ((XCell+P2P->DirX[DirectionN])<=P2P->MaxXCell) && ((YCell+P2P->DirY[DirectionN])>=0) && ((YCell+P2P->DirY[DirectionN])<=P2P->MaxYCell)){ CHECK(P2P->headCell[XCell+P2P->DirX[DirectionN]][YCell+P2P->DirY[DirectionN]], "internal error: HUGE P2P EXPRESSION is null in Forward() birth case loop A"); TempCell2 = P2P->headCell[XCell+P2P->DirX[DirectionN]] [YCell+P2P->DirY[DirectionN]]->next; CHECK(TempCell2, "internal error: TempCell2 is null in Forward() birth case loop B"); while(TempCell2!=TempCell2->next){ dtmpx = TempCell->X - TempCell2->X; dtmpy = TempCell->Y - TempCell2->Y; dtmp2 = dtmpx*dtmpx+dtmpy*dtmpy; TempI = PP->Interaction(dtmp2); if(TempCell2->InLower[0]==1) TempGamma[0] = TempGamma[0]*TempI; if(TempCell2->InLower[1]==1) TempGamma[1] = TempGamma[1]*TempI; TempCell2=TempCell2->next; CHECK(TempCell2, "internal error: TempCell2 is null in Forward() birth case loop C"); } } } if(tmpR <= TempGamma[1] ){ TempCell->InLower[0]=1; P2P->UpperLiving[0] = P2P->UpperLiving[0] +1; } if(tmpR <= TempGamma[0] ){ TempCell->InLower[1]=1; P2P->UpperLiving[1] = P2P->UpperLiving[1] +1; } } /* Death */ if(TT==0){ TempCell=P2P->headCell[(int)TX][(int)TY]; CHECK(TempCell, "internal error: TempCell is null in Forward() death case"); while(TempCell->next->No != *DDD){ TempCell = TempCell->next; CHECK(TempCell, "internal error: TempCell is null in Forward() death case loop"); if(TempCell->next == TempCell) { // Rprintf("internal error: unexpected self-reference. Dumping...\n"); // P2P->Print(); error("internal error: unexpected self-reference"); break; } }; CHECK(TempCell->next, "internal error: TempCell->next is null in Forward() death case"); if(*DDD!=TempCell->next->No) Rprintf("diagnostic message: multi cell: !!DDD:%ld TempUpper->No:%ld ", *DDD,TempCell->No); if(TempCell->next->InLower[0]==1) P2P->UpperLiving[0] = P2P->UpperLiving[0] -1; if(TempCell->next->InLower[1]==1) P2P->UpperLiving[1] = P2P->UpperLiving[1] -1; TempCell2 = TempCell->next; CHECK(TempCell2, "internal error: TempCell2 is null in Forward() death case B"); TempCell->next = TempCell2->next; FREE(TempCell2); /* Common stuff */ //KillCounter ++; *DDD = *DDD - 1; } } long int Sampler::BirthDeath(long int TimeStep, struct Point *headLiving, struct Point *headDeleted, struct Point3 *headTransition){ long int i,n; float f1,f2,f3,f4; double xtemp,ytemp; char InWindow, Success; struct Point *TempPoint, *TempPoint2; struct Point3 *TempTransition; R_CheckUserInterrupt(); f1 = LivingPoints; f2 = PP->TotalBirthRate; f3 = f2/(f1+f2); f4 = slumptal(); n = 0; Success = 0; //Rprintf("LivingPoints: %d TotalBirthRate %f GeneratedPoints %d\n", // LivingPoints,PP->TotalBirthRate,GeneratedPoints); /* Birth */ while(Success==0){ if(f4NewEvent(&xtemp, &ytemp, &InWindow); //Rprintf("Ping 2 (BD)\n"); if(InWindow==1){ Success = 1; // TempTransition = ALLOCATE(struct Point3); // //Rprintf("Ping 3 (BD)\n"); TempTransition->Case = 0; LivingPoints ++; GeneratedPoints ++; // TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = GeneratedPoints; TempPoint->R = slumptal(); TempPoint->next = headLiving->next; headLiving->next = TempPoint; NoP ++; f1 = (TempPoint->X-P2P->Xmin)/P2P->XCellDim; TempTransition->XCell = int(f1); f1 = (TempPoint->Y-P2P->Ymin)/P2P->YCellDim; TempTransition->YCell = int(f1); //Rprintf("X %f XCell %d\n",TempPoint->X,TempTransition->XCell); // CLAMP(TempTransition->XCell, 0, P2P->MaxXCell, "TempTransition->XCell"); CLAMP(TempTransition->YCell, 0, P2P->MaxYCell, "TempTransition->YCell"); TempTransition->next = headTransition->next; headTransition->next = TempTransition; } } /* Death */ else{ Success = 1; // TempTransition = ALLOCATE(struct Point3); // TempTransition->Case = 1; f1 = LivingPoints; f2 = f1*slumptal()+1.0; n = int(f2); if(n < 1) n = 1; if(n>LivingPoints){ // Rprintf("diagnostic message: random integer n=%ld > %ld = number of living points\n", n,LivingPoints); n=LivingPoints; } TempPoint2 = TempPoint = headLiving; for(i=1; i<=n; i++){ TempPoint2 = TempPoint; TempPoint = TempPoint->next; } TempPoint2->next = TempPoint->next; TempPoint->next = headDeleted->next; headDeleted->next = TempPoint; LivingPoints --; NoP --; TempTransition->next = headTransition->next; headTransition->next = TempTransition; } } return(n); } void Sampler::Sim(Point2Pattern *p2p, long int *ST, long int *ET) { P2P = p2p; long int StartTime, EndTime, TimeStep, D0Time, D0Living; long int XCell, YCell, DDD, i; float f1; /* Initialising linked listed for backward simulation */ struct Point *headDeleted, *headLiving, *dummyDeleted, *dummyLiving; struct Point *TempPoint; // headLiving = ALLOCATE(struct Point); dummyLiving = ALLOCATE(struct Point); // headLiving->next = dummyLiving; dummyLiving->next = dummyLiving; // headDeleted = ALLOCATE(struct Point); dummyDeleted = ALLOCATE(struct Point); // headDeleted->next = dummyDeleted; dummyDeleted->next = dummyDeleted; struct Point2 *TempCell2; struct Point3 *headTransition, *dummyTransition; // headTransition = ALLOCATE(struct Point3); dummyTransition = ALLOCATE(struct Point3); // headTransition->next = dummyTransition; dummyTransition->next = dummyTransition; PP->GeneratePoisson(headLiving, &GeneratedPoints, &LivingPoints, &NoP); StartTime=1; EndTime=1; TimeStep = 0; D0Time = 0; D0Living = GeneratedPoints; long int tmp, D0; do{ tmp=BirthDeath(TimeStep, headLiving, headDeleted, headTransition); if(tmp>0){ if(tmp>(LivingPoints+1-D0Living)){ D0Living --; } } D0Time++; }while(D0Living>0); tmp=BirthDeath(TimeStep, headLiving, headDeleted, headTransition); StartTime=1; EndTime=D0Time+1; D0 = 0; do{ if(D0==1){ for(TimeStep=StartTime;TimeStep<=EndTime;TimeStep ++){ tmp=BirthDeath(TimeStep, headLiving, headDeleted, headTransition); } } D0 = 1; P2P->Empty(); /* headUpper->next = dummyUpper; dummyUpper->next = dummyUpper; for(XCell=0;XCell<=P2P->MaxXCell;XCell++){ for(YCell=0;YCell<=P2P->MaxYCell;YCell++){ headUpperCell[XCell][YCell]->next=dummyUpper; } } */ P2P->UpperLiving[0] = LivingPoints; P2P->UpperLiving[1] = 0; P2P->NoP = 0; i=0; TempPoint = headLiving->next; CHECK(TempPoint, "internal error: TempPoint is null in Sim()"); while(TempPoint!=TempPoint->next){ i++; // TempCell2 = ALLOCATE(struct Point2); // TempCell2->No = TempPoint->No; TempCell2->X = TempPoint->X; TempCell2->Y = TempPoint->Y; TempCell2->InLower[0] = 1; TempCell2->InLower[1] = 0; f1 = (TempPoint->X-P2P->Xmin)/P2P->XCellDim; XCell = int(floor(f1)); CLAMP(XCell, 0, P2P->MaxXCell, "XCell"); f1 = (TempPoint->Y-P2P->Ymin)/P2P->YCellDim; YCell = int(floor(f1)); CLAMP(YCell, 0, P2P->MaxYCell, "YCell"); TempCell2->next = P2P->headCell[XCell][YCell]->next; P2P->headCell[XCell][YCell]->next = TempCell2; TempPoint = TempPoint->next; CHECK(TempPoint, "internal error: TempPoint is null in Sim() loop"); } //P2P->DumpToFile("temp0.dat"); struct Point3 *TempTransition; struct Point *Proposal; TempTransition = headTransition->next; CHECK(TempTransition, "internal error: TempTransition is null in Sim()"); Proposal = headDeleted->next; DDD = GeneratedPoints; for(TimeStep=EndTime;TimeStep>=1;TimeStep--){ R_CheckUserInterrupt(); Forward(TimeStep,TempTransition->Case, TempTransition->XCell,TempTransition->YCell, Proposal,&DDD); if(TempTransition->Case == 1) Proposal = Proposal ->next; TempTransition = TempTransition->next; CHECK(TempTransition, "internal error: TempTransition is null in Sim() loop"); } /* Doubling strategy used!*/ StartTime = EndTime+1; EndTime=EndTime*2; //P2P->DumpToFile("temp.dat"); }while(P2P->UpperLiving[0]!=P2P->UpperLiving[1]); P2P->Clean(); i=0; struct Point *TempPoint2; TempPoint = headLiving; TempPoint2 = headLiving->next; CHECK(TempPoint2, "internal error: TempPoint2 is null in Sim() position B"); while(TempPoint!=TempPoint->next){ i++; FREE(TempPoint); TempPoint = TempPoint2; TempPoint2 = TempPoint2->next; CHECK(TempPoint2, "internal error: TempPoint2 is null in Sim() loop C"); } FREE(TempPoint); i = 0; TempPoint = headDeleted; TempPoint2 = headDeleted->next; CHECK(TempPoint2, "internal error: TempPoint2 is null in Sim() position D"); while(TempPoint!=TempPoint->next){ i++; FREE(TempPoint); TempPoint = TempPoint2; TempPoint2 = TempPoint2->next; CHECK(TempPoint2, "internal error: TempPoint2 is null in Sim() loop D"); } FREE(TempPoint); //Rprintf("%d ",i); struct Point3 *TempTransition,*TempTransition2; i = 0; TempTransition = headTransition; TempTransition2 = headTransition->next; CHECK(TempTransition2, "internal error: TempTransition2 is null in Sim() position E"); while(TempTransition!=TempTransition->next){ i++; FREE(TempTransition); TempTransition = TempTransition2; TempTransition2 = TempTransition2->next; CHECK(TempTransition2, "internal error: TempTransition2 is null in Sim() loop F"); } FREE(TempTransition); //Rprintf("%d ST: %d ET: %d\n",i,StartTime,EndTime); //scanf("%f",&f1); *ST = StartTime; *ET = EndTime; } #include "PerfectStrauss.h" #include "PerfectStraussHard.h" #include "PerfectHardcore.h" #include "PerfectDiggleGratton.h" #include "PerfectDGS.h" #include "PerfectPenttinen.h" spatstat.random/src/PerfectDGS.h0000755000176200001440000001166114325152137016275 0ustar liggesusers // ........................... Diggle-Gates-Stibbard process ................ // $Revision: 1.5 $ $Date: 2020/05/12 03:31:12 $ #ifndef PI #define PI 3.14159265358979 #endif class DgsProcess : public PointProcess { public: double beta, rho, rhosquared; DgsProcess(double xmin, double xmax, double ymin, double ymax, double b, double r); ~DgsProcess(){} void NewEvent(double *x, double *y, char *InWindow); void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP); double Interaction(double dsquared); }; DgsProcess::DgsProcess(double xmin, double xmax, double ymin, double ymax, double b, double r) : PointProcess(xmin, xmax, ymin, ymax){ beta = b; rho = r; rhosquared = rho * rho; InteractionRange = rho; TotalBirthRate = beta*(xmax-xmin)*(ymax-ymin); } double DgsProcess::Interaction(double dsquared) { double rtn, dist, t; rtn = 1; if(dsquared < rhosquared) { dist = sqrt(dsquared); t = sin((PI/2) * dist/rho); rtn = t * t; } return(rtn); } void DgsProcess::NewEvent(double *x, double *y, char *InWindow) { double Xdim, Ydim; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; *x = slumptal()*Xdim+Xmin; *y = slumptal()*Ydim+Ymin; *InWindow = 1; } void DgsProcess::GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP) { int i; double xtemp, ytemp, L, Xdim, Ydim; struct Point *TempPoint; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; L = beta*Xdim*Ydim; *GeneratedPoints = poisson(L); *LivingPoints = *GeneratedPoints; for (i=1; i<=*GeneratedPoints ; i++){ //Rprintf("Generating DgsProcess Poisson 3\n"); //scanf("%f",&f1); xtemp = slumptal()*Xdim+Xmin; ytemp = slumptal()*Ydim+Ymin; // //Rprintf("Generating DgsProcess Poisson 3.2\n"); TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = i; TempPoint->R = slumptal(); //Rprintf("Generating DgsProcess Poisson 3.6\n"); TempPoint->next = headPoint->next; headPoint->next = TempPoint; *NoP = *NoP + 1; } } // ........................... Interface to R .......................... extern "C" { SEXP PerfectDGS(SEXP beta, SEXP rho, SEXP xrange, SEXP yrange) { // input parameters double Beta, Rho, Xmin, Xmax, Ymin, Ymax; double *Xrange, *Yrange; // internal int xcells, ycells; long int StartTime, EndTime; // output int noutmax; SEXP xout, yout, nout, out; double *xx, *yy; int *nn; // protect arguments from garbage collector PROTECT(beta = AS_NUMERIC(beta)); PROTECT(rho = AS_NUMERIC(rho)); PROTECT(xrange = AS_NUMERIC(xrange)); PROTECT(yrange = AS_NUMERIC(yrange)); // that's 4 protected objects // extract arguments // model parameters Beta = *(NUMERIC_POINTER(beta)); Rho = *(NUMERIC_POINTER(rho)); // window Xrange = NUMERIC_POINTER(xrange); Xmin = Xrange[0]; Xmax = Xrange[1]; Yrange = NUMERIC_POINTER(yrange); Ymin = Yrange[0]; Ymax = Yrange[1]; // compute cell array size xcells = (int) floor((Xmax-Xmin)/ Rho); if(xcells > 9) { xcells = 9; } else if(xcells < 1) { xcells = 1; } ycells = (int) floor((Ymax-Ymin)/ Rho); if(ycells > 9) { ycells = 9; } else if(ycells < 1) { ycells = 1; } #ifdef DBGS Rprintf("xcells %d ycells %d\n",xcells,ycells); Rprintf("Initialising\n"); #endif // Initialise Diggle-Gates-Stibbard point process DgsProcess ExampleProcess(Xmin,Xmax,Ymin,Ymax,Beta,Rho); // Initialise point pattern Point2Pattern ExamplePattern(Xmin,Xmax,Ymin,Ymax, xcells, ycells); // parameters: min x, max x, min y, max y, "cells" in x and y direction // used for speeding up neighbour counting, 9 is max here #ifdef DBGS Rprintf("Initialisation complete\n"); #endif // Synchronise random number generator GetRNGstate(); // Initialise perfect sampler Sampler PerfectSampler(&ExampleProcess); // Perform perfect sampling PerfectSampler.Sim(&ExamplePattern, &StartTime, &EndTime); // Synchronise random number generator PutRNGstate(); // Get upper estimate of number of points noutmax = ExamplePattern.UpperCount() + 1; // Allocate space for output PROTECT(xout = NEW_NUMERIC(noutmax)); PROTECT(yout = NEW_NUMERIC(noutmax)); PROTECT(nout = NEW_INTEGER(1)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); nn = INTEGER_POINTER(nout); // copy data into output storage ExamplePattern.Return(xx, yy, nn, noutmax); // pack up into output list PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, nout); // return UNPROTECT(8); // 4 arguments plus xout, yout, nout, out return(out); } } spatstat.random/src/badgey.c0000755000176200001440000003115514531531170015572 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" /* To get debug output, insert the line: #define DEBUG 1 */ /* Conditional intensity function for a multiscale saturation process. parameter vector: ipar[0] = ndisc ipar[1] = gamma[0] ipar[2] = r[0] ipar[3] = s[0] ... */ typedef struct BadGey { /* model parameters */ int ndisc; double *gamma; double *r; double *s; /* transformations of the parameters */ double *r2; double *loggamma; int *hard; /* periodic distance */ double *period; int per; /* auxiliary counts */ int *aux; /* matrix[ndisc, npmax]: neighbour counts in current state */ int *tee; /* vector[ndisc] : neighbour count at point in question */ double *w; /* vector[ndisc] : sum of changes in counts at other points */ } BadGey; Cdata *badgeyinit(State state, Model model, Algor algo) { int i, j, k, i0, ndisc, nmatrix; double r, g, d2; BadGey *badgey; /* create storage */ badgey = (BadGey *) R_alloc(1, sizeof(BadGey)); badgey->ndisc = ndisc = model.ipar[0]; /* Allocate space for parameter vectors */ badgey->gamma = (double *) R_alloc((size_t) ndisc, sizeof(double)); badgey->r = (double *) R_alloc((size_t) ndisc, sizeof(double)); badgey->s = (double *) R_alloc((size_t) ndisc, sizeof(double)); /* Derived values */ badgey->r2 = (double *) R_alloc((size_t) ndisc, sizeof(double)); badgey->loggamma = (double *) R_alloc((size_t) ndisc, sizeof(double)); badgey->hard = (int *) R_alloc((size_t) ndisc, sizeof(int)); /* copy and transform parameters */ for(i=0; i < ndisc; i++) { i0 = 3*i + 1; g = badgey->gamma[i] = model.ipar[i0]; r = badgey->r[i] = model.ipar[i0 + 1]; badgey->s[i] = model.ipar[i0 + 2]; badgey->r2[i] = r * r; badgey->hard[i] = (g < DBL_EPSILON); badgey->loggamma[i] = (g < DBL_EPSILON) ? 0 : log(g); } /* periodic boundary conditions? */ badgey->period = model.period; badgey->per = (model.period[0] > 0.0); /* Allocate scratch space */ badgey->tee = (int *) R_alloc((size_t) ndisc, sizeof(int)); badgey->w = (double *) R_alloc((size_t) ndisc, sizeof(double)); /* Allocate space for auxiliary counts */ nmatrix = ndisc * state.npmax; badgey->aux = (int *) R_alloc((size_t) nmatrix, sizeof(int)); /* Initialise auxiliary counts */ for(i = 0; i < nmatrix; i++) badgey->aux[i] = 0; for(i = 0; i < state.npts; i++) { for(j = 0; j < state.npts; j++) { if(j == i) continue; d2 = dist2either(state.x[i], state.y[i], state.x[j], state.y[j], badgey->period); for(k = 0; k < ndisc; k++) { if(d2 < badgey->r2[k]) MAT(badgey->aux, k, i, ndisc) += 1; } } } #ifdef DEBUG Rprintf("Finished initialiser; ndisc=%d\n", ndisc); #endif return((Cdata *) badgey); } #define AUX(I,J) MAT(aux, I, J, ndisc) double badgeycif(Propo prop, State state, Cdata *cdata) { int ix, j, k, npts, ndisc, tk; double u, v, d2; double a, dd2, b, f, r2, s, cifval; double *x, *y; int *tee, *aux; double *w; BadGey *badgey; badgey = (BadGey *) cdata; #ifdef DEBUG Rprintf("Entering badgeycif\n"); #endif npts = state.npts; cifval = 1.0; if(npts==0) return cifval; x = state.x; y = state.y; u = prop.u; v = prop.v; ix = prop.ix; ndisc = badgey->ndisc; tee = badgey->tee; aux = badgey->aux; w = badgey->w; /* For disc k, tee[k] = neighbour count at the point in question; w[k] = sum of changes in (saturated) neighbour counts at other points */ if(prop.itype == BIRTH) { /* compute tee[k] and w[k] from scratch */ for(k = 0; k < ndisc; k++) { tee[k] = 0; w[k] = 0.0; } if(badgey->per) { /* periodic distance */ for(j=0; jperiod); for(k = 0; k < ndisc; k++) { if(d2 < badgey->r2[k]) { tee[k]++; f = badgey->s[k] - AUX(k,j); if(f > 1) /* j is not saturated after addition of (u,v) */ w[k] += 1; /* addition of (u,v) increases count by 1 */ else if(f > 0) /* j becomes saturated by addition of (u,v) */ w[k] += f; } } } } else { /* Euclidean distance */ for(j=0; jr2[k]) { tee[k]++; f = badgey->s[k] - AUX(k,j); if(f > 1) /* j is not saturated after addition of (u,v) */ w[k] += 1; /* addition of (u,v) increases count by 1 */ else if(f > 0) /* j becomes saturated by addition of (u,v) */ w[k] += f; } } } } } else if(prop.itype == DEATH) { /* extract current auxiliary counts for point ix */ /* compute w[k] from scratch */ for(k = 0; k < ndisc; k++) { tee[k] = AUX(k,ix); w[k] = 0.0; } /* compute change in counts for other points */ if(badgey->per) { /* Periodic distance */ for(j=0; jperiod); for(k = 0; k < ndisc; k++) { if(d2 < badgey->r2[k]) { f = badgey->s[k] - AUX(k,j); if(f > 0) /* j is not saturated */ w[k] += 1; /* deletion of 'ix' decreases count by 1 */ else { f += 1; if(f > 0) { /* j is not saturated after deletion of 'ix' (s must be fractional) */ w[k] += f; } } } } } } else { /* Euclidean distance */ for(j=0; jr2[k]) { f = badgey->s[k] - AUX(k,j); if(f > 0) /* j is not saturated */ w[k] += 1; /* deletion of 'ix' decreases count by 1 */ else { f += 1; if(f > 0) { /* j is not saturated after deletion of 'ix' (s must be fractional) */ w[k] += f; } } } } } } } else if(prop.itype == SHIFT) { /* compute auxiliary counts from scratch */ for(k = 0; k < ndisc; k++) { tee[k] = 0; w[k] = 0.0; } /* Compute the cif at the new point, not the ratio of new/old */ if(badgey->per) { /* periodic distance */ for(j=0; jperiod); for(k = 0; k < ndisc; k++) { r2 = badgey->r2[k]; if(d2 < r2) { /* shifted point is a neighbour of point j */ tee[k]++; a = AUX(k,j); s = badgey->s[k]; /* Adjust */ dd2 = dist2(x[ix],y[ix], x[j],y[j],badgey->period); if(dd2 < r2) a -= 1; b = a + 1; /* b is the number of neighbours of point j in new state */ if(a < s && s < b) { w[k] += s - a; /* s is fractional and j is saturated */ } else if(s >= b) w[k] += 1; } } } } else { /* Euclidean distance */ for(j=0; jr2[k]; if(d2 < r2) { /* shifted point is a neighbour of point j */ tee[k]++; a = AUX(k,j); s = badgey->s[k]; /* Adjust */ dd2 = pow(x[ix] - x[j], 2) + pow(y[ix] - y[j], 2); if(dd2 < r2) a -= 1; b = a + 1; /* b is the number of neighbours of point j in new state */ if(a < s && s < b) { w[k] += s - a; /* s is fractional and j is saturated */ } else if(s >= b) w[k] += 1; } } } } } #ifdef DEBUG Rprintf("ndisc=%d\n", ndisc); #endif /* compute total change in saturated count */ for(k = 0; k < ndisc; k++) { s = badgey->s[k]; tk = tee[k]; w[k] += ((tk < s) ? tk : s); #ifdef DEBUG Rprintf("s[%d]=%lf, t[%d]=%d, w[%d]=%lf\n", k, s, k, tk, k, w[k]); #endif } /* evaluate cif */ for(k = 0; k < ndisc; k++) { if(badgey->hard[k]) { if(tee[k] > 0) return(0.0); /* else cifval multiplied by 0^0 = 1 */ } else cifval *= exp(badgey->loggamma[k] * w[k]); } return cifval; } void badgeyupd(State state, Propo prop, Cdata *cdata) { /* Declare other variables */ int ix, npts, ndisc, j, k; double u, v, xix, yix, r2, d2, d2old, d2new; double *x, *y; int *aux; BadGey *badgey; badgey = (BadGey *) cdata; aux = badgey->aux; /* 'state' is current state before transition */ x = state.x; y = state.y; npts = state.npts; ndisc = badgey->ndisc; #ifdef DEBUG Rprintf("start update ---- \n"); for(j=0; j < npts; j++) { for(k=0; k < ndisc; k++) Rprintf("aux[%d,%d]=%d\t", k, j, AUX(k,j)); Rprintf("\n"); } #endif if(prop.itype == BIRTH) { #ifdef DEBUG Rprintf("Update for birth ---- \n"); #endif /* Birth */ u = prop.u; v = prop.v; /* initialise auxiliary counters for new point x[npts], y[npts] */ for(k = 0; k < ndisc; k++) AUX(k, npts) = 0; /* update all auxiliary counters */ if(badgey->per) { /* periodic distance */ for(j=0; j < npts; j++) { d2 = dist2(u,v,x[j],y[j],badgey->period); for(k = 0; k < ndisc; k++) { if(d2 < badgey->r2[k]) { AUX(k, j) += 1; AUX(k, npts) += 1; } } } } else { /* Euclidean distance */ for(j=0; j < npts; j++) { d2 = pow(u - x[j], 2) + pow(v - y[j], 2); for(k = 0; k < ndisc; k++) { if(d2 < badgey->r2[k]) { AUX( k, j) += 1; AUX( k, npts) += 1; } } } } #ifdef DEBUG Rprintf("end update ---- \n"); for(j=0; j <= npts; j++) { for(k=0; k < ndisc; k++) Rprintf("aux[%d,%d]=%d\t", k, j, AUX(k,j)); Rprintf("\n"); } #endif return; } if(prop.itype == DEATH) { /* Death */ ix = prop.ix; u = x[ix]; v = y[ix]; #ifdef DEBUG Rprintf("--- Update for death of point %d = (%lf,%lf) ---- \n", ix, u, v); #endif /* Decrement auxiliary counter for each neighbour of deleted point, and remove entry corresponding to deleted point */ if(badgey->per) { /* periodic distance */ for(j=0; jperiod); for(k = 0; k < ndisc; k++) { if(d2 < badgey->r2[k]) { if(j < ix) AUX(k,j) -= 1; else AUX(k,j-1) = AUX(k,j) - 1; } else if(j >= ix) AUX(k,j-1) = AUX(k,j); } } } else { /* Euclidean distance */ for(j=0; jr2[k]) { #ifdef DEBUG Rprintf("hit for point %d with radius r[%d]\n", j, k); #endif if(j < ix) AUX(k,j) -= 1; else AUX(k,j-1) = AUX(k,j) - 1; } else if(j >= ix) AUX(k,j-1) = AUX(k,j); } } } #ifdef DEBUG Rprintf("end update ---- \n"); for(j=0; j < npts-1; j++) { for(k=0; k < ndisc; k++) Rprintf("aux[%d,%d]=%d\t", k, j, AUX(k,j)); Rprintf("\n"); } #endif return; } if(prop.itype == SHIFT) { #ifdef DEBUG Rprintf("Update for shift ---- \n"); #endif /* Shift */ u = prop.u; v = prop.v; ix = prop.ix; xix = x[ix]; yix = y[ix]; /* recompute all auxiliary counters for point ix */ for(k = 0; k < ndisc; k++) AUX(k,ix) = 0; if(badgey->per) { for(j=0; jperiod); d2old = dist2(xix,yix,x[j],y[j],badgey->period); for(k = 0; k < ndisc; k++) { r2 = badgey->r2[k]; if(d2old >= r2 && d2new >= r2) continue; if(d2new < r2) { /* increment neighbour count for new point */ AUX(k,ix) += 1; if(d2old >= r2) AUX(k,j) += 1; /* point j gains a new neighbour */ } else if(d2old < r2) AUX(k,j) -= 1; /* point j loses a neighbour */ } } } else { /* Euclidean distance */ for(j=0; jr2[k]; if(d2old >= r2 && d2new >= r2) continue; if(d2new < r2) { #ifdef DEBUG Rprintf("shifted point is close to j=%d\n", j); #endif /* increment neighbour count for new point */ AUX(k,ix) += 1; if(d2old >= r2) { #ifdef DEBUG Rprintf("\t(previous position was not)\n"); #endif AUX(k,j) += 1; /* point j gains a new neighbour */ } } else if(d2old < r2) { #ifdef DEBUG Rprintf("previous position was close to j=%d, shifted point is not\n", j); #endif AUX(k,j) -= 1; /* point j loses a neighbour */ } } } } #ifdef DEBUG Rprintf("end update ---- \n"); for(j=0; j < npts; j++) { for(k=0; k < ndisc; k++) Rprintf("aux[%d,%d]=%d\t", k, j, AUX(k,j)); Rprintf("\n"); } #endif return; } error("Unrecognised transition type; bailing out.\n"); } Cifns BadGeyCifns = { &badgeyinit, &badgeycif, &badgeyupd, NO}; spatstat.random/src/rmatclus.h0000644000176200001440000002430514364101623016172 0ustar liggesusers/* rmatclus.h $Revision: 1.3 $ $Date: 2023/01/25 00:56:04 $ Generate realisation of stationary Matern cluster process in a disc D Baddeley-Chang hybrid algorithm This file is included multiple times in rmatclus.c Macros: FNAME name of C function BUGGER print debug messages SAVEPARENTS save coordinates of parents, and map from offspring to parents Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #include SEXP FNAME(SEXP KAPPA, SEXP MU, SEXP CLUSTERSCALE, SEXP DISCRADIUS, SEXP INFLATE ) { /* generic inputs */ double kappa, mu, scale, rD, inflate; /* generic outputs */ double *xo, *yo; /* offspring locations */ SEXP Sout, Sxo, Syo; double *xoffspring, *yoffspring; #ifdef SAVEPARENTS double *xp, *yp; /* parent locations */ int *ip; /* map from offspring to parents */ int *parentid; SEXP Sxp, Syp, Sip; double *xparent, *yparent; #endif /* quantities/variables used in generic algorithm */ double lambda, kappadag, rE, rD2, rE2, Minf, MrE, p0, p0plus; double rpi, xpi, ypi, mi, roj, xoj, yoj, theta, muplus, dx, dy, tmp; int NoMax, newmax, no, i, j, n, m; #ifdef SAVEPARENTS int np, added, ipcurrent; #endif /* model parameters (for readability) */ double R; /* model-specific quantities */ double R2, RrD, A, B; PROTECT(KAPPA = AS_NUMERIC(KAPPA)); PROTECT(MU = AS_NUMERIC(MU)); PROTECT(CLUSTERSCALE = AS_NUMERIC(CLUSTERSCALE)); PROTECT(DISCRADIUS = AS_NUMERIC(DISCRADIUS)); PROTECT(INFLATE = AS_NUMERIC(INFLATE)); /* That's 5 protected */ #define NINPUTS 5 GetRNGstate(); /* get values */ kappa = *(NUMERIC_POINTER(KAPPA)); mu = *(NUMERIC_POINTER(MU)); scale = *(NUMERIC_POINTER(CLUSTERSCALE)); rD = *(NUMERIC_POINTER(DISCRADIUS)); inflate = *(NUMERIC_POINTER(INFLATE)); #ifdef BUGGER Rprintf("INPUT: kappa = %lf, mu = %lf, scale = %lf\n", kappa, mu, scale); Rprintf("rD = %lf, inflate = %lf\n", rD, inflate); #endif /* model-specific translation of inputs */ R = scale; /* specific to kernels with compact support */ RrD = R + rD; /* maximum distance from origin to parent, if parent has offspring in D */ rE = inflate * rD; #ifdef BUGGER Rprintf("R + rD = %lf,\t rE = %lf\n", RrD, rE); #endif if(rE > RrD) { /* no need to generate parents in disc larger than RrD */ rE = RrD; #ifdef BUGGER Rprintf("Trimmed rE to %lf\n", RrD); #endif } /* calculate some constants */ lambda = kappa * mu; /* intensity of cluster process */ kappadag = kappa * (1 - exp(-mu)); /* intensity of parents which have offspring anywhere */ p0 = exp(-mu); /* P(X == 0) where X ~ Pois(mu) */ rD2 = rD * rD; rE2 = rE * rE; /* model-specific constants */ R2 = R * R; muplus = mu * rD2/R2; /* integral of dominating kernel over D (for parents in b(0, RrD)) */ p0plus = exp(-muplus); A = kappa * (1 - exp(- muplus)); /* intensity of dominating parents (for parents in b(0, RrD)) */ B = M_PI * A; MrE = B * rE2; Minf = B * RrD * RrD; #ifdef BUGGER Rprintf("p0 = %lf, p0plus = %lf\n", p0, p0plus); #endif /* Guess amount of storage required */ NoMax = (int) ceil(2.0 * M_PI * lambda * rD2); if(NoMax < 2048) NoMax = 2048; xo = (double *) R_alloc(NoMax, sizeof(double)); yo = (double *) R_alloc(NoMax, sizeof(double)); no = 0; #ifdef SAVEPARENTS ip = (int *) R_alloc(NoMax, sizeof(int)); xp = (double *) R_alloc(NoMax, sizeof(double)); yp = (double *) R_alloc(NoMax, sizeof(double)); np = 0; #endif /* ----------- parents inside E ------------------- */ tmp = rpois(M_PI * rE2 * kappadag); n = (tmp > 2147483647.0) ? 2147483647 : ((int) tmp); #ifdef BUGGER Rprintf("Generating %d parents inside E\n", n); #endif if(n > 0) { for(i = 0; i < n; i++) { R_CheckUserInterrupt(); /* generate parent position uniform in E */ rpi = sqrt(runif((double) 0.0, rE2)); theta = runif((double) 0.0, M_2PI); xpi = rpi * cos(theta); ypi = rpi * sin(theta); #ifdef SAVEPARENTS added = 0; #endif /* number of offspring of parent i: zero truncated Poisson (mu) */ m = (int) qpois(runif(p0, (double) 1.0), mu, (int) 1, (int) 0); #ifdef BUGGER Rprintf("Generating %d offspring of parent %d\n", m, i); #endif /* generate offspring positions */ for(j = 0; j < m; j++) { /* model specific: displacement radius */ roj = sqrt(runif((double) 0.0, R2)); theta = runif((double) 0.0, M_2PI); xoj = xpi + roj * cos(theta); yoj = ypi + roj * sin(theta); if(xoj * xoj + yoj * yoj < rD2) { /* offspring point will be retained */ #ifdef SAVEPARENTS if(added == 0) { #ifdef BUGGER Rprintf("Adding proposed parent %d to result, as parent %d\n", i, np); #endif /* add parent point */ xp[np] = xpi; yp[np] = ypi; ipcurrent = np; np++; added = 1; } #endif /* add offspring point */ #ifdef BUGGER Rprintf("\tAdding offspring %d to result\n", j); #endif xo[no] = xoj; yo[no] = yoj; #ifdef SAVEPARENTS ip[no] = ipcurrent; #endif no++; /* check data overflow */ if(no > NoMax) { #ifdef BUGGER Rprintf("OVERFLOW\n"); #endif newmax = 2 * NoMax; xo = (double *) S_realloc((char *) xo, newmax, NoMax, sizeof(double)); yo = (double *) S_realloc((char *) yo, newmax, NoMax, sizeof(double)); #ifdef SAVEPARENTS xp = (double *) S_realloc((char *) xp, newmax, NoMax, sizeof(double)); yp = (double *) S_realloc((char *) yp, newmax, NoMax, sizeof(double)); ip = (int *) S_realloc((char *) ip, newmax, NoMax, sizeof(int)); #endif NoMax = newmax; } } } } } #ifdef BUGGER #ifdef SAVEPARENTS Rprintf("\n\nRunning total %d parents, %d offspring\n\n", np, no); #else Rprintf("\n\nRunning total %d offspring\n\n", no); #endif #endif /* ----------- parents outside E ------------------- */ /* number of dominating parents */ if(RrD <= rE || Minf <= MrE) { n = 0; #ifdef BUGGER Rprintf("No dominating parents outside E because R+rD <= rE\n"); #endif } else { n = rpois(Minf - MrE); #ifdef BUGGER Rprintf("Expect %lf dominating parents outside E\n", Minf - MrE); Rprintf("Generated %d dominating parents outside E\n", n); #endif } if(n > 0) { for(i = 0; i < n; i++) { R_CheckUserInterrupt(); /* generate parent position using dominating intensity */ mi = runif(MrE, Minf); /* solve M(r) = mi for radius r */ rpi = sqrt(mi/B); /* make coordinates */ theta = runif((double) 0.0, M_2PI); xpi = rpi * cos(theta); ypi = rpi * sin(theta); #ifdef SAVEPARENTS added = 0; #endif /* number of dominating offspring */ if(rpi > RrD) { /* This should not be reached */ m = 0; } else { /* zero truncated Poisson (muplus) */ m = (int) qpois(runif(p0plus, (double) 1.0), muplus, (int) 1, (int) 0); } #ifdef BUGGER Rprintf("Generated %d offspring of dominating parent %d\n", m, i); #endif if(m > 0) { for(j = 0; j < m; j++) { /* generate dominating offspring uniformly in D */ roj = sqrt(runif((double) 0.0, rD2)); theta = runif((double) 0.0, M_2PI); xoj = roj * cos(theta); yoj = roj * sin(theta); /* thin according to true kernel */ dx = xoj - xpi; dy = yoj - ypi; /* model specific */ /* true kernel: k(u|x) = 1/(pi R2) if |u-x| < R, 0 otherwise */ /* dominating kernel: ktil(u|x) = 1/(pi R2) if |x| < R+rD, 0 otherwise */ if(dx * dx + dy * dy < R2) { /* offspring will be retained */ #ifdef SAVEPARENTS if(added == 0) { /* add parent point */ #ifdef BUGGER Rprintf("Adding proposed parent %d to the output list as parent %d\n", i, np); #endif xp[np] = xpi; yp[np] = ypi; ipcurrent = np; np++; added = 1; } #endif /* add offspring point */ xo[no] = xoj; yo[no] = yoj; #ifdef SAVEPARENTS ip[no] = ipcurrent; #endif no++; #ifdef BUGGER Rprintf("\tAdded offspring %d to the output list\n", j); #endif /* check data overflow */ if(no > NoMax) { #ifdef BUGGER Rprintf("OVERFLOW\n"); #endif newmax = 2 * NoMax; xo = (double *) S_realloc((char *) xo, newmax, NoMax, sizeof(double)); yo = (double *) S_realloc((char *) yo, newmax, NoMax, sizeof(double)); #ifdef SAVEPARENTS xp = (double *) S_realloc((char *) xp, newmax, NoMax, sizeof(double)); yp = (double *) S_realloc((char *) yp, newmax, NoMax, sizeof(double)); ip = (int *) S_realloc((char *) ip, newmax, NoMax, sizeof(int)); #endif NoMax = newmax; } } } } } } #ifdef BUGGER #ifdef SAVEPARENTS Rprintf("Total %d parents, %d offspring\n", np, no); #else Rprintf("Total %d offspring\n", no); #endif #endif /* copy to result */ /* create output list */ #ifdef SAVEPARENTS #define NOUT 5 #else #define NOUT 2 #endif PROTECT(Sout = NEW_LIST(NOUT)); /* create entries in output list */ PROTECT(Sxo = NEW_NUMERIC(no)); PROTECT(Syo = NEW_NUMERIC(no)); #ifdef SAVEPARENTS PROTECT(Sxp = NEW_NUMERIC(np)); PROTECT(Syp = NEW_NUMERIC(np)); PROTECT(Sip = NEW_INTEGER(no)); #endif #define NPROTECTED (NINPUTS + 1 + NOUT) /* create pointers to list components */ xoffspring = NUMERIC_POINTER(Sxo); yoffspring = NUMERIC_POINTER(Syo); #ifdef SAVEPARENTS xparent = NUMERIC_POINTER(Sxp); yparent = NUMERIC_POINTER(Syp); parentid = INTEGER_POINTER(Sip); #endif /* copy */ #ifdef SAVEPARENTS for(i = 0; i < np; i++) { xparent[i] = xp[i]; yparent[i] = yp[i]; } #endif for(j = 0; j < no; j++) { xoffspring[j] = xo[j]; yoffspring[j] = yo[j]; #ifdef SAVEPARENTS parentid[j] = ip[j] + 1; #endif } SET_VECTOR_ELT(Sout, 0, Sxo); SET_VECTOR_ELT(Sout, 1, Syo); #ifdef SAVEPARENTS SET_VECTOR_ELT(Sout, 2, Sxp); SET_VECTOR_ELT(Sout, 3, Syp); SET_VECTOR_ELT(Sout, 4, Sip); #endif PutRNGstate(); UNPROTECT(NPROTECTED); return(Sout); } #undef NINPUTS #undef NOUT #undef NPROTECTED spatstat.random/src/PerfectPenttinen.h0000755000176200001440000001236114325152137017622 0ustar liggesusers // ........................... Penttinen process ................ // $Revision: 1.5 $ $Date: 2022/03/27 01:58:21 $ class PenttProcess : public PointProcess { public: double beta, gamma, radius, reachsquared, loggamma2pi; int ishard; PenttProcess(double xmin, double xmax, double ymin, double ymax, double b, double g, double r); ~PenttProcess(){} void NewEvent(double *x, double *y, char *InWindow); void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP); double Interaction(double dsquared); }; PenttProcess::PenttProcess(double xmin, double xmax, double ymin, double ymax, double b, double g, double r) : PointProcess(xmin, xmax, ymin, ymax){ beta = b; gamma = g; radius = r; ishard = (gamma <= DBL_EPSILON); loggamma2pi = M_2PI * (ishard? 0.0 : log(gamma)); reachsquared = 4.0 * radius * radius; InteractionRange = 2.0 * radius; TotalBirthRate = beta*(xmax-xmin)*(ymax-ymin); } double PenttProcess::Interaction(double dsquared) { double rtn, z, z2; rtn = 1.0; if(dsquared < reachsquared) { if(ishard) return(0.0); z2 = dsquared/reachsquared; z = sqrt(z2); if(z < 1.0) { rtn = exp(loggamma2pi * (acos(z) - z * sqrt(1.0 - z2))); } } return(rtn); } void PenttProcess::NewEvent(double *x, double *y, char *InWindow) { double Xdim, Ydim; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; *x = slumptal()*Xdim+Xmin; *y = slumptal()*Ydim+Ymin; *InWindow = 1; } void PenttProcess::GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP) { int i; double xtemp, ytemp, L, Xdim, Ydim; struct Point *TempPoint; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; L = beta*Xdim*Ydim; *GeneratedPoints = poisson(L); *LivingPoints = *GeneratedPoints; for (i=1; i<=*GeneratedPoints ; i++){ //Rprintf("Generating PenttProcess Poisson 3\n"); //scanf("%f",&f1); xtemp = slumptal()*Xdim+Xmin; ytemp = slumptal()*Ydim+Ymin; // //Rprintf("Generating PenttProcess Poisson 3.2\n"); TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = i; TempPoint->R = slumptal(); //Rprintf("Generating PenttProcess Poisson 3.6\n"); TempPoint->next = headPoint->next; headPoint->next = TempPoint; *NoP = *NoP + 1; } } // ........................... Interface to R .......................... extern "C" { SEXP PerfectPenttinen(SEXP beta, SEXP gamma, SEXP r, SEXP xrange, SEXP yrange) { // input parameters double Beta, Gamma, R, Xmin, Xmax, Ymin, Ymax; double *Xrange, *Yrange; // internal int xcells, ycells; long int StartTime, EndTime; // output int noutmax; SEXP xout, yout, nout, out; double *xx, *yy; int *nn; // protect arguments from garbage collector PROTECT(beta = AS_NUMERIC(beta)); PROTECT(gamma = AS_NUMERIC(gamma)); PROTECT(r = AS_NUMERIC(r)); PROTECT(xrange = AS_NUMERIC(xrange)); PROTECT(yrange = AS_NUMERIC(yrange)); // that's 5 protected objects // extract arguments // model parameters Beta = *(NUMERIC_POINTER(beta)); Gamma = *(NUMERIC_POINTER(gamma)); R = *(NUMERIC_POINTER(r)); // window Xrange = NUMERIC_POINTER(xrange); Xmin = Xrange[0]; Xmax = Xrange[1]; Yrange = NUMERIC_POINTER(yrange); Ymin = Yrange[0]; Ymax = Yrange[1]; // compute cell array size xcells = (int) floor((Xmax-Xmin)/ R); if(xcells > 9) { xcells = 9; } else if(xcells < 1) { xcells = 1; } ycells = (int) floor((Ymax-Ymin)/ R); if(ycells > 9) { ycells = 9; } else if(ycells < 1) { ycells = 1; } #ifdef DBGS Rprintf("xcells %d ycells %d\n",xcells,ycells); Rprintf("Initialising\n"); #endif // Initialise Penttinen point process PenttProcess ExampleProcess(Xmin,Xmax,Ymin,Ymax,Beta,Gamma,R); // Initialise point pattern Point2Pattern ExamplePattern(Xmin,Xmax,Ymin,Ymax, xcells, ycells); // parameters: min x, max x, min y, max y, "cells" in x and y direction // used for speeding up neighbour counting, 9 is max here #ifdef DBGS Rprintf("Initialisation complete\n"); #endif // Synchronise random number generator GetRNGstate(); // Initialise perfect sampler Sampler PerfectSampler(&ExampleProcess); // Perform perfect sampling PerfectSampler.Sim(&ExamplePattern, &StartTime, &EndTime); // Synchronise random number generator PutRNGstate(); // Get upper estimate of number of points noutmax = ExamplePattern.UpperCount() + 1; // Allocate space for output PROTECT(xout = NEW_NUMERIC(noutmax)); PROTECT(yout = NEW_NUMERIC(noutmax)); PROTECT(nout = NEW_INTEGER(1)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); nn = INTEGER_POINTER(nout); // copy data into output storage ExamplePattern.Return(xx, yy, nn, noutmax); // pack up into output list PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, nout); // return UNPROTECT(9); // 5 arguments plus xout, yout, nout, out return(out); } } spatstat.random/src/straussm.c0000755000176200001440000001267614325152137016232 0ustar liggesusers#include #include #include "methas.h" #include "dist2.h" /* for debugging code, include #define DEBUG 1 */ /* Conditional intensity computation for Multitype Strauss process */ /* NOTE: types (marks) are numbered from 0 to ntypes-1 */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct MultiStrauss { int ntypes; double *gamma; /* gamma[i,j] = gamma[i+ntypes*j] for i,j = 0... ntypes-1 */ double *rad; /* rad[i,j] = rad[j+ntypes*i] for i,j = 0... ntypes-1 */ double *rad2; /* squared radii */ double range2; /* square of interaction range */ double *loggamma; /* logs of gamma[i,j] */ double *period; int *hard; /* hard[i,j] = 1 if gamma[i,j] ~~ 0 */ int *kount; /* space for kounting pairs of each type */ int per; } MultiStrauss; /* initialiser function */ Cdata *straussminit(State state, Model model, Algor algo) { int i, j, ntypes, n2, hard; double g, r, r2, logg, range2; MultiStrauss *multistrauss; multistrauss = (MultiStrauss *) R_alloc(1, sizeof(MultiStrauss)); multistrauss->ntypes = ntypes = model.ntypes; n2 = ntypes * ntypes; #ifdef DEBUG Rprintf("initialising space for %d types\n", ntypes); #endif /* Allocate space for parameters */ multistrauss->gamma = (double *) R_alloc((size_t) n2, sizeof(double)); multistrauss->rad = (double *) R_alloc((size_t) n2, sizeof(double)); /* Allocate space for transformed parameters */ multistrauss->rad2 = (double *) R_alloc((size_t) n2, sizeof(double)); multistrauss->loggamma = (double *) R_alloc((size_t) n2, sizeof(double)); multistrauss->hard = (int *) R_alloc((size_t) n2, sizeof(int)); /* Allocate scratch space for counts of each pair of types */ multistrauss->kount = (int *) R_alloc((size_t) n2, sizeof(int)); /* Copy and process model parameters*/ /* ipar will contain n^2 gamma values followed by n^2 values of r */ range2 = 0.0; for(i = 0; i < ntypes; i++) { for(j = 0; j < ntypes; j++) { g = model.ipar[i + j*ntypes]; r = model.ipar[n2 + i + j*ntypes]; r2 = r * r; hard = (g < DBL_EPSILON); logg = (hard) ? 0 : log(g); MAT(multistrauss->gamma, i, j, ntypes) = g; MAT(multistrauss->rad, i, j, ntypes) = r; MAT(multistrauss->hard, i, j, ntypes) = hard; MAT(multistrauss->loggamma, i, j, ntypes) = logg; MAT(multistrauss->rad2, i, j, ntypes) = r2; if(r2 > range2) range2 = r2; } } multistrauss->range2 = range2; /* periodic boundary conditions? */ multistrauss->period = model.period; multistrauss->per = (model.period[0] > 0.0); #ifdef DEBUG Rprintf("end initialiser\n"); #endif return((Cdata *) multistrauss); } /* conditional intensity evaluator */ double straussmcif(Propo prop, State state, Cdata *cdata) { int npts, ntypes, kount, ix, ixp1, j, mrk, mrkj, m1, m2; int *marks; double *x, *y; double u, v, lg; double d2, cifval; double range2; double *period; MultiStrauss *multistrauss; DECLARE_CLOSE_D2_VARS; multistrauss = (MultiStrauss *) cdata; range2 = multistrauss->range2; period = multistrauss->period; u = prop.u; v = prop.v; mrk = prop.mrk; ix = prop.ix; x = state.x; y = state.y; marks = state.marks; npts = state.npts; #ifdef DEBUG Rprintf("computing cif: u=%lf, v=%lf, mrk=%d\n", u, v, mrk); #endif cifval = 1.0; if(npts == 0) return(cifval); ntypes = multistrauss->ntypes; #ifdef DEBUG Rprintf("initialising pair counts\n"); #endif /* initialise pair counts */ for(m1 = 0; m1 < ntypes; m1++) for(m2 = 0; m2 < ntypes; m2++) MAT(multistrauss->kount, m1, m2, ntypes) = 0; /* compile pair counts */ #ifdef DEBUG Rprintf("compiling pair counts\n"); #endif ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(multistrauss->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],period,range2,d2)) { mrkj = marks[j]; if(d2 < MAT(multistrauss->rad2, mrk, mrkj, ntypes)) MAT(multistrauss->kount, mrk, mrkj, ntypes)++; } } } if(ixp1 < npts) { for(j=ixp1; jrad2, mrk, mrkj, ntypes)) MAT(multistrauss->kount, mrk, mrkj, ntypes)++; } } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], range2, d2)) { mrkj = marks[j]; if(d2 < MAT(multistrauss->rad2, mrk, mrkj, ntypes)) MAT(multistrauss->kount, mrk, mrkj, ntypes)++; } } } if(ixp1 < npts) { for(j=ixp1; jrad2, mrk, mrkj, ntypes)) MAT(multistrauss->kount, mrk, mrkj, ntypes)++; } } } } #ifdef DEBUG Rprintf("multiplying cif factors\n"); #endif /* multiply cif value by pair potential */ for(m1 = 0; m1 < ntypes; m1++) { for(m2 = 0; m2 < ntypes; m2++) { kount = MAT(multistrauss->kount, m1, m2, ntypes); if(MAT(multistrauss->hard, m1, m2, ntypes)) { if(kount > 0) { cifval = 0.0; return(cifval); } } else { lg = MAT(multistrauss->loggamma, m1, m2, ntypes); cifval *= exp(lg * kount); } } } #ifdef DEBUG Rprintf("returning positive cif\n"); #endif return cifval; } Cifns MultiStraussCifns = { &straussminit, &straussmcif, (updafunptr) NULL, YES}; spatstat.random/src/fiksel.c0000755000176200001440000000563614325152137015624 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Fiksel process */ /* Conditional intensity function for a pairwise interaction point process with interaction function e(t) = 0 for t < h = exp(a * exp(- kappa * t)) for h <= t < r = 1 for t >= r */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Fiksel { double r; double h; double kappa; double a; double h2; /* h^2 */ double r2; /* r^2 */ double *period; int per; } Fiksel; /* initialiser function */ Cdata *fikselinit(State state, Model model, Algor algo) { Fiksel *fiksel; fiksel = (Fiksel *) R_alloc(1, sizeof(Fiksel)); /* Interpret model parameters*/ fiksel->r = model.ipar[0]; fiksel->h = model.ipar[1]; fiksel->kappa = model.ipar[2]; fiksel->a = model.ipar[3]; fiksel->period = model.period; /* constants */ fiksel->h2 = pow(fiksel->h, 2); fiksel->r2 = pow(fiksel->r, 2); /* periodic boundary conditions? */ fiksel->per = (model.period[0] > 0.0); return((Cdata *) fiksel); } /* conditional intensity evaluator */ double fikselcif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double d2, pairpotsum, cifval; double kappa, r2, h2; double *period; Fiksel *fiksel; DECLARE_CLOSE_D2_VARS; fiksel = (Fiksel *) cdata; period = fiksel->period; kappa = fiksel->kappa; r2 = fiksel->r2; h2 = fiksel->h2; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; cifval = 1.0; if(npts == 0) return(cifval); pairpotsum = 0; ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(fiksel->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],period,r2,d2)) { if(d2 < h2) { cifval = 0.0; return(cifval); } else { pairpotsum += exp(-kappa * sqrt(d2)); } } } } if(ixp1 < npts) { for(j=ixp1; j 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u,v,x[j],y[j],r2,d2)) { if(d2 < h2) { cifval = 0.0; return(cifval); } else { pairpotsum += exp(-kappa * sqrt(d2)); } } } } if(ixp1 < npts) { for(j=ixp1; ja * pairpotsum); return cifval; } Cifns FikselCifns = { &fikselinit, &fikselcif, (updafunptr) NULL, NO}; spatstat.random/src/mhv5.h0000755000176200001440000000054114164500132015212 0ustar liggesusers/* mhv5.h tempered or not Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef MH_TEMPER if(tempered) { /* tempering */ #define MH_TEMPER YES #include "mhloop.h" #undef MH_TEMPER } else { /* usual, no tempering */ #define MH_TEMPER NO #include "mhloop.h" #undef MH_TEMPER } spatstat.random/src/methas.c0000755000176200001440000002756614531531170015633 0ustar liggesusers#include #include #include #include "methas.h" #include "chunkloop.h" #include "mhsnoop.h" /* To switch on debugging code, insert the line: #define MH_DEBUG YES To switch off debugging code, insert the line: #define MH_DEBUG NO */ #ifndef MH_DEBUG #define MH_DEBUG NO #endif /* This is the value of 'ix' when we are proposing a birth. It must be equal to -1 so that NONE+1 = 0. */ #define NONE -1 extern Cifns getcif(char *); SEXP xmethas( SEXP ncif, SEXP cifname, SEXP beta, SEXP ipar, SEXP iparlen, SEXP period, SEXP xprop, SEXP yprop, SEXP mprop, SEXP ntypes, SEXP nrep, SEXP p, SEXP q, SEXP nverb, SEXP nrep0, SEXP x, SEXP y, SEXP marks, SEXP ncond, SEXP fixall, SEXP track, SEXP thin, SEXP snoopenv, SEXP temper, SEXP invertemp) { char *cifstring; double cvd, cvn, qnodds, anumer, adenom, betavalue; double *iparvector; int verb, marked, tempered, mustupdate, itype; int nfree, nsuspect; int irep, ix, j, maxchunk, iverb; int Ncif; int *plength; long Nmore; int permitted; double invtemp; double *xx, *yy, *xpropose, *ypropose; int *mm, *mpropose, *pp, *aa; SEXP out, xout, yout, mout, pout, aout; int tracking, thinstart; #ifdef HISTORY_INCLUDES_RATIO SEXP numout, denout; double *nn, *dd; #endif State state; Model model; Algor algo; Propo birthprop, deathprop, shiftprop; History history; Snoop snooper; /* The following variables are used only for a non-hybrid interaction */ Cifns thecif; /* cif structure */ Cdata *thecdata; /* pointer to initialised cif data block */ /* The following variables are used only for a hybrid interaction */ Cifns *cif; /* vector of cif structures */ Cdata **cdata; /* vector of pointers to initialised cif data blocks */ int *needupd; /* vector of logical values */ int k; /* loop index for cif's */ /* =================== Protect R objects from garbage collector ======= */ PROTECT(ncif = AS_INTEGER(ncif)); PROTECT(cifname = AS_CHARACTER(cifname)); PROTECT(beta = AS_NUMERIC(beta)); PROTECT(ipar = AS_NUMERIC(ipar)); PROTECT(iparlen = AS_INTEGER(iparlen)); PROTECT(period = AS_NUMERIC(period)); PROTECT(xprop = AS_NUMERIC(xprop)); PROTECT(yprop = AS_NUMERIC(yprop)); PROTECT(mprop = AS_INTEGER(mprop)); PROTECT(ntypes = AS_INTEGER(ntypes)); PROTECT(nrep = AS_INTEGER(nrep)); PROTECT( p = AS_NUMERIC(p)); PROTECT( q = AS_NUMERIC(q)); PROTECT(nverb = AS_INTEGER(nverb)); PROTECT(nrep0 = AS_INTEGER(nrep0)); PROTECT( x = AS_NUMERIC(x)); PROTECT( y = AS_NUMERIC(y)); PROTECT( marks = AS_INTEGER(marks)); PROTECT(fixall = AS_INTEGER(fixall)); PROTECT(ncond = AS_INTEGER(ncond)); PROTECT(track = AS_INTEGER(track)); PROTECT(thin = AS_INTEGER(thin)); PROTECT(temper = AS_INTEGER(temper)); PROTECT(invertemp = AS_NUMERIC(invertemp)); /* that's 24 protected objects */ /* =================== Translate arguments from R to C ================ */ /* Ncif is the number of cif's plength[i] is the number of interaction parameters in the i-th cif */ Ncif = *(INTEGER_POINTER(ncif)); plength = INTEGER_POINTER(iparlen); /* copy RMH algorithm parameters */ algo.nrep = *(INTEGER_POINTER(nrep)); algo.nverb = *(INTEGER_POINTER(nverb)); algo.nrep0 = *(INTEGER_POINTER(nrep0)); algo.p = *(NUMERIC_POINTER(p)); algo.q = *(NUMERIC_POINTER(q)); algo.fixall = ((*(INTEGER_POINTER(fixall))) == 1); algo.ncond = *(INTEGER_POINTER(ncond)); algo.tempered = tempered = (*(INTEGER_POINTER(temper)) != 0); algo.invtemp = invtemp = *(NUMERIC_POINTER(invertemp)); /* copy model parameters without interpreting them */ model.beta = NUMERIC_POINTER(beta); model.ipar = iparvector = NUMERIC_POINTER(ipar); model.period = NUMERIC_POINTER(period); model.ntypes = *(INTEGER_POINTER(ntypes)); state.ismarked = marked = (model.ntypes > 1); /* copy initial state */ state.npts = LENGTH(x); state.npmax = 4 * ((state.npts > 256) ? state.npts : 256); state.x = (double *) R_alloc(state.npmax, sizeof(double)); state.y = (double *) R_alloc(state.npmax, sizeof(double)); xx = NUMERIC_POINTER(x); yy = NUMERIC_POINTER(y); if(marked) { state.marks =(int *) R_alloc(state.npmax, sizeof(int)); mm = INTEGER_POINTER(marks); } if(!marked) { for(j = 0; j < state.npts; j++) { state.x[j] = xx[j]; state.y[j] = yy[j]; } } else { for(j = 0; j < state.npts; j++) { state.x[j] = xx[j]; state.y[j] = yy[j]; state.marks[j] = mm[j]; } } #if MH_DEBUG Rprintf("\tnpts=%d\n", state.npts); #endif /* access proposal data */ xpropose = NUMERIC_POINTER(xprop); ypropose = NUMERIC_POINTER(yprop); mpropose = INTEGER_POINTER(mprop); /* we need to initialise 'mpropose' to keep compilers happy. mpropose is only used for marked patterns. Note 'mprop' is always a valid pointer */ /* ================= Allocate space for cifs etc ========== */ if(Ncif > 1) { cif = (Cifns *) R_alloc(Ncif, sizeof(Cifns)); cdata = (Cdata **) R_alloc(Ncif, sizeof(Cdata *)); needupd = (int *) R_alloc(Ncif, sizeof(int)); } else { /* Keep the compiler happy */ cif = (Cifns *) R_alloc(1, sizeof(Cifns)); cdata = (Cdata **) R_alloc(1, sizeof(Cdata *)); needupd = (int *) R_alloc(1, sizeof(int)); } /* ================= Determine process to be simulated ========== */ /* Get the cif's */ if(Ncif == 1) { cifstring = (char *) STRING_VALUE(cifname); thecif = getcif(cifstring); mustupdate = NEED_UPDATE(thecif); if(thecif.marked && !marked) error("cif is for a marked point process, but proposal data are not marked points; bailing out."); /* Keep compiler happy*/ cif[0] = thecif; needupd[0] = mustupdate; } else { mustupdate = NO; for(k = 0; k < Ncif; k++) { cifstring = (char *) CHAR(STRING_ELT(cifname, k)); cif[k] = getcif(cifstring); needupd[k] = NEED_UPDATE(cif[k]); if(needupd[k]) mustupdate = YES; if(cif[k].marked && !marked) error("component cif is for a marked point process, but proposal data are not marked points; bailing out."); } } /* ============= Initialise transition history ========== */ tracking = (*(INTEGER_POINTER(track)) != 0); /* Initialise even if not needed, to placate the compiler */ if(tracking) { history.nmax = algo.nrep; } else { history.nmax = 1; } history.n = 0; history.proptype = (int *) R_alloc(history.nmax, sizeof(int)); history.accepted = (int *) R_alloc(history.nmax, sizeof(int)); #ifdef HISTORY_INCLUDES_RATIO history.numerator = (double *) R_alloc(history.nmax, sizeof(double)); history.denominator = (double *) R_alloc(history.nmax, sizeof(double)); #endif /* ============= Visual debugging ========== */ /* Active if 'snoopenv' is an environment */ #if MH_DEBUG Rprintf("Initialising mhsnoop\n"); #endif initmhsnoop(&snooper, snoopenv); #if MH_DEBUG Rprintf("Initialised\n"); if(snooper.active) Rprintf("Debugger is active.\n"); #endif /* ================= Thinning of initial state ==================== */ thinstart = (*(INTEGER_POINTER(thin)) != 0); /* ================= Initialise algorithm ==================== */ /* Interpret the model parameters and initialise auxiliary data */ if(Ncif == 1) { thecdata = (*(thecif.init))(state, model, algo); /* keep compiler happy */ cdata[0] = thecdata; } else { for(k = 0; k < Ncif; k++) { if(k > 0) model.ipar += plength[k-1]; cdata[k] = (*(cif[k].init))(state, model, algo); } /* keep compiler happy */ thecdata = cdata[0]; } /* Set the fixed elements of the proposal objects */ birthprop.itype = BIRTH; deathprop.itype = DEATH; shiftprop.itype = SHIFT; birthprop.ix = NONE; if(!marked) birthprop.mrk = deathprop.mrk = shiftprop.mrk = NONE; /* Set up some constants */ verb = (algo.nverb !=0); qnodds = (1.0 - algo.q)/algo.q; /* Set value of beta for unmarked process */ /* (Overwritten for marked process, but keeps compiler happy) */ betavalue = model.beta[0]; /* ============= Run Metropolis-Hastings ================== */ /* Initialise random number generator */ GetRNGstate(); /* Here comes the code for the M-H loop. The basic code (in mhloop.h) is #included many times using different options The C preprocessor descends through a chain of files mhv1.h, mhv2.h, ... to enumerate all possible combinations of flags. */ #include "mhv1.h" /* relinquish random number generator */ PutRNGstate(); /* ============= Done ================== */ /* Create space for output, and copy final state */ /* Point coordinates */ PROTECT(xout = NEW_NUMERIC(state.npts)); PROTECT(yout = NEW_NUMERIC(state.npts)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); for(j = 0; j < state.npts; j++) { xx[j] = state.x[j]; yy[j] = state.y[j]; } /* Marks */ if(marked) { PROTECT(mout = NEW_INTEGER(state.npts)); mm = INTEGER_POINTER(mout); for(j = 0; j < state.npts; j++) mm[j] = state.marks[j]; } else { /* Keep the compiler happy */ PROTECT(mout = NEW_INTEGER(1)); mm = INTEGER_POINTER(mout); mm[0] = 0; } /* Transition history */ if(tracking) { PROTECT(pout = NEW_INTEGER(algo.nrep)); PROTECT(aout = NEW_INTEGER(algo.nrep)); pp = INTEGER_POINTER(pout); aa = INTEGER_POINTER(aout); for(j = 0; j < algo.nrep; j++) { pp[j] = history.proptype[j]; aa[j] = history.accepted[j]; } #ifdef HISTORY_INCLUDES_RATIO PROTECT(numout = NEW_NUMERIC(algo.nrep)); PROTECT(denout = NEW_NUMERIC(algo.nrep)); nn = NUMERIC_POINTER(numout); dd = NUMERIC_POINTER(denout); for(j = 0; j < algo.nrep; j++) { nn[j] = history.numerator[j]; dd[j] = history.denominator[j]; } #endif } else { /* Keep the compiler happy */ PROTECT(pout = NEW_INTEGER(1)); PROTECT(aout = NEW_INTEGER(1)); pp = INTEGER_POINTER(pout); aa = INTEGER_POINTER(aout); pp[0] = aa[0] = 0; #ifdef HISTORY_INCLUDES_RATIO PROTECT(numout = NEW_NUMERIC(1)); PROTECT(denout = NEW_NUMERIC(1)); nn = NUMERIC_POINTER(numout); dd = NUMERIC_POINTER(denout); nn[0] = dd[0] = 0; #endif } /* Pack up into list object for return */ if(!tracking) { /* no transition history */ if(!marked) { PROTECT(out = NEW_LIST(2)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); } else { PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, mout); } } else { /* transition history */ if(!marked) { #ifdef HISTORY_INCLUDES_RATIO PROTECT(out = NEW_LIST(6)); #else PROTECT(out = NEW_LIST(4)); #endif SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, pout); SET_VECTOR_ELT(out, 3, aout); #ifdef HISTORY_INCLUDES_RATIO SET_VECTOR_ELT(out, 4, numout); SET_VECTOR_ELT(out, 5, denout); #endif } else { #ifdef HISTORY_INCLUDES_RATIO PROTECT(out = NEW_LIST(7)); #else PROTECT(out = NEW_LIST(5)); #endif SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, mout); SET_VECTOR_ELT(out, 3, pout); SET_VECTOR_ELT(out, 4, aout); #ifdef HISTORY_INCLUDES_RATIO SET_VECTOR_ELT(out, 5, numout); SET_VECTOR_ELT(out, 6, denout); #endif } } #ifdef HISTORY_INCLUDES_RATIO UNPROTECT(32); /* 24 arguments plus xout, yout, mout, pout, aout, out, numout, denout */ #else UNPROTECT(30); /* 24 arguments plus xout, yout, mout, pout, aout, out */ #endif return(out); } spatstat.random/src/straush.c0000755000176200001440000000572014325152137016032 0ustar liggesusers#include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Hard core Strauss process */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct StraussHard { double gamma; double r; /* interaction distance */ double h; /* hard core distance */ double loggamma; double r2; double h2; double r2h2; /* r^2 - h^2 */ double *period; int hard; int per; } StraussHard; /* initialiser function */ Cdata *straushinit(State state, Model model, Algor algo) { StraussHard *strausshard; strausshard = (StraussHard *) R_alloc(1, sizeof(StraussHard)); /* Interpret model parameters*/ strausshard->gamma = model.ipar[0]; strausshard->r = model.ipar[1]; /* No longer passed as r^2 */ strausshard->h = model.ipar[2]; /* No longer passed as h^2 */ strausshard->r2 = pow(strausshard->r, 2); strausshard->h2 = pow(strausshard->h, 2); strausshard->r2h2 = strausshard->r2 - strausshard->h2; strausshard->period = model.period; /* is the interaction numerically equivalent to hard core ? */ strausshard->hard = (strausshard->gamma < DBL_EPSILON); strausshard->loggamma = (strausshard->hard) ? 0.0 : log(strausshard->gamma); /* periodic boundary conditions? */ strausshard->per = (model.period[0] > 0.0); return((Cdata *) strausshard); } /* conditional intensity evaluator */ double straushcif(Propo prop, State state, Cdata *cdata) { int npts, kount, ix, ixp1, j; double *x, *y; double u, v; double r2, r2h2, cifval; StraussHard *strausshard; double *period; DECLARE_CLOSE_VARS; strausshard = (StraussHard *) cdata; r2 = strausshard->r2; r2h2 = strausshard->r2h2; period = strausshard->period; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; if(npts == 0) return((double) 1.0); kount = 0; ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(strausshard->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC(u,v,x[j],y[j],period,r2)) { /* RESIDUE = r2 - distance^2 */ if(RESIDUE > r2h2) return((double) 0.0); ++kount; } } } if(ixp1 < npts) { for(j=ixp1; j r2h2) return((double) 0.0); ++kount; } } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE(u,v,x[j],y[j],r2)) { if(RESIDUE > r2h2) return((double) 0.0); ++kount; } } } if(ixp1 < npts) { for(j=ixp1; j r2h2) return((double) 0.0); ++kount; } } } } if(strausshard->hard) { if(kount > 0) cifval = (double) 0.0; else cifval = (double) 1.0; } else cifval = exp(strausshard->loggamma*kount); return cifval; } Cifns StraussHardCifns = { &straushinit, &straushcif, (updafunptr) NULL, NO}; spatstat.random/src/chunkloop.h0000755000176200001440000000161514325152137016347 0ustar liggesusers/* chunkloop.h Divide a loop into chunks Convenient for divide-and-recombine, and reducing calls to R_CheckUserInterrupt, etc. $Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #define OUTERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \ IVAR = 0; \ ICHUNK = 0; \ while(IVAR < LOOPLENGTH) #define INNERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \ ICHUNK += CHUNKSIZE; \ if(ICHUNK > LOOPLENGTH) ICHUNK = LOOPLENGTH; \ for(; IVAR < ICHUNK; IVAR++) #define XOUTERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \ IVAR = ISTART; \ ICHUNK = 0; \ while(IVAR <= IEND) #define XINNERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \ ICHUNK += CHUNKSIZE; \ if(ICHUNK > IEND) ICHUNK = IEND; \ for(; IVAR <= IEND; IVAR++) #define CHUNKLOOP_H spatstat.random/src/methas.h0000755000176200001440000000712314164500132015617 0ustar liggesusers/* Definitions of types and data structures for Metropolis-Hastings State Current state of point pattern Model Model parameters passed from R Cdata (pointer to) model parameters and precomputed data in C Algor Algorithm parameters (p, q, nrep etc) Propo Proposal in Metropolis-Hastings algorithm History Transition history of MH algorithm Cifns Set of functions for computing the conditional intensity for a point process model. This consists of three functions init(State, Model, Algor) .... initialises auxiliary data eval(State, Propo) ........... evaluates cif update(State,Propo) .......... updates auxiliary data */ /* Current state of point pattern */ typedef struct State { double *x; /* vectors of Cartesian coordinates */ double *y; int *marks; /* vector of mark values */ int npts; /* current number of points */ int npmax; /* storage limit */ int ismarked; /* whether the pattern is marked */ } State; /* Parameters of model passed from R */ typedef struct Model { double *beta; /* vector of activity parameters */ double *ipar; /* vector of interaction parameters */ double *period; /* width & height of rectangle, if torus */ int ntypes; /* number of possible marks */ } Model; /* A pointer to Cdata is a pointer to C storage for parameters of model */ typedef void Cdata; /* RMH Algorithm parameters */ typedef struct Algor { double p; /* probability of proposing shift */ double q; /* conditional probability of proposing death */ int fixall; /* if TRUE, only shifts of location are feasible */ int ncond; /* For conditional simulation, the first 'ncond' points are fixed */ int nrep; /* number of iterations */ int nverb; /* print report every 'nverb' iterations */ int nrep0; /* number of iterations already performed in previous blocks - for reporting purposes */ int tempered; /* TRUE if tempering is applied */ double invtemp; /* inverse temperature if tempering is applied */ } Algor; /* Metropolis-Hastings proposal */ typedef struct Propo { double u; /* location of point of interest */ double v; int mrk; /* mark of point of interest */ int ix; /* index of point of interest, if already in pattern */ int itype; /* transition type */ } Propo; /* transition codes 'itype' */ #define REJECT 0 #define BIRTH 1 #define DEATH 2 #define SHIFT 3 #define HISTORY_INCLUDES_RATIO /* Record of transition history */ typedef struct History { int nmax; /* length of vectors */ int n; /* number of events recorded */ int *proptype; /* vector: proposal type */ int *accepted; /* vector: 0 for reject, 1 for accept */ #ifdef HISTORY_INCLUDES_RATIO double *numerator; /* vectors: Hastings ratio numerator & denominator */ double *denominator; #endif } History; /* conditional intensity functions */ typedef Cdata * (*initfunptr)(State state, Model model, Algor algo); typedef double (*evalfunptr)(Propo prop, State state, Cdata *cdata); typedef void (*updafunptr)(State state, Propo prop, Cdata *cdata); typedef struct Cifns { initfunptr init; evalfunptr eval; updafunptr update; int marked; } Cifns; #define NEED_UPDATE(X) ((X).update != (updafunptr) NULL) #define NULL_CIFNS { (initfunptr) NULL, (evalfunptr) NULL, (updafunptr) NULL, NO} /* miscellaneous macros */ #include "yesno.h" # define MAT(X,I,J,M) (X[(I)+(J)*(M)]) spatstat.random/src/triplets.c0000755000176200001440000000605014325152137016204 0ustar liggesusers#include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Triplets process */ /* Format for storage of parameters and precomputed/auxiliary data */ typedef struct Triplets { double gamma; double r; double loggamma; double r2; double *period; int hard; int per; int *neighbour; /* scratch list of neighbours of current point */ int Nmax; /* length of scratch space allocated */ } Triplets; /* initialiser function */ Cdata *tripletsinit(State state, Model model, Algor algo) { /* create storage for model parameters */ Triplets *triplets; triplets = (Triplets *) R_alloc(1, sizeof(Triplets)); /* create scratch space */ triplets->Nmax = 1024; triplets->neighbour = (int *) R_alloc(1024, sizeof(int)); /* Interpret model parameters*/ triplets->gamma = model.ipar[0]; triplets->r = model.ipar[1]; /* No longer passed as r^2 */ triplets->r2 = triplets->r * triplets->r; triplets->period = model.period; #ifdef MHDEBUG Rprintf("Initialising Triplets gamma=%lf, r=%lf\n", triplets->gamma, triplets->r); #endif /* is the model numerically equivalent to hard core ? */ triplets->hard = (triplets->gamma < DBL_EPSILON); triplets->loggamma = (triplets->hard) ? 0 : log(triplets->gamma); /* periodic boundary conditions? */ triplets->per = (model.period[0] > 0.0); return((Cdata *) triplets); } /* conditional intensity evaluator */ double tripletscif(Propo prop, State state, Cdata *cdata) { int npts, kount, ix, j, k, nj, nk, N, Nmax, Nmore, N1; int *neighbour; double *x, *y; double u, v; double r2, d2, cifval; Triplets *triplets; triplets = (Triplets *) cdata; r2 = triplets->r2; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; if(npts == 0) return((double) 1.0); neighbour = triplets->neighbour; Nmax = triplets->Nmax; N = 0; /* compile list of neighbours */ for(j=0; j < npts; j++) { if(j != ix) { d2 = dist2either(u,v,x[j],y[j],triplets->period); if(d2 < r2) { /* add j to list of neighbours of current point */ if(N >= Nmax) { /* storage space overflow: reallocate */ Nmore = 2 * Nmax; triplets->neighbour = neighbour = (int *) S_realloc((char *) triplets->neighbour, Nmore, Nmax, sizeof(int)); triplets->Nmax = Nmax = Nmore; } neighbour[N] = j; N++; } } } /* count r-close (ordered) pairs of neighbours */ kount = 0; if(N > 1) { N1 = N - 1; for(j = 0; j < N1; j++) { nj = neighbour[j]; for(k = j+1; k < N; k++) { nk = neighbour[k]; if(nj != nk) { d2 = dist2either(x[nj],y[nj],x[nk],y[nk],triplets->period); if(d2 < r2) kount++; } } } } if(triplets->hard) { if(kount > 0) cifval = 0.0; else cifval = 1.0; } else cifval = exp((triplets->loggamma) * kount); #ifdef MHDEBUG Rprintf("triplet count=%d cif=%lf\n", kount, cifval); #endif return cifval; } Cifns TripletsCifns = { &tripletsinit, &tripletscif, (updafunptr) NULL, NO}; spatstat.random/src/rcauchy.c0000644000176200001440000000143514356000564015773 0ustar liggesusers/* rcauchy.c $Revision: 1.1 $ $Date: 2023/01/06 10:48:26 $ Generate realisation of stationary Cluster cluster process in a disc D Baddeley-Chang hybrid algorithm Parameter: scale = sqrt(eta2)/2 eta2 = 4 * scale^2 Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include /* debug activated if this is #defined */ #undef BUGGER /* macros used */ #undef FNAME #undef SAVEPARENTS /* return offspring, parents and offspring-parent map */ #define FNAME rcauchyAll #define SAVEPARENTS #include "rcauchy.h" #undef FNAME #undef SAVEPARENTS /* return offspring only */ #define FNAME rcauchyOff #undef SAVEPARENTS #include "rcauchy.h" spatstat.random/src/dgs.c0000755000176200001440000000475014325152137015120 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" #include "constants.h" /* Conditional intensity computation for Diggle-Gates-Stibbard process */ /* Conditional intensity function for a pairwise interaction point process with interaction function as given by e(t) = sin^2(pi*t/2*rho) for t < rho = 1 for t >= rho (See page 767 of Diggle, Gates, and Stibbard, Biometrika vol. 74, 1987, pages 763 -- 770.) */ #define PION2 M_PI_2 /* pi/2 defined in Rmath.h */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Dgs { double rho; double rho2; double pion2rho; double *period; int per; } Dgs; /* initialiser function */ Cdata *dgsinit(State state, Model model, Algor algo) { Dgs *dgs; /* allocate storage */ dgs = (Dgs *) R_alloc(1, sizeof(Dgs)); /* Interpret model parameters*/ dgs->rho = model.ipar[0]; dgs->period = model.period; /* constants */ dgs->rho2 = pow(dgs->rho, 2); dgs->pion2rho = PION2/dgs->rho; /* periodic boundary conditions? */ dgs->per = (model.period[0] > 0.0); return((Cdata *) dgs); } /* conditional intensity evaluator */ double dgscif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double d2, r2, pairprod, cifval; Dgs *dgs; DECLARE_CLOSE_D2_VARS; dgs = (Dgs *) cdata; r2 = dgs->rho2; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; cifval = pairprod = 1.0; if(npts == 0) return(cifval); ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(dgs->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],dgs->period,r2,d2)) pairprod *= sin(dgs->pion2rho * sqrt(d2)); } } if(ixp1 < npts) { for(j=ixp1; jperiod,r2,d2)) pairprod *= sin(dgs->pion2rho * sqrt(d2)); } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], r2, d2)) pairprod *= sin(dgs->pion2rho * sqrt(d2)); } } if(ixp1 < npts) { for(j=ixp1; jpion2rho * sqrt(d2)); } } } /* sin to sin^2 */ cifval = pairprod * pairprod; return cifval; } Cifns DgsCifns = { &dgsinit, &dgscif, (updafunptr) NULL, NO}; spatstat.random/src/mhloop.h0000755000176200001440000003261314325152137015645 0ustar liggesusers /* mhloop.h This file contains the iteration loop for the Metropolis-Hastings algorithm methas.c It is #included several times in methas.c with different #defines for the following variables MH_MARKED whether the simulation is marked (= the variable 'marked' is TRUE) MH_SINGLE whether there is a single interaction (as opposed to a hybrid of several interactions) MH_TEMPER whether tempering is applied MH_TRACKING whether to save transition history MH_DEBUG whether to print debug information MH_SNOOP whether to run visual debugger $Revision: 1.24 $ $Date: 2021/12/24 04:27:36 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifndef MH_DEBUG #define MH_DEBUG NO #endif /* ..... Pre-processing: recursively delete illegal/improbable points ..... */ nfree = state.npts - algo.ncond; /* number of 'free' points */ if(thinstart && nfree > 0) { nsuspect = nfree; while(nsuspect > 0) { /* scan for illegal points */ ix = state.npts - nsuspect; deathprop.ix = ix; deathprop.u = state.x[ix]; deathprop.v = state.y[ix]; #if MH_MARKED deathprop.mrk = state.marks[ix]; #endif #if MH_DEBUG #if MH_MARKED Rprintf("[mhloop]\t check legality of point %d = (%lf, %lf) with mark %d\n", ix, deathprop.u, deathprop.v, deathprop.mrk); #else Rprintf("[mhloop]\t check legality of point %d = (%lf, %lf)\n", ix, deathprop.u, deathprop.v); #endif #endif /* evaluate conditional intensity without trend terms */ #if MH_SINGLE adenom = (*(thecif.eval))(deathprop, state, thecdata); #else adenom = 1.0; for(k = 0; k < Ncif; k++) adenom *= (*(cif[k].eval))(deathprop, state, cdata[k]); #endif #if MH_TEMPER adenom = pow(adenom, invtemp); #endif #if MH_DEBUG Rprintf("[mhloop]\t cif = %lf\n", adenom); #endif /* accept/reject */ if(unif_rand() >= adenom) { #if MH_DEBUG Rprintf("[mhloop]\t deleting illegal/improbable point\n"); #endif /* delete point x[ix], y[ix] */ if(mustupdate) { /* Update auxiliary variables first */ #if MH_SINGLE (*(thecif.update))(state, deathprop, thecdata); #else for(k = 0; k < Ncif; k++) { if(needupd[k]) (*(cif[k].update))(state, deathprop, cdata[k]); } #endif } state.npts--; nfree--; #if MH_DEBUG Rprintf("[mhloop]\t deleting point %d\n", ix); Rprintf("\t\tnpts=%d\n", state.npts); #endif if(ix < state.npts) { for(j = ix; j < state.npts; j++) { state.x[j] = state.x[j+1]; state.y[j] = state.y[j+1]; #if MH_MARKED state.marks[j] = state.marks[j+1]; #endif } } } nsuspect--; } } /* ............... MAIN ITERATION LOOP ............................. */ OUTERCHUNKLOOP(irep, algo.nrep, maxchunk, 1024) { R_CheckUserInterrupt(); INNERCHUNKLOOP(irep, algo.nrep, maxchunk, 1024) { #if MH_DEBUG Rprintf("\n\n\n [mhloop] >>>>>>>>>>> iteration %d <<<<<<<<<<<<<<< \n", irep); #endif if(verb) { /* print progress message every nverb iterations */ iverb = irep + 1 + algo.nrep0; if((iverb % algo.nverb) == 0) Rprintf("iteration %d\n", iverb); } itype = REJECT; nfree = state.npts - algo.ncond; /* number of 'free' points */ /* ................ generate proposal ..................... */ /* Shift or birth/death: */ if(unif_rand() > algo.p) { #if MH_DEBUG Rprintf("[mhloop]\t propose birth or death\n"); #endif /* Birth/death: */ if(unif_rand() > algo.q) { /* Propose birth: */ birthprop.u = xpropose[irep]; birthprop.v = ypropose[irep]; #if MH_MARKED birthprop.mrk = mpropose[irep]; #endif #if MH_DEBUG #if MH_MARKED Rprintf("[mhloop]\t propose birth at (%lf, %lf) with mark %d\n", birthprop.u, birthprop.v, birthprop.mrk); #else Rprintf("[mhloop]\t propose birth at (%lf, %lf)\n", birthprop.u, birthprop.v); #endif #endif /* evaluate conditional intensity */ #if MH_MARKED betavalue = model.beta[birthprop.mrk]; #endif #if MH_SINGLE anumer = betavalue * (*(thecif.eval))(birthprop, state, thecdata); #else anumer = betavalue; for(k = 0; k < Ncif; k++) anumer *= (*(cif[k].eval))(birthprop, state, cdata[k]); #endif #if MH_TEMPER anumer = pow(anumer, invtemp); #endif adenom = qnodds*(nfree+1); #if MH_DEBUG Rprintf("[mhloop]\t cif = %lf, Hastings ratio = %lf\n", anumer, anumer/adenom); #endif /* accept/reject */ if(unif_rand() * adenom < anumer) { itype = BIRTH; /* Birth proposal accepted. */ #if MH_DEBUG Rprintf("[mhloop]\t accept birth\n"); } else { Rprintf("[mhloop]\t reject birth\n"); #endif } #if MH_SNOOP /* visual debugger */ #if MH_DEBUG Rprintf("[mhloop]\t Entering visual debugger with birth proposal\n"); #endif mhsnoop(&snooper, irep, &algo, &state, &birthprop, anumer, adenom, &itype); #if MH_DEBUG Rprintf("[mhloop]\t Exited visual debugger with itype=%d\n", itype); #endif #endif #if MH_TRACKING /* save transition history */ if(irep < history.nmax) { history.n++; history.proptype[irep] = BIRTH; history.accepted[irep] = (itype == REJECT) ? 0 : 1; #ifdef HISTORY_INCLUDES_RATIO history.numerator[irep] = anumer; history.denominator[irep] = adenom; #endif } #endif } else if(nfree > 0) { /* Propose death: */ ix = floor(nfree * unif_rand()); if(ix < 0) ix = 0; ix = algo.ncond + ix; if(ix >= state.npts) ix = state.npts - 1; deathprop.ix = ix; deathprop.u = state.x[ix]; deathprop.v = state.y[ix]; #if MH_MARKED deathprop.mrk = state.marks[ix]; #endif #if MH_DEBUG #if MH_MARKED Rprintf("[mhloop]\t propose death of point %d = (%lf, %lf) with mark %d\n", ix, deathprop.u, deathprop.v, deathprop.mrk); #else Rprintf("[mhloop]\t propose death of point %d = (%lf, %lf)\n", ix, deathprop.u, deathprop.v); #endif #endif /* evaluate conditional intensity */ #if MH_MARKED betavalue = model.beta[deathprop.mrk]; #endif #if MH_SINGLE adenom = betavalue * (*(thecif.eval))(deathprop, state, thecdata); #else adenom = betavalue; for(k = 0; k < Ncif; k++) adenom *= (*(cif[k].eval))(deathprop, state, cdata[k]); #endif #if MH_TEMPER adenom = pow(adenom, invtemp); #endif anumer = qnodds * nfree; #if MH_DEBUG Rprintf("[mhloop]\t cif = %lf, Hastings ratio = %lf\n", adenom, anumer/adenom); #endif /* accept/reject */ if(unif_rand() * adenom < anumer) { itype = DEATH; /* Death proposal accepted. */ #if MH_DEBUG Rprintf("[mhloop]\t accept death\n"); } else { Rprintf("[mhloop]\t reject death\n"); #endif } #if MH_SNOOP /* visual debug */ #if MH_DEBUG Rprintf("[mhloop]\t Entering visual debugger with death proposal\n"); #endif mhsnoop(&snooper, irep, &algo, &state, &deathprop, anumer, adenom, &itype); #if MH_DEBUG Rprintf("[mhloop]\t Exited visual debugger with itype=%d\n", itype); #endif #endif #if MH_TRACKING /* save transition history */ if(irep < history.nmax) { history.n++; history.proptype[irep] = DEATH; history.accepted[irep] = (itype == REJECT) ? 0 : 1; #ifdef HISTORY_INCLUDES_RATIO history.numerator[irep] = anumer; history.denominator[irep] = adenom; #endif } #endif #if MH_DEBUG } else { Rprintf("[mhloop] death proposal selected, but no points to delete\n"); #endif } } else if(nfree > 0) { /* Propose shift: */ /* point to be shifted */ ix = floor(nfree * unif_rand()); if(ix < 0) ix = 0; ix = algo.ncond + ix; if(ix >= state.npts) ix = state.npts - 1; deathprop.ix = ix; deathprop.u = state.x[ix]; deathprop.v = state.y[ix]; #if MH_MARKED deathprop.mrk = state.marks[ix]; #endif /* where to shift */ permitted = YES; shiftprop.ix = ix; shiftprop.u = xpropose[irep]; shiftprop.v = ypropose[irep]; #if MH_MARKED shiftprop.mrk = mpropose[irep]; if(algo.fixall) permitted = (shiftprop.mrk == deathprop.mrk); #endif #if MH_DEBUG #if MH_MARKED Rprintf("[mhloop]\t propose shift of point %d = (%lf, %lf)[mark %d] to (%lf, %lf)[mark %d]\n", ix, deathprop.u, deathprop.v, deathprop.mrk, shiftprop.u, shiftprop.v, shiftprop.mrk); #else Rprintf("[mhloop]\t propose shift of point %d = (%lf, %lf) to (%lf, %lf)\n", ix, deathprop.u, deathprop.v, shiftprop.u, shiftprop.v); #endif #endif /* evaluate cif in two stages */ cvn = cvd = 1.0; if(permitted) { #if MH_SINGLE cvn = (*(thecif.eval))(shiftprop, state, thecdata); if(cvn > 0.0) { cvd = (*(thecif.eval))(deathprop, state, thecdata); } else { permitted = NO; } #else for(k = 0; k < Ncif; k++) { cvn *= (*(cif[k].eval))(shiftprop, state, cdata[k]); if(cvn > 0.0) { cvd *= (*(cif[k].eval))(deathprop, state, cdata[k]); } else { permitted = NO; break; } } #endif } if(permitted) { #if MH_MARKED cvn *= model.beta[shiftprop.mrk]; cvd *= model.beta[deathprop.mrk]; #endif #if MH_TEMPER cvn = pow(cvn, invtemp); cvd = pow(cvd, invtemp); #endif #if MH_DEBUG Rprintf("[mhloop]\t cif[old] = %lf, cif[new] = %lf, Hastings ratio = %lf\n", cvd, cvn, cvn/cvd); #endif /* accept/reject */ if(unif_rand() * cvd < cvn) { itype = SHIFT; /* Shift proposal accepted . */ #if MH_DEBUG Rprintf("[mhloop]\t accept shift\n"); } else { Rprintf("[mhloop]\t reject shift\n"); #endif } } else { cvn = 0.0; cvd = 1.0; #if MH_DEBUG Rprintf("[mhloop]\t Forbidden shift"); #endif } #if MH_SNOOP /* visual debug */ #if MH_DEBUG Rprintf("[mhloop]\t Entering visual debugger with shift proposal\n"); #endif mhsnoop(&snooper, irep, &algo, &state, &shiftprop, cvn, cvd, &itype); #if MH_DEBUG Rprintf("[mhloop]\t Exited visual debugger with itype=%d\n", itype); #endif #endif #if MH_TRACKING /* save transition history */ if(irep < history.nmax) { history.n++; history.proptype[irep] = SHIFT; history.accepted[irep] = (itype == REJECT) ? 0 : 1; #ifdef HISTORY_INCLUDES_RATIO history.numerator[irep] = cvn; history.denominator[irep] = cvd; #endif } #endif } if(itype != REJECT) { /* ....... implement the transition ............ */ if(itype == BIRTH) { /* Birth transition */ /* add point at (u,v) */ #if MH_DEBUG #if MH_MARKED Rprintf("[mhloop]\t implementing birth at (%lf, %lf) with mark %d\n", birthprop.u, birthprop.v, birthprop.mrk); #else Rprintf("[mhloop]\t implementing birth at (%lf, %lf)\n", birthprop.u, birthprop.v); #endif #endif if(state.npts + 1 > state.npmax) { #if MH_DEBUG Rprintf("!!!!!!!!!!! storage overflow !!!!!!!!!!!!!!!!!\n"); #endif /* storage overflow; allocate more storage */ Nmore = 2 * state.npmax; state.x = (double *) S_realloc((char *) state.x, Nmore, state.npmax, sizeof(double)); state.y = (double *) S_realloc((char *) state.y, Nmore, state.npmax, sizeof(double)); #if MH_MARKED state.marks = (int *) S_realloc((char *) state.marks, Nmore, state.npmax, sizeof(int)); #endif state.npmax = Nmore; /* call the initialiser again, to allocate additional space */ #if MH_SINGLE thecdata = (*(thecif.init))(state, model, algo); #else model.ipar = iparvector; for(k = 0; k < Ncif; k++) { if(k > 0) model.ipar += plength[k-1]; cdata[k] = (*(cif[k].init))(state, model, algo); } #endif #if MH_DEBUG Rprintf("........... storage extended .................\n"); #endif } if(mustupdate) { /* Update auxiliary variables first */ #if MH_SINGLE (*(thecif.update))(state, birthprop, thecdata); #else for(k = 0; k < Ncif; k++) { if(needupd[k]) (*(cif[k].update))(state, birthprop, cdata[k]); } #endif } /* Now add point */ state.x[state.npts] = birthprop.u; state.y[state.npts] = birthprop.v; #if MH_MARKED state.marks[state.npts] = birthprop.mrk; #endif state.npts = state.npts + 1; #if MH_DEBUG Rprintf("[mhloop]\t \tnpts=%d\n", state.npts); #endif } else if(itype==DEATH) { /* Death transition */ /* delete point x[ix], y[ix] */ if(mustupdate) { /* Update auxiliary variables first */ #if MH_SINGLE (*(thecif.update))(state, deathprop, thecdata); #else for(k = 0; k < Ncif; k++) { if(needupd[k]) (*(cif[k].update))(state, deathprop, cdata[k]); } #endif } ix = deathprop.ix; state.npts = state.npts - 1; #if MH_DEBUG Rprintf("[mhloop]\t implementing death of point %d\n", ix); Rprintf("[mhloop]\t\tnpts=%d\n", state.npts); #endif if(ix < state.npts) { for(j = ix; j < state.npts; j++) { state.x[j] = state.x[j+1]; state.y[j] = state.y[j+1]; #if MH_MARKED state.marks[j] = state.marks[j+1]; #endif } } } else { /* Shift transition */ /* Shift (x[ix], y[ix]) to (u,v) */ #if MH_DEBUG #if MH_MARKED Rprintf("[mhloop]\t implementing shift from %d = (%lf, %lf)[%d] to (%lf, %lf)[%d]\n", deathprop.ix, deathprop.u, deathprop.v, deathprop.mrk, shiftprop.u, shiftprop.v, shiftprop.mrk); #else Rprintf("[mhloop]\t implementing shift from %d = (%lf, %lf) to (%lf, %lf)\n", deathprop.ix, deathprop.u, deathprop.v, shiftprop.u, shiftprop.v); Rprintf("[mhloop]\t\tnpts=%d\n", state.npts); #endif #endif if(mustupdate) { /* Update auxiliary variables first */ #if MH_SINGLE (*(thecif.update))(state, shiftprop, thecdata); #else for(k = 0; k < Ncif; k++) { if(needupd[k]) (*(cif[k].update))(state, shiftprop, cdata[k]); } #endif } ix = shiftprop.ix; state.x[ix] = shiftprop.u; state.y[ix] = shiftprop.v; #if MH_MARKED state.marks[ix] = shiftprop.mrk; #endif } #if MH_DEBUG } else { Rprintf("[mhloop]\t No transition\n"); #endif } } } spatstat.random/src/hardcore.c0000755000176200001440000000400114325152137016117 0ustar liggesusers#include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Hard core process */ /* Storage of parameters and precomputed/auxiliary data */ typedef struct Hardcore { double h; /* hard core distance */ double h2; double *period; int per; } Hardcore; /* initialiser function */ Cdata *hardcoreinit(State state, Model model, Algor algo) { Hardcore *hardcore; double h; hardcore = (Hardcore *) R_alloc(1, sizeof(Hardcore)); /* Interpret model parameters*/ hardcore->h = h = model.ipar[0]; hardcore->h2 = h * h; hardcore->period = model.period; /* periodic boundary conditions? */ hardcore->per = (model.period[0] > 0.0); return((Cdata *) hardcore); } /* conditional intensity evaluator */ double hardcorecif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double h2, a; Hardcore *hardcore; hardcore = (Hardcore *) cdata; h2 = hardcore->h2; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; if(npts == 0) return((double) 1.0); ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(hardcore->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(dist2thresh(u,v,x[j],y[j],hardcore->period, h2)) return((double) 0.0); } } if(ixp1 < npts) { for(j=ixp1; jperiod, h2)) return((double) 0.0); } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { a = h2 - pow(u - x[j], 2); if(a > 0) { a -= pow(v - y[j], 2); if(a > 0) return((double) 0.0); } } } if(ixp1 < npts) { for(j=ixp1; j 0) { a -= pow(v - y[j], 2); if(a > 0) return((double) 0.0); } } } } return ((double) 1.0); } Cifns HardcoreCifns = { &hardcoreinit, &hardcorecif, (updafunptr) NULL, NO}; spatstat.random/src/PerfectStrauss.h0000755000176200001440000002156414325152137017327 0ustar liggesusers // ........................... Strauss process .......................... // $Revision: 1.6 $ $Date: 2020/05/12 03:32:45 $ class StraussProcess : public PointProcess { public: double beta, gamma, R, Rsquared; StraussProcess(double xmin, double xmax, double ymin, double ymax, double b, double g, double Ri); ~StraussProcess(){} void NewEvent(double *x, double *y, char *InWindow); void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP); double Interaction(double dsquared); // void CalcBeta(long int xsidepomm, long int ysidepomm, // double *betapomm); // void CheckBeta(long int xsidepomm, long int ysidepomm, // double *betapomm); // double lnCondInt(struct Point2 *TempCell, Point2Pattern *p2p); // void Beta(struct Point2 *TempCell); // void CalcBeta(Point2Pattern *p2p); }; StraussProcess::StraussProcess(double xmin, double xmax, double ymin, double ymax, double b, double g, double Ri) : PointProcess(xmin, xmax, ymin, ymax){ beta = b; gamma = g; R = Ri; Rsquared = R * R; InteractionRange = R; TotalBirthRate = beta*(xmax-xmin)*(ymax-ymin); } double StraussProcess::Interaction(double dsquared) { double rtn; rtn = 1; if(dsquared < Rsquared) rtn = gamma; return(rtn); } void StraussProcess::NewEvent(double *x, double *y, char *InWindow) { double Xdim, Ydim; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; *x = slumptal()*Xdim+Xmin; *y = slumptal()*Ydim+Ymin; *InWindow = 1; } void StraussProcess::GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP) { int i; double xtemp, ytemp, L, Xdim, Ydim; struct Point *TempPoint; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; L = beta*Xdim*Ydim; *GeneratedPoints = poisson(L); *LivingPoints = *GeneratedPoints; for (i=1; i<=*GeneratedPoints ; i++){ //Rprintf("Generating StraussProcess Poisson 3\n"); //scanf("%f",&f1); xtemp = slumptal()*Xdim+Xmin; ytemp = slumptal()*Ydim+Ymin; // //Rprintf("Generating StraussProcess Poisson 3.2\n"); TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = i; TempPoint->R = slumptal(); //Rprintf("Generating StraussProcess Poisson 3.6\n"); TempPoint->next = headPoint->next; headPoint->next = TempPoint; *NoP = *NoP + 1; } } //void StraussProcess::CalcBeta(long int xsidepomm, long int ysidepomm, // double *betapomm){ // long int i,j,k; // k=0; // // Rprintf("\ndiagnostic message: Strauss CalcBeta... %ld %ld\n",xsidepomm,ysidepomm); // for(i=0; ibeta; // k++; // } // } //} //void StraussProcess::CheckBeta(long int xsidepomm, long int ysidepomm, // double *betapomm){ // long int i,j,k; // // double d1; // k=0; // // Rprintf("\ndiagnostic message: Strauss CalcBeta... %ld %ld\n",xsidepomm,ysidepomm); // for(i=0; i0.001) && (k==0)){ // Rprintf("%f %f %f %ld %ld\n",fabs(*(betapomm + i*ysidepomm + j)- beta), // *(betapomm + i*ysidepomm + j),beta,i,j); // k++; // // scanf("%lf",&d1); // } // } // } //} //double StraussProcess::lnCondInt(struct Point2 *TempCell, // Point2Pattern *p2p){ // double f1; // long int xco,yco,xc,yc,fx,tx,fy,ty,ry,rx,k; // double dy,dx, lnCI,dst2; // struct Point2 *TempCell2; // // f1 = (TempCell->X-p2p->Xmin)/p2p->XCellDim; xc = int(f1); // CLAMP(xc, 0, p2p->MaxXCell, "xc"); // f1 = (TempCell->Y-p2p->Ymin)/p2p->YCellDim; yc = int(f1); // CLAMP(yc, 0, p2p->MaxYCell, "yc"); // // dx = (Xmax-Xmin)/(double(p2p->MaxXCell+1)); // dy = (Ymax-Ymin)/(double(p2p->MaxYCell+1)); // rx = int(this->InteractionRange/dx+1.0); // ry = int(this->InteractionRange/dy+1.0); // // lnCI = log(TempCell->Beta); // // k = 0; // // if((xc+rx)<=p2p->MaxXCell) tx=xc+rx; else tx = p2p->MaxXCell; // if((yc+ry)<=p2p->MaxYCell) ty=yc+ry; else ty = p2p->MaxYCell; // if((xc-rx)>=0) fx=xc-rx; else fx = 0; // if((yc-ry)>=0) fy=yc-ry; else fy = 0; // // //Rprintf("MCI! %d %d %d %d\n",fx,tx,fy,ty); // // for(xco = fx; xco <= tx; xco++){ // for(yco = fy; yco <= ty; yco++){ // CHECK(p2p->headCell[xco][yco], // "internal error: p2p->headCell[xco][yco] is null in lnCondInt()"); // TempCell2 = p2p->headCell[xco][yco]->next; // CHECK(TempCell2, "internal error: TempCell2 is null in lnCondInt()"); // while(TempCell2!=TempCell2->next){ // if(TempCell2 != TempCell){ // k++; // dst2 = pow(TempCell->X-TempCell2->X,2)+ // pow(TempCell->Y-TempCell2->Y,2); // lnCI += log(Interaction(dst2)); // } // TempCell2 = TempCell2->next; // CHECK(TempCell2, // "internal error: TempCell2 is null in lnCondInt() loop"); // } // } // } // return(lnCI); //} //void StraussProcess::Beta(struct Point2 *TempCell){ // TempCell->Beta = beta; //} //void StraussProcess::CalcBeta(Point2Pattern *p2p){ // long int xco,yco; // // double dy,dx; // struct Point2 *TempMother; // // for(xco = 0; xco <= p2p->MaxXCell; xco++){ // for(yco = 0; yco <= p2p->MaxYCell; yco++){ // CHECK(p2p->headCell[xco][yco], // "internal error: p2p->headCell[xco][yco] is null in CalcBeta()"); // TempMother = p2p->headCell[xco][yco]->next; // CHECK(TempMother, "internal error: TempMother is null in CalcBeta()"); // while(TempMother!=TempMother->next){ // TempMother->Beta = this->beta; // TempMother = TempMother->next; // CHECK(TempMother, // "internal error: TempMother is null in CalcBeta() loop"); // } // } // } //} // ........................... Interface to R .......................... extern "C" { SEXP PerfectStrauss(SEXP beta, SEXP gamma, SEXP r, SEXP xrange, SEXP yrange) { // input parameters double Beta, Gamma, R, Xmin, Xmax, Ymin, Ymax; double *Xrange, *Yrange; // internal int xcells, ycells; long int EndTime, StartTime; // output int noutmax; SEXP xout, yout, nout, out; double *xx, *yy; int *nn; SEXP stout, etout; int *ss, *ee; // protect arguments from garbage collector PROTECT(beta = AS_NUMERIC(beta)); PROTECT(gamma = AS_NUMERIC(gamma)); PROTECT(r = AS_NUMERIC(r)); PROTECT(xrange = AS_NUMERIC(xrange)); PROTECT(yrange = AS_NUMERIC(yrange)); // that's 5 protected objects // extract arguments // model parameters Beta = *(NUMERIC_POINTER(beta)); Gamma = *(NUMERIC_POINTER(gamma)); R = *(NUMERIC_POINTER(r)); // window Xrange = NUMERIC_POINTER(xrange); Xmin = Xrange[0]; Xmax = Xrange[1]; Yrange = NUMERIC_POINTER(yrange); Ymin = Yrange[0]; Ymax = Yrange[1]; // compute cell array size xcells = (int) floor((Xmax-Xmin)/ R); if(xcells > 9) { xcells = 9; } else if(xcells < 1) { xcells = 1; } ycells = (int) floor((Ymax-Ymin)/ R); if(ycells > 9) { ycells = 9; } else if(ycells < 1) { ycells = 1; } #ifdef DBGS Rprintf("xcells %d ycells %d\n",xcells,ycells); Rprintf("Initialising\n"); #endif // Initialise Strauss point process StraussProcess ExampleProcess(Xmin,Xmax,Ymin,Ymax, Beta, Gamma, R); // Initialise point pattern Point2Pattern ExamplePattern(Xmin,Xmax,Ymin,Ymax, xcells, ycells); // parameters: min x, max x, min y, max y, "cells" in x and y direction // used for speeding up neighbour counting, 9 is max here #ifdef DBGS Rprintf("Initialisation complete\n"); #endif // Synchronise random number generator GetRNGstate(); // Initialise perfect sampler Sampler PerfectSampler(&ExampleProcess); // Perform perfect sampling PerfectSampler.Sim(&ExamplePattern, &StartTime, &EndTime); // Synchronise random number generator PutRNGstate(); // Get upper estimate of number of points noutmax = ExamplePattern.UpperCount() + 1; // Allocate space for output PROTECT(xout = NEW_NUMERIC(noutmax)); PROTECT(yout = NEW_NUMERIC(noutmax)); PROTECT(nout = NEW_INTEGER(1)); PROTECT(stout = NEW_INTEGER(1)); PROTECT(etout = NEW_INTEGER(1)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); nn = INTEGER_POINTER(nout); ss = INTEGER_POINTER(stout); ee = INTEGER_POINTER(etout); // copy data into output storage ExamplePattern.Return(xx, yy, nn, noutmax); *ss = StartTime; *ee = EndTime; // pack up into output list PROTECT(out = NEW_LIST(5)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, nout); SET_VECTOR_ELT(out, 3, stout); SET_VECTOR_ELT(out, 4, etout); // return UNPROTECT(11); // 5 arguments plus xout, yout, nout, stout, etout, out return(out); } } spatstat.random/src/mhsnoop.h0000755000176200001440000000065114325152137016027 0ustar liggesusers/* Function declarations from mhsnoop.c $Revision: 1.5 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include "mhsnoopdef.h" void initmhsnoop(Snoop *s, SEXP env); void mhsnoop(Snoop *s, int irep, Algor *algo, State *state, Propo *prop, double numer, double denom, int *itype); spatstat.random/src/mhv4.h0000755000176200001440000000055214164500132015213 0ustar liggesusers/* mhv4.h visual debugger or not Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef MH_SNOOP if(snooper.active) { /* visual debugger */ #define MH_SNOOP YES #include "mhv5.h" #undef MH_SNOOP } else { /* no visual debugger */ #define MH_SNOOP NO #include "mhv5.h" #undef MH_SNOOP } spatstat.random/src/penttinen.c0000755000176200001440000000572114325152137016346 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" #include "constants.h" /* Conditional intensity computation for Penttinen process */ /* Format for storage of parameters and precomputed/auxiliary data */ typedef struct Penttinen { double gamma; double r; double loggamma; double reach2; double *period; int hard; int per; } Penttinen; /* initialiser function */ Cdata *penttineninit(State state, Model model, Algor algo) { /* create storage for model parameters */ Penttinen *penttinen; penttinen = (Penttinen *) R_alloc(1, sizeof(Penttinen)); /* Interpret model parameters*/ penttinen->gamma = model.ipar[0]; penttinen->r = model.ipar[1]; penttinen->reach2 = 4.0 * penttinen->r * penttinen->r; penttinen->period = model.period; #ifdef MHDEBUG Rprintf("Initialising Penttinen gamma=%lf, r=%lf\n", penttinen->gamma, penttinen->r); #endif /* is the model numerically equivalent to hard core ? */ penttinen->hard = (penttinen->gamma < DBL_EPSILON); penttinen->loggamma = (penttinen->hard) ? 0 : log(penttinen->gamma); /* periodic boundary conditions? */ penttinen->per = (model.period[0] > 0.0); return((Cdata *) penttinen); } /* conditional intensity evaluator */ double penttinencif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *x, *y; double u, v; double d2, reach2, z, z2, logpot, cifval; Penttinen *penttinen; DECLARE_CLOSE_D2_VARS; penttinen = (Penttinen *) cdata; reach2 = penttinen->reach2; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; if(npts == 0) return((double) 1.0); logpot = 0.0; ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(penttinen->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC_D2(u,v,x[j],y[j],penttinen->period,reach2,d2)) { z2 = d2/reach2; z = sqrt(z2); if(z < 1.0) { logpot += acos(z) - z * sqrt(1 - z2); } } } } if(ixp1 < npts) { for(j=ixp1; jperiod,reach2,d2)) { z2 = d2/reach2; z = sqrt(z2); if(z < 1.0) { logpot += acos(z) - z * sqrt(1 - z2); } } } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_D2(u, v, x[j], y[j], reach2, d2)) { z2 = d2/reach2; z = sqrt(z2); if(z < 1.0) { logpot += acos(z) - z * sqrt(1 - z2); } } } } if(ixp1 < npts) { for(j=ixp1; jhard) { if(logpot > 0) cifval = 0.0; else cifval = 1.0; } else cifval = exp((penttinen->loggamma) * M_2_PI * logpot); return cifval; } Cifns PenttinenCifns = { &penttineninit, &penttinencif, (updafunptr) NULL, NO}; spatstat.random/src/rtruncpois.c0000644000176200001440000001652614364101623016551 0ustar liggesusers/* rtruncpois.c $Revision: 1.3 $ $Date: 2023/01/25 01:17:56 $ Generate random variate with zero-truncated Poisson distribution Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include /* ============== Functions for use in C code, to generate a single realisation =================== */ /* Names begin with 'r1' If used alone, these functions should be preceded by GetRNGState() and succeeded by PutRNGState() */ int r1nzpoisHarding( double lambda /* mean parameter */ ) { /* from a post by Ted Harding (2005) */ int x; lambda = lambda + log(runif(exp(-lambda), (double) 1.0)); if(lambda < 0.0) return((int) 1); x = 1 + rpois(lambda); return(x); } int r1nzpoisDalgaard( double lambda /* mean parameter */ ) { /* from a post by Peter Dalgaard (2005) in response to Harding */ int x; x = qpois(runif(exp(-lambda), (double) 1.0), lambda, (int) 1, (int) 0); return(x); } int r1truncpoisHarding( double lambda, /* mean parameter */ int k /* truncation value (minimum value of x) */ ) { /* Adrian Baddeley, after Harding (2005) */ int i, x; for(i = 0; i < k; i++) { lambda = lambda + log(runif(exp(-lambda), (double) 1.0)); if(lambda < 0.0) { return(k); } } x = k + rpois(lambda); return(x); } int r1truncpoisDalgaard( double lambda, /* mean parameter */ int k /* truncation value (minimum value of x) */ ) { /* Adrian Baddeley, after Dalgaard (2005) */ double pk; int x; pk = ppois(k-1, lambda, (int) 1, (int) 0); x = qpois(runif(pk, (double) 1.0), lambda, (int) 1, (int) 0); return(x); } /* ============ Interface to R, with efficiencies ================ */ /* Names begin with 'Rr' */ SEXP RrnzpoisHarding(SEXP N, SEXP LAMBDA) { int n, i, nlambda; double *lambdavector; double lambda, lambdadash, expmlam; SEXP y; int *yp; PROTECT(N = AS_INTEGER(N)); PROTECT(LAMBDA = AS_NUMERIC(LAMBDA)); GetRNGstate(); n = *(INTEGER_POINTER(N)); lambdavector = NUMERIC_POINTER(LAMBDA); nlambda = LENGTH(LAMBDA); PROTECT(y = NEW_INTEGER(n)); yp = INTEGER_POINTER(y); if(nlambda == 1) { /* common value of lambda */ lambda = lambdavector[0]; expmlam = exp(-lambda); for(i = 0; i < n; i++) { lambdadash = lambda + log(runif(expmlam, (double) 1.0)); yp[i] = 1 + rpois(lambdadash); } } else { /* vector of lambda values */ for(i = 0; i < n; i++) { lambda = lambdavector[i]; lambdadash = lambda + log(runif(exp(-lambda), (double) 1.0)); yp[i] = 1 + rpois(lambdadash); } } PutRNGstate(); UNPROTECT(3); return(y); } SEXP RrnzpoisDalgaard(SEXP N, SEXP LAMBDA) { int n, i, nlambda; double *lambdavector; double lambda, expmlam; SEXP y; int *yp; PROTECT(N = AS_INTEGER(N)); PROTECT(LAMBDA = AS_NUMERIC(LAMBDA)); GetRNGstate(); n = *(INTEGER_POINTER(N)); lambdavector = NUMERIC_POINTER(LAMBDA); nlambda = LENGTH(LAMBDA); PROTECT(y = NEW_INTEGER(n)); yp = INTEGER_POINTER(y); if(nlambda == 1) { /* common value of lambda */ lambda = lambdavector[0]; expmlam = exp(-lambda); for(i = 0; i < n; i++) { yp[i] = qpois(runif(expmlam, (double) 1.0), lambda, (int) 1, (int) 0); } } else { /* vector of lambda values */ for(i = 0; i < n; i++) { lambda = lambdavector[i]; yp[i] = qpois(runif(exp(-lambda), (double) 1.0), lambda, (int) 1, (int) 0); } } PutRNGstate(); UNPROTECT(3); return(y); } SEXP RrtruncpoisHarding(SEXP N, SEXP LAMBDA, SEXP TRUNC) { int n, i, k, nlambda, ntrunc; double *lambdavector; int *truncvector; int trunc; double lambda; SEXP y; int *yp; PROTECT(N = AS_INTEGER(N)); PROTECT(LAMBDA = AS_NUMERIC(LAMBDA)); PROTECT(TRUNC = AS_INTEGER(TRUNC)); GetRNGstate(); n = *(INTEGER_POINTER(N)); lambdavector = NUMERIC_POINTER(LAMBDA); truncvector = INTEGER_POINTER(TRUNC); nlambda = LENGTH(LAMBDA); ntrunc = LENGTH(TRUNC); PROTECT(y = NEW_INTEGER(n)); yp = INTEGER_POINTER(y); lambda = lambdavector[0]; trunc = truncvector[0]; if(nlambda == 1 && ntrunc == 1) { lambda = lambdavector[0]; trunc = truncvector[0]; for(i = 0; i < n; i++) { for(k = 0; k < trunc; k++) { lambda = lambda + log(runif(exp(-lambda), (double) 1.0)); if(lambda <= 0.0) { yp[i] = trunc; break; } } if(lambda > 0.0) yp[i] = trunc + rpois(lambda); } } else if(nlambda == 1 && ntrunc == n) { lambda = lambdavector[0]; for(i = 0; i < n; i++) { trunc = truncvector[i]; for(k = 0; k < trunc; k++) { lambda = lambda + log(runif(exp(-lambda), (double) 1.0)); if(lambda <= 0.0) { yp[i] = trunc; break; } } if(lambda > 0.0) yp[i] = trunc + rpois(lambda); } } else if(nlambda == n && ntrunc == 1) { trunc = truncvector[0]; for(i = 0; i < n; i++) { lambda = lambdavector[i]; for(k = 0; k < trunc; k++) { lambda = lambda + log(runif(exp(-lambda), (double) 1.0)); if(lambda <= 0.0) { yp[i] = trunc; break; } } if(lambda > 0.0) yp[i] = trunc + rpois(lambda); } } else if(nlambda == n && ntrunc == n) { for(i = 0; i < n; i++) { lambda = lambdavector[i]; trunc = truncvector[i]; for(k = 0; k < trunc; k++) { lambda = lambda + log(runif(exp(-lambda), (double) 1.0)); if(lambda <= 0.0) { yp[i] = trunc; break; } } if(lambda > 0.0) yp[i] = trunc + rpois(lambda); } } PutRNGstate(); UNPROTECT(4); return(y); } SEXP RrtruncpoisDalgaard(SEXP N, SEXP LAMBDA, SEXP TRUNC) { int n, i, nlambda, ntrunc; double *lambdavector; int *truncvector; int trunc; double lambda, ptrunc; SEXP y; int *yp; PROTECT(N = AS_INTEGER(N)); PROTECT(LAMBDA = AS_NUMERIC(LAMBDA)); PROTECT(TRUNC = AS_INTEGER(TRUNC)); GetRNGstate(); n = *(INTEGER_POINTER(N)); lambdavector = NUMERIC_POINTER(LAMBDA); truncvector = INTEGER_POINTER(TRUNC); nlambda = LENGTH(LAMBDA); ntrunc = LENGTH(TRUNC); PROTECT(y = NEW_INTEGER(n)); yp = INTEGER_POINTER(y); if(nlambda == 1 && ntrunc == 1) { lambda = lambdavector[0]; trunc = truncvector[0]; for(i = 0; i < n; i++) { ptrunc = ppois(trunc-1, lambda, (int) 1, (int) 0); yp[i] = qpois(runif(ptrunc, (double) 1.0), lambda, (int) 1, (int) 0); } } else if(nlambda == 1 && ntrunc == n) { lambda = lambdavector[0]; for(i = 0; i < n; i++) { trunc = truncvector[i]; ptrunc = ppois(trunc-1, lambda, (int) 1, (int) 0); yp[i] = qpois(runif(ptrunc, (double) 1.0), lambda, (int) 1, (int) 0); } } else if(nlambda == n && ntrunc == 1) { trunc = truncvector[0]; for(i = 0; i < n; i++) { lambda = lambdavector[i]; ptrunc = ppois(trunc-1, lambda, (int) 1, (int) 0); yp[i] = qpois(runif(ptrunc, (double) 1.0), lambda, (int) 1, (int) 0); } } else if(nlambda == n && ntrunc == n) { for(i = 0; i < n; i++) { lambda = lambdavector[i]; trunc = truncvector[i]; ptrunc = ppois(trunc-1, lambda, (int) 1, (int) 0); yp[i] = qpois(runif(ptrunc, (double) 1.0), lambda, (int) 1, (int) 0); } } PutRNGstate(); UNPROTECT(4); return(y); } spatstat.random/src/dist2.c0000755000176200001440000000424514325152137015367 0ustar liggesusers# include #include #include "yesno.h" /* dist2: squared distance in torus dist2thresh: faster code for testing whether dist2 < r2 dist2Mthresh: same as dist2thresh, but does not assume the points are within one period of each other. Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ double dist2( double u, double v, double x, double y, double *period) { double wide, high, dx, dy, dxp, dyp, a, b, d2; /* points are assumed to lie within one period of each other */ wide = period[0]; high = period[1]; dx = u - x; if(dx < 0.0) dx = -dx; dxp = wide - dx; a = (dx < dxp)? dx : dxp; dy = v - y; if(dy < 0.0) dy = -dy; dyp = high - dy; b = (dy < dyp)? dy : dyp; d2 = a * a + b * b; return d2; } double dist2either( double u, double v, double x, double y, double *period) { if(period[0] < 0.0) return pow(u-x,2) + pow(v-y,2); return(dist2(u,v,x,y,period)); } int dist2thresh( double u, double v, double x, double y, double *period, double r2) { double wide, high, dx, dy, dxp, dyp, a, b, residue; /* points are assumed to lie within one period of each other */ wide = period[0]; high = period[1]; dx = u - x; if(dx < 0.0) dx = -dx; dxp = wide - dx; a = (dx < dxp) ? dx : dxp; residue = r2 - a * a; if(residue <= 0.0) return NO; dy = v - y; if(dy < 0.0) dy = -dy; dyp = high - dy; b = (dy < dyp) ? dy : dyp; if (residue > b * b) return YES; return NO; } int dist2Mthresh( double u, double v, double x, double y, double *period, double r2) { double wide, high, dx, dy, dxp, dyp, a, b, residue; /* points are NOT assumed to lie within one period of each other */ wide = period[0]; high = period[1]; dx = u - x; if(dx < 0.0) dx = -dx; while(dx > wide) dx -= wide; dxp = wide - dx; a = (dx < dxp) ? dx : dxp; residue = r2 - a * a; if(residue < 0.0) return NO; dy = v - y; if(dy < 0.0) dy = -dy; while(dy > high) dy -= high; dyp = high - dy; b = (dy < dyp) ? dy : dyp; if (residue >= b * b) return YES; return NO; } spatstat.random/src/areaint.c0000755000176200001440000001623514531531170015764 0ustar liggesusers#include #include #include #include "methas.h" #include "dist2.h" /* Conditional intensity function for an area-interaction process: cif = eta^(1-B) where B = (uncovered area)/(pi r^2) Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #define NGRID 16 /* To explore serious bug, #define BADBUG */ #undef BADBUG /* Format for storage of parameters and precomputed/auxiliary data */ typedef struct AreaInt { /* model parameters */ double eta; double r; /* transformations of the parameters */ double r2; double range2; double logeta; int hard; /* periodic distance */ double *period; int per; /* grid counting */ double dx; double xgrid0; int *my; int kdisc; /* scratch space for saving list of neighbours */ int *neighbour; } AreaInt; /* initialiser function */ Cdata *areaintInit(State state, Model model, Algor algo) { double r, dx, dy, x0; int i, my, kdisc; AreaInt *areaint; /* create storage */ areaint = (AreaInt *) R_alloc(1, sizeof(AreaInt)); /* Interpret model parameters*/ areaint->eta = model.ipar[0]; areaint->r = r = model.ipar[1]; #ifdef BADBUG Rprintf("r = %lf\n", r); #endif areaint->r2 = r * r; areaint->range2 = 4 * r * r; /* square of interaction distance */ /* is the model numerically equivalent to hard core ? */ areaint->hard = (areaint->eta == 0.0); areaint->logeta = (areaint->hard) ? log(DBL_MIN) : log(areaint->eta); #ifdef BADBUG if(areaint->hard) Rprintf("Hard core recognised\n"); #endif /* periodic boundary conditions? */ areaint->period = model.period; areaint->per = (model.period[0] > 0.0); #ifdef BADBUG if(areaint->per) { Rprintf("*** periodic boundary conditions ***\n"); Rprintf("period = %lf, %lf\n", model.period[0], model.period[1]); } #endif /* grid counting */ dx = dy = areaint->dx = (2 * r)/NGRID; #ifdef BADBUG Rprintf("areaint->dx = %lf\n", areaint->dx); #endif areaint->xgrid0 = -r + dx/2; areaint->my = (int *) R_alloc((long) NGRID, sizeof(int)); kdisc = 0; for(i = 0; i < NGRID; i++) { x0 = areaint->xgrid0 + i * dx; my = floor(sqrt(r * r - x0 * x0)/dy); my = (my < 0) ? 0 : my; areaint->my[i] = my; #ifdef BADBUG Rprintf("\tmy[%ld] = %ld\n", i, my); #endif kdisc += 2 * my + 1; } areaint->kdisc = kdisc; #ifdef BADBUG Rprintf("areaint->kdisc = %ld\n", areaint->kdisc); #endif /* allocate space for neighbour indices */ areaint->neighbour = (int *) R_alloc((long) state.npmax, sizeof(int)); return((Cdata *) areaint); } /* conditional intensity evaluator */ double areaintCif(Propo prop, State state, Cdata *cdata) { int npts, ix, ixp1, j; double *period, *x, *y; double u, v; double r2, dx, dy, a, range2; double xgrid, ygrid, xgrid0, covfrac, cifval; int kount, kdisc, kx, my, ky; int *neighbour; int nn, k; AreaInt *areaint; areaint = (AreaInt *) cdata; r2 = areaint->r2; range2 = areaint->range2; /* square of interaction distance */ dy = dx = areaint->dx; kdisc = areaint->kdisc; /* pointers */ period = areaint->period; neighbour = areaint->neighbour; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; if(npts == 0) return ((double) 1.0); if(!areaint->per) { /* .......... Euclidean distance .................... First identify which data points are neighbours of (u,v) */ nn = 0; ixp1 = ix + 1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(ix > 0) { for(j=0; j < ix; j++) { a = range2 - pow(u - x[j], 2); if(a > 0.) { a -= pow(v - y[j], 2); if(a > 0.) { /* point j is a neighbour of (u,v) */ neighbour[nn] = j; ++nn; } } } } if(ixp1 < npts) { for(j=ixp1; j < npts; j++) { a = range2 - pow(u - x[j], 2); if(a > 0.) { a -= pow(v - y[j], 2); if(a > 0.) { /* point j is a neighbour of (u,v) */ neighbour[nn] = j; ++nn; } } } } if(nn == 0) { /* no neighbours; no interaction */ cifval = 1.0; return cifval; } else if(areaint->hard) { /* neighbours forbidden if it's a hard core process */ cifval = 0.0; return cifval; } else { /* scan a grid of points centred at (u,v) */ kount = 0; xgrid0 = u + areaint->xgrid0; for(kx=0; kxmy[kx]; for(ky=(-my); ky<=my; ky++) { ygrid = v + ky * dy; /* Grid point (xgrid,ygrid) is inside disc of radius r centred at (u,v) Loop through all neighbouring data points to determine whether the grid point is covered by another disc */ if(nn > 0) { for(k=0; k < nn; k++) { j = neighbour[k]; a = r2 - pow(xgrid - x[j], 2); if(a > 0) { a -= pow(ygrid - y[j], 2); if(a > 0) { /* point j covers grid point */ ++kount; break; } } } } /* finished consideration of grid point (xgrid, ygrid) */ } } } } else { /* ............. periodic distance ...................... First identify which data points are neighbours of (u,v) */ nn = 0; ixp1 = ix + 1; if(ix > 0) { for(j=0; j < ix; j++) { if(dist2thresh(u,v,x[j],y[j],period,range2)) { /* point j is a neighbour of (u,v) */ neighbour[nn] = j; ++nn; } } } if(ixp1 < npts) { for(j=ixp1; jhard) { /* neighbours forbidden if it's a hard core process */ cifval = 0.0; return cifval; } else { /* scan a grid of points centred at (u,v) */ kount = 0; xgrid0 = u + areaint->xgrid0; for(kx=0; kxmy[kx]; for(ky=(-my); ky<=my; ky++) { ygrid = v + ky * dy; /* Grid point (xgrid,ygrid) is inside disc of radius r centred at (u,v) Loop through all neighbouring data points to determine whether the grid point is covered by another disc */ for(k=0; k < nn; k++) { j = neighbour[k]; if(dist2Mthresh(xgrid,ygrid,x[j],y[j],period,r2)) { /* point j covers grid point */ ++kount; break; } } /* finished considering grid point (xgrid,ygrid) */ } } } } /* `kdisc' is the number of grid points in the disc `kount' is the number of COVERED grid points in the disc */ /* Hard core case has been handled. */ /* Usual calculation: covered area fraction */ covfrac = ((double) kount)/((double) kdisc); cifval = exp(areaint->logeta * covfrac); #ifdef BADBUG if(!R_FINITE(cifval)) { Rprintf("Non-finite CIF value\n"); Rprintf("kount=%ld, kdisc=%ld, covfrac=%lf, areaint->logeta=%lf\n", kount, kdisc, covfrac, areaint->logeta); Rprintf("u=%lf, v=%lf\n", u, v); error("Non-finite CIF"); } #endif return cifval; } Cifns AreaIntCifns = { &areaintInit, &areaintCif, (updafunptr) NULL, NO}; spatstat.random/src/mhv3.h0000755000176200001440000000060014164500132015204 0ustar liggesusers/* mhv3.h tracking or not Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef MH_TRACKING if(tracking) { /* saving transition history */ #define MH_TRACKING YES #include "mhv4.h" #undef MH_TRACKING } else { /* not saving transition history */ #define MH_TRACKING NO #include "mhv4.h" #undef MH_TRACKING } spatstat.random/src/mhv2.h0000755000176200001440000000056314164500132015213 0ustar liggesusers/* mhv2.h single interaction or hybrid Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef MH_SINGLE if(Ncif == 1) { /* single interaction */ #define MH_SINGLE YES #include "mhv3.h" #undef MH_SINGLE } else { /* hybrid interaction */ #define MH_SINGLE NO #include "mhv3.h" #undef MH_SINGLE } spatstat.random/src/strauss.c0000755000176200001440000000463614325152137016052 0ustar liggesusers#include #include #include "methas.h" #include "dist2.h" /* Conditional intensity computation for Strauss process */ /* Format for storage of parameters and precomputed/auxiliary data */ typedef struct Strauss { double gamma; double r; double loggamma; double r2; double *period; int hard; int per; } Strauss; /* initialiser function */ Cdata *straussinit(State state, Model model, Algor algo) { /* create storage for model parameters */ Strauss *strauss; strauss = (Strauss *) R_alloc(1, sizeof(Strauss)); /* Interpret model parameters*/ strauss->gamma = model.ipar[0]; strauss->r = model.ipar[1]; /* No longer passed as r^2 */ strauss->r2 = strauss->r * strauss->r; strauss->period = model.period; #ifdef MHDEBUG Rprintf("Initialising Strauss gamma=%lf, r=%lf\n", strauss->gamma, strauss->r); #endif /* is the model numerically equivalent to hard core ? */ strauss->hard = (strauss->gamma < DBL_EPSILON); strauss->loggamma = (strauss->hard) ? 0 : log(strauss->gamma); /* periodic boundary conditions? */ strauss->per = (model.period[0] > 0.0); return((Cdata *) strauss); } /* conditional intensity evaluator */ double strausscif(Propo prop, State state, Cdata *cdata) { int npts, kount, ix, ixp1, j; double *x, *y; double u, v; double r2, cifval; Strauss *strauss; DECLARE_CLOSE_VARS; strauss = (Strauss *) cdata; r2 = strauss->r2; u = prop.u; v = prop.v; ix = prop.ix; x = state.x; y = state.y; npts = state.npts; if(npts == 0) return((double) 1.0); kount = 0; ixp1 = ix+1; /* If ix = NONE = -1, then ixp1 = 0 is correct */ if(strauss->per) { /* periodic distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE_PERIODIC(u,v,x[j],y[j],strauss->period, r2)) ++kount; } } if(ixp1 < npts) { for(j=ixp1; jperiod, r2)) ++kount; } } } else { /* Euclidean distance */ if(ix > 0) { for(j=0; j < ix; j++) { if(CLOSE(u,v,x[j],y[j], r2)) ++kount; } } if(ixp1 < npts) { for(j=ixp1; jhard) { if(kount > 0) cifval = 0.0; else cifval = 1.0; } else cifval = exp((strauss->loggamma) * kount); return cifval; } Cifns StraussCifns = { &straussinit, &strausscif, (updafunptr) NULL, NO}; spatstat.random/src/PerfectDiggleGratton.h0000755000176200001440000001300014325152137020377 0ustar liggesusers // ........................... Diggle-Gratton process .......................... // $Revision: 1.6 $ $Date: 2020/05/12 03:30:46 $ class DiggleGrattonProcess : public PointProcess { public: double beta, delta, rho, kappa, rhominusdelta, deltasquared, rhosquared; DiggleGrattonProcess(double xmin, double xmax, double ymin, double ymax, double b, double d, double r, double k); ~DiggleGrattonProcess(){} void NewEvent(double *x, double *y, char *InWindow); void GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP); double Interaction(double dsquared); }; DiggleGrattonProcess::DiggleGrattonProcess(double xmin, double xmax, double ymin, double ymax, double b, double d, double r, double k) : PointProcess(xmin, xmax, ymin, ymax){ beta = b; delta = d; rho = r; kappa = k; deltasquared = delta * delta; rhosquared = rho * rho; rhominusdelta = rho - delta; InteractionRange = rho; TotalBirthRate = beta*(xmax-xmin)*(ymax-ymin); } double DiggleGrattonProcess::Interaction(double dsquared) { double rtn, dist, t; rtn = 1; if(dsquared < rhosquared) { if(dsquared < deltasquared) { rtn = 0; } else { dist = sqrt(dsquared); t = (dist - delta)/rhominusdelta; rtn = pow(t, kappa); } } return(rtn); } void DiggleGrattonProcess::NewEvent(double *x, double *y, char *InWindow) { double Xdim, Ydim; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; *x = slumptal()*Xdim+Xmin; *y = slumptal()*Ydim+Ymin; *InWindow = 1; } void DiggleGrattonProcess::GeneratePoisson(Point *headPoint, long int *GeneratedPoints, long int *LivingPoints, long int *NoP) { int i; double xtemp, ytemp, L, Xdim, Ydim; struct Point *TempPoint; Xdim = Xmax-Xmin; Ydim = Ymax-Ymin; L = beta*Xdim*Ydim; *GeneratedPoints = poisson(L); *LivingPoints = *GeneratedPoints; for (i=1; i<=*GeneratedPoints ; i++){ //Rprintf("Generating DiggleGrattonProcess Poisson 3\n"); //scanf("%f",&f1); xtemp = slumptal()*Xdim+Xmin; ytemp = slumptal()*Ydim+Ymin; // //Rprintf("Generating DiggleGrattonProcess Poisson 3.2\n"); TempPoint = ALLOCATE(struct Point); // TempPoint->X = xtemp; TempPoint->Y = ytemp; TempPoint->No = i; TempPoint->R = slumptal(); //Rprintf("Generating DiggleGrattonProcess Poisson 3.6\n"); TempPoint->next = headPoint->next; headPoint->next = TempPoint; *NoP = *NoP + 1; } } // ........................... Interface to R .......................... extern "C" { SEXP PerfectDiggleGratton(SEXP beta, SEXP delta, SEXP rho, SEXP kappa, SEXP xrange, SEXP yrange) { // input parameters double Beta, Delta, Rho, Kappa, Xmin, Xmax, Ymin, Ymax; double *Xrange, *Yrange; // internal int xcells, ycells; long int StartTime, EndTime; // output int noutmax; SEXP xout, yout, nout, out; double *xx, *yy; int *nn; // protect arguments from garbage collector PROTECT(beta = AS_NUMERIC(beta)); PROTECT(delta = AS_NUMERIC(delta)); PROTECT(rho = AS_NUMERIC(rho)); PROTECT(kappa = AS_NUMERIC(kappa)); PROTECT(xrange = AS_NUMERIC(xrange)); PROTECT(yrange = AS_NUMERIC(yrange)); // that's 6 protected objects // extract arguments // model parameters Beta = *(NUMERIC_POINTER(beta)); Delta = *(NUMERIC_POINTER(delta)); Rho = *(NUMERIC_POINTER(rho)); Kappa = *(NUMERIC_POINTER(kappa)); // window dimensions Xrange = NUMERIC_POINTER(xrange); Xmin = Xrange[0]; Xmax = Xrange[1]; Yrange = NUMERIC_POINTER(yrange); Ymin = Yrange[0]; Ymax = Yrange[1]; // compute cell array size xcells = (int) floor((Xmax-Xmin)/ Rho); if(xcells > 9) { xcells = 9; } else if(xcells < 1) { xcells = 1; } ycells = (int) floor((Ymax-Ymin)/ Rho); if(ycells > 9) { ycells = 9; } else if(ycells < 1) { ycells = 1; } #ifdef DBGS Rprintf("xcells %d ycells %d\n",xcells,ycells); Rprintf("Initialising\n"); #endif // Initialise DiggleGratton point process DiggleGrattonProcess ExampleProcess(Xmin,Xmax,Ymin,Ymax,Beta,Delta,Rho,Kappa); // Initialise point pattern Point2Pattern ExamplePattern(Xmin,Xmax,Ymin,Ymax, xcells, ycells); // parameters: min x, max x, min y, max y, "cells" in x and y direction // used for speeding up neighbour counting, 9 is max here #ifdef DBGS Rprintf("Initialisation complete\n"); #endif // Synchronise random number generator GetRNGstate(); // Initialise perfect sampler Sampler PerfectSampler(&ExampleProcess); // Perform perfect sampling PerfectSampler.Sim(&ExamplePattern, &StartTime, &EndTime); // Synchronise random number generator PutRNGstate(); // Get upper estimate of number of points noutmax = ExamplePattern.UpperCount() + 1; // Allocate space for output PROTECT(xout = NEW_NUMERIC(noutmax)); PROTECT(yout = NEW_NUMERIC(noutmax)); PROTECT(nout = NEW_INTEGER(1)); xx = NUMERIC_POINTER(xout); yy = NUMERIC_POINTER(yout); nn = INTEGER_POINTER(nout); // copy data into output storage ExamplePattern.Return(xx, yy, nn, noutmax); // pack up into output list PROTECT(out = NEW_LIST(3)); SET_VECTOR_ELT(out, 0, xout); SET_VECTOR_ELT(out, 1, yout); SET_VECTOR_ELT(out, 2, nout); // return UNPROTECT(10); // 6 arguments plus xout, yout, nout, out return(out); } } spatstat.random/NEWS0000644000176200001440000001600214570033472014077 0ustar liggesusers CHANGES IN spatstat.random VERSION 3.2-3 OVERVIEW o Slightly accelerated. o Minor bug fixes. SIGNIFICANT USER-VISIBLE CHANGES o spatstat.random Some computations are slightly accelerated. BUG FIXES o rLGCP In certain special cases, an error message about incompatible images was issued, and in the resulting point pattern object X, the driving intensity image attr(X,"Lambda") had incorrect dimensions or spatial coordinates. Fixed. CHANGES IN spatstat.random VERSION 3.2-2 OVERVIEW o Internal changes to appease the package checker. CHANGES IN spatstat.random VERSION 3.2-1 OVERVIEW o Minor changes to appease the package checker. CHANGES IN spatstat.random VERSION 3.2-0 OVERVIEW o We thank Tilman Davies and David Bryant for contributions. o spatstat.random no longer uses 'maptools' or 'RandomFields'. o Minor internal improvements and bug fixes. SIGNIFICANT USER-VISIBLE CHANGES o Package dependence spatstat.random no longer suggests the packages 'maptools', 'RandomFields' and 'RandomFieldsUtils'. o rLGCP This function has been re-implemented without using 'RandomFields'. The implementation currently supports only the 'exponential', 'gaussian', 'stable', 'gencauchy' and 'matern' covariance functions. BUG FIXES o rpoislinetess Results were incorrect unless the window was centred at the origin. Fixed. CHANGES IN spatstat.random VERSION 3.1-6 OVERVIEW o Conditional simulation for Matern cluster process. o Improvements to runifpoint and rpoispp. SIGNIFICANT USER-VISIBLE CHANGES o rMatClust Can now perform conditional simulation given a fixed number of points. New arguments n.cond and w.cond. o runifpoint Argument 'win' can be a tessellation. The specified number of points n will be randomly generated in each tile of the tessellation. o rpoispp New argument 'forcewin'. CHANGES IN spatstat.random VERSION 3.1-5 OVERVIEW o Minor improvements. SIGNIFICANT USER-VISIBLE CHANGES o rLGCP Now recognises argument 'rule.eps' passed to 'as.mask'. CHANGES IN spatstat.random VERSION 3.1-4 OVERVIEW o spatstat.random now suggests the package 'gsl'. o Generate truncated Poisson random variables. o reciprocal moment of Poisson variable conditioned to be positive. o Internal improvements. NEW FUNCTIONS o rpoisnonzero Generate Poisson random variables conditioned to be positive. o rpoistrunc Generate 'truncated' Poisson random variables, conditioned to be greater than or equal to a specified minimum value. o recipEnzpois Calculate the first reciprocal moment of nonzero Poisson variable SIGNIFICANT USER-VISIBLE CHANGES o rVarGamma, rclusterBKBC Suppressed some irrelevant warnings about numerical error. CHANGES IN spatstat.random VERSION 3.1-3 OVERVIEW o We thank Bethany Macdonald for contributions. o Bug fixes and internal improvements. CHANGES IN spatstat.random VERSION 3.1-2 OVERVIEW o We thank Ya-Mei Chang for substantial contributions. o Faster algorithms for simulating cluster processes. o Bug fixes and internal improvements. NEW FUNCTIONS o rclusterBKBC (Advanced use) Internal algorithm to simulate any Neyman-Scott cluster process using either the naive, Brix-Kendall, or Baddeley-Chang algorithm. SIGNIFICANT USER-VISIBLE CHANGES o rCauchy, rThomas, rMatClust, rVarGamma These algorithms have been accelerated by several orders of magnitude in the case where the cluster radius is large. o rCauchy, rThomas, rMatClust, rVarGamma These functions now offer a choice of simulation algorithms. o rCauchy, rThomas, rMatClust, rVarGamma, rNeymanScott Formal arguments have changed. o rNeymanScott Argument 'lmax' has been replaced by 'kappamax'. New argument 'mumax'. o rPoissonCluster Argument 'lmax' has been replaced by 'kappamax'. BUG FIXES o rThomas, rMatClust, rCauchy, rVarGamma If the model was very close to a Poisson process, and if saveLambda=TRUE was selected, the attribute "Lambda" was incorrectly labelled "lambda". Fixed. o clusterradius Crashed sometimes with message about infinite values of the integrand. Fixed. CHANGES IN spatstat.random VERSION 3.1-0 OVERVIEW o Internal improvements. CHANGES IN spatstat.random VERSION 3.0-2 OVERVIEW o Pakes distribution. NEW FUNCTIONS o dpakes, ppakes, qpakes, rpakes Density, cumulative probability, quantiles, and random generator for the Pakes distribution. CHANGES IN spatstat.random VERSION 3.0-1 OVERVIEW o Tweaks to placate package checker. CHANGES IN spatstat.random VERSION 3.0-0 OVERVIEW o We thank Liu Yijia for contributions. o spatstat.random now suggests the new packages 'spatstat.explore' and 'spatstat.model' rather than the old 'spatstat.core'. o Bug fixes and internal improvements. SIGNIFICANT USER-VISIBLE CHANGES o Package dependence 'spatstat.random' now suggests the new packages 'spatstat.explore' and 'spatstat.model' rather than the old 'spatstat.core'. o random generators Random generators now accept 'nsim=0', and return a zero-length list. o random generators Code in the case 'nsim > 1' has been accelerated. BUG FIXES o rmpoint Crashed if 'f' was a pixel image. [Spotted by Liu Yijia.] Fixed. CHANGES IN spatstat.random VERSION 2.2-0 OVERVIEW o Bug fixes and internal improvements. BUG FIXES o Internal code Fix a bug in internal code that causes bug in spatstat.core::kppm CHANGES IN spatstat.random VERSION 2.1-0 OVERVIEW o Indefinite integral. o Internal repairs, code acceleration, and improvements. NEW FUNCTIONS o indefinteg Numerically computes the indefinite integral of a function. CHANGES IN spatstat.random VERSION 2.0-0 OVERVIEW o We thank Dominic Schuhmacher for contributions. o This is a new package containing code removed from spatstat.core o Bug fixes in rmh visual debugger. o Minor improvements SIGNIFICANT USER-VISIBLE CHANGES o spatstat.random The 'spatstat.core' package has been divided into two packages, called 'spatstat.random' and 'spatstat.core'. The new 'spatstat.random' package consists of functions for generating random point patterns, and other random spatial data, that were originally in 'spatstat.core'. o rMatClust, rThomas, rCauchy, rVarGamma New argument 'nonempty' BUG FIXES o rmh The visual debugger did not display accepted births and deaths correctly. [Spotted by Dominic Schuhmacher.] Fixed. o rmh The visual debugger exited prematurely sometimes, if the current state was the empty point pattern. [Spotted by Dominic Schuhmacher.] Fixed. spatstat.random/R/0000755000176200001440000000000014514462531013602 5ustar liggesusersspatstat.random/R/indefinteg.R0000644000176200001440000000412514243055211016033 0ustar liggesusers#' #' indefinteg.R #' #' Indefinite integral #' #' $Revision: 1.8 $ $Date: 2022/02/12 02:56:33 $ indefinteg <- function (f, x, ..., method=c("trapezoid", "quadrature"), lower=min(x), nfine=8192) { method <- match.arg(method) if(length(x) == 0) return(numeric(0)) adjust <- !missing(lower) if(method == "trapezoid" && (any(is.infinite(x)) || (adjust && is.infinite(lower)) || (diff(ra <- range(x)) < sqrt(.Machine$double.eps)))) { method <- "quadrature" } switch(method, trapezoid = { ## indefinite integral using trapezoidal rule ## Determine range for numerical calculation if(adjust) { check.1.real(lower) raplus <- ra + c(-1,1) * diff(ra)/2 included <- inside.range(lower, raplus) if(included) ra <- range(ra, lower) } ## Make a fine sequence of x values xfine <- seq(ra[1L], ra[2L], length.out=nfine) delta <- diff(ra)/(nfine - 1) ## Evaluate integrand on finer sequence yfine <- f(xfine, ...) ## Apply trapezoidal rule zfine <- c(0, cumsum(delta * (yfine[-1L] + yfine[-nfine]))/2) ## Evaluate at 'x' Intf <- approxfun(xfine, zfine, rule=2) z <- Intf(x) ## Adjust for different lower limit if(adjust) { ## calculate indefinite integral from 'lower' to min(xfine) x0 <- ra[1L] deltaI <- if(included) { Intf(x0) - Intf(lower) } else { integrate(f, lower=lower, upper=x0, ...)$value } ## adjust z <- z + deltaI } }, quadrature = { ## indefinite integral using 'integrate' at each value n <- length(x) z <- numeric(n) for(i in 1:n) z[i] <- integrate(f, lower=lower, upper=x[i], ...)$value }) return(z) } spatstat.random/R/rmh.default.R0000644000176200001440000010215314331654772016147 0ustar liggesusers# # $Id: rmh.default.R,v 1.119 2022/05/21 08:53:38 adrian Exp $ # rmh.default <- function(model,start=NULL, control=default.rmhcontrol(model), ..., nsim=1, drop=TRUE, saveinfo=TRUE, verbose=TRUE, snoop=FALSE) { # # Function rmh. To simulate realizations of 2-dimensional point # patterns, given the conditional intensity function of the # underlying process, via the Metropolis-Hastings algorithm. # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # V A L I D A T E # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== if(verbose) cat("Checking arguments..") # validate arguments and fill in the defaults model <- rmhmodel(model) start <- rmhstart(start) if(is.null(control)) { control <- default.rmhcontrol(model) } else { control <- rmhcontrol(control) } # override if(length(list(...)) > 0) control <- update(control, ...) control <- rmhResolveControl(control, model) saveinfo <- as.logical(saveinfo) check.1.integer(nsim) stopifnot(nsim >= 0) # retain "..." arguments unrecognised by rmhcontrol # These are assumed to be arguments of functions defining the trend argh <- list(...) known <- names(argh) %in% names(formals(rmhcontrol.default)) f.args <- argh[!known] #### Multitype models # Decide whether the model is multitype; if so, find the types. types <- rmhResolveTypes(model, start, control) ntypes <- length(types) mtype <- (ntypes > 1) # If the model is multitype, check that the model parameters agree with types # and digest them if(mtype && !is.null(model$check)) { model <- rmhmodel(model, types=types) } else { model$types <- types } ######## Check for illegal combinations of model, start and control ######## # No expansion can be done if we are using x.start if(start$given == "x") { if(control$expand$force.exp) stop("Cannot expand window when using x.start.\n", call.=FALSE) control$expand <- .no.expansion } # Warn about a silly value of fixall: if(control$fixall & ntypes==1) { warning("control$fixall applies only to multitype processes. Ignored.", call.=FALSE) control$fixall <- FALSE if(control$fixing == "n.each.type") control$fixing <- "n.total" } #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # M O D E L P A R A M E T E R S # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== ####### Determine windows ################################ if(verbose) cat("determining simulation windows...") # these may be NULL w.model <- model$w x.start <- start$x.start trend <- model$trend trendy <- !is.null(trend) singletrend <- trendy && (is.im(trend) || is.function(trend) || (is.numeric(trend) && length(trend) == 1)) trendlist <- if(singletrend) list(trend) else trend # window implied by trend image, if any w.trend <- if(is.im(trend)) as.owin(trend) else if(is.list(trend) && any(ok <- unlist(lapply(trend, is.im)))) as.owin((trend[ok])[[1L]]) else NULL ## Clipping window (for final result) w.clip <- if(!is.null(w.model)) w.model else if(!will.expand(control$expand)) { if(start$given == "x" && is.ppp(x.start)) x.start$window else if(is.owin(w.trend)) w.trend } else NULL if(!is.owin(w.clip)) stop("Unable to determine window for pattern", call.=FALSE) ## Simulation window xpn <- rmhResolveExpansion(w.clip, control, trendlist, "trend") w.sim <- xpn$wsim expanded <- xpn$expanded ## Check the fine print if(expanded) { if(control$fixing != "none") stop(paste("If we're conditioning on the number of points,", "we cannot clip the result to another window."), call.=FALSE) if(!is.subset.owin(w.clip, w.sim)) stop("Expanded simulation window does not contain model window", call.=FALSE) } ####### Trend ################################ # Check that the expanded window fits inside the window # upon which the trend(s) live if there are trends and # if any trend is given by an image. if(expanded && !is.null(trend)) { trends <- if(is.im(trend)) list(trend) else trend images <- unlist(lapply(trends, is.im)) if(any(images)) { iwindows <- lapply(trends[images], as.owin) nimages <- length(iwindows) misfit <- !sapply(iwindows, is.subset.owin, A=w.sim) nmisfit <- sum(misfit) if(nmisfit > 1) stop(paste("Expanded simulation window is not contained in", "several of the trend windows.\n", "Bailing out."), call.=FALSE) else if(nmisfit == 1) { warning(paste("Expanded simulation window is not contained in", if(nimages == 1) "the trend window.\n" else "one of the trend windows.\n", "Expanding to this trend window (only)."), call.=FALSE) w.sim <- iwindows[[which(misfit)]] } } } # Extract the 'beta' parameters if(length(model$cif) == 1) { # single interaction beta <- model$C.beta betalist <- list(beta) } else { # hybrid betalist <- model$C.betalist # multiply beta vectors for each component beta <- Reduce("*", betalist) } ##### .................. CONDITIONAL SIMULATION ................... ##### #|| Determine windows for conditional simulation #|| #|| w.state = window for the full configuration #|| #|| w.sim = window for the 'free' (random) points #|| w.state <- w.sim condtype <- control$condtype x.cond <- control$x.cond # n.cond <- control$n.cond switch(condtype, none={ w.cond <- NULL }, window={ # conditioning on the realisation inside a subwindow w.cond <- as.owin(x.cond) # subtract from w.sim w.sim <- setminus.owin(w.state, w.cond) if(is.empty(w.sim)) stop(paste("Conditional simulation is undefined;", "the conditioning window", sQuote("as.owin(control$x.cond)"), "covers the entire simulation window"), call.=FALSE) }, Palm={ # Palm conditioning w.cond <- NULL }) ##### #|| Convert conditioning points to appropriate format x.condpp <- switch(condtype, none=NULL, window=x.cond, Palm=as.ppp(x.cond, w.state)) # validate if(!is.null(x.condpp)) { if(mtype) { if(!is.marked(x.condpp)) stop("Model is multitype, but x.cond is unmarked", call.=FALSE) if(!isTRUE(all.equal(types, levels(marks(x.condpp))))) stop("Types of points in x.cond do not match types in model", call.=FALSE) } } #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # S T A R T I N G S T A T E # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== ###################### Starting state data ############################ # whether the initial state should be thinned thin <- (start$given != "x") && (control$fixing == "none") # There must now be a starting state. if(start$given == "none") { # For conditional simulation, the starting state must be given if(condtype != "none") stop("No starting state given", call.=FALSE) # Determine integral of beta * trend over data window. # This is the expected number of points in the reference Poisson process. area.w.clip <- area(w.clip) if(trendy) { tsummaries <- summarise.trend(trend, w=w.clip, a=area.w.clip) En <- beta * sapply(tsummaries, getElement, name="integral") } else { En <- beta * area.w.clip } # Fix n.start equal to this integral n.start <- if(spatstat.options("scalable")) round(En) else ceiling(En) start <- rmhstart(n.start=n.start) } # In the case of conditional simulation, the start data determine # the 'free' points (i.e. excluding x.cond) in the initial state. switch(start$given, none={ stop("No starting state given", call.=FALSE) }, x = { # x.start was given # coerce it to a ppp object if(!is.ppp(x.start)) x.start <- as.ppp(x.start, w.state) if(condtype == "window") { # clip to simulation window xs <- x.start[w.sim] nlost <- x.start$n - xs$n if(nlost > 0) warning(paste(nlost, ngettext(nlost, "point","points"), "of x.start", ngettext(nlost, "was", "were"), "removed because", ngettext(nlost, "it", "they"), "fell in the window of x.cond"), call.=FALSE) x.start <- xs } npts.free <- x.start$n }, n = { # n.start was given n.start <- start$n.start # Adjust the number of points in the starting state in accordance # with the expansion that has occurred. if(expanded) { holnum <- if(spatstat.options("scalable")) round else ceiling n.start <- holnum(n.start * area(w.sim)/area(w.clip)) } # npts.free <- sum(n.start) # The ``sum()'' is redundant if n.start # is scalar; no harm, but. }, stop("Internal error: start$given unrecognized"), call.=FALSE) #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # C O N T R O L P A R A M E T E R S # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== ################### Periodic boundary conditions ######################### periodic <- control$periodic if(is.null(periodic)) { # undecided. Use default rule control$periodic <- periodic <- expanded && is.rectangle(w.state) } else if(periodic && !is.rectangle(w.state)) { # if periodic is TRUE we have to be simulating in a rectangular window. stop("Need rectangular window for periodic simulation.", call.=FALSE) } # parameter passed to C: period <- if(periodic) c(diff(w.state$xrange), diff(w.state$yrange)) else c(-1,-1) #### vector of proposal probabilities if(!mtype) ptypes <- 1 else { ptypes <- control$ptypes if(is.null(ptypes)) { # default proposal probabilities ptypes <- if(start$given == "x" && (nx <- npoints(x.start)) > 0) { table(marks(x.start, dfok=FALSE))/nx } else rep.int(1/ntypes, ntypes) } else { # Validate ptypes if(length(ptypes) != ntypes | sum(ptypes) != 1) stop("Argument ptypes is mis-specified.", call.=FALSE) } } ######################################################################## # Normalising constant for proposal density # # Integral of trend over the expanded window (or area of window): # Iota == Integral Of Trend (or) Area. area.w.sim <- area(w.sim) if(trendy) { if(verbose) cat("Evaluating trend integral...") tsummaries <- summarise.trend(trend, w=w.sim, a=area.w.sim) mins <- sapply(tsummaries, getElement, name="min") if(any(mins < 0)) stop("Trend has negative values", call.=FALSE) iota <- sapply(tsummaries, getElement, name="integral") tmax <- sapply(tsummaries, getElement, name="max") } else { iota <- area.w.sim tmax <- NULL } #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # A.S. EMPTY PROCESS # # for conditional simulation, 'empty' means there are no 'free' points # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== a.s.empty <- FALSE # # Empty pattern, simulated conditional on n # if(npts.free == 0 && control$fixing != "none") { a.s.empty <- TRUE if(verbose) { mess <- paste("Initial pattern has 0 random points,", "and simulation is conditional on the number of points -") if(condtype == "none") warning(paste(mess, "returning an empty pattern"), call.=FALSE) else warning(paste(mess, "returning a pattern with no random points"), call.=FALSE) } } # # If beta = 0, the process is almost surely empty # if(all(beta < .Machine$double.eps)) { if(control$fixing == "none" && condtype == "none") { # return empty pattern if(verbose) warning("beta = 0 implies an empty pattern", call.=FALSE) a.s.empty <- TRUE } else stop("beta = 0 implies an empty pattern, but we are simulating conditional on a nonzero number of points", call.=FALSE) } # # If we're conditioning on the contents of a subwindow, # and the subwindow covers the clipping region, # the result is deterministic. if(condtype == "window" && is.subset.owin(w.clip, w.cond)) { a.s.empty <- TRUE warning(paste("Model window is a subset of conditioning window:", "result is deterministic"), call.=FALSE) } # # if(a.s.empty) { # create empty pattern, to be returned if(!is.null(x.condpp)) empty <- x.condpp[w.clip] else { empty <- ppp(numeric(0), numeric(0), window=w.clip) if(mtype) { vide <- factor(types[integer(0)], levels=types) empty <- empty %mark% vide } } } #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # PACK UP # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== ######### Store decisions Model <- model Start <- start Control <- control Model$w <- w.clip Model$types <- types Control$expand <- if(expanded) rmhexpand(w.state) else .no.expansion Control$internal <- list(w.sim=w.sim, w.state=w.state, x.condpp=x.condpp, ptypes=ptypes, period=period, thin=thin) Model$internal <- list(a.s.empty=a.s.empty, empty=if(a.s.empty) empty else NULL, mtype=mtype, trendy=trendy, betalist=betalist, beta=beta, iota=iota, tmax=tmax) Start$internal <- list(npts.free=npts.free) InfoList <- list(model=Model, start=Start, control=Control) class(InfoList) <- c("rmhInfoList", class(InfoList)) # go if(nsim == 1 && drop) { result <- do.call(rmhEngine, append(list(InfoList, verbose=verbose, snoop=snoop, kitchensink=saveinfo), f.args)) } else { result <- vector(mode="list", length=nsim) if(verbose) { splat("Generating", nsim, "point patterns...") pstate <- list() } subverb <- verbose && (nsim == 1) for(isim in seq_len(nsim)) { if(verbose) pstate <- progressreport(isim, nsim, state=pstate) result[[isim]] <- do.call(rmhEngine, append(list(InfoList, verbose=subverb, snoop=snoop, kitchensink=saveinfo), f.args)) } if(verbose) splat("Done.\n") result <- simulationresult(result, nsim, drop) } return(result) } print.rmhInfoList <- function(x, ...) { cat("\nPre-digested Metropolis-Hastings algorithm parameters (rmhInfoList)\n") print(as.anylist(x)) } #--------------- rmhEngine ------------------------------------------- # # This is the interface to the C code. # # InfoList is a list of pre-digested, validated arguments # obtained from rmh.default. # # This function is called by rmh.default to generate one simulated # realisation of the model. # It's called repeatedly by ho.engine and qqplot.ppm to generate multiple # realisations (saving time by not repeating the argument checking # in rmh.default). # arguments: # kitchensink: whether to tack InfoList on to the return value as an attribute # preponly: whether to just return InfoList without simulating # # rmh.default digests arguments and calls rmhEngine with kitchensink=T # # qqplot.ppm first gets InfoList by calling rmh.default with preponly=T # (which digests the model arguments and calls rmhEngine # with preponly=T, returning InfoList), # then repeatedly calls rmhEngine(InfoList) to simulate. # # ------------------------------------------------------- rmhEngine <- function(InfoList, ..., verbose=FALSE, kitchensink=FALSE, preponly=FALSE, snoop=FALSE, overrideXstart=NULL, overrideclip=FALSE) { # Internal Use Only! # This is the interface to the C code. if(!inherits(InfoList, "rmhInfoList")) stop("data not in correct format for internal function rmhEngine", call.=FALSE) if(preponly) return(InfoList) model <- InfoList$model start <- InfoList$start control <- InfoList$control w.sim <- control$internal$w.sim w.state <- control$internal$w.state w.clip <- model$w condtype <- control$condtype x.condpp <- control$internal$x.condpp types <- model$types ntypes <- length(types) ptypes <- control$internal$ptypes period <- control$internal$period mtype <- model$internal$mtype trend <- model$trend trendy <- model$internal$trendy # betalist <- model$internal$betalist beta <- model$internal$beta iota <- model$internal$iota tmax <- model$internal$tmax npts.free <- start$internal$npts.free n.start <- start$n.start x.start <- start$x.start #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # E M P T Y P A T T E R N # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== if(model$internal$a.s.empty) { if(verbose) cat("\n") empty <- model$internal$empty attr(empty, "info") <- InfoList return(empty) } #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== # # S I M U L A T I O N # #==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== ############################################# #### #### Random number seed: initialisation & capture #### ############################################# if(!exists(".Random.seed")) runif(1L) saved.seed <- .Random.seed ############################################# #### #### Poisson case #### ############################################# if(is.poisson.rmhmodel(model)) { if(verbose) cat("\n") intensity <- if(!trendy) beta else model$trend Xsim <- switch(control$fixing, none= { # Poisson process if(!mtype) rpoispp(intensity, win=w.sim, ..., warnwin=FALSE) else rmpoispp(intensity, win=w.sim, types=types, warnwin=FALSE) }, n.total = { # Binomial/multinomial process with fixed total number of points if(!mtype) rpoint(npts.free, intensity, win=w.sim, verbose=verbose) else rmpoint(npts.free, intensity, win=w.sim, types=types, verbose=verbose) }, n.each.type = { # Multinomial process with fixed number of points of each type npts.each <- switch(start$given, n = n.start, x = as.integer(table(marks(x.start, dfok=FALSE))), stop("No starting state given; can't condition on fixed number of points", call.=FALSE)) rmpoint(npts.each, intensity, win=w.sim, types=types, verbose=verbose) }, stop("Internal error: control$fixing unrecognised", call.=FALSE) ) # if conditioning, add fixed points if(condtype != "none") Xsim <- superimpose(Xsim, x.condpp, W=w.state) # clip result to output window Xclip <- if(!overrideclip) Xsim[w.clip] else Xsim attr(Xclip, "info") <- InfoList return(Xclip) } ######################################################################## # M e t r o p o l i s H a s t i n g s s i m u l a t i o n ######################################################################## if(verbose) cat("Starting simulation.\nInitial state...") #### Build starting state npts.cond <- if(condtype != "none") x.condpp$n else 0 # npts.total <- npts.free + npts.cond #### FIRST generate the 'free' points #### First the marks, if any. #### The marks must be integers 0 to (ntypes-1) for passing to C Ctypes <- if(mtype) 0:(ntypes-1) else 0 Cmarks <- if(!mtype) 0 else switch(start$given, n = { # n.start given if(control$fixing=="n.each.type") rep.int(Ctypes,n.start) else sample(Ctypes,npts.free,TRUE,ptypes) }, x = { # x.start given as.integer(marks(x.start, dfok=FALSE))-1L }, stop("internal error: start$given unrecognised", call.=FALSE) ) # # Then the x, y coordinates # switch(start$given, x = { x <- x.start$x y <- x.start$y }, n = { xy <- if(!trendy) runifpoint(npts.free, w.sim, ...) else rpoint.multi(npts.free, trend, tmax, factor(Cmarks,levels=Ctypes), w.sim, ...) x <- xy$x y <- xy$y }) ## APPEND the free points AFTER the conditioning points if(condtype != "none") { x <- c(x.condpp$x, x) y <- c(x.condpp$y, y) if(mtype) Cmarks <- c(as.integer(marks(x.condpp))-1L, Cmarks) } if(!is.null(overrideXstart)) { #' override the previous data x <- overrideXstart$x y <- overrideXstart$y if(mtype) Cmarks <- as.integer(marks(overrideXstart))-1L } # decide whether to activate visual debugger if(snoop) { Xinit <- ppp(x, y, window=w.sim) if(mtype) marks(Xinit) <- factor(Cmarks, levels=Ctypes, labels=types) if(verbose) cat("\nCreating debugger environment..") snoopenv <- rmhSnoopEnv(Xinit=Xinit, Wclip=w.clip, R=reach(model)) if(verbose) cat("Done.\n") } else snoopenv <- "none" ####################################################################### # Set up C call ###################################################################### # Determine the name of the cif used in the C code C.id <- model$C.id ncif <- length(C.id) # Get the parameters in C-ese ipar <- model$C.ipar iparlist <- if(ncif == 1) list(ipar) else model$C.iparlist iparlen <- lengths(iparlist) beta <- model$internal$beta # Absorb the constants or vectors `iota' and 'ptypes' into the beta parameters beta <- (iota/ptypes) * beta # Algorithm control parameters p <- control$p q <- control$q nrep <- control$nrep # fixcode <- control$fixcode # fixing <- control$fixing fixall <- control$fixall nverb <- control$nverb saving <- control$saving nsave <- control$nsave nburn <- control$nburn track <- control$track thin <- control$internal$thin pstage <- control$pstage %orifnull% "start" if(pstage == "block" && !saving) pstage <- "start" temper <- FALSE invertemp <- 1.0 if(verbose) cat("Ready to simulate. ") storage.mode(ncif) <- "integer" storage.mode(C.id) <- "character" storage.mode(beta) <- "double" storage.mode(ipar) <- "double" storage.mode(iparlen) <- "integer" storage.mode(period) <- "double" storage.mode(ntypes) <- "integer" storage.mode(nrep) <- "integer" storage.mode(p) <- storage.mode(q) <- "double" storage.mode(nverb) <- "integer" storage.mode(x) <- storage.mode(y) <- "double" storage.mode(Cmarks) <- "integer" storage.mode(fixall) <- "integer" storage.mode(npts.cond) <- "integer" storage.mode(track) <- "integer" storage.mode(thin) <- "integer" storage.mode(temper) <- "integer" storage.mode(invertemp) <- "double" if(pstage == "start" || !saving) { #' generate all proposal points now. if(verbose) cat("Generating proposal points...") #' If the pattern is multitype, generate the mark proposals (0 to ntypes-1) Cmprop <- if(mtype) sample(Ctypes,nrep,TRUE,prob=ptypes) else 0 storage.mode(Cmprop) <- "integer" #' Generate the ``proposal points'' in the expanded window. xy <- if(trendy) { rpoint.multi(nrep,trend,tmax, factor(Cmprop, levels=Ctypes), w.sim, ..., warn=FALSE) } else runifpoint(nrep, w.sim, warn=FALSE) xprop <- xy$x yprop <- xy$y storage.mode(xprop) <- storage.mode(yprop) <- "double" } if(!saving) { # ////////// Single block ///////////////////////////////// nrep0 <- 0 storage.mode(nrep0) <- "integer" # Call the Metropolis-Hastings C code: if(verbose) cat("Running Metropolis-Hastings.\n") out <- .Call(SR_xmethas, ncif, C.id, beta, ipar, iparlen, period, xprop, yprop, Cmprop, ntypes, nrep, p, q, nverb, nrep0, x, y, Cmarks, npts.cond, fixall, track, thin, snoopenv, temper, invertemp, PACKAGE="spatstat.random") # Extract the point pattern returned from C X <- ppp(x=out[[1L]], y=out[[2L]], window=w.state, check=FALSE) if(mtype) { #' convert integer marks from C to R #' then restore original type levels marks(X) <- factor(out[[3L]], levels=Ctypes, labels=types) } # Now clip the pattern to the ``clipping'' window: if(!overrideclip && !control$expand$force.noexp) X <- X[w.clip] # Extract transition history: if(track) { usedout <- if(mtype) 3 else 2 proptype <- factor(out[[usedout+1]], levels=1:3, labels=c("Birth", "Death", "Shift")) accepted <- as.logical(out[[usedout+2]]) History <- data.frame(proposaltype=proptype, accepted=accepted) if(length(out) >= usedout + 4) { # history includes numerator & denominator of Hastings ratio numerator <- as.double(out[[usedout + 3]]) denominator <- as.double(out[[usedout + 4]]) History <- cbind(History, data.frame(numerator=numerator, denominator=denominator)) } } } else { # ////////// Multiple blocks ///////////////////////////////// ## determine length of each block of simulations nsuperblocks <- as.integer(1L + ceiling((nrep - nburn)/sum(nsave))) block <- c(nburn, rep.int(nsave, nsuperblocks-1L)) block <- block[cumsum(block) <= nrep] if((tot <- sum(block)) < nrep) block <- c(block, nrep-tot) block <- block[block >= 1L] nblocks <- length(block) blockend <- cumsum(block) ## set up list to contain the saved point patterns Xlist <- vector(mode="list", length=nblocks+1L) ## save initial state Xinit <- ppp(x=x, y=y, window=w.state, check=FALSE) if(mtype) { ## convert integer marks from C to R ## then restore original type levels marks(Xinit) <- factor(Cmarks, levels=Ctypes, labels=types) } Xlist[[1L]] <- Xinit # Call the Metropolis-Hastings C code repeatedly: xprev <- x yprev <- y Cmarksprev <- Cmarks # thinFALSE <- as.integer(FALSE) storage.mode(thinFALSE) <- "integer" # ................ loop ......................... for(I in 1:nblocks) { # number of iterations for this block nrepI <- block[I] storage.mode(nrepI) <- "integer" # number of previous iterations nrep0 <- if(I == 1) 0 else blockend[I-1] storage.mode(nrep0) <- "integer" # Generate or extract proposals switch(pstage, start = { #' extract proposals from previously-generated vectors if(verbose) cat("Extracting proposal points...") seqI <- 1:nrepI xpropI <- xprop[seqI] ypropI <- yprop[seqI] CmpropI <- Cmprop[seqI] storage.mode(xpropI) <- storage.mode(ypropI) <- "double" storage.mode(CmpropI) <- "integer" }, block = { # generate 'nrepI' random proposals if(verbose) cat("Generating proposal points...") #' If the pattern is multitype, generate the mark proposals CmpropI <- if(mtype) sample(Ctypes,nrepI,TRUE,prob=ptypes) else 0 storage.mode(CmpropI) <- "integer" #' Generate the ``proposal points'' in the expanded window. xy <- if(trendy) { rpoint.multi(nrepI,trend,tmax, factor(CmpropI, levels=Ctypes), w.sim, ..., warn=FALSE) } else runifpoint(nrepI, w.sim, warn=FALSE) xpropI <- xy$x ypropI <- xy$y storage.mode(xpropI) <- storage.mode(ypropI) <- "double" }) # no thinning in subsequent blocks if(I > 1) thin <- thinFALSE #' call if(verbose) cat("Running Metropolis-Hastings.\n") out <- .Call(SR_xmethas, ncif, C.id, beta, ipar, iparlen, period, xpropI, ypropI, CmpropI, ntypes, nrepI, p, q, nverb, nrep0, xprev, yprev, Cmarksprev, npts.cond, fixall, track, thin, snoopenv, temper, invertemp, PACKAGE="spatstat.random") # Extract the point pattern returned from C X <- ppp(x=out[[1L]], y=out[[2L]], window=w.state, check=FALSE) if(mtype) { # convert integer marks from C to R # then restore original type levels marks(X) <- factor(out[[3L]], levels=Ctypes, labels=types) } # Now clip the pattern to the ``clipping'' window: if(!overrideclip && !control$expand$force.noexp) X <- X[w.clip] # commit to list Xlist[[I+1L]] <- X # Extract transition history: if(track) { usedout <- if(mtype) 3 else 2 proptype <- factor(out[[usedout+1]], levels=1:3, labels=c("Birth", "Death", "Shift")) accepted <- as.logical(out[[usedout+2]]) HistoryI <- data.frame(proposaltype=proptype, accepted=accepted) if(length(out) >= usedout + 4) { # history includes numerator & denominator of Hastings ratio numerator <- as.double(out[[usedout + 3]]) denominator <- as.double(out[[usedout + 4]]) HistoryI <- cbind(HistoryI, data.frame(numerator=numerator, denominator=denominator)) } # concatenate with histories of previous blocks History <- if(I == 1) HistoryI else rbind(History, HistoryI) } # update 'previous state' xprev <- out[[1L]] yprev <- out[[2L]] Cmarksprev <- if(!mtype) 0 else out[[3]] storage.mode(xprev) <- storage.mode(yprev) <- "double" storage.mode(Cmarksprev) <- "integer" if(pstage == "start") { #' discard used proposals xprop <- xprop[-seqI] yprop <- yprop[-seqI] Cmprop <- Cmprop[-seqI] } } # .............. end loop ............................... # Result of simulation is final state 'X' # Tack on the list of intermediate states names(Xlist) <- paste("Iteration", c(0,as.integer(blockend)), sep="_") attr(X, "saved") <- as.solist(Xlist) } # Append to the result information about how it was generated. if(kitchensink) { attr(X, "info") <- InfoList attr(X, "seed") <- saved.seed } if(track) attr(X, "history") <- History return(X) } # helper function summarise.trend <- local({ # main function summarise.trend <- function(trend, w, a=area(w)) { tlist <- if(is.function(trend) || is.im(trend)) list(trend) else trend return(lapply(tlist, summarise1, w=w, a=a)) } # summarise1 <- function(x, w, a) { if(is.numeric(x)) { mini <- maxi <- x integ <- a*x } else { Z <- as.im(x, w)[w, drop=FALSE] ran <- range(Z) mini <- ran[1L] maxi <- ran[2L] integ <- integral.im(Z) } return(list(min=mini, max=maxi, integral=integ)) } summarise.trend }) spatstat.random/R/rclusterBKBC.R0000644000176200001440000010170214400530524016203 0ustar liggesusers#' rclusterBKBC.R #' #' $Revision: 1.6 $ $Date: 2023/03/04 02:47:17 $ #' #' Simulation of stationary cluster process #' using Brix-Kendall algorithm and Baddeley-Chang modification #' #' Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022-2023 #' GNU Public Licence >= 2 rclusterBKBC <- function(clusters="Thomas", kappa, mu, scale, ..., W=unit.square(), nsim=1, drop=TRUE, best=FALSE, external=c("BK", "superBK", "border"), internal=c("dominating", "naive"), inflate=1, psmall=1e-4, use.inverse=TRUE, use.special=TRUE, integralmethod=c("quadrature", "trapezoid"), verbose=TRUE, warn=TRUE) { external.given <- !missing(external) integralmethod <- match.arg(integralmethod) if(!missing(inflate)) { if(is.numeric(inflate)) { check.1.real(inflate) stopifnot(inflate >= 1) if(verbose && inflate > 1) splat("Inflating disc by factor", inflate) } else if(is.function(inflate)) { if(verbose) splat("Using a user-supplied inflation rule") } else if(identical(inflate, "optimal")) { if(verbose) splat("Using optimal inflation rule") } else stop("Argument 'inflate' should be a number or a function") } ## ............. Information about the model ............................. cinfo <- spatstatClusterModelInfo(clusters) # error if unrecognised sinfo <- spatstatClusterSimInfo(clusters) # NULL if unrecognised iscompact <- isTRUE(sinfo$iscompact) ## Validate parameters and convert to native parametrisation par.generic <- c(kappa=kappa, scale=scale) par <- cinfo$checkpar(par.generic, old=TRUE) if(length(cinfo$clustargsnames)) { ## shape of kernel shapestuff <- cinfo$resolvedots(...)$covmodel shapemodel <- shapestuff$model ## optional: name of covariance model e.g. 'exponential' shapeargs <- shapestuff$margs ## shape parameter values } else shapemodel <- shapeargs <- NULL ## Assemble model information in format required by cluster simulation functions in bkinfo.R mod <- list(par=par, mu=mu, shapemodel=shapemodel, shapeargs=shapeargs) ## ................ Geometry ............................. ## shift window to convenient origin oldW <- W oldcentre <- as.numeric(centroid.owin(Frame(oldW))) W <- shift(oldW, -oldcentre) ## enclose it in a disc rD <- with(vertices(Frame(W)), sqrt(max(x^2+y^2))) if(verbose) splat("Disc radius rD =", rD) ## D <- disc(radius=rD) ## inflated disc if(identical(inflate, "optimal")) { rE <- optimalinflation(clusters, mod, rD) } else if(is.function(inflate)) { rE <- inflate(mod, rD) if(rE < rD) stop("Function 'inflate' yielded rE < rD") } else if(inflate == 1) { ## default rE <- rD } else { rE <- inflate * rD if(iscompact) { rmax <- cinfo$range(par=par.generic, margs=shapeargs) rEmax <- rD + rmax if(rE > rEmax) { if(verbose) splat("Kernel has compact support;", "reducing inflated radius from", rE, "to", rEmax) rE <- rEmax } } } if(rE == rD) { if(verbose) splat("Disc will not be inflated") discEname <- "disc" } else { if(verbose) splat("Inflated radius rE =", rE) discEname <- "inflated disc" } ## ............. Decide on computation policy .......................................... use.special <- isTRUE(use.special) && !is.null(sinfo) # TRUE if using specialised code in 'sinfo' use.inverse <- isTRUE(use.inverse) sizecode <- 1L + (scale > rD/10) + (scale > rD/2) external <- if(best) switch(sizecode, "border", "BK", "superBK") else match.arg(external) internal <- if(best) switch(sizecode, "naive", "dominating", "dominating") else match.arg(internal) if(use.special && external == "superBK") { ## check whether this is supported if(!all(c("rhoplusplus", "Mplusplus", "MplusplusInf") %in% names(sinfo))) { external <- "BK" if(!best && external.given) message("Superdominating strategy (external='superBK') is not supported for this cluster process; reverting to 'BK'") } } ## create empty pattern in required format emptypattern <- ppp(window=oldW) attr(emptypattern, "parents") <- list(x=numeric(0), y=numeric(0)) attr(emptypattern, "parentid") <- integer(0) ## Threshold for warnings about large number of points if(warn) nhuge <- spatstat.options("huge.npoints") ## ........................................... ## Define components of simulation algorithm ## ........................................... ## intensity of parents conditioned on having any offspring anywhere kappadag <- kappa * (1 - exp(-mu)) ## integral over D of dominating kernel, given distance to origin from parent if(use.special) { ## function to compute expected number of dominating offspring of a parent at given distance from origin Eplus <- sinfo$Eplus hdomfun <- sinfo$hdom ## random generator of offspring roffspring <- sinfo$roffspring } else { ## generic code kernel <- cinfo$kernel # function(par, r, ..., model, margs) hdomfun <- function(r, mod, rD) { z <- numeric(length(r)) high <- (r > rD) z[!high] <- with(mod, kernel(par, 0, model=shapemodel, margs=shapeargs)) z[high] <- with(mod, kernel(par, (r[high]-rD), model=shapemodel, margs=shapeargs)) return(z) } Eplus <- function(r, ...) { mu * pi * rD^2 * hdomfun(r, mod, rD) } ## random generator of offspring cinfo.roff <- cinfo$roffspring if(!is.function(cinfo.roff)) stop("I don't know how to generate clusters of this kind") roffspring <- function(n, mod) { with(mod, cinfo.roff(n, par, model=shapemodel, margs=shapeargs)) } } ## For Brix-Kendall and super-dominating algorithms, ## kernel must be bounded at r=0 LowerLimit <- 0 if(is.infinite(hdomfun(0, mod, rD))) { offence <- remedy <- NULL if(internal != "naive") { offence <- "Cannot use Brix-Kendall type algorithm" remedy <- "Switching to hybrid algorithm" internal <- "naive" } if(inflate == 1) { offence <- c(offence, "Cannot use inflate = 1") remedy <- c(remedy, "Setting inflate = 2") inflate <- 2 rE <- inflate * rD } if(length(offence)) message(paste("The kernel is infinite at distance zero.", paste0(paste(offence, collapse="; "), "."), paste0(paste(remedy, collapse="; "), "."))) if(!use.special) LowerLimit <- rE } ## intensity of Brix-Kendall dominating parent process, given distance to origin switch(external, border = { ## determine border width if(iscompact) { ## compact support: determine radius of disc containing support rbord <- cinfo$range(par=par.generic, model=shapemodel, margs=shapeargs) } else { ## non-compact support: determine radius of disc which has probability (1 - psmall) rbord <- cinfo$range(par=par.generic, model=shapemodel, margs=shapeargs, thresh=psmall) } Rmax <- rD + rbord if(Rmax > rE) { Eborder <- kappadag * pi * (Rmax^2 - rE^2) if(verbose) splat("External parents: border method", "\n\tBorder width:", signif(Rmax - rE, 3), "\n\tMaximum distance of parent from origin:", signif(Rmax, 3), "\n\tExpected number of parents in border:", round(Eborder, 3)) } else { Eborder <- 0 if(verbose) splat("External parents: border method\n\tNot required; covered by inflated disc") } }, BK = { ## ....................... ## original B-K algorithm ## ....................... if(verbose) splat("External parents: Brix-Kendall dominating process") ## Radial cumulative integral of dominating parent intensity if(use.special) { rhoplus <- sinfo$rhoplus sinfoMplus <- sinfo$Mplus Mplus <- function(r) { sinfoMplus(r, mod, rD, method=integralmethod) } ## Integral of dominating parent intensity = Mplus(Inf) MplusInf <- sinfo$MplusInf(mod, rD) } else { ## generic code rhoplus <- function(r, ...) { kappa <- mod$par[["kappa"]] z <- numeric(length(r)) above <- (r > rD) z[!above] <- Eplus(0) z[above] <- Eplus(r[above]) return(kappa * (1 - exp(-z))) } MplusIntegrand <- function(r) { 2 * pi * r * rhoplus(r) } ## Mplus(r) is the integral from LowerLimit to r Mplus <- function(r) { rstart <- LowerLimit if(rstart == 0) { z <- pi * pmin(r, rD)^2 * rhoplus(0) high <- (r > rD) if(any(high)) z[high] <- z[high] + indefinteg(MplusIntegrand, r[high], lower=rD, method=integralmethod) } else { z <- numeric(length(r)) high <- (r > rstart) if(any(high)) z[high] <- indefinteg(MplusIntegrand, r[high], lower=rstart, method=integralmethod) } return(z) } MplusInf <- Mplus(Inf) } if(verbose) splat("\tTotal integral of intensity of dominating parents:", round(MplusInf, 2)) ## We will generate values uniformly distributed between Mmin and MplusInf Mmin <- switch(internal, dominating=0, naive=Mplus(rE)) if(verbose && internal == "naive") { splat("\tIntegral inside", paste0(discEname, ":"), round(Mmin, 2)) splat("\tDifference:", MplusInf - Mmin) } ## use a slightly lower maximum, to ensure finite radii Margin <- MplusInf - Mmin eps <- sqrt(.Machine$double.eps) if(Margin >= 0) { delta <- 1e-4 * Margin delta <- max(min(delta, 0.1), eps) Mmax <- MplusInf - delta } else { if(Margin < -eps) warning(paste0("Internal numerical problem: MplusInf < Mmin ", paren(paste("difference", Margin)), "; reset MplusInf = Mmin")) Mmax <- MplusInf <- Mmin } if(Mmin >= Mmax) { Mmax <- MplusInf <- Mmin if(verbose) splat("\tNo dominating parents required (Mmax <= Mmin)") } else { if(verbose) splat("\tExpected number of dominating parents to be generated:", round(Mmax-Mmin, 2)) ## Inverse function of Mplus available? inverseMplus <- sinfo$invMplus use.inverse <- use.special && isTRUE(use.inverse) && is.function(inverseMplus) if(!use.inverse) { ## Numerical root-finding is required ## Mplus(r) is proportional to r^2 on [0, rD] MplusrD <- Mplus(rD) ## Find upper bound on distance to origin corresponding to 'Mmax' Rmax <- rD + scale doublings <- 0L while(Mplus(Rmax) < Mmax) { Rmax <- 2 * Rmax doublings <- doublings + 1L if(doublings > 1e5) stop("Internal error: no solution for Mplus(Rmax) >= Mmax") } if(verbose) splat("\tUpper bound on distance from parent to centre of window:", signif(Rmax, 4)) Contrast <- function(x, m) { Mplus(x) - m } SolveRadius <- function(m, rD, rmax, MrD) { if(m <= MrD) return(rD * sqrt(m/MrD)) if(m >= Mmax) return(Rmax) uniroot(Contrast, c(rD, 1.1*rmax), m=m)[["root"]] } } } }, superBK = { ## .............................................................................................. ## Use a process that dominates the dominating process ## .............................................................................................. if(verbose) splat("External parents: super-dominating process") if(use.special) { rhoplus <- sinfo$rhoplus ## superdominating parent intensity, given distance to origin rhoplusplus <- sinfo$rhoplusplus ## radial cumulative integral of intensity for superdominating process ## i.e. Mplusplus(r) = int_0^r { s * rhoplusplus(s) } ds sinfoMplusplus <- sinfo$Mplusplus Mplusplus <- function(r) { sinfoMplusplus(r, mod, rD, method=integralmethod) } ## integral of superparent intensity = Mplusplus(Inf) MplusplusInf <- sinfo$MplusplusInf(mod, rD) } else { ## generic code rhoplus <- function(r, ...) { kappa <- mod$par[["kappa"]] z <- numeric(length(r)) above <- (r > rD) z[!above] <- Eplus(0) z[above] <- Eplus(r[above]) return(kappa * (1 - exp(-z))) } rhoplusplus <- function(r, ...) { kappa <- mod$par[["kappa"]] z <- numeric(length(r)) above <- (r > rD) z[!above] <- Eplus(0) z[above] <- Eplus(r[above]) return(kappa * z) } MplusplusIntegrand <- function(r) { 2 * pi * r * rhoplusplus(r) } Mplusplus <- function(r) { rstart <- LowerLimit if(rstart == 0) { z <- pi * pmin(r, rD)^2 * rhoplusplus(0) high <- (r > rD) if(any(high)) z[high] <- z[high] + indefinteg(MplusplusIntegrand, r[high], lower=rD, method=integralmethod) } else { z <- numeric(length(r)) high <- (r > rstart) if(any(high)) z[high] <- indefinteg(MplusplusIntegrand, r[high], lower=rstart, method=integralmethod) } return(z) } MplusplusInf <- Mplusplus(Inf) } if(verbose) splat("\tTotal integral of intensity of superparents:", round(MplusplusInf, 2)) ## generate values uniformly distributed between Mmin and MplusplusInf Mmin <- switch(internal, dominating=0, naive=Mplusplus(rE)) if(verbose && internal == "naive") { splat("\tIntegral inside", paste0(discEname, ":"), round(Mmin, 2)) splat("\tDifference:", MplusplusInf - Mmin) } ## use a slightly lower maximum, to ensure finite radii Margin <- MplusplusInf - Mmin eps <- sqrt(.Machine$double.eps) if(Margin >= 0) { delta <- 1e-4 * Margin delta <- max(min(delta, 0.1), eps) Mmax <- MplusplusInf - delta } else { if(Margin < -eps) warning(paste0("Internal numerical problem: ", "MplusplusInf < Mmin ", paren(paste("difference", Margin)), "; reset MplusplusInf = Mmin")) Mmax <- MplusplusInf <- Mmin } if(Mmin >= Mmax) { Mmax <- MplusplusInf <- Mmin if(verbose) splat("\tNo superparents required (Mmax = Mmin)") } else { if(verbose) splat("\tExpected number of superparents to be generated:", round(Mmax-Mmin, 2)) ## Inverse function of Mplusplus available? inverseMplusplus <- sinfo$invMplusplus use.inverse <- use.special && isTRUE(use.inverse) && is.function(inverseMplusplus) if(!use.inverse) { ## Numerical root-finding required ## Mplusplus(r) is proportional to r^2 on [0, rD] MplusplusrD <- Mplusplus(rD) ## Find upper bound on solution corresponding to 'Mmax' Rmax <- rD + scale doublings <- 0L while(Mplusplus(Rmax) < Mmax) { Rmax <- 2 * Rmax doublings <- doublings + 1L if(doublings > 1e5) stop("Internal error: no solution for Mplusplus(Rmax) >= Mmax") } if(verbose) splat("Upper bound on distance from superparent to centre of window:", signif(Rmax, 6)) Contrast <- function(x, m) { Mplusplus(x) - m } SolveRadius <- function(m, rD, rmax, MrD) { if(m <= MrD) return(rD * sqrt(m/MrD)) if(m >= Mmax) return(Rmax) uniroot(Contrast, c(rD, 1.1*rmax), m=m)[["root"]] } } } }) ## >>>>>>>>>>>>>>> s t a r t s i m u l a t i o n l o o p <<<<<<<<<<<<<<<<<<<<<<< resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { if(verbose && nsim > 1) splat("Generating realisation", isim) cost <- 0 ## ....................... ## PARENTS OUTSIDE DISC ## ....................... switch(external, border = { ## ................................................................. ## naive: generate parents uniformly in border region ## ................................................................. externalparentname <- "dominating parents in border region" if(Eborder == 0) { ndom <- 0 } else { ndom <- rpois(1, Eborder) cost <- cost + ndom if(verbose) splat("Generated", externalparentname, "\n\tNumber:", ndom) if(warn && ndom > nhuge) { whinge <- paste("Generating", ndom, externalparentname) message(whinge) warning(whinge, call.=FALSE) } } if(ndom > 0) rdom <- sqrt(runif(ndom, min=rE^2, max=Rmax^2)) }, BK = { ## ................................................................. ## original Brix-Kendall (possibly restricted to parents outside E) ## ................................................................. ## generate Poisson number of parents in dominating process ## (possibly restricted to locations outside E) externalparentname <- if(internal != "naive") "dominating parents" else paste("dominating parents outside", discEname) if(MplusInf > Mmin) { ndom <- rpois(1, MplusInf - Mmin) cost <- cost + ndom if(verbose) splat("Generated", externalparentname, "\n\tNumber:", ndom) if(warn && ndom > nhuge) { whinge <- paste("Generating", ndom, externalparentname) message(whinge) warning(whinge, call.=FALSE) } } else { ndom <- 0 } ## generate parent locations if(ndom > 0) { mdom <- runif(ndom, min=Mmin, max=Mmax) if(use.inverse) { ## inverse function is analytic rdom <- inverseMplus(mdom, mod, rD, MplusInf) } else { ## use root-finding mdom <- sort(mdom, decreasing=TRUE) rdom <- numeric(ndom) rmax <- Rmax ## Mplus(r) is proportional to r^2 on [0, rD] below <- (mdom <= MplusrD) rdom[below] <- rD * sqrt(mdom[below]/MplusrD) for(i in which(!below)) { ## solve for radius, and use this as the upper bound for the next problem rmax <- rdom[i] <- SolveRadius(mdom[i], rD, rmax, MplusrD) } } if(verbose) splat("\tRange of distances from origin:", prange(signif(range(rdom), 3))) } }, superBK = { ## ................................................................. ## Brix-Kendall with super-dominating process ## (possibly restricted to parents outside E) ## ................................................................. externalparentname <- if(internal != "naive") "super-parents" else paste("super-parents outside", discEname) ## generate Poisson number of superparents if(MplusplusInf > Mmin) { nsuper <- rpois(1, MplusplusInf - Mmin) cost <- cost + nsuper if(verbose) splat("Generated", externalparentname, "\n\tNumber:", nsuper) if(warn && nsuper > nhuge) { whinge <- paste("Generating", nsuper, externalparentname) message(whinge) warning(whinge, call.=FALSE) } } else { nsuper <- 0 } ## generate superparent locations if(nsuper == 0) { ndom <- 0 } else { ## generate radii by inverting Mplusplus msuper <- runif(nsuper, min=Mmin, max=Mmax) rsuper <- numeric(nsuper) if(use.inverse) { ## inverse function is analytic rsuper <- inverseMplusplus(msuper, mod, rD, MplusplusInf) } else { ## use numerical root-finding msuper <- sort(msuper, decreasing=TRUE) rmax <- Rmax ## Mplusplus(r) is proportional to r^2 on [0, rD] below <- (msuper < MplusplusrD) rsuper[below] <- rD * sqrt(msuper[below]/MplusplusrD) for(i in which(!below)) rmax <- rsuper[i] <- SolveRadius(msuper[i], rD, rmax, MplusplusrD) } if(verbose) splat("\tRange of distances from origin:", prange(signif(range(rsuper), 3))) ## thin the superdominating parents to dominating parents rdom <- rsuper[rhoplus(rsuper, mod, rD) > runif(nsuper) * rhoplusplus(rsuper, mod, rD)] ndom <- length(rdom) if(verbose) { splat("Thinned superparents to obtain dominating parents\n", "\tNumber of dominating parents:", ndom, "\n\t", "Acceptance rate:", signif(as.numeric(ndom)/nsuper, 4)) if(ndom > 0) splat("\tRange of distances from origin:", prange(signif(range(rdom), 3))) } } }) ## Now generate offspring if(ndom == 0) { noff <- 0L } else { ## generate locations of [dominating/proposed] parents theta <- runif(ndom, max=2*pi) xp <- rdom * cos(theta) yp <- rdom * sin(theta) if(verbose) { splat("Generated spatial locations of", ndom, externalparentname) splat("\n\nGenerating offspring of", externalparentname) } ## generate offspring switch(external, border = { ## for each proposed parent, generate nonzero number of offspring, ## according to cluster mechanism offspringname <- paste("offspring of", externalparentname) noffeach <- rpoisnonzero(ndom, mu) noff <- sum(noffeach) cost <- cost + noff if(verbose) splat("Generated", offspringname, "\n\tNumber of offspring:", noff) if(warn && noff > nhuge) { whinge <- paste("Generating", noff, offspringname) message(whinge) warning(whinge, call.=FALSE) } ## assign offspring to parents parentid <- rep.int(1:ndom, noffeach) ## offspring are random displacements of parents displace <- roffspring(noff, mod) xoff <- xp[parentid] + displace$x yoff <- yp[parentid] + displace$y ## clip to window retain <- inside.owin(xoff, yoff, W) noff <- sum(retain) if(verbose) splat("Clipped to window\n\tNumber of offspring in window:", noff) }, BK = , superBK = { ## generate nonzero number of offspring in disc, for each dominating parent Edom <- Eplus(rdom, mod, rD) noffeach <- rpoisnonzero(ndom, Edom) noff <- sum(noffeach) cost <- cost + noff offspringname <- paste("offspring (inside disc) of", externalparentname) if(verbose) splat("Generated", offspringname, "\n\tNumber of offspring:", noff) if(warn && noff > nhuge) { whinge <- paste("Generating", noff, offspringname) message(whinge) warning(whinge, call.=FALSE) } ## offspring are uniform in disc roff <- sqrt(runif(noff, max=rD^2)) toff <- runif(noff, max=2*pi) xoff <- roff * cos(toff) yoff <- roff * sin(toff) ## assign offspring to parents parentid <- rep.int(1:ndom, noffeach) ## thin using correct kernel dx <- xoff - xp[parentid] dy <- yoff - yp[parentid] dr <- sqrt(dx^2 + dy^2) hcorrect <- cinfo$kernel(par=par, rvals=dr, model=shapemodel, margs=shapeargs) hdom <- hdomfun(rdom, mod, rD)[parentid] if(any(bad <- (hcorrect > hdom))) stop(paste("Internal error:", sum(bad), "values of the dominating kernel do not dominate the true kernel"), call.=FALSE) retain <- (hcorrect >= runif(noff) * hdom) if(verbose) splat("Thinned offspring to correct process\n", "\tNumber of retained offspring in disc:", sum(retain), "\n\tAcceptance rate:", signif(mean(retain), 4)) if(any(retain)) { ## finally clip to window retain[retain] <- inside.owin(xoff[retain], yoff[retain], W) } noff <- sum(retain) if(verbose) splat("Clipped to window\n\tNumber of offspring in window:", noff) }) } ## ................................... ## Apply the thinning ## ................................... if(noff > 0) { xoff <- xoff[retain] yoff <- yoff[retain] parentid <- parentid[retain] retainedparents <- sort(unique(parentid)) parentid <- match(parentid, retainedparents) xp <- xp[retainedparents] yp <- yp[retainedparents] np <- length(retainedparents) } else { xoff <- yoff <- xp <- yp <- numeric(0) parentid <- integer(0) np <- 0L } if(verbose) splat("Total number of offspring points", if(internal == "naive") "(of parents outside disc):" else ":", noff) ## ................................ ## PARENTS INSIDE (inflated) DISC ## ................................ switch(internal, dominating = { ## Parents were already generated above if(verbose) splat("Internal parents:", switch(external, BK="Brix-Kendall dominating process", superBK = "super-dominating process", border = "border method"), "(already generated)") }, naive = { ## Generate parents inside (inflated) disc ## conditional on having at least 1 offspring **anywhere** internalparentname <- paste("additional parents inside", discEname) if(verbose) { splat("Internal parents: naive method", "\n\tGenerating", internalparentname, "with intensity", signif(kappadag, 4)) } npin <- rpois(1, kappadag * pi * rE^2) rpin <- sqrt(runif(npin, max=rE^2)) tpin <- runif(npin, max=2*pi) xpin <- rpin * cos(tpin) ypin <- rpin * sin(tpin) cost <- cost + npin if(verbose) splat("\tNumber of", paste0(internalparentname, ":"), npin) if(warn && npin > nhuge) { whinge <- paste("Generating", npin, internalparentname) message(whinge) warning(whinge, call.=FALSE) } if(npin > 0) { offspringname <- paste("offspring of", internalparentname) if(verbose) splat("\nGenerating", offspringname) noff.in.each <- rpoisnonzero(npin, mu) noff.in <- sum(noff.in.each) cost <- cost + noff.in if(verbose) splat("\tNumber of", paste0(offspringname, ":"), noff.in) if(warn && noff.in > nhuge) { whinge <- paste("Generating", noff.in, offspringname) message(whinge) warning(whinge, call.=FALSE) } pid.in <- rep.int(1:npin, noff.in.each) displace <- roffspring(noff.in, mod) xoff.in <- xpin[pid.in] + displace[["x"]] yoff.in <- ypin[pid.in] + displace[["y"]] ## restrict to window retain.in <- inside.owin(xoff.in, yoff.in, W) if(verbose) splat("Clipping", offspringname, "to window", "\n\tNumber retained:", sum(retain.in), paren(paste("acceptance rate", signif(mean(retain.in), 4)))) if(any(retain.in)) { ## retain these offspring xoff.in <- xoff.in[retain.in] yoff.in <- yoff.in[retain.in] pid.in <- pid.in[retain.in] retainedpid.in <- sort(unique(pid.in)) pid.in <- match(pid.in, retainedpid.in) xpin <- xpin[retainedpid.in] ypin <- ypin[retainedpid.in] npin <- length(retainedpid.in) ## append to existing xoff <- c(xoff, xoff.in) yoff <- c(yoff, yoff.in) parentid <- c(parentid, np + pid.in) noff <- noff + sum(retain.in) xp <- c(xp, xpin) yp <- c(yp, ypin) np <- np + npin } } }) ## Pack up simulation result [[isim]] if(verbose) splat("Final total number of offspring points:", noff) if(noff == 0) { Y <- emptypattern } else { Y <- ppp(xoff + oldcentre[1], yoff + oldcentre[2], window=oldW) attr(Y, "parents") <- list(x = xp + oldcentre[1], y = yp + oldcentre[2]) attr(Y, "parentid") <- parentid } attr(Y, "cost") <- cost resultlist[[isim]] <- Y } ## >>>>>>>>>>>>>>> e n d l o o p <<<<<<<<<<<<<<<<<<<<<<< result <- simulationresult(resultlist, nsim, drop) return(result) } optimalinflation <- function(clusters, mod, rD) { ## Optimal inflated disc radius rE, determined by root-finding ## as in section 6.6 of Baddeley and Chang (2023) cinfo <- spatstatClusterModelInfo(clusters) # error if unrecognised par.native <- cinfo$checkpar(mod$par, native=TRUE) mu <- mod$mu margs <- mod$shapeargs a <- if(mu == 0) 1 else (1 + (1-exp(-mu))/mu) b <- a/(pi * rD^2) h0 <- cinfo$kernel(par.native, 0, margs=margs) if(h0 <= b) { rE <- rD } else { kernel <- cinfo$kernel f <- function(x) { b - kernel(par.native, x, margs=margs) } u <- try(uniroot(f, c(0, 100 * scale)), silent=TRUE) if(inherits(u, "try-error")) { rE <- 2 * rD } else { rE <- rD + u$root } } return(rE) } spatstat.random/R/randomsets.R0000644000176200001440000000077414331654772016123 0ustar liggesusers#' #' randomsets.R #' #' Generation of random sets #' #' $Revision: 1.2 $ $Date: 2019/08/16 07:53:05 $ rthinclumps <- function(W, p, ...) { check.1.real(p) if(badprobability(p, TRUE)) stop("p must be a valid probability between 0 and 1", call.=FALSE) if(!(is.im(W) || is.owin(W))) stop("W should be a window or pixel image", call.=FALSE) clumps <- connected(W, ...) keep <- (runif(length(levels(clumps))) < p) retained <- eval.im(keep[clumps]) return(solutionset(retained)) } spatstat.random/R/randompp3.R0000644000176200001440000000301014331654772015631 0ustar liggesusers#' #' randompp3.R #' #' $Revision: 1.2 $ $Date: 2022/05/23 02:33:06 $ #' runifpoint3 <- function(n, domain=box3(), nsim=1, drop=TRUE) { domain <- as.box3(domain) check.1.integer(nsim) stopifnot(nsim >= 0) result <- vector(mode="list", length=nsim) dd <- as.list(domain)[c("xrange", "yrange", "zrange")] for(i in seq_len(nsim)) { x <- with(dd, runif(n, min=xrange[1], max=xrange[2])) y <- with(dd, runif(n, min=yrange[1], max=yrange[2])) z <- with(dd, runif(n, min=zrange[1], max=zrange[2])) result[[i]] <- pp3(x,y,z,domain) } if(drop && nsim == 1) return(result[[1]]) result <- as.anylist(result) if(nsim > 0) names(result) <- paste("Simulation", seq_len(nsim)) return(result) } rpoispp3 <- function(lambda, domain=box3(), nsim=1, drop=TRUE) { domain <- as.box3(domain) v <- volume(domain) check.1.integer(nsim) stopifnot(nsim >= 0) if(!(is.numeric(lambda) && length(lambda) == 1)) stop("lambda must be a single numeric value") np <- rpois(nsim, lambda * v) dd <- as.list(domain)[c("xrange", "yrange", "zrange")] result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { ni <- np[i] x <- with(dd, runif(ni, min=xrange[1], max=xrange[2])) y <- with(dd, runif(ni, min=yrange[1], max=yrange[2])) z <- with(dd, runif(ni, min=zrange[1], max=zrange[2])) result[[i]] <- pp3(x,y,z,domain) } if(drop && nsim == 1) return(result[[1]]) result <- as.anylist(result) if(nsim > 0) names(result) <- paste("Simulation", seq_len(nsim)) return(result) } spatstat.random/R/pakes.R0000644000176200001440000000650114331654772015041 0ustar liggesusers## pakes.R ## ## The probability distribution that satisfies the distributional equivalence ## X == U^(1/zeta) (1 + X) ## where X, U are independent r.v.'s and U is uniform [0,1] ## ## Solution due to A.G. Pakes presented in ## Baddeley, Moller & Pakes (2008) ## Properties of residuals for spatial point processes, ## Annals of the Institute of Statistical Mathematics 60 (2008) 627-649 ## ## Implementation (c) Adrian Baddeley 2021 ## GNU Public Licence >= 2.0 pakesCalc <- function(zeta, dx=0.001, xmax=5) { check.1.real(zeta) stopifnot(zeta > 0) EulerGamma <- -digamma(1) # Euler-Mascheroni constant C <- exp(-EulerGamma * zeta)/gamma(1 + zeta) ## cat(paste("C=", C, "\n")) x <- seq(0, xmax, by=dx) xzeta <- x^zeta inv1x1zeta <- 1/(1 + x)^(1+zeta) nx <- length(x) shifted <- seq_len(nx) - floor(1/dx) shifted[shifted < 1] <- NA Fx <- numeric(nx) ceilx <- ceiling(x) slice1 <- (ceilx == 1) Fx[slice1] <- C * xzeta[slice1] nmax <- ceiling(xmax) if(nmax > 1) { for(k in 2:nmax) { integrand <- Fx * inv1x1zeta indefInteg <- zeta * dx * cumsum(integrand) ## plot(x, indefInteg, type="l") shiftedIndefInt <- ifelse(is.na(shifted), 0, indefInteg[shifted]) ## plot(x, shiftedIndefInt, type="l") slicek <- (ceilx == k) Fx[slicek] <- xzeta[slicek] * (C - shiftedIndefInt[slicek]) ## suppress numerical glitch close to F(x) = 1 if(any(exceed <- (Fx >= 1))) { last <- min(which(exceed)) Fx[last:length(Fx)] <- 1 break; } } } ## suppress numerical glitches if(any(dip <- (Fx < cummax(Fx)))) { ok <- !dip Fx[dip] <- approx(x=x[ok], y=Fx[ok], xout=x[dip], rule=2, yright=1)$y } ## return data.frame(x=x, Fx=Fx) } ppakes <- function(q, zeta) { q <- as.numeric(q) zeta <- as.numeric(zeta) if(length(zeta) > 1) return(mapply(ppakes, q=q, zeta=zeta)) a <- pakesCalc(zeta, xmax=max(ceiling(q))) Fpakes <- approxfun(a$x, a$Fx, rule=2) p <- Fpakes(q) return(p) } dpakes <- function(x, zeta) { x <- as.numeric(x) zeta <- as.numeric(zeta) if(length(zeta) > 1) return(mapply(dpakes, x=x, zeta=zeta)) C <- exp(digamma(1) * zeta)/gamma(1 + zeta) y <- numeric(length(x)) if(any(low <- (x <= 1))) y[low] <- C * zeta * x[low]^(zeta-1) if(any(high <- !low)) { xhigh <- x[high] a <- pakesCalc(zeta, xmax=max(xhigh)) Fxhigh <- approx(x=a$x, y=a$Fx, xout=xhigh, rule=2, yright=1)$y Fxhigh1 <- approx(x=a$x, y=a$Fx, xout=xhigh - 1, rule=2, yright=1)$y y[high] <- (zeta/xhigh) * (Fxhigh - Fxhigh1) } return(y) } qpakes <- function(p, zeta) { p <- as.numeric(p) zeta <- as.numeric(zeta) if(length(zeta) > 1) return(mapply(qpakes, p=p, zeta=zeta)) ## find 'xmax' such that F(xmax) = 1 within numerical error zetabreaks <- c(0, 0.1, 0.5, 1, 2, 10, 20, Inf) xmaxvalues <- c( 3, 6, 8, 10, 20, 30, 1.5 * zeta) xmax <- xmaxvalues[findInterval(zeta, zetabreaks, all.inside=TRUE)] ## compute CDF a <- pakesCalc(zeta, xmax=xmax) a <- a[!duplicated(a$Fx), ] ## invert q <- approx(x=a$Fx, y=a$x, xout=p, rule=2, yleft=0, yright=1)$y return(q) } rpakes <- function(n, zeta) { qpakes(runif(n), zeta) } spatstat.random/R/rvargamma.R0000644000176200001440000001601314356425372015711 0ustar liggesusers#' #' rvargamma.R #' #' $Revision: 1.6 $ $Date: 2023/01/08 02:26:28 $ #' #' Simulation of Variance-Gamma cluster process #' using either naive algorithm or BKBC algorithm #' (R code) #' #' rVarGamma #' #' Original code for naive simulation of Neyman-Scott by Adrian Baddeley #' Original code for simulation of rVarGamma offspring by Abdollah Jalilian #' Bug fixes by Abdollah, Adrian Baddeley, and Rolf Turner #' #' Implementation of BKBC algorithm by Adrian Baddeley and Ya-Mei Chang #' #' Copyright (c) 2000-2023 Adrian Baddeley, Abdollah Jalilian, Ya-Mei Chang #' GNU Public Licence >= 2 ## ## ================================================================= ## Neyman-Scott process with Variance Gamma (Bessel) kernel function ## ================================================================= ## nu.ker: smoothness parameter of Variance Gamma kernel function ## omega: scale parameter of kernel function ## nu.pcf: smoothness parameter of Variance Gamma pair correlation function ## eta: scale parameter of Variance Gamma pair correlation function ## nu.pcf = 2 * nu.ker + 1 and eta = omega rVarGamma <- local({ ## simulates mixture of isotropic Normal points in 2D with gamma variances rnmix.gamma <- function(n = 1, shape, rate) { V <- matrix(rnorm(2 * n, 0, 1), nrow = n, ncol = 2) s <- rgamma(n, shape=shape, rate=rate) return(sqrt(s) * V) } ## main function rVarGamma <- function(kappa, scale, mu, nu, win = square(1), nsim=1, drop=TRUE, ..., algorithm=c("BKBC", "naive"), nonempty=TRUE, thresh = 0.001, poisthresh=1e-6, expand = NULL, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL) { ## Variance-Gamma cluster process ## nu / nu.ker: smoothness parameter of Variance Gamma kernel function ## scale / omega: scale parameter of kernel function check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) ## Catch old nu.ker/nu.pcf syntax and resolve nu-value. dots <- list(...) if(missing(nu)){ nu <- resolve.vargamma.shape(nu.ker=dots$nu.ker, nu.pcf=dots$nu.pcf, allow.default=TRUE)$nu.ker } else { check.1.real(nu) stopifnot(nu > -1) } nu.ker <- nu ## Catch old scale syntax (omega) if(missing(scale)) scale <- dots$omega ## Catch old name 'eps' for 'thresh': if(missthresh <- missing(thresh)) thresh <- dots$eps %orifnull% 0.001 ## determine the effective maximum radius of clusters ## (for the naive algorithm, or when kappa is not constant) if(missing(expand)){ expand <- clusterradius("VarGamma", scale = scale, nu = nu.ker, thresh = thresh, ...) } else if(!missthresh) { warning("Argument ", sQuote("thresh"), " is ignored when ", sQuote("expand"), " is given") } #' validate 'kappa' and 'mu' km <- validate.kappa.mu(kappa, mu, kappamax, mumax, win, expand, ..., context="In rCauchy") kappamax <- km[["kappamax"]] mumax <- km[["mumax"]] ## detect trivial case where patterns are empty if(kappamax == 0 || mumax == 0) { empt <- ppp(window=win) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } if(saveLambda) attr(empt, "Lambda") <- as.im(0, W=win) result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } #' determine algorithm algorithm <- match.arg(algorithm) do.parents <- saveparents || saveLambda || !is.numeric(kappa) do.hybrid <- (algorithm == "BKBC") && nonempty if(do.hybrid) { ## ........ Fast algorithm (BKBC) ................................. ## run BKBC algorithm for stationary model ## (generic R implementation using information from cluster model table) result <- do.call(rclusterBKBC, resolve.defaults( list(clusters = "VarGamma", kappa = kappamax, scale = scale, mu = mumax, nu.ker = nu.ker, W = quote(win), nsim = nsim, drop = FALSE), list(...), list(internal = "naive", external = "super", inflate = "optimal", verbose=FALSE))) ## thin if(!is.numeric(kappa)) result <- solapply(result, thinParents, P=kappa, Pmax=kappamax) if(!is.numeric(mu)) result <- solapply(result, rthin, P=mu, Pmax=mumax, na.zero=TRUE, fatal=FALSE) } else { ## .......... Slower algorithm ('naive') .......................... ## trap case of large clusters, close to Poisson if(is.numeric(kappa) && 1/(4 * pi * kappamax * scale^2) < poisthresh) { if(is.function(mu)) mu <- as.im(mu, W=win, ...) kapmu <- kappa * mu result <- rpoispp(kapmu, win=win, nsim=nsim, drop=drop, warnwin=FALSE) result <- fakeNeyScot(result, kapmu, win, saveLambda, saveparents) return(result) } ## gamma mixture of normals alpha <- 2 * (nu.ker + 1) beta <- 1/(2 * scale^2) ## simulate result <- rNeymanScott(kappa=kappa, expand=expand, rcluster=list(mu, rnmix.gamma), win=win, shape = alpha/2, # formal argument of rnmix.gamma rate = beta, # formal argument of rnmix.gamma nsim=nsim, drop=FALSE, nonempty = nonempty, saveparents = do.parents, kappamax=kappamax, mumax=mumax) } if(saveLambda){ BW <- Frame(win) for(i in 1:nsim) { parents <- attr(result[[i]], "parents") BX <- boundingbox(BW, bounding.box.xy(parents)) parents <- as.ppp(parents, W=BX, check=FALSE) Lambda <- clusterfield("VarGamma", parents, scale=scale, nu=nu.ker, mu=mu, ...) attr(result[[i]], "Lambda") <- Lambda[win, drop=FALSE] } } return(simulationresult(result, nsim, drop)) } inflateVarGamma <- function(mod, rD) { optimalinflation("VarGamma", mod, rD) } rVarGamma }) spatstat.random/R/rmh.R0000644000176200001440000000010714243055211014501 0ustar liggesusers# # generic rmh rmh <- function(model, ...){ UseMethod("rmh") } spatstat.random/R/randomseg.R0000644000176200001440000000403014560117311015673 0ustar liggesusers# # randomseg.R # # $Revision: 1.18 $ $Date: 2024/02/04 08:04:51 $ # rpoisline <- function(lambda, win=owin()) { win <- as.owin(win) # determine circumcircle xr <- win$xrange yr <- win$yrange xmid <- mean(xr) ymid <- mean(yr) width <- diff(xr) height <- diff(yr) rmax <- sqrt(width^2 + height^2)/2 boundbox <- owin(xmid + c(-1,1) * rmax, ymid + c(-1,1) * rmax) # generate poisson lines through circumcircle n <- rpois(1, lambda * 2 * pi * rmax) if(n == 0) { X <- psp(numeric(0), numeric(0), numeric(0), numeric(0), marks=integer(0), window=win) attr(X, "lines") <- infline(p=numeric(0), theta=numeric(0)) attr(X, "linemap") <- integer(0) return(X) } theta <- runif(n, max= 2 * pi) p <- runif(n, max=rmax) # compute intersection points with circle q <- sqrt(rmax^2 - p^2) co <- cos(theta) si <- sin(theta) X <- psp(x0= xmid + p * co + q * si, y0= ymid + p * si - q * co, x1= xmid + p * co - q * si, y1= ymid + p * si + q * co, marks = seq_len(n), window=boundbox, check=FALSE) # infinite lines L <- infline(p = p + xmid * co + ymid * si, theta = theta) # clip to window X <- X[win] # append info linemap <- as.integer(marks(X)) X <- unmark(X) attr(X, "lines") <- L attr(X, "linemap") <- linemap return(X) } rjitter.psp <- function(X, radius, ..., clip=TRUE, nsim=1, drop=TRUE) { if(nsegments(X) == 0) { result <- rep(list(X), nsim) result <- simulationresult(result, nsim, drop) return(result) } Xfrom <- endpoints.psp(X, "first") Xto <- endpoints.psp(X, "second") if(clip) Window(Xfrom) <- Window(Xto) <- grow.rectangle(Frame(X), radius) result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { Xfrom <- rjitter(Xfrom, radius) Xto <- rjitter(Xto, radius) Y <- as.psp(from=Xfrom, to=Xto) if(clip) Y <- Y[Window(X), clip=TRUE] result[[isim]] <- Y } result <- simulationresult(result, nsim, drop) return(result) } spatstat.random/R/rags.R0000644000176200001440000000511314331654772014670 0ustar liggesusers#' #' rags.R #' #' Alternating Gibbs Sampler #' #' $Revision: 1.6 $ $Date: 2016/11/29 05:01:51 $ #' #' Initial implementation for multitype hard core process #' without interaction within types rags <- function(model, ..., ncycles=100) { if(!is.list(model)) stop("Argument 'model' should be a list") if(!all(c("beta", "hradii") %in% names(model))) stop("Argument 'model' should have entries 'beta' and 'hradii'") do.call(ragsMultiHard, append(model, list(..., ncycles=ncycles))) } ragsMultiHard <- function(beta, hradii, ..., types=NULL, bmax=NULL, periodic=FALSE, ncycles=100) { ## validate beta by generating first proposal points Xprop <- rmpoispp(lambda=beta, lmax=bmax, ..., types=types) ntypes <- length(levels(marks(Xprop))) check.nmatrix(hradii, ntypes, things="types of points") if(any(is.finite(dh <- diag(hradii)) & dh > 0)) stop("Interaction between points of the same type is not permitted") ## initial state empty X <- Xprop[integer(0)] Y <- split(X) ## for(cycle in 1:ncycles) { if(cycle > 1) Xprop <- rmpoispp(lambda=beta, lmax=bmax, ..., types=types) Xprop <- Xprop[order(coords(Xprop)$x)] Yprop <- split(Xprop) for(i in 1:ntypes) { Xi <- Yprop[[i]] ok <- TRUE for(j in (1:ntypes)[-i]) { if(!any(ok)) break; ok <- ok & !has.close(Xi, hradii[i,j], Y[[j]], sorted=TRUE, periodic=periodic) } Y[[i]] <- Xi[ok] } } Z <- do.call(superimpose, Y) return(Z) } ragsAreaInter <- function(beta, eta, r, ..., win=NULL, bmax=NULL, periodic=FALSE, ncycles=100) { check.1.real(eta) check.1.real(r) if(r == 0 || eta == 1) return(rpoispp(beta, win=win, lmax=bmax, ...)) if(eta < 1) stop("Alternating Gibbs algorithm requires eta >= 1", call.=FALSE) if(is.function(beta)) { beta <- as.im(beta, W=win, ...) } else if(is.numeric(beta)) { check.1.real(beta) stopifnot(beta >= 0) } else if(!is.im(beta)) { stop("beta should be a number, a pixel image, or a function(x,y)", call.=FALSE) } if(is.im(beta) && is.null(win)) win <- as.owin(beta) kappa <- beta * eta loggamma <- log(eta)/(pi * r^2) bmax <- if(is.null(bmax)) NULL else c(max(kappa), loggamma) B <- if(is.numeric(beta)) c(kappa, loggamma) else solist(kappa, as.im(loggamma, W=win)) H <- matrix(c(0,r,r,0), 2, 2) Y <- ragsMultiHard(B, H, types=1:2, bmax=bmax, periodic=periodic, ncycles=ncycles) X <- split(Y)[[1]] return(X) } spatstat.random/R/rmatclust.R0000644000176200001440000002772314432633410015751 0ustar liggesusers#' #' rmatclust.R #' #' $Revision: 1.5 $ $Date: 2023/05/22 09:33:57 $ #' #' Simulation of Matern cluster process #' naive algorithm or BKBC algorithm #' #' rMatClustHom Interface to C code for stationary case (BKBC) #' rMatClust General case (naive or BKBC) #' #' Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022-2023 #' Licence: GNU Public Licence >= 2 rMatClustHom <- function(kappa, mu, R, W=unit.square(), ..., nsim=1, drop=TRUE, inflate=NULL, saveparents=FALSE) { check.1.real(kappa) && check.finite(kappa) check.1.real(mu) && check.finite(mu) check.1.real(R) && check.finite(R) if(!is.null(inflate)) { check.1.real(inflate) && check.finite(inflate) stopifnot(inflate >= 1) } check.1.integer(nsim) stopifnot(kappa >= 0) stopifnot(mu >= 0) stopifnot(R > 0) ## trivial cases if(nsim == 0) return(simulationresult(list())) if(kappa == 0 || mu == 0) { ## intensity is zero - patterns are empty empt <- ppp(window=W) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } ## shift window to convenient origin oldW <- W oldcentre <- as.numeric(centroid.owin(Frame(oldW))) W <- shift(oldW, -oldcentre) ## enclose it in a disc rD <- with(vertices(Frame(W)), sqrt(max(x^2+y^2))) ## optimal inflation if(is.null(inflate)) { rE <- if(R < rD) (rD + R) else rD inflate <- rE/rD } ## Prepare for C code storage.mode(kappa) <- "double" storage.mode(mu) <- "double" storage.mode(R) <- "double" storage.mode(rD) <- "double" storage.mode(inflate) <- "double" ## resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## call C code if(saveparents) { z <- .Call(SR_rmatclusAll, kappa, mu, R, rD, inflate, PACKAGE="spatstat.random") } else { z <- .Call(SR_rmatclusOff, kappa, mu, R, rD, inflate, PACKAGE="spatstat.random") } ## unpack xo <- z[[1]] yo <- z[[2]] if(saveparents) { xp <- z[[3]] yp <- z[[4]] parentid <- z[[5]] } ## shift back to original window xo <- xo + oldcentre[1L] yo <- yo + oldcentre[2L] if(saveparents) { xp <- xp + oldcentre[1L] yp <- yp + oldcentre[2L] } ## restrict to original window retain <- inside.owin(xo, yo, oldW) if(!all(retain)) { xo <- xo[retain] yo <- yo[retain] if(saveparents) { parentid <- parentid[retain] retainedparents <- sort(unique(parentid)) parentid <- match(parentid, retainedparents) xp <- xp[retainedparents] yp <- yp[retainedparents] } } ## save as point pattern Y <- ppp(xo, yo, window=oldW, check=FALSE) if(saveparents) { attr(Y, "parents") <- list(x = xp, y = yp) attr(Y, "parentid") <- parentid attr(Y, "cost") <- length(xo) + length(xp) } resultlist[[isim]] <- Y } result <- simulationresult(resultlist, nsim, drop=drop) return(result) } rMatClust <- local({ ## like runifdisc but returns only the coordinates rundisk <- function(n, radius) { R <- radius * sqrt(runif(n, min=0, max=1)) Theta <- runif(n, min=0, max=2*pi) cbind(R * cos(Theta), R * sin(Theta)) } rMatClust <- function(kappa, scale, mu, win = square(1), nsim=1, drop=TRUE, ..., n.cond=NULL, w.cond=NULL, algorithm=c("BKBC", "naive"), nonempty=TRUE, poisthresh=1e-6, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL) { ## Matern Cluster Process ## Poisson (mu) number of offspring, uniform inside disc check.1.integer(nsim) && check.finite(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) ## Catch old scale syntax (r) if(missing(scale)) scale <- list(...)$r check.1.real(scale) stopifnot(scale > 0) #' validate 'kappa' and 'mu' km <- validate.kappa.mu(kappa, mu, kappamax, mumax, win, scale, ..., context="In rMatClust") kappamax <- km[["kappamax"]] mumax <- km[["mumax"]] #' conditional simulation? if(!is.null(n.cond)) { result <- CondSimMatClust(kappa=kappa, scale=scale, mu=mu, win=win, nsim=nsim, drop=drop, ..., n.cond=n.cond, w.cond=w.cond, algorithm=algorithm, nonempty=nonempty, poisthresh=poisthresh, saveparents=saveparents, saveLambda=saveLambda, kappamax=kappamax, mumax=mumax) return(result) } ## detect trivial case where patterns are empty if(kappamax == 0 || mumax == 0) { empt <- ppp(window=win) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } if(saveLambda) attr(empt, "Lambda") <- as.im(0, W=win) result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } #' determine algorithm algorithm <- match.arg(algorithm) do.parents <- saveparents || saveLambda || !is.numeric(kappa) do.hybrid <- (algorithm == "BKBC") && nonempty if(do.hybrid) { ## ........ Fast algorithm (BKBC) ................................. ## run BKBC algorithm for stationary model result <- rMatClustHom(kappamax, mumax, scale, W=win, ..., nsim=nsim, drop=FALSE, saveparents=do.parents) ## thin if(!is.numeric(kappa)) result <- solapply(result, thinParents, P=kappa, Pmax=kappamax) if(!is.numeric(mu)) result <- solapply(result, rthin, P=mu, Pmax=mumax, na.zero=TRUE, fatal=FALSE) } else { ## .......... Slower algorithm ('naive') .......................... ## trap case of large clusters, close to Poisson if(is.numeric(kappa) && 1/(pi * kappa * scale^2) < poisthresh) { if(is.function(mu)) mu <- as.im(mu, W=win, ...) kapmu <- kappa * mu result <- rpoispp(kapmu, win=win, nsim=nsim, drop=drop, warnwin=FALSE) result <- fakeNeyScot(result, kapmu, win, saveLambda, saveparents) return(result) } result <- rNeymanScott(kappa=kappa, expand=scale, rcluster=list(mu, rundisk), win=win, radius=scale, # formal argument of 'rundisk' nsim=nsim, drop=FALSE, nonempty=nonempty, saveparents = do.parents, kappamax=kappamax, mumax=mumax) } if(saveLambda){ B <- grow.rectangle(Frame(win), scale) for(i in 1:nsim) { parents <- attr(result[[i]], "parents") parents <- as.ppp(parents, W=B, check=FALSE) Lambda <- clusterfield("MatClust", parents, scale=scale, mu=mu, ...) attr(result[[i]], "Lambda") <- Lambda[win, drop=FALSE] } } return(simulationresult(result, nsim, drop)) } CondSimMatClust <- function(kappa, scale, mu, win = square(1), ..., n.cond=NULL, w.cond=NULL, nsim=1, drop=TRUE, kappamax=NULL, mumax=NULL, maxchunk=100, giveup=1000, verbose=FALSE, saveparents=FALSE, saveLambda=FALSE) { #' validate conditioning information check.1.integer(n.cond) && check.finite(n.cond) stopifnot(n.cond >= 0) w.sim <- as.owin(win) fullwindow <- is.null(w.cond) if(fullwindow) { w.cond <- w.sim w.free <- NULL } else { stopifnot(is.owin(w.cond)) w.free <- setminus.owin(w.sim, w.cond) } if(verbose <- isTRUE(verbose)) splat("Conditional simulation given", n.cond, "points...") ## detect trivial cases where patterns are empty allempty <- (kappamax == 0) || (mumax == 0) if(allempty && n.cond > 0) stop(paste("Impossible condition: ntensity is zero but n.cond =", n.cond)) if(allempty || n.cond == 0) { empt <- ppp(window=win) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } if(saveLambda) attr(empt, "Lambda") <- as.im(0, W=win) result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } ## start simulation nremaining <- nsim ntried <- 0 accept <- FALSE nchunk <- 1 phistory <- mhistory <- numeric(0) results <- list() while(nremaining > 0) { ## increase chunk length nchunk <- min(maxchunk, giveup - ntried, 2 * nchunk) ## bite off next chunk of simulations if(verbose) splat("Generating", nchunk, "trial simulations...") Xlist <- rMatClust(kappa, scale, mu, w.sim, nsim=nchunk, saveLambda=TRUE, nonempty=FALSE, kappamax=kappamax, mumax=mumax, ..., drop=FALSE, verbose=FALSE) lamlist <- lapply(unname(Xlist), attr, which="Lambda", exact=TRUE) ## compute acceptance probabilities lamlist <- lapply(lamlist, "[", i=w.sim, drop=FALSE, tight=TRUE) if(fullwindow) { EN <- sapply(lamlist, integral) } else { EN <- sapply(lamlist, integral, domain=w.cond) } p <- exp(n.cond * log(EN/n.cond) + n.cond - EN) phistory <- c(phistory, p) mhistory <- c(mhistory, EN) ## accept/reject accept <- (runif(length(p)) < p) if(any(accept)) { jaccept <- which(accept) if(length(jaccept) > nremaining) jaccept <- jaccept[seq_len(nremaining)] naccepted <- length(jaccept) if(verbose) splat("Accepted the", commasep(ordinal(ntried + jaccept)), ngettext(naccepted, "proposal", "proposals")) nremaining <- nremaining - naccepted for(j in jaccept) { lamj <- lamlist[[j]] if(min(lamj) < 0) lamj <- eval.im(pmax(lamj, 0)) if(fullwindow) { Y <- rpoint(n.cond, lamj, win=w.sim, forcewin=TRUE) } else { lamj.cond <- lamj[w.cond, drop=FALSE, tight=TRUE] lamj.free <- lamj[w.free, drop=FALSE, tight=TRUE] Ycond <- rpoint(n.cond, lamj.cond, win=w.cond) Yfree <- rpoispp(lamj.free) Y <- superimpose(Ycond, Yfree, W=w.sim) } if(saveLambda) attr(Y, "Lambda") <- lamj results <- append(results, list(Y)) } } ntried <- ntried + nchunk if(ntried >= giveup && nremaining > 0) { message(paste("Gave up after", ntried, "proposals with", nsim - nremaining, "accepted")) message(paste("Mean acceptance probability =", signif(mean(phistory), 3))) break } } nresults <- length(results) results <- simulationresult(results, nresults, drop) attr(results, "history") <- data.frame(mu=mhistory, p=phistory) if(verbose && nresults == nsim) splat("Mean acceptance probability", signif(mean(phistory), 3)) return(results) } rMatClust }) spatstat.random/R/rshift.psp.R0000644000176200001440000000257414331654772016044 0ustar liggesusers# # rshift.psp.R # # $Revision: 1.8 $ $Date: 2022/01/04 05:30:06 $ # rshift.psp <- function(X, ..., group=NULL, which=NULL) { verifyclass(X, "psp") # process arguments W <- rescue.rectangle(X$window) arglist <- handle.rshift.args(W, ..., edgedefault="erode") radius <- arglist$radius width <- arglist$width height <- arglist$height edge <- arglist$edge clip <- arglist$clip if(W$type != "rectangle") stop("Not yet implemented for non-rectangular windows") if(edge != "erode") stop(paste("Only implemented for edge=", dQuote("erode"))) # split into groups if(is.null(group)) Y <- list(X) else { stopifnot(is.factor(group)) stopifnot(length(group) == X$n) Y <- lapply(levels(group), function(l, Z, group) {Z[group == l]}, Z=X, group=group) } ############ loop ################ result <- NULL for(i in seq_along(Y)) { Z <- Y[[i]] # generate random translation vector if(!is.null(radius)) jump <- runifdisc(1, radius=radius) else { jump <- list(x=runif(1, min=0, max=width), y=runif(1, min=0, max=height)) } # translate segments Zsh <- shift(Z, c(jump$x, jump$y)) Zsh$window <- W # append to result result <- append.psp(result, Zsh) } # clip if(!is.null(clip)) result <- result[clip] return(result) } spatstat.random/R/hermite.R0000644000176200001440000000417014331654772015373 0ustar liggesusers## ## hermite.R ## ## Gauss-Hermite quadrature ## ## $Revision: 1.5 $ $Date: 2017/02/07 07:35:32 $ ## HermiteCoefs <- function(order) { ## compute coefficients of Hermite polynomial (unnormalised) x <- 1 if(order > 0) for(n in 1:order) x <- c(0, 2 * x) - c(((0:(n-1)) * x)[-1L], 0, 0) return(x) } gauss.hermite <- function(f, mu=0, sd=1, ..., order=5) { stopifnot(is.function(f)) stopifnot(length(mu) == 1) stopifnot(length(sd) == 1) ## Hermite polynomial coefficients (un-normalised) Hn <- HermiteCoefs(order) Hn1 <- HermiteCoefs(order-1) ## quadrature points x <- sort(Re(polyroot(Hn))) ## weights Hn1x <- matrix(Hn1, nrow=1) %*% t(outer(x, 0:(order-1), "^")) w <- 2^(order-1) * factorial(order) * sqrt(pi)/(order * Hn1x)^2 ## adjust ww <- w/sqrt(pi) xx <- mu + sd * sqrt(2) * x ## compute ans <- 0 for(i in seq_along(x)) ans <- ans + ww[i] * f(xx[i], ...) return(ans) } dmixpois <- local({ dpoisG <- function(x, ..., k, g) dpois(k, g(x)) function(x, mu, sd, invlink=exp, GHorder=5) gauss.hermite(dpoisG, mu=mu, sd=sd, g=invlink, k=x, order=GHorder) }) pmixpois <- local({ ppoisG <- function(x, ..., q, g, lot) ppois(q, g(x), lower.tail=lot) function(q, mu, sd, invlink=exp, lower.tail = TRUE, GHorder=5) gauss.hermite(ppoisG, mu=mu, sd=sd, g=invlink, q=q, order=GHorder, lot=lower.tail) }) qmixpois <- function(p, mu, sd, invlink=exp, lower.tail = TRUE, GHorder=5) { ## guess upper limit ## Guess upper and lower limits pmin <- min(p, 1-p)/2 lam.hi <- invlink(qnorm(pmin, mean=max(mu), sd=max(sd), lower.tail=FALSE)) lam.lo <- invlink(qnorm(pmin, mean=min(mu), sd=max(sd), lower.tail=TRUE)) kmin <- qpois(pmin, lam.lo, lower.tail=TRUE) kmax <- qpois(pmin, lam.hi, lower.tail=FALSE) kk <- kmin:kmax pp <- pmixpois(kk, mu, sd, invlink, lower.tail=TRUE, GHorder) ans <- if(lower.tail) kk[findInterval(p, pp, all.inside=TRUE)] else rev(kk)[findInterval(1-p, rev(1-pp), all.inside=TRUE)] return(ans) } rmixpois <- function(n, mu, sd, invlink=exp) { lam <- invlink(rnorm(n, mean=mu, sd=sd)) y <- rpois(n, lam) return(y) } spatstat.random/R/rmhexpand.R0000644000176200001440000001714214331654772015727 0ustar liggesusers# # rmhexpand.R # # Rules/data for expanding the simulation window in rmh # # $Revision: 1.9 $ $Date: 2022/01/03 05:37:14 $ # # Establish names and rules for each type of expansion RmhExpandRule <- local({ .RmhExpandTable <- list(area=list(descrip ="Area expansion factor", minval = 1, expands = function(x) { unname(x) > 1 }), length=list(descrip ="Length expansion factor", minval = 1, expands = function(x) { unname(x) > 1 }), distance=list(descrip="Expansion buffer distance", minval = 0, expands = function(x) { unname(x) > 0 })) RmhExpandRule <- function(nama) { if(length(nama) == 0) nama <- "area" if(length(nama) > 1) stop("Internal error: too many names in RmhExpandRule", call.=FALSE) if(!(nama %in% names(.RmhExpandTable))) stop(paste("Internal error: unrecognised expansion type", sQuote(nama)), call.=FALSE) return(.RmhExpandTable[[nama]]) } RmhExpandRule }) rmhexpand <- function(x=NULL, ..., area=NULL, length=NULL, distance=NULL) { trap.extra.arguments(..., .Context="In rmhexpand") # check for incompatibility n <- (!is.null(x)) + (!is.null(area)) + (!is.null(length)) + (!is.null(distance)) if(n > 1) stop("Only one argument should be given") # absorb other arguments into 'x' if(is.null(x) && n > 0) { if(!is.null(area)) x <- c(area=area) if(!is.null(length)) x <- c(length=length) if(!is.null(distance)) x <- c(distance=distance) } if(is.null(x)) { # No expansion rule supplied. # Use spatstat default, indicating that the user did not choose it. force.exp <- force.noexp <- FALSE x <- spatstat.options("expand") x <- rmhexpand(x)$expand } else { # process x if(inherits(x, "rmhexpand")) return(x) if(is.owin(x)) { force.exp <- TRUE force.noexp <- FALSE } else { # expecting c(name=value) or list(name=value) if(is.list(x)) x <- unlist(x) if(!is.numeric(x)) stop(paste("Expansion argument must be either", "a number, a window, or NULL.\n")) # x is numeric check.1.real(x, "In rmhexpand(x)") explain.ifnot(is.finite(x), "In rmhexpand(x)") # an unlabelled numeric value is interpreted as an area expansion factor if(!any(nzchar(names(x)))) names(x) <- "area" # validate rule <- RmhExpandRule(names(x)) if(x < rule$minval) { warning(paste(rule$descrip, "<", rule$minval, "has been reset to", rule$minval), call.=FALSE) x[] <- rule$minval } force.exp <- rule$expands(x) force.noexp <- !force.exp } } result <- list(expand=x, force.exp=force.exp, force.noexp=force.noexp) class(result) <- "rmhexpand" return(result) } .no.expansion <- list(expand=c(area=1), force.exp=FALSE, force.noexp=TRUE) class(.no.expansion) <- "rmhexpand" print.rmhexpand <- function(x, ..., prefix=TRUE) { if(prefix) cat("Expand the simulation window? ") if(x$force.noexp) { cat("No.\n") } else { if(x$force.exp) cat("Yes:\n") else cat("Not determined. Default is:\n") y <- x$expand if(is.null(y)) { print(rmhexpand(spatstat.options("expand")), prefix=FALSE) } else if(is.numeric(y)) { descrip <- RmhExpandRule(names(y))$descrip cat(paste("\t", descrip, unname(y), "\n")) } else { print(y) } } return(invisible(NULL)) } summary.rmhexpand <- function(object, ...) { decided <- with(object, force.exp || force.noexp) ex <- object$expand if(is.null(ex)) ex <- rmhexpand(spatstat.options("expand"))$expand if(is.owin(ex)) { willexpand <- TRUE descrip <- "Window" } else if(is.numeric(ex)) { rule <- RmhExpandRule(names(ex)) descrip <- rule$descrip willexpand <- if(object$force.exp) TRUE else if(object$force.noexp) FALSE else (unname(ex) > rule$minval) } else stop("Internal error: unrecognised format in summary.rmhexpand", call.=FALSE) out <- list(rule.decided=decided, window.decided=decided && is.owin(ex), expand=ex, descrip=descrip, willexpand=willexpand) class(out) <- "summary.rmhexpand" return(out) } print.summary.rmhexpand <- function(x, ...) { cat("Expansion rule\n") ex <- x$expand if(x$window.decided) { cat("Window is decided.\n") print(ex) } else { if(x$rule.decided) { cat("Rule is decided.\n") } else { cat("Rule is not decided.\nDefault is:\n") } if(!x$willexpand) { cat("No expansion\n") } else { if(is.numeric(ex)) cat(paste(x$descrip, ex, "\n")) else print(ex) } } return(invisible(NULL)) } expand.owin <- function(W, ...) { ex <- list(...) if(length(ex) > 1) stop("Too many arguments") # get an rmhexpand object if(inherits(ex[[1]], "rmhexpand")) { ex <- ex[[1]] } else ex <- do.call(rmhexpand, ex) f <- ex$expand if(is.null(f)) return(W) if(is.owin(f)) return(f) if(!is.numeric(f)) stop("Format not understood") switch(names(f), area = { if(f == 1) return(W) bb <- boundingbox(W) xr <- bb$xrange yr <- bb$yrange fff <- (sqrt(f) - 1)/2 Wexp <- grow.rectangle(bb, fff * diff(xr), fff * diff(yr)) }, length = { if(f == 1) return(W) bb <- boundingbox(W) xr <- bb$xrange yr <- bb$yrange fff <- (f - 1)/2 Wexp <- grow.rectangle(bb, fff * diff(xr), fff * diff(yr)) }, distance = { if(f == 0) return(W) Wexp <- if(is.rectangle(W)) grow.rectangle(W, f) else dilation(W, f) }, stop("Internal error: unrecognised type") ) return(Wexp) } will.expand <- function(x) { stopifnot(inherits(x, "rmhexpand")) if(x$force.exp) return(TRUE) if(x$force.noexp) return(FALSE) return(summary(x)$willexpand) } is.expandable <- function(x) { UseMethod("is.expandable") } change.default.expand <- function(x, newdefault) { stopifnot(inherits(x, "rmhexpand")) decided <- with(x, force.exp || force.noexp) if(!decided) x$expand <- rmhexpand(newdefault)$expand return(x) } rmhResolveExpansion <- function(win, control, imagelist, itype="covariate") { # Determine expansion window for simulation ex <- control$expand # The following is redundant because it is implied by !will.expand(ex) # if(ex$force.noexp) { # # Expansion prohibited # return(list(wsim=win, expanded=FALSE)) # } # Is expansion contemplated? if(!will.expand(ex)) return(list(wsim=win, expanded=FALSE)) # Proposed expansion window wexp <- expand.owin(win, ex) # Check feasibility isim <- unlist(lapply(imagelist, is.im)) imagelist <- imagelist[isim] if(length(imagelist) == 0) { # Unlimited expansion is feasible return(list(wsim=wexp, expanded=TRUE)) } # Expansion is limited to domain of image data # Determine maximum possible expansion window wins <- lapply(imagelist, as.owin) cwin <- do.call(intersect.owin, unname(wins)) if(!is.subset.owin(wexp, cwin)) { # Cannot expand to proposed window if(ex$force.exp) stop(paste("Cannot expand the simulation window,", "because the", itype, "images do not cover", "the expanded window"), call.=FALSE) # Take largest possible window wexp <- intersect.owin(wexp, cwin) } return(list(wsim=wexp, expanded=TRUE)) } spatstat.random/R/rLGCP.R0000644000176200001440000001031514567023173014637 0ustar liggesusers#' #' rLGCP.R #' #' simulation of log-Gaussian Cox process #' #' original code by Abdollah Jalilian #' #' modifications by Adrian Baddeley, Ege Rubak and Tilman Davies #' #' $Revision: 1.31 $ $Date: 2024/02/26 05:33:48 $ #' rLGCP <- local({ rLGCP <- function(model=c("exponential", "gauss", "stable", "gencauchy", "matern"), mu = 0, param = NULL, ..., win=NULL, saveLambda=TRUE, nsim=1, drop=TRUE) { ## validate model <- match.arg(model) if (is.numeric(mu)) { check.1.real(mu, paste("if", sQuote("mu"), "is numeric,")) } else if(!is.function(mu) && !is.im(mu)) stop(paste(sQuote("mu"), "must be a constant, a function or an image")) check.1.integer(nsim) stopifnot(nsim >= 0) ## check for outdated usage if(!all(nzchar(names(param)))) stop("Outdated syntax of argument 'param' to rLGCP", call.=FALSE) ## do.call(do.rLGCP, append(list(model=model, mu=mu, win=win, saveLambda=saveLambda, nsim=nsim, drop=drop), resolve.defaults(list(...), param))) } do.rLGCP <- function(model=c("exponential", "gauss", "stable", "gencauchy", "matern"), mu = 0, ..., win=NULL, saveLambda=TRUE, Lambdaonly=FALSE, nsim=1, drop=TRUE) { ## empty list if(nsim == 0) return(simulationresult(list())) model <- match.arg(model) ## simulation window win.given <- !is.null(win) mu.image <- is.im(mu) win <- if(win.given) as.owin(win) else if(mu.image) as.owin(mu) else owin() if(win.given && mu.image && !is.subset.owin(win, as.owin(mu))) stop(paste("The spatial domain of the pixel image", sQuote("mu"), "does not cover the simulation window", sQuote("win"))) ## get shape parameters needed <- switch(model, exponential = , gauss = character(0), stable = "alpha", gencauchy = c("alpha", "beta"), matern = "nu") if(length(needed)) { stuff <- list(...) missed <- is.na(match(needed, names(stuff))) if(any(missed)) { nbad <- sum(missed) stop(paste(ngettext(nbad, "Parameter", "Parameters"), commasep(sQuote(needed[missed])), ngettext(nbad, "is", "are"), "required"), call.=FALSE) } } ## generate Gaussian Random Field Zlist <- switch(model, exponential = { rGRFexpo(W=win, mu=mu, ..., nsim=nsim, drop=FALSE) }, gauss = { rGRFgauss(W=win, mu=mu, ..., nsim=nsim, drop=FALSE) }, stable = { rGRFstable(W=win, mu=mu, ..., nsim=nsim, drop=FALSE) }, gencauchy = { rGRFgencauchy(W=win, mu=mu, ..., nsim=nsim, drop=FALSE) }, matern = { rGRFmatern(W=win, mu=mu, ..., nsim=nsim, drop=FALSE) }, stop(paste("Model", sQuote(model), "not matched"))) if(length(Zlist) != nsim) stop("Internal error in generating realisations") ## exponentiate Lambdalist <- solapply(Zlist, exp) if(Lambdaonly) { ## undocumented exit - return Lambda only return(simulationresult(Lambdalist, nsim, drop)) } ## generate realisations of LGCP result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { Lambda <- Lambdalist[[isim]] ## generate Poisson points X <- rpoispp(Lambda)[win] ## if(saveLambda) attr(X, "Lambda") <- Lambda result[[isim]] <- X } return(simulationresult(result, nsim, drop)) } rLGCP }) spatstat.random/R/clusterfunctions.R0000644000176200001440000000504614452153466017351 0ustar liggesusers## clusterfunctions.R ## ## Contains the generic functions: ## - clusterkernel ## - clusterfield ## - clusterradius. ## ## $Revision: 1.13 $ $Date: 2023/06/09 05:13:54 $ ## clusterkernel <- function(model, ...) { UseMethod("clusterkernel") } clusterkernel.character <- function(model, ...){ info <- spatstatClusterModelInfo(model, onlyPCP = TRUE) internalkernel <- info$kernel dots <- list(...) par <- c(kappa = 1, scale = dots$scale) par <- info$checkpar(par, native = TRUE) nam <- info$shapenames margs <- NULL if(!is.null(nam)) margs <- dots[nam] f <- function(x, y = 0, ...){ internalkernel(par = par, rvals = sqrt(x^2+y^2), margs = margs) } return(f) } ## The method clusterkernel.kppm is in spatstat.model clusterfield <- function(model, locations = NULL, ...) { UseMethod("clusterfield") } clusterfield.character <- function(model, locations = NULL, ...){ f <- clusterkernel(model, ...) clusterfield.function(f, locations, ...) } clusterfield.function <- function(model, locations = NULL, ..., mu = NULL) { if(is.null(locations)){ locations <- ppp(.5, .5, window=square(1)) } else if(!is.ppp(locations)) stop("Argument ", sQuote("locations"), " must be a point pattern (ppp).") if("sigma" %in% names(list(...)) && "sigma" %in% names(formals(model))) warning("Currently ", sQuote("sigma"), "cannot be passed as an extra argument to the kernel function. ", "Please redefine the kernel function to use another argument name.") if(requireNamespace("spatstat.explore")) { rslt <- spatstat.explore::density.ppp(locations, kernel=model, ..., edge=FALSE) } else { message("The package spatstat.explore is required.") return(NULL) } if(is.null(mu)) return(rslt) mu <- as.im(mu, W=rslt) if(min(mu)<0) stop("Cluster reference intensity ", sQuote("mu"), " is negative.") return(rslt*mu) } ## The method clusterfield.kppm is in spatstat.model clusterradius <- function(model, ...){ UseMethod("clusterradius") } clusterradius.character <- function(model, ..., thresh = NULL, precision = FALSE){ info <- spatstatClusterModelInfo(model, onlyPCP=FALSE) if(!isTRUE(info$isPCP)) { warning("cluster radius is only defined for cluster processes", call.=FALSE) return(NA) } rmax <- info$range(..., thresh = thresh) if(precision && is.function(info$ddist)){ ddist <- function(r) info$ddist(r, ...) prec <- integrate(ddist, 0, rmax) attr(rmax, "prec") <- prec } return(rmax) } ## The method clusterradius.kppm is in spatstat.model spatstat.random/R/rthomas.R0000644000176200001440000001720214364101623015377 0ustar liggesusers#' #' rthomas.R #' #' $Revision: 1.6 $ $Date: 2023/01/25 00:41:02 $ #' #' Simulation of modified Thomas cluster process #' using either naive algorithm or BKBC algorithm #' #' rThomasHom Interface to C code for stationary case (BKBC) #' rThomas General case (naive or BKBC) #' #' Copyright (C) Adrian Baddeley, Rolf Turner and Ya-Mei Chang 2000-2023 #' Licence: GNU Public Licence >= 2 rThomasHom <-function(kappa, mu, sigma, W=unit.square(), ..., nsim=1, drop=TRUE, inflate=NULL, saveparents=FALSE, maxinflate=10) { check.1.real(kappa) && check.finite(kappa) check.1.real(mu) && check.finite(mu) check.1.real(sigma) && check.finite(sigma) check.1.integer(nsim) stopifnot(kappa >= 0) stopifnot(mu >= 0) stopifnot(sigma > 0) if(!is.null(inflate)) { check.1.real(inflate) && check.finite(inflate) stopifnot(inflate >= 1) } ## trivial cases if(nsim == 0) return(simulationresult(list())) if(kappa == 0 || mu == 0) { ## intensity is zero - patterns are empty empt <- ppp(window=W) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } ## shift window to convenient origin oldW <- W oldcentre <- as.numeric(centroid.owin(Frame(oldW))) W <- shift(oldW, -oldcentre) ## enclose it in a disc rD <- with(vertices(Frame(W)), sqrt(max(x^2+y^2))) ## optimal inflation if(is.null(inflate)) { a <- if(mu == 0) 1 else (1 + (1-exp(-mu))/mu) b <- (rD^2)/(2*a*sigma^2) if(b <= 1) { inflate <- 1 } else { delta <- 2 * sigma * sqrt(log(b)/2) inflate <- 1 + delta/rD inflate <- min(inflate, maxinflate) } } ## Prepare for C code storage.mode(kappa) <- "double" storage.mode(mu) <- "double" storage.mode(sigma) <- "double" storage.mode(rD) <- "double" storage.mode(inflate) <- "double" ## resultlist <- vector(mode="list", length=nsim) for(isim in 1:nsim) { ## call C code if(saveparents) { z <- .Call(SR_rthomasAll, kappa, mu, sigma, rD, inflate, PACKAGE="spatstat.random") } else { z <- .Call(SR_rthomasOff, kappa, mu, sigma, rD, inflate, PACKAGE="spatstat.random") } ## unpack xo <- z[[1]] yo <- z[[2]] if(saveparents) { xp <- z[[3]] yp <- z[[4]] parentid <- z[[5]] } ## shift back to original window xo <- xo + oldcentre[1L] yo <- yo + oldcentre[2L] if(saveparents) { xp <- xp + oldcentre[1L] yp <- yp + oldcentre[2L] } ## restrict to original window retain <- inside.owin(xo, yo, oldW) if(!all(retain)) { xo <- xo[retain] yo <- yo[retain] if(saveparents) { parentid <- parentid[retain] retainedparents <- sort(unique(parentid)) parentid <- match(parentid, retainedparents) xp <- xp[retainedparents] yp <- yp[retainedparents] } } ## save as point pattern Y <- ppp(xo, yo, window=oldW, check=FALSE) if(saveparents) { attr(Y, "parents") <- list(x = xp, y = yp) attr(Y, "parentid") <- parentid attr(Y, "cost") <- length(xo) + length(xp) } resultlist[[isim]] <- Y } result <- simulationresult(resultlist, nsim, drop=drop) return(result) } rThomas <- local({ ## random displacements gaus <- function(n, sigma) { matrix(rnorm(2 * n, mean=0, sd=sigma), ncol=2) } ## main function rThomas <- function(kappa, scale, mu, win = square(1), nsim=1, drop=TRUE, ..., algorithm=c("BKBC", "naive"), nonempty=TRUE, poisthresh=1e-6, expand = 4*scale, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL, sigma) { ## modified Thomas process ## Poisson(mu) number of offspring ## at isotropic Normal(0,sigma^2) displacements from parent check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) ## Catch old scale syntax (sigma) if((missing(scale) || is.null(scale)) && !missing(sigma)) { ## message("Argument 'sigma' is deprecated; it has been replaced by 'scale'") scale <- sigma } check.1.real(scale) stopifnot(scale > 0) ## determine the effective maximum radius of clusters ## (for the naive algorithm, or when kappa is not constant) if(missing(expand)) expand <- clusterradius("Thomas", scale = scale, ...) #' validate 'kappa' and 'mu' km <- validate.kappa.mu(kappa, mu, kappamax, mumax, win, expand, ..., context="In rThomas") kappamax <- km[["kappamax"]] mumax <- km[["mumax"]] ## detect trivial case where patterns are empty if(kappamax == 0 || mumax == 0) { empt <- ppp(window=win) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } if(saveLambda) attr(empt, "Lambda") <- as.im(0, W=win) result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } #' determine algorithm algorithm <- match.arg(algorithm) do.parents <- saveparents || saveLambda || !is.numeric(kappa) do.hybrid <- (algorithm == "BKBC") && nonempty if(do.hybrid) { ## ........ Fast algorithm (BKBC) ................................. ## run BKBC algorithm for stationary model result <- rThomasHom(kappamax, mumax, sigma=scale, W=win, ..., nsim=nsim, drop=FALSE, saveparents=do.parents) ## thin if(!is.numeric(kappa)) result <- solapply(result, thinParents, P=kappa, Pmax=kappamax) if(!is.numeric(mu)) result <- solapply(result, rthin, P=mu, Pmax=mumax, na.zero=TRUE, fatal=FALSE) } else { ## .......... Slower algorithm ('naive') .......................... ## trap case of large clusters, close to Poisson if(is.numeric(kappa) && 1/(4*pi * kappa * scale^2) < poisthresh) { if(is.function(mu)) mu <- as.im(mu, W=win, ...) kapmu <- kappa * mu result <- rpoispp(kapmu, win=win, nsim=nsim, drop=drop, warnwin=FALSE) result <- fakeNeyScot(result, kapmu, win, saveLambda, saveparents) return(result) } result <- rNeymanScott(kappa=kappa, expand=expand, rcluster=list(mu, gaus), win=win, sigma=scale, # formal argument of 'gaus' nsim=nsim, drop=FALSE, nonempty=nonempty, saveparents = do.parents, kappamax=kappamax, mumax=mumax) } if(saveLambda){ BW <- Frame(win) for(i in 1:nsim) { parents <- attr(result[[i]], "parents") BX <- boundingbox(BW, bounding.box.xy(parents)) parents <- as.ppp(parents, W=BX, check=FALSE) Lambda <- clusterfield("Thomas", parents, scale=scale, mu=mu, ...) attr(result[[i]], "Lambda") <- Lambda[win, drop=FALSE] } } return(simulationresult(result, nsim, drop)) } rThomas }) spatstat.random/R/randomImage.R0000644000176200001440000000057314331654772016164 0ustar liggesusers#' #' randomImage.R #' #' Functions for generating random images #' #' $Revision: 1.1 $ $Date: 2015/03/23 10:44:04 $ #' #' rnoise <- function(rgen=runif, w=square(1), ...) { a <- do.call.matched(as.mask, list(w=w, ...), sieve=TRUE) W <- a$result argh <- a$otherargs Z <- as.im(W) n <- sum(W$m) Z[] <- do.call(rgen, append(list(n=n), argh)) return(Z) } spatstat.random/R/rmhstart.R0000644000176200001440000000473414331654772015610 0ustar liggesusers# # # rmhstart.R # # $Revision: 1.12 $ $Date: 2016/02/11 10:17:12 $ # # rmhstart <- function(start, ...) { UseMethod("rmhstart") } rmhstart.rmhstart <- function(start, ...) { return(start) } rmhstart.list <- function(start, ...) { st <- do.call.matched(rmhstart.default, start) return(st) } rmhstart.default <- function(start=NULL, ..., n.start=NULL, x.start=NULL) { if(!is.null(start) || length(list(...)) > 0) stop("Syntax should be rmhstart(n.start) or rmhstart(x.start)") ngiven <- !is.null(n.start) xgiven <- !is.null(x.start) # n.start and x.start are incompatible if(ngiven && xgiven) stop("Give only one of the arguments n.start and x.start") given <- if(ngiven) "n" else if(xgiven) "x" else "none" # Validate arguments if(ngiven && !is.numeric(n.start)) stop("n.start should be numeric") if(xgiven) { # We can't check x.start properly because we don't have the relevant window # Just check that it is INTERPRETABLE as a point pattern xx <- as.ppp(x.start, W=ripras, fatal=FALSE) if(is.null(xx)) stop(paste("x.start should be a point pattern object,", "or coordinate data in a format recognised by as.ppp")) } else xx <- NULL ################################################################### # return augmented list out <- list(n.start=n.start, x.start=x.start, given=given, xx=xx) class(out) <- c("rmhstart", class(out)) return(out) } print.rmhstart <- function(x, ...) { verifyclass(x, "rmhstart") cat("Metropolis-Hastings algorithm starting parameters\n") cat("Initial state: ") switch(x$given, none={ cat("not given\n") }, x = { cat("given as x.start\n") if(is.ppp(x$x.start)) print(x$x.start) else cat(paste("(x,y) coordinates of", x$xx$n, "points (window unspecified)\n")) cat("\n") }, n = { n.start <- x$n.start nstring <- if(length(n.start) == 1) paste(n.start) else paste("(", paste(n.start, collapse=","), ")", sep="") cat(paste("number fixed at n.start =", nstring, "\n")) } ) } update.rmhstart <- function(object, ...) { do.call.matched(rmhstart.default, resolve.defaults(list(...), as.list(object), .StripNull=TRUE)) } spatstat.random/R/clustersiminfo.R0000644000176200001440000002753314356240517017007 0ustar liggesusers#' #' clustersiminfo.R #' #' Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022-2023 #' GNU Public Licence >= 2 #' #' ----------------------------------------------------------------- #' #' Table of additional information for cluster models #' for use in Brix-Kendall and Baddeley-Chang simulation algorithms #' #' D = bounding disc #' rD = radius of D (numeric > 0) #' r = distance from parent point to centre of disc (numeric vector) #' mod = list containing all model parameters: #' $par = original (native) parameters of cluster model e.g. (kappa, sigma2) #' $mu = mean number of offspring per parent in stationary process #' $margs = list of shape parameters #' #' Entries: #' #' (A) cluster model #' #' roffspring = function(n, mod) #' generate x, y coordinates of n offspring of parent at origin #' #' (A) Brix-Kendall dominating process #' #' hdom = function(r, mod, rD) #' Value inside D of the dominating offspring density, for a parent at distance r from centre of D #' #' Eplus = function(r, mod, rD) #' Integral over D of dominating kernel, for a parent at distance r from centre of D #' Eplus(r) = pi * rD^2 * mu * hdom(r) #' #' rhoplus = function(r, mod, rD) #' Intensity of Brix-Kendall dominating parent process, given distance to origin #' rhoplus(r) = kappa * (1 - exp(-Eplus(r))) #' #' Mplus = function(r, mod, rD, ...) #' Radial cumulative integral of intensity of Brix-Kendall dominating intensity #' Mplus(r) = \int_0^r 2 pi t rhoplus(t) dt #' #' MplusInf = function(mod, rD) #' Total integral Mplus(infty) #' Expected total number of parents in the dominating process #' #' invMplus = function(v, mod, rD, Minfty) #' Inverse function of Mplus (IF KNOWN) #' #' (B) Baddeley-Chang super-dominating process #' #' rhoplusplus = function(r, mod, rD) #' Intensity of superdominating process #' rhoplusplus(r) = kappa * Eplus(r) #' #' Mplusplus = function(r, mod, rD, ...) #' Radial cumulative integral of superdominating intensity #' Mplusplus(r) = \int_0^r 2 pi t rhoplusplus(t) dt #' = kappa \int_0^r 2 pi t Eplus(t) dt #' #' MplusplusInf = function(mod, rD) #' Total integral Mplusplus(infty) #' Expected total number of parents in the superdominating process #' #' invMplusplus = function(v, mod, rD, Minfty) #' Inverse function of Mplusplus (IF KNOWN) #' #' inflate = function(mod, rD) #' Rule for determining optimal inflated radius rE #' according to Baddeley and Chang (2023) section 6.6 #' >>>>>>>>>>>>>>>> THOMAS PROCESS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< .Thomas.roffspring <- function(n, mod) { sigma <- sqrt(mod$par[["sigma2"]]) list(x=rnorm(n, sd=sigma), y=rnorm(n, sd=sigma)) } .Thomas.hdom <- function(r, mod, rD) { inv2sig2 <- 1/(2 * mod$par[["sigma2"]]) B <- inv2sig2/pi z <- numeric(length(r)) above <- (r > rD) z[!above] <- B z[above] <- B * exp(- inv2sig2 * (r[above] - rD)^2) return(z) } .Thomas.Eplus <- function(r, mod, rD) { mu <- mod$mu inv2sig2 <- 1/(2 * mod$par[["sigma2"]]) A <- mu * rD^2 * inv2sig2 z <- numeric(length(r)) above <- (r > rD) z[!above] <- A z[above] <- A * exp(- inv2sig2 * (r[above]-rD)^2) return(z) } .Thomas.rhoplus <- function(r, mod, rD) { kappa <- mod$par[["kappa"]] z <- numeric(length(r)) above <- (r > rD) z[!above] <- kappa * (1 - exp(-.Thomas.Eplus(0, mod, rD))) z[above] <- kappa * (1 - exp(-.Thomas.Eplus(r[above], mod, rD))) return(z) } .Thomas.MplusIntegrand <- function(r, mod, rD) { 2 * pi * r * .Thomas.rhoplus(r, mod, rD) } .Thomas.Mplus <- function(r, mod, rD, ..., method="q") { ## integrand is linear on [0, rD] z <- pi * pmin(r, rD)^2 * .Thomas.rhoplus(0, mod, rD) high <- (r > rD) if(any(high)) z[high] <- z[high] + indefinteg(.Thomas.MplusIntegrand, r[high], lower=rD, mod=mod, rD=rD, method=method) return(z) } .Thomas.MplusInf <- function(mod, rD) { .Thomas.Mplus(Inf, mod, rD) } ## inverse function requires numerical root-finding .Thomas.rhoplusplus <- function(r, mod, rD) { mod$par[["kappa"]] * .Thomas.Eplus(r, mod, rD) } .Thomas.Mplusplus <- function(r, mod, rD, ...) { mu <- mod$mu kappa <- mod$par[["kappa"]] sigma2 <- mod$par[["sigma2"]] inv2sig2 <- 1/(2 * sigma2) z <- pi * pmin(r, rD)^2 high <- (r > rD) z[high] <- z[high] + 2 * pi * sigma2 * (1 - exp(-inv2sig2 * (r[high]-rD)^2)) + 2 * pi * rD * sqrt(2 * pi * sigma2) * ( pnorm(r[high]-rD, sd=sqrt(sigma2)) - 1/2 ) z <- kappa * mu * rD^2 * inv2sig2 * z return(z) } .Thomas.MplusplusInf <- function(mod, rD) { mu <- mod$mu kappa <- mod$par[["kappa"]] sigma2 <- mod$par[["sigma2"]] inv2sig2 <- 1/(2 * sigma2) kappa * mu * pi * rD^2 * ( rD^2 * inv2sig2 + 1 + rD * sqrt(2 * pi * sigma2) * inv2sig2 ) } ## inverse function requires numerical root-finding .Thomas.inflate <- function(mod, rD) { mu <- mod$mu sigma2 <- mod$par[["sigma2"]] a <- if(mu == 0) 1 else (1 + (1-exp(-mu))/mu) b <- (rD^2)/(2*a*sigma2) if(b <= 1) return(rD) delta <- 2 * sqrt(sigma2) * sqrt(log(b)/2) return(rD + delta) } #' >>>>>>>>>>>>>>>> MATERN CLUSTER PROCESS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<< .MatClust.roffspring <- function(n, mod) { R <- mod$par[["R"]] rad <- R * sqrt(runif(n)) theta <- runif(n, max=2*pi) list(x = rad * cos(theta), y = rad * sin(theta)) } .MatClust.hdom <- function(r, mod, rD) { R <- mod$par[["R"]] (r - rD < R)/(pi * R^2) } .MatClust.Eplus <- function(r, mod, rD) { R <- mod$par[["R"]] mu <- mod$mu mu * (r - rD < R) * (rD/R)^2 } .MatClust.rhoplus <- function(r, mod, rD) { mod$par[["kappa"]] * (1 - exp(-.MatClust.Eplus(r, mod, rD))) } .MatClust.Mplus <- function(r, mod, rD, ...) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu pi * pmin(r, R+rD)^2 * kappa * ( 1 - exp(-mu * (rD/R)^2)) } .MatClust.MplusInf <- function(mod, rD) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu pi * (R+rD)^2 * kappa * ( 1 - exp(-mu * (rD/R)^2)) } .MatClust.inverseMplus <- function(v, mod, rD, Minfty) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu B <- pi * kappa * (1 - exp(- mu * rD^2/R^2)) sqrt(v/B) } .MatClust.rhoplusplus <- function(r, mod, rD) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu kappa * mu * (r < (R+rD)) * (rD/R)^2 } .MatClust.Mplusplus <- function(r, mod, rD, ...) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu kappa * mu * pi * (pmin(r, R+rD) * rD/R)^2 } .MatClust.MplusplusInf <- function(mod, rD) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu kappa * mu * pi * ((R+rD) * rD/R)^2 } .MatClust.inverseMplusplus <- function(v, mod, rD, Minfty) { R <- mod$par[["R"]] kappa <- mod$par[["kappa"]] mu <- mod$mu (R/rD) * sqrt(v/(pi * kappa * mu)) } .MatClust.inflate <- function(mod, rD) { R <- mod$par[["R"]] rE <- if(R < rD) (rD + R) else rD return(rE) } #' >>>>>>>>>>>>>>>> CAUCHY CLUSTER PROCESS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< #' idiosyncratic parameter eta2 = 4 * scale^2 #' scale <- sqrt(mod$par[["eta2"]])/2 .Cauchy.roffspring <- function(n, mod) { rate <- mod$par[["eta2"]]/8 b <- 1/sqrt(rgamma(n, shape=1/2, rate=rate)) list(x = b * rnorm(n), y = b * rnorm(n)) } .Cauchy.hdom <- function(r, mod, rD) { scale2 <- mod$par[["eta2"]]/4 z <- numeric(length(r)) above <- (r > rD) z[!above] <- 1/(2*pi*scale2) z[above] <- (1/(2*pi*scale2)) * (1 + ((r[above]-rD)^2)/scale2)^(-3/2) return(z) } .Cauchy.Eplus <- function(r, mod, rD) { scale2 <- mod$par[["eta2"]]/4 mu <- mod$mu z <- numeric(length(r)) above <- (r > rD) A <- mu * (rD^2/(2*scale2)) z[!above] <- A z[above] <- A * (1 + ((r[above]-rD)^2)/scale2)^(-3/2) return(z) } .Cauchy.rhoplus <- function(r, mod, rD) { kappa <- mod$par[["kappa"]] z <- numeric(length(r)) above <- (r > rD) z[!above] <- kappa * (1 - exp(-.Cauchy.Eplus(0, mod, rD))) z[above] <- kappa * (1 - exp(-.Cauchy.Eplus(r[above], mod, rD))) return(z) } .Cauchy.MplusIntegrand <- function(r, mod, rD) { 2 * pi * r * .Cauchy.rhoplus(r, mod, rD) } .Cauchy.Mplus <- function(r, mod, rD, ..., method="q") { ## integrand is linear on [0, rD] z <- pi * pmin(r, rD)^2 * .Cauchy.rhoplus(0, mod, rD) high <- (r > rD) if(any(high)) z[high] <- z[high] + indefinteg(.Cauchy.MplusIntegrand, r[high], lower=rD, mod=mod, rD=rD, method=method) return(z) } .Cauchy.MplusInf <- function(mod, rD) { .Cauchy.Mplus(Inf, mod, rD) } .Cauchy.rhoplusplus <- function(r, mod, rD) { mod$par[["kappa"]] * .Cauchy.Eplus(r, mod, rD) } .Cauchy.Mplusplus <- function(r, mod, rD, ...) { mu <- mod$mu kappa <- mod$par[["kappa"]] lambda <- kappa * mu scale2 <- mod$par[["eta2"]]/4 distD <- pmax(0, r - rD) lambda * pi * rD^2 * ifelse(r <= rD, r^2/(2*scale2), rD^2/(2*scale2) + 1 + (rD * distD/scale2 - 1)/sqrt(1+distD^2/scale2)) } .Cauchy.MplusplusInf <- function(mod, rD) { mu <- mod$mu kappa <- mod$par[["kappa"]] lambda <- kappa * mu scale2 <- mod$par[["eta2"]]/4 rdons2 <- rD^2/scale2 lambda * pi * rD^2 * (1 + sqrt(rdons2) + rdons2/2) } .Cauchy.inflate <- function(mod, rD) { mu <- mod$mu scale2 <- mod$par[["eta2"]]/4 a <- if(mu == 0) 1 else (1 + (1-exp(-mu))/mu) b <- (rD^2)/(2*a*scale2) if(b <= 1) return(rD) delta <- sqrt(scale2) * (b^(2/3) - 1) return(rD + delta) } #' ........................................................................ .spatstat.clustersim.InfoTable <- list( Thomas = list( iscompact = FALSE, roffspring = .Thomas.roffspring, hdom = .Thomas.hdom, Eplus = .Thomas.Eplus, rhoplus = .Thomas.rhoplus, Mplus = .Thomas.Mplus, MplusInf = .Thomas.MplusInf, invMplus = NULL, rhoplusplus = .Thomas.rhoplusplus, Mplusplus = .Thomas.Mplusplus, MplusplusInf = .Thomas.MplusplusInf, invMplusplus = NULL, inflate = .Thomas.inflate ), MatClust = list( iscompact = TRUE, roffspring = .MatClust.roffspring, hdom = .MatClust.hdom, Eplus = .MatClust.Eplus, rhoplus = .MatClust.rhoplus, Mplus = .MatClust.Mplus, MplusInf = .MatClust.MplusInf, invMplus = .MatClust.inverseMplus, rhoplusplus = .MatClust.rhoplusplus, Mplusplus = .MatClust.Mplusplus, MplusplusInf = .MatClust.MplusplusInf, invMplusplus = .MatClust.inverseMplusplus, inflate = .MatClust.inflate ), Cauchy = list( iscompact = FALSE, roffspring = .Cauchy.roffspring, hdom = .Cauchy.hdom, Eplus = .Cauchy.Eplus, rhoplus = .Cauchy.rhoplus, Mplus = .Cauchy.Mplus, MplusInf = .Cauchy.MplusInf, invMplus = NULL, rhoplusplus = .Cauchy.rhoplusplus, Mplusplus = .Cauchy.Mplusplus, MplusplusInf = .Cauchy.MplusplusInf, invMplusplus = NULL, inflate = .Cauchy.inflate ) ) spatstatClusterSimModelMatch <- function(name, verbose=TRUE) { if(!is.character(name) || length(name) != 1) stop("Argument must be a single character string", call.=FALSE) TheTable <- .spatstat.clustersim.InfoTable nama2 <- names(TheTable) mat <- pmatch(name, nama2) if(!is.null(mat)) return(nama2[mat]) if(verbose) warning(sQuote(name), "is not supported;", "available options are", commasep(sQuote(nama2))) return(NULL) } spatstatClusterSimInfo <- function(name) { known <- spatstatClusterSimModelMatch(name, FALSE) if(is.null(known)) return(NULL) return(.spatstat.clustersim.InfoTable[[known]]) } spatstat.random/R/rPSNCP.R0000644000176200001440000001607514331654772015012 0ustar liggesusers#' simulation of product shot-noise Cox process #' Original: (c) Abdollah Jalilian 2021 #' Adapted to spatstat by Adrian Baddeley #' $Revision: 1.6 $ $Date: 2022/04/06 07:29:33 $ rPSNCP <- local({ ## =================================================================== ## kernel functions ## =================================================================== bkernels <- list( ## Gaussian kernel with bandwidth omega Thomas = function(r, omega, ...){ exp(- r^2/(2 * omega^2)) / (2 * pi * omega^2) }, ## Variance-Gamma (Bessel) kernel ## with bandwidth omega and shape parameter nu.ker VarGamma = function(r, omega, nu.ker){ stopifnot(nu.ker > -1/2) sigma2 <- 1 / (4 * pi * nu.ker * omega^2) u <- r/omega u <- ifelse(u > 0, (u^nu.ker) * besselK(u, nu.ker) / (2^(nu.ker - 1) * gamma(nu.ker)), 1) return(abs(sigma2 * u)) }, ## Cauchy kernel with bandwith omega Cauchy = function(r, omega, ...){ ((1 + (r / omega)^2)^(-1.5)) / (2 * pi * omega^2) } ## end of 'bkernels' list ) ## =================================================================== ## simulating from the product shot-noise Cox processes ## =================================================================== ## simulation from the null model of independent shot-noise components rPSNCP0 <- function(lambda, kappa, omega, kernels=NULL, nu.ker=NULL, win=owin(), nsim=1, drop=TRUE, ..., cnames=NULL, epsth=0.001 # , mc.cores=1L ) { check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) m <- length(lambda) if(m == 0) stop("No lambda values supplied") if ((length(kappa) != m) || length(omega) != m ) stop("arguments kappa and omega must have the same length as lambda") if (is.null(kernels)) kernels <- rep("Thomas", m) else if(length(kernels) != m) stop("length of argument 'kernels' must equal the number of components") if(is.null(nu.ker)) nu.ker <- rep(-1/4, m) lambda <- as.list(lambda) if (is.null(cnames)) cnames <- 1:m ## simulation from the null model of independent shot-noise components corefun0 <- function(dumm) { xp <- yp <- numeric(0) mp <- integer(0) for (i in 1:m) { mui <- lambda[[i]]/kappa[i] Xi <- switch(kernels[i], Thomas = rThomas(kappa[i], scale=omega[i], mu=mui, win=win, ...), Cauchy = rCauchy(kappa[i], scale=omega[i], mu=mui, win=win, thresh=epsth, ...), VarGamma = rVarGamma(kappa[i], scale=omega[i], mu=mui, win=win, nu.ker=nu.ker[i], nu.pcf=NULL, thresh=epsth, ...)) xp <- c(xp, Xi$x) yp <- c(yp, Xi$y) mp <- c(mp, rep.int(i, Xi$n)) } mp <- factor(mp, labels=cnames) out <- ppp(xp, yp, window=win, marks=mp, check=FALSE) return(out) } ## outlist <- if (mc.cores == 1) lapply(1:nsim, corefun0) ## else parallel::mclapply(1:nsim, corefun0, mc.cores=mc.cores) outlist <- lapply(seq_len(nsim), corefun0) outlist <- simulationresult(outlist, nsim, drop) return(outlist) } # =================================================================== # simulation from the model rPSNCP <- function(lambda=rep(100, 4), kappa=rep(25, 4), omega=rep(0.03, 4), alpha=matrix(runif(16, -1, 3), nrow=4, ncol=4), kernels=NULL, nu.ker=NULL, win=owin(), nsim=1, drop=TRUE, ..., cnames=NULL, epsth=0.001 # , mc.cores=1L ) { m <- length(lambda) if(m == 0) stop("No lambda values supplied") if ((length(kappa) != m) || length(omega) != m ) stop("Arguments kappa and omega must have the same length as lambda") if (!all(dim(alpha) == c(m, m))) stop("Dimensions of matrix alpha are not correct") if (is.null(kernels)) kernels <- rep("Thomas", m) else if(length(kernels) != m) stop("Length of argument kernels must equal the number of components") if (is.null(nu.ker)) nu.ker <- rep(-1/4, m) diag(alpha) <- 0 if(all(alpha == 0)) return(rPSNCP0(lambda=lambda, kappa=kappa, omega=omega, kernels=kernels, nu.ker=nu.ker, win=win, nsim=nsim, cnames=cnames, ..., epsth=epsth # , mc.cores=mc.cores )) lambda <- as.list(lambda) frame <- boundingbox(win) dframe <- diameter(frame) W <- as.mask(win, ...) Wdim <- dim(W) wx <- as.vector(raster.x(W)) wy <- as.vector(raster.y(W)) sigma <- rmax <- numeric(m) for (i in 1:m) { if(is.im(lambda[[i]])) lambda[[i]] <- as.im(lambda[[i]], dimyx=Wdim, W=W) keri <- function(r){ bkernels[[kernels[i]]](r, omega[i], nu.ker[i]) } keri0 <- keri(0) sigma[i] <- kappa[i] / keri0 kerithresh <- function(r){ keri(r) / keri0 - epsth} rmax[i] <- uniroot(kerithresh, lower = omega[i] / 2, upper = 5 * dframe)$root # 4 * omega[i] # } dilated <- grow.rectangle(frame, max(rmax)) corefun <- function(idumm) { Phi <- lapply(kappa, rpoispp, win=dilated) fr <- vector("list", length=m) for (i in 1:m) { keri <- function(r){ bkernels[[kernels[i]]](r, omega[i], nu.ker[i]) } keri0 <- keri(0) Phii <- Phi[[i]] fr[[i]] <- keri(crossdist.default(wx, wy, Phii$x, Phii$y)) / keri0 } if (is.null(cnames)) cnames <- 1:m xp <- yp <- numeric(0) mp <- integer(0) for (i in 1:m) { Si <- rowSums(fr[[i]]) / sigma[i] E <- matrix(1, nrow=length(wx), ncol=m) for (j in (1:m)[-i]) { E[, j] <- apply(1 + alpha[j, i] * fr[[j]], 1, prod) * exp(-alpha[j, i] * sigma[j]) } values <- Si * apply(E, 1, prod) Lam <- im(values, xcol=W$xcol, yrow=W$yrow, unitname = unitname(W)) rhoi <- lambda[[i]] Xi <- rpoispp(rhoi * Lam) xp <- c(xp, Xi$x) yp <- c(yp, Xi$y) mp <- c(mp, rep.int(i, Xi$n)) } mp <- factor(mp, labels=cnames) simout <- ppp(xp, yp, window=win, marks=mp, check=FALSE) # attr(simout, "parents") <- Phi return(simout) } ## outlist <- if (mc.cores == 1) lapply(1:nsim, corefun) ## else parallel::mclapply(1:nsim, corefun, mc.cores=mc.cores) outlist <- lapply(seq_len(nsim), corefun) outlist <- simulationresult(outlist, nsim, drop) return(outlist) } rPSNCP }) spatstat.random/R/is.cadlag.R0000644000176200001440000000053614331654772015565 0ustar liggesusers#' #' is.cadlag.R #' #' Test whether a stepfun is cadlag/rcll #' (continue a droite; limites a gauche) #' #' $Revision: 1.4 $ $Date: 2020/11/30 04:10:33 $ is.cadlag <- function (s) { stopifnot(is.stepfun(s)) r <- knots(s) h <- s(r) n <- length(r) r1 <- c(r[-1L],r[n]+1) rm <- (r+r1)/2 hm <- s(rm) isTRUE(all.equal(h,hm)) } spatstat.random/R/rcauchy.R0000644000176200001440000002111614364101623015357 0ustar liggesusers#' #' rcauchy.R #' #' $Revision: 1.7 $ $Date: 2023/01/24 23:31:38 $ #' #' Simulation of Cauchy cluster process #' using either naive algorithm or BKBC algorithm #' #' rCauchyHom Interface to C code for stationary case (BKBC algorithm) #' rCauchy General case (naive or BKBC) #' #' Original code for naive simulation of Neyman-Scott by Adrian Baddeley #' Original code for simulation of rCauchy offspring by Abdollah Jalilian #' Bug fixes by Abdollah, Adrian Baddeley, and Rolf Turner #' #' Implementation of BKBC algorithm by Adrian Baddeley and Ya-Mei Chang #' #' Copyright (c) 2000-2023 Adrian Baddeley, Abdollah Jalilian, Ya-Mei Chang #' Licence: GNU Public Licence >= 2 #' rCauchyHom <-function(kappa, mu, scale, W=unit.square(), ..., nsim=1, drop=TRUE, inflate=NULL, saveparents=FALSE, maxinflate=10) { check.1.real(kappa) && check.finite(kappa) check.1.real(mu) && check.finite(mu) check.1.real(scale) && check.finite(scale) check.1.integer(nsim) stopifnot(kappa >= 0) stopifnot(mu >= 0) stopifnot(scale > 0) if(!is.null(inflate)) { check.1.real(inflate) && check.finite(inflate) stopifnot(inflate >= 1) } ## trivial cases if(nsim == 0) return(simulationresult(list())) if(kappa == 0 || mu == 0) { ## intensity is zero - patterns are empty empt <- ppp(window=W) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } ## shift window to convenient origin oldW <- W oldcentre <- as.numeric(centroid.owin(Frame(oldW))) W <- shift(oldW, -oldcentre) ## enclose it in a disc rD <- with(vertices(Frame(W)), sqrt(max(x^2+y^2))) ## optimal inflation if(is.null(inflate)) { a <- if(mu == 0) 1 else (1 + (1-exp(-mu))/mu) b <- (rD^2)/(2*a*scale^2) if(b <= 1) { inflate <- 1 } else { delta <- scale * (b^(2/3) - 1) inflate <- 1 + delta/rD inflate <- min(inflate, maxinflate) } } ## Prepare for C code storage.mode(kappa) <- "double" storage.mode(mu) <- "double" storage.mode(scale) <- "double" storage.mode(rD) <- "double" storage.mode(inflate) <- "double" ## resultlist <- vector(mode="list", length=nsim) for(isim in 1:nsim) { ## call C code if(saveparents) { z <- .Call(SR_rcauchyAll, kappa, mu, scale, rD, inflate, PACKAGE="spatstat.random") } else { z <- .Call(SR_rcauchyOff, kappa, mu, scale, rD, inflate, PACKAGE="spatstat.random") } ## unpack xo <- z[[1]] yo <- z[[2]] if(saveparents) { xp <- z[[3]] yp <- z[[4]] parentid <- z[[5]] } ## shift back to original window xo <- xo + oldcentre[1L] yo <- yo + oldcentre[2L] if(saveparents) { xp <- xp + oldcentre[1L] yp <- yp + oldcentre[2L] } ## restrict to original window retain <- inside.owin(xo, yo, oldW) if(!all(retain)) { xo <- xo[retain] yo <- yo[retain] if(saveparents) { parentid <- parentid[retain] retainedparents <- sort(unique(parentid)) parentid <- match(parentid, retainedparents) xp <- xp[retainedparents] yp <- yp[retainedparents] } } ## save as point pattern Y <- ppp(xo, yo, window=oldW, check=FALSE) if(saveparents) { attr(Y, "parents") <- list(x = xp, y = yp) attr(Y, "parentid") <- parentid attr(Y, "cost") <- length(xo) + length(xp) } resultlist[[isim]] <- Y } result <- simulationresult(resultlist, nsim, drop=drop) return(result) } ## ================================================ ## Neyman-Scott process with Cauchy kernel function ## ================================================ ## scale / omega: scale parameter of Cauchy kernel function ## eta: scale parameter of Cauchy pair correlation function ## eta = 2 * omega rCauchy <- local({ ## simulate mixture of normals with inverse-gamma distributed variance rnmix.invgam <- function(n = 1, rate) { V <- matrix(rnorm(2 * n, 0, 1), nrow = n, ncol = 2) s <- 1/rgamma(n, shape=1/2, rate=rate) return(sqrt(s) * V) } ## main function rCauchy <- function(kappa, scale, mu, win = square(1), nsim=1, drop=TRUE, ..., algorithm=c("BKBC", "naive"), nonempty=TRUE, thresh = 0.001, poisthresh=1e-6, expand = NULL, saveparents=FALSE, saveLambda=FALSE, kappamax=NULL, mumax=NULL) { ## Cauchy cluster process ## scale / omega: scale parameter of Cauchy kernel function ## eta: scale parameter of Cauchy pair correlation function check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) ## Catch old scale syntax (omega) dots <- list(...) if(missing(scale)) scale <- dots[["omega"]] check.1.real(scale) stopifnot(scale > 0) ## Catch old name 'eps' for 'thresh': if(missing(thresh)) thresh <- dots[["eps"]] %orifnull% 0.001 ## determine the effective maximum radius of clusters ## (for the naive algorithm, or when kappa is not constant) if(is.null(expand)){ expand <- clusterradius("Cauchy", scale = scale, thresh = thresh, ...) } else if(!missing(thresh)){ warning(paste("Argument ", sQuote("thresh"), "is ignored when", sQuote("expand"), "is given"), call.=FALSE) } #' validate 'kappa' and 'mu' km <- validate.kappa.mu(kappa, mu, kappamax, mumax, win, expand, ..., context="In rCauchy") kappamax <- km[["kappamax"]] mumax <- km[["mumax"]] ## detect trivial case where patterns are empty if(kappamax == 0 || mumax == 0) { empt <- ppp(window=win) if(saveparents) { attr(empt, "parents") <- list(x=numeric(0), y=numeric(0)) attr(empt, "parentid") <- integer(0) attr(empt, "cost") <- 0 } if(saveLambda) attr(empt, "Lambda") <- as.im(0, W=win) result <- rep(list(empt), nsim) return(simulationresult(result, nsim=nsim, drop=drop)) } #' determine algorithm algorithm <- match.arg(algorithm) do.parents <- saveparents || saveLambda || !is.numeric(kappa) do.hybrid <- (algorithm == "BKBC") && nonempty if(do.hybrid) { ## ........ Fast algorithm (BKBC) ................................. ## run BKBC algorithm for stationary model result <- rCauchyHom(kappamax, mumax, scale=scale, W=win, ..., nsim=nsim, drop=FALSE, saveparents=do.parents) ## thin if(!is.numeric(kappa)) result <- solapply(result, thinParents, P=kappa, Pmax=kappamax) if(!is.numeric(mu)) result <- solapply(result, rthin, P=mu, Pmax=mumax, na.zero=TRUE, fatal=FALSE) } else { ## .......... Slower algorithm ('naive') .......................... ## trap case of large clusters, close to Poisson if(is.numeric(kappa) && 1/(pi * kappamax * scale^2) < poisthresh) { if(is.function(mu)) mu <- as.im(mu, W=win, ...) kapmu <- kappa * mu result <- rpoispp(kapmu, win=win, nsim=nsim, drop=drop, warnwin=FALSE) result <- fakeNeyScot(result, kapmu, win, saveLambda, saveparents) return(result) } ## simulate result <- rNeymanScott(kappa=kappa, expand=expand, rcluster=list(mu, rnmix.invgam), win=win, rate = scale^2/2, # formal argument of rnmix.invgam nsim=nsim, drop=FALSE, nonempty=nonempty, saveparents = do.parents, kappamax=kappamax, mumax=mumax) } if(saveLambda){ BW <- Frame(win) for(i in 1:nsim) { parents <- attr(result[[i]], "parents") BX <- boundingbox(BW, bounding.box.xy(parents)) parents <- as.ppp(parents, W=BX, check=FALSE) Lambda <- clusterfield("Cauchy", parents, scale=scale, mu=mu, ...) attr(result[[i]], "Lambda") <- Lambda[win, drop=FALSE] } } return(simulationresult(result, nsim, drop)) } rCauchy }) spatstat.random/R/rmhcontrol.R0000644000176200001440000001766714331654772016144 0ustar liggesusers# # # rmhcontrol.R # # $Revision: 1.35 $ $Date: 2019/12/31 04:56:58 $ # # rmhcontrol <- function(...) { UseMethod("rmhcontrol") } rmhcontrol.rmhcontrol <- function(...) { argz <- list(...) if(length(argz) == 1) return(argz[[1]]) stop("Arguments not understood") } rmhcontrol.list <- function(...) { argz <- list(...) nama <- names(argz) if(length(argz) == 1 && !any(nzchar(nama))) do.call(rmhcontrol.default, argz[[1]]) else do.call.matched(rmhcontrol.default, argz) } rmhcontrol.default <- function(..., p=0.9, q=0.5, nrep=5e5, expand=NULL, periodic=NULL, ptypes=NULL, x.cond=NULL, fixall=FALSE, nverb=0, nsave=NULL, nburn=nsave, track=FALSE, pstage=c("block", "start")) { argh <- list(...) nargh <- length(argh) if(nargh > 0) { # allow rmhcontrol(NULL), otherwise flag an error if(!(nargh == 1 && is.null(argh[[1]]))) stop(paste("Unrecognised arguments to rmhcontrol;", "valid arguments are listed in help(rmhcontrol.default)")) } # impose default values if(missing(p)) p <- spatstat.options("rmh.p") if(missing(q)) q <- spatstat.options("rmh.q") if(missing(nrep)) nrep <- spatstat.options("rmh.nrep") # validate arguments if(!is.numeric(p) || length(p) != 1 || p < 0 || p > 1) stop("p should be a number in [0,1]") if(!is.numeric(q) || length(q) != 1 || q < 0 || q > 1) stop("q should be a number in [0,1]") if(!is.numeric(nrep) || length(nrep) != 1 || nrep < 1) stop("nrep should be an integer >= 1") nrep <- as.integer(nrep) if(!is.numeric(nverb) || length(nverb) != 1 || nverb < 0 || nverb > nrep) stop("nverb should be an integer <= nrep") nverb <- as.integer(nverb) if(!is.logical(fixall) || length(fixall) != 1) stop("fixall should be a logical value") if(!is.null(periodic) && (!is.logical(periodic) || length(periodic) != 1)) stop(paste(sQuote("periodic"), "should be a logical value or NULL")) if(saving <- !is.null(nsave)) { nsave <- as.integer(as.vector(nsave)) if(length(nsave) == 1L) { if(nsave <= 0) stop("nsave should be a positive integer") stopifnot(nsave < nrep) } else { stopifnot(all(nsave > 0)) stopifnot(sum(nsave) <= nrep) } if(missing(nburn) || is.null(nburn)) { nburn <- min(nsave[1], nrep-sum(nsave)) } else { check.1.integer(nburn) stopifnot(nburn + sum(nsave) <= nrep) } } stopifnot(is.logical(track)) pstage <- match.arg(pstage) ################################################################# # Conditioning on point configuration # # condtype = "none": no conditioning # condtype = "Palm": conditioning on the presence of specified points # condtype = "window": conditioning on the configuration in a subwindow # if(is.null(x.cond)) { condtype <- "none" n.cond <- NULL } else if(is.ppp(x.cond)) { condtype <- "window" n.cond <- x.cond$n } else if(is.data.frame(x.cond)) { if(ncol(x.cond) %in% c(2,3)) { condtype <- "Palm" n.cond <- nrow(x.cond) } else stop("Wrong number of columns in data frame x.cond") } else if(is.list(x.cond)) { if(length(x.cond) %in% c(2,3)) { x.cond <- as.data.frame(x.cond) condtype <- "Palm" n.cond <- nrow(x.cond) } else stop("Wrong number of components in list x.cond") } else stop("Unrecognised format for x.cond") if(condtype == "Palm" && n.cond == 0) { warning(paste("Ignored empty configuration x.cond;", "conditional (Palm) simulation given an empty point pattern", "is equivalent to unconditional simulation"), call.=FALSE) condtype <- "none" x.cond <- NULL n.cond <- NULL } ################################################################# # Fixing the number of points? # # fixcode = 1 <--> no conditioning # fixcode = 2 <--> conditioning on n = number of points # fixcode = 3 <--> conditioning on the number of points of each type. fixcode <- 2 - (p<1) + fixall - fixall*(p<1) fixing <- switch(fixcode, "none", "n.total", "n.each.type") # Warn about silly combination if(fixall && p < 1) warning("fixall = TRUE conflicts with p < 1. Ignored.", call.=FALSE) ############################################################### # `expand' determines expansion of the simulation window expand <- rmhexpand(expand) # No expansion is permitted if we are conditioning on the # number of points if(fixing != "none") { if(expand$force.exp) stop(paste("When conditioning on the number of points,", "no expansion may be done."), call.=FALSE) # no expansion expand <- .no.expansion } ################################################################### # return augmented list out <- list(p=p, q=q, nrep=nrep, nverb=nverb, expand=expand, periodic=periodic, ptypes=ptypes, fixall=fixall, fixcode=fixcode, fixing=fixing, condtype=condtype, x.cond=x.cond, saving=saving, nsave=nsave, nburn=nburn, track=track, pstage=pstage) class(out) <- c("rmhcontrol", class(out)) return(out) } print.rmhcontrol <- function(x, ...) { verifyclass(x, "rmhcontrol") splat("Metropolis-Hastings algorithm control parameters") splat("Probability of shift proposal: p =", x$p) if(x$fixing == "none") { splat("Conditional probability of death proposal: q =", x$q) if(!is.null(x$ptypes)) { splat("Birth proposal probabilities for each type of point:") print(x$ptypes) } } switch(x$fixing, none={}, n.total=splat("The total number of points is fixed"), n.each.type=splat("The number of points of each type is fixed")) switch(x$condtype, none={}, window={ splat("Conditional simulation given the", "configuration in a subwindow") print(x$x.cond$window) }, Palm={ splat("Conditional simulation of Palm type") }) splat("Number of M-H iterations: nrep =", x$nrep) if(x$saving) { nsave <- x$nsave len <- length(nsave) howmany <- if(len == 1L) nsave else if(len < 5L) commasep(nsave) else paste(paste(nsave[1:5], collapse=", "), "[...]") splat("After a burn-in of", x$nburn, "iterations,", "save point pattern after every", howmany, "iterations.") } pstage <- x$pstage %orifnull% "start" hdr <- "Generate random proposal points:" switch(pstage, start = splat(hdr, "at start of simulations."), block = splat(hdr, "before each block of", if(length(x$nsave) == 1L) x$nsave else "", "iterations.")) cat(paste("Track proposal type and acceptance/rejection?", if(x$track) "yes" else "no", "\n")) if(x$nverb > 0) cat(paste("Progress report every nverb=", x$nverb, "iterations\n")) else cat("No progress reports (nverb = 0).\n") # invoke print.rmhexpand print(x$expand) cat("Periodic edge correction? ") if(is.null(x$periodic)) cat("Not yet determined.\n") else if(x$periodic) cat("Yes.\n") else cat("No.\n") # return(invisible(NULL)) } default.rmhcontrol <- function(model, w=NULL) { # set default for 'expand' return(rmhcontrol(expand=default.expand(model, w=w))) } update.rmhcontrol <- function(object, ...) { do.call.matched(rmhcontrol.default, resolve.defaults(list(...), as.list(object), .StripNull=TRUE)) } rmhResolveControl <- function(control, model) { # adjust control information once the model is known stopifnot(inherits(control, "rmhcontrol")) # change *default* expansion rule to something appropriate for model # (applies only if expansion rule is undecided) control$expand <- change.default.expand(control$expand, default.expand(model)) return(control) } spatstat.random/R/randomfields.R0000644000176200001440000000513414514516612016377 0ustar liggesusers#' #' R/randomfields.R #' #' Random generators of Gaussian random fields #' #' $Revision: 1.7 $ $Date: 2023/10/20 14:50:06 $ #' #' Copyright (c) 2023 Adrian Baddeley #' GNU Public Licence (>= 2.0) rGRFgauss <- function(W=owin(), mu=0, var=1, scale, ..., nsim=1, drop=TRUE) { ## Gaussian random field with Gaussian covariance function check.1.real(scale) stopifnot(scale > 0) gfun <- function(x) { exp(-(x/scale)^2) } rGRFcircembed(W=W, mu=mu, var=var, corrfun = gfun, ..., nsim=nsim, drop=drop) } rGRFexpo <- function(W=owin(), mu=0, var=1, scale, ..., nsim=1, drop=TRUE) { ## Gaussian random field with exponential covariance function check.1.real(scale) stopifnot(scale > 0) efun <- function(x) { exp(-x/scale) } rGRFcircembed(W=W, mu=mu, var=var, corrfun = efun, ..., nsim=nsim, drop=drop) } rGRFstable <- function(W=owin(), mu=0, var=1, scale, alpha, ..., nsim=1, drop=TRUE) { ## Gaussian random field with stable covariance check.1.real(alpha) sfun <- function(x) { exp(-(x/scale)^alpha) } rGRFcircembed(W=W, mu=mu, var=var, corrfun = sfun, ..., nsim=nsim, drop=drop) } rGRFgencauchy <- function(W=owin(), mu=0, var=1, scale, alpha, beta, ..., nsim=1, drop=TRUE) { ## Gaussian random field with generalised Cauchy covariance check.1.real(alpha) check.1.real(beta) cfun <- function(x) { (1 + (x/scale)^alpha)^(-beta/alpha) } rGRFcircembed(W=W, mu=mu, var=var, corrfun = cfun, ..., nsim=nsim, drop=drop) } rGRFmatern <- function(W=owin(), mu=0, var=1, scale, nu, ..., nsim=1, drop=TRUE) { ## Gaussian random field with Matern covariance check.1.real(nu) mfun <- function(x) { z <- (x/scale) * sqrt(2 * nu) ifelse(x == 0, 1, (z^nu) * besselK(z, nu) * (2^(1-nu))/gamma(nu)) } rGRFcircembed(W=W, mu=mu, var=var, corrfun = mfun, ..., nsim=nsim, drop=drop) } ## test functions - not for distribution! ## pvar <- function(Zlist, X=ppp(0.5, 0.5, 0:1, 0:1)) { ## zvals <- sapply(Zlist, "[", i=X) ## var(zvals) ## } ## pcor <- function(Zlist, ## lag=0.1, X=ppp(0.5, 0.5, 0:1, 0:1), ## Y=ppp(0.5, 0.5+lag, 0:1, 0:1)) { ## zXvals <- sapply(Zlist, "[", i=X) ## zYvals <- sapply(Zlist, "[", i=Y) ## cov(zXvals, zYvals)/sqrt(var(zXvals) * var(zYvals)) ## } spatstat.random/R/reach.R0000644000176200001440000000017414331654772015020 0ustar liggesusers# # reach.R # # $Revision: 1.10 $ $Date: 2022/11/03 11:08:33 $ # reach <- function(x, ...) { UseMethod("reach") } spatstat.random/R/First.R0000644000176200001440000000061614243055211015007 0ustar liggesusers## spatstat.random/R/First.R .onLoad <- function(...) reset.spatstat.options() .onAttach <- function(libname, pkgname) { vs <- read.dcf(file=system.file("DESCRIPTION", package="spatstat.random"), fields="Version") vs <- as.character(vs) putSpatstatVariable("SpatstatRandomVersion", vs) packageStartupMessage(paste("spatstat.random", vs)) return(invisible(NULL)) } spatstat.random/R/rlabel.R0000644000176200001440000000272514331654772015203 0ustar liggesusers# # rlabel.R # # random (re)labelling # # $Revision: 1.13 $ $Date: 2020/10/23 15:18:00 $ # # rlabel <- local({ resample <- function(x, replace=FALSE) { x[sample(length(x), replace=replace)] } rlabel <- function(X, labels=marks(X), permute=TRUE, group=NULL, ..., nsim=1, drop=TRUE) { stopifnot(is.ppp(X) || is.lpp(X) || is.pp3(X) || is.ppx(X) || is.psp(X)) if(is.null(labels)) stop("labels not given and marks not present") singlecolumn <- (length(dim(labels)) < 2) nthings <- nobjects(X) things <- if(is.psp(X)) "segments" else "points" nlabels <- if(singlecolumn) length(labels) else nrow(labels) if((nlabels != nthings) && (permute || !is.null(group))) stop(paste(if(singlecolumn) "Length" else "Number of rows", "of labels does not match the number of", things), call.=FALSE) ## if(is.null(group)) { Y <- replicate(nsim, { X %mark% marksubset(labels, sample(nlabels, nthings, replace=!permute)) }, simplify=FALSE) } else { group <- marks(cut(X, group, ...)) seqn <- seq_len(nlabels) pieces <- split(seqn, group) Y <- replicate(nsim, { X %mark% marksubset(labels, unsplit(lapply(pieces, resample, replace=!permute), group)) }, simplify=FALSE) } ## return(simulationresult(Y, nsim, drop)) } rlabel }) spatstat.random/R/quadratresample.R0000644000176200001440000000223214331654772017125 0ustar liggesusers# # quadratresample.R # # resample a point pattern by resampling quadrats # # $Revision: 1.7 $ $Date: 2015/10/21 09:06:57 $ # quadratresample <- function(X, nx, ny=nx, ..., replace=FALSE, nsamples=1, verbose=(nsamples > 1)) { stopifnot(is.ppp(X)) if(X$window$type != "rectangle") stop("Resampling is only implemented for rectangular windows") # create tessellation A <- quadrats(X, nx=nx, ny=ny) # split data over tessellation B <- split(X, A) nq <- length(B) # determine bottom left corner of each tile V <- lapply(B, framebottomleft) out <- list() if(verbose) { cat("Generating resampled patterns...") pstate <- list() } for(i in 1:nsamples) { # resample tiles ind <- sample(1:nq, nq, replace=replace) Xresampled <- X Bresampled <- B for(j in 1:nq) { k <- ind[j] Bresampled[[j]] <- shift(B[[k]], unlist(V[[j]]) - unlist(V[[k]])) } split(Xresampled, A) <- Bresampled out[[i]] <- Xresampled if(verbose) pstate <- progressreport(i, nsamples, state=pstate) } if(nsamples == 1) return(out[[1]]) return(as.solist(out)) } spatstat.random/R/randomppx.R0000644000176200001440000000263414331654772015751 0ustar liggesusers#' #' randomppx.R #' #' $Revision: 1.2 $ $Date: 2022/04/06 07:16:18 $ #' runifpointx <- function(n, domain, nsim=1, drop=TRUE) { check.1.integer(n) check.1.integer(nsim) stopifnot(nsim >= 0) stopifnot(inherits(domain, "boxx")) ra <- domain$ranges d <- length(ra) result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { if(n == 0) { coo <- matrix(numeric(0), nrow=0, ncol=d) } else { coo <- mapply(runif, n=rep(n, d), min=ra[1,], max=ra[2,]) if(!is.matrix(coo)) coo <- matrix(coo, ncol=d) } colnames(coo) <- colnames(ra) df <- as.data.frame(coo) result[[i]] <- ppx(df, domain, coord.type=rep("s", d)) } if(nsim == 1 && drop) return(result[[1]]) result <- as.anylist(result) if(nsim > 0) names(result) <- paste("Simulation", 1:nsim) return(result) } rpoisppx <- function(lambda, domain, nsim=1, drop=TRUE) { check.1.integer(nsim) stopifnot(nsim >= 0) stopifnot(inherits(domain, "boxx")) stopifnot(is.numeric(lambda) && length(lambda) == 1 && lambda >= 0) n <- rpois(nsim, lambda * volume.boxx(domain)) result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) result[[i]] <- runifpointx(n[i], domain) if(nsim == 1 && drop) return(result[[1]]) result <- as.anylist(result) if(nsim > 0) names(result) <- paste("Simulation", 1:nsim) return(result) } spatstat.random/R/clusterinfo.R0000644000176200001440000011563214514462531016272 0ustar liggesusers#' clusterinfo.R #' #' Lookup table of information about cluster processes and Cox processes #' #' $Revision: 1.63 $ $Date: 2023/10/20 11:06:21 $ #' #' Information is extracted by calling #' spatstatClusterModelInfo() #' where is the name of the cluster type (e.g. 'Thomas', 'MatClust', 'Cauchy'). #' #' Information is stored in the named list .Spatstat.ClusterModelInfoTable #' with names 'Thomas', 'MatClust' etc. #' #' Each list entry contains information about a particular cluster mechanism. #' It is a list with the following entries: #' #' modelname (String) The name of the process as it would be stated in an article #' e.g. "Neyman-Scott process with Cauchy kernel" #' #' descname (String) abbreviated name of the process for use in fv objects #' e.g. "Cauchy process" #' #' modelabbrev (String) short name of the process for use in kppm object #' e.g. "Cauchy process" #' #' printmodelname function(obj) #' Invoked by print.kppm to construct the name of the process #' (where the name includes shape parameters of the kernel) #' e.g. produces value "Variance-Gamma process with nu=0.3" #' #' parnames (Character vector of length 2) #' The names of the "NATIVE" cluster parameters #' e.g. Thomas -> c('kappa', 'sigma2') #' MatClust -> c('kappa', 'R') #' #' **NOTE** that there are two parametrisations: #' - the 'GENERIC' parameters (e.g. 'kappa' and 'scale' for cluster models) #' - the 'NATIVE' parameters depend on the model. #' #' The native parameters are designed to be a more efficient representation #' for internal use when fitting models. Starting values for the parameters #' are expected to be given in the native parametrisation. #' #' shapenames (Character vector) #' The names of any shape parameters of the kernel #' that could/should be provided by the user #' e.g. 'nu' #' #' clustargsnames (Character vector) #' DEPRECATED #' Identical to shapenames #' #' checkpar function(par, native=TRUE, ...) #' Validates the parameters 'par' (in either format) #' and converts them to the native parameters (if native=TRUE) #' or converts them to the generic parameters (if native=FALSE). #' Transitional syntax: function(par, native=old, ..., old=TRUE) #' ('old' is a synonym for 'native') #' #' native2generic function(par) #' Streamlined function to convert 'par' from native to generic format. #' #' outputshape function(margs, ..) #' Convert 'margs' to the format required for printed output. #' #' checkclustargs function(margs, old=TRUE, ...) #' DEPRECATED: equivalent to outputshape(...) #' If old=TRUE, return 'margs' (NEVER USED) #' If old=FALSE, convert 'margs' to the format required for output. #' #' resolveshape function(...) #' Extracts any shape parameters that may be present in '...' #' under different aliases or formats (e.g. 'nu.pcf' versus 'nu.ker'). #' Returns list(margs, covmodel) where covmodel=list(type, model, margs) #' where 'margs' is in the format required for internal use. #' #' resolvedots function(...) #' DEPRECATED - equivalent to resolveshape(...) #' #' parhandler function(...) #' DEPRECATED - equivalent to function(...) { resolveshape(...)$covmodel } #' #' ddist function(r, scale, ...) #' One-dimensional probability density of distance from parent to offspring #' ('scale' is in generic format) #' #' range function(..., par, thresh) #' Computes cluster radius #' 'par' is in generic format #' (thresh = probability that parent-to-offspring distance exceeds this radius) #' #' kernel function(par, rvals, ..., margs) #' [DEFINED ONLY FOR POISSON CLUSTER PROCESSES] #' compute kernel (two-dimensional probability density of offspring) #' as a function of distance from parent to offspring. #' 'par' is in native format #' 'margs' is a list of shape arguments, if required #' #' isPCP logical. #' TRUE iff the model is a Poisson cluster process #' #' iscompact logical. #' TRUE if the kernel has compact support. #' #' roffspring function(n, par, ..., margs) #' [DEFINED ONLY FOR POISSON CLUSTER PROCESSES] #' Random generator of cluster. #' Generates n offspring of a parent at the origin. #' #' K function(par, rvals, ..., model, margs) #' Compute K-function #' 'par' is in native format #' Arguments 'model', 'margs' are required if there are shape parameters #' #' pcf function(par, rvals, ..., model, margs) #' Compute pair correlation function #' 'par' is in native format #' Arguments 'model', 'margs' are required if there are shape parameters #' #' Dpcf function(par, rvals, ..., model, margs) #' Compute vector of partial derivatives of pair correlation function with respect to 'par' #' 'par' is in native format #' Arguments 'model', 'margs' are required if there are shape parameters #' #' funaux DEPRECATED #' List of additional functions used in computation #' (These should now be defined as stand-alone objects) #' #' selfstart function(X) #' Calculates reasonable default estimates of 'par' from point pattern X #' Returns 'par' in native format #' #' interpret function(par, lambda) #' Return a full set of model parameters in a meaningful format for printing #' #' roffspring function(n, par, ..., model, margs) #' Generates random offspring of a parent at the origin #' #' .................................................................................................. #' This file defines each entry in the table separately, then creates the table #' .................................................................................................. #' ## ................. general helper functions (exported) .................... ## The following function simplifies code maintenance ## (due to changes in subscripting behaviour in recent versions of R) retrieve.param <- function(desired, aliases, ..., par=NULL) { ## Retrieve the generic parameter named (or one of its ) ## from (...) or from 'par' dots <- list(...) par <- as.list(par) # may be empty dnames <- names(dots) pnames <- names(par) for(key in c(desired, aliases)) { if(key %in% dnames) return(dots[[key]]) if(key %in% pnames) return(par[[key]]) } ## failed nali <- length(aliases) if(nali == 0) { explain <- NULL } else { explain <- paren(paste("also tried", ngettext(nali, "alias", "aliases"), commasep(sQuote(aliases)))) } mess <- paste("Unable to retrieve argument", sQuote(desired), explain) stop(mess, call.=FALSE) } detect.par.format <- function(par, native, generic) { a <- check.named.vector(par, native, onError="null") if(!is.null(a)) return("native") a <- check.named.vector(par, generic, onError="null") if(!is.null(a)) return("generic") whinge <- paste("'par' should be a named vector with elements", paren(paste(sQuote(native), collapse=" and "), "["), "or", paren(paste(sQuote(generic), collapse=" and "), "[")) stop(whinge, call.=FALSE) } #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' >>>>>>>>>>>>>>>>>>>>>> Thomas process <<<<<<<<<<<<<<<<<<<<<<<<<<<< #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| .ThomasInfo <- list( modelname = "Thomas process", # In modelname field of mincon fv obj. descname = "Thomas process", # In desc field of mincon fv obj. modelabbrev = "Thomas process", # In fitted kppm obj. printmodelname = function(...) "Thomas process", # Used by print.kppm parnames = c("kappa", "sigma2"), shapenames = NULL, clustargsnames = NULL, checkpar = function(par, native = old, ..., old=TRUE, strict=TRUE){ ## 'par' is in either format if(is.null(par)) par <- c(kappa=1,scale=1) if(strict && any(par<=0)) stop("par values must be positive.", call.=FALSE) fmt <- detect.par.format(par, native=c("kappa", "sigma2"), generic=c("kappa", "scale")) if(fmt == "generic" && native) { ## convert generic to native par[2L] <- par[2L]^2 names(par)[2L] <- "sigma2" } else if(fmt == "native" && !native) { ## convert native to generic par[2L] <- sqrt(par[2L]) names(par)[2L] <- "scale" } return(par) }, native2generic = function(par) { par[2L] <- sqrt(par[2L]) names(par) <- c("kappa", "scale") return(par) }, outputshape = function(margs, ...) list(), checkclustargs = function(margs, old = TRUE, ...) list(), resolveshape = function(...){ return(list(...)) }, resolvedots = function(...){ return(list(...)) }, parhandler = NULL, ## density function for the distance to offspring ddist = function(r, scale, ...) { ## 'scale' is generic format 2 * pi * r * dnorm(r, 0, scale)/sqrt(2*pi*scale^2) }, ## Practical range of clusters range = function(..., par=NULL, thresh=NULL){ ## 'par' is in generic format scale <- retrieve.param("scale", "sigma", ..., par=par) if(!is.null(thresh)){ ## The squared length of isotropic Gaussian (sigma) ## is exponential with mean 2 sigma^2 rmax <- scale * sqrt(2 * qexp(thresh, lower.tail=FALSE)) } else { rmax <- 4*scale } return(rmax) }, kernel = function(par, rvals, ...) { ## 'par' is in native format scale <- sqrt(par[2L]) dnorm(rvals, 0, scale)/sqrt(2*pi*scale^2) }, isPCP=TRUE, iscompact=FALSE, roffspring=function(n, par, ...) { ## 'par' is in native format sigma <- sqrt(par[2L]) list(x=rnorm(n, sd=sigma), y=rnorm(n, sd=sigma)) }, ## K-function K = function(par,rvals, ..., strict=TRUE){ ## 'par' is in native format if(strict && any(par <= 0)) return(rep.int(Inf, length(rvals))) pi*rvals^2+(1-exp(-rvals^2/(4*par[2L])))/par[1L] }, ## pair correlation function pcf= function(par,rvals, ..., strict=TRUE){ ## 'par' is in native format if(strict && any(par <= 0)) return(rep.int(Inf, length(rvals))) 1 + exp(-rvals^2/(4 * par[2L]))/(4 * pi * par[1L] * par[2L]) }, ## gradient of pcf (contributed by Chiara Fend) Dpcf= function(par,rvals, ..., strict=TRUE){ ## 'par' is in native format if(strict && any(par <= 0)){ dsigma2 <- rep.int(Inf, length(rvals)) dkappa <- rep.int(Inf, length(rvals)) } else { dsigma2 <- exp(-rvals^2/(4 * par[2L])) * (rvals/(4^2 * pi * par[1L] * par[2L]^3) - 1/(4 * pi * par[1L] * par[2L]^2)) dkappa <- -exp(-rvals^2/(4 * par[2L]))/(4 * pi * par[1L]^2 * par[2L]) } out <- rbind(dkappa, dsigma2) rownames(out) <- c("kappa","sigma2") return(out) }, ## Convert to/from canonical cluster parameters tocanonical = function(par, ...) { ## 'par' is in native format ## convert to experimental 'canonical' format kappa <- par[[1L]] sigma2 <- par[[2L]] c(strength=1/(4 * pi * kappa * sigma2), scale=sqrt(sigma2)) }, tohuman = function(can, ...) { ## 'can' is in 'canonical' format ## convert to native format strength <- can[[1L]] scale <- can[[2L]] sigma2 <- scale^2 c(kappa=1/(4 * pi * strength * sigma2), sigma2=sigma2) }, ## sensible starting parameters selfstart = function(X) { ## return 'par' in native format kappa <- intensity(X) sigma2 <- 4 * mean(nndist(X))^2 c(kappa=kappa, sigma2=sigma2) }, ## meaningful model parameters interpret = function(par, lambda) { kappa <- par[["kappa"]] sigma <- sqrt(par[["sigma2"]]) mu <- if(is.numeric(lambda) && length(lambda) == 1) lambda/kappa else NA c(kappa=kappa, sigma=sigma, mu=mu) }, roffspring = function(n, par, ...) { sd <- sqrt(par[["sigma2"]]) list(x=rnorm(n, sd=sd), y=rnorm(n, sd=sd)) } ) #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' >>>>>>>>>>>>>>>>> Matern cluster process <<<<<<<<<<<<<<<<<<<<<<<<<< #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' auxiliary functions .MatClustHfun <- function(zz) { ok <- (zz < 1) h <- numeric(length(zz)) h[!ok] <- 1 z <- zz[ok] h[ok] <- 2 + (1/pi) * ( (8 * z^2 - 4) * acos(z) - 2 * asin(z) + 4 * z * sqrt((1 - z^2)^3) - 6 * z * sqrt(1 - z^2) ) return(h) } .MatClustDOH <- function(zz) { ok <- (zz < 1) h <- numeric(length(zz)) h[!ok] <- 0 z <- zz[ok] h[ok] <- (16/pi) * (z * acos(z) - (z^2) * sqrt(1 - z^2)) return(h) } ## g(z) = DOH(z)/z has a limit at z=0. .MatClustgfun <- function(zz) { ok <- (zz < 1) h <- numeric(length(zz)) h[!ok] <- 0 z <- zz[ok] h[ok] <- (2/pi) * (acos(z) - z * sqrt(1 - z^2)) return(h) } .MatClustgprime <- function(zz) { ok <- (zz < 1) h <- numeric(length(zz)) h[!ok] <- 0 z <- zz[ok] h[ok] <- -(2/pi) * 2 * sqrt(1 - z^2) return(h) } #' main list of info .MatClustInfo = list( modelname = "Matern cluster process", # In modelname field of mincon fv obj. descname = "Matern cluster process", # In desc field of mincon fv obj. modelabbrev = "Matern cluster process", # In fitted obj. printmodelname = function(...) "Matern cluster process", # Used by print.kppm parnames = c("kappa", "R"), shapenames = NULL, clustargsnames = NULL, checkpar = function(par, native = old, ..., old=TRUE, strict=TRUE){ ## 'par' is in either format if(is.null(par)) par <- c(kappa=1,scale=1) if(strict && any(par<=0)) stop("par values must be positive.", call.=FALSE) detect.par.format(par, native=c("kappa", "R"), generic=c("kappa", "scale")) names(par)[2L] <- if(native) "R" else "scale" return(par) }, native2generic = function(par) { names(par) <- c("kappa", "scale") return(par) }, ## density function for the distance to offspring ddist = function(r, scale, ...) { ## 'scale' is generic format ifelse(r>scale, 0, 2 * r / scale^2) }, ## Practical range of clusters range = function(..., par=NULL, thresh=NULL){ ## 'par' is in generic format scale <- retrieve.param("scale", "R", ..., par=par) return(scale) }, outputshape = function(margs, ...) list(), checkclustargs = function(margs, old = TRUE, ...) list(), resolveshape = function(...){ return(list(...)) }, resolvedots = function(...){ return(list(...)) }, parhandler = NULL, kernel = function(par, rvals, ...) { ## 'par' is in native format scale <- par[2L] ifelse(rvals>scale, 0, 1/(pi*scale^2)) }, isPCP=TRUE, iscompact=TRUE, roffspring = function(n, par, ...) { ## 'par' is in native format R <- par[2L] rad <- R * sqrt(runif(n)) theta <- runif(n, max=2*pi) list(x = rad * cos(theta), y = rad * sin(theta)) }, K = function(par,rvals, ...){ ## 'par' is in native format if(any(par <= 0)) return(rep.int(Inf, length(rvals))) kappa <- par[1L] R <- par[2L] y <- pi * rvals^2 + (1/kappa) * .MatClustHfun(rvals/(2 * R)) return(y) }, pcf= function(par,rvals, ...){ ## 'par' is in native format if(any(par <= 0)) return(rep.int(Inf, length(rvals))) kappa <- par[1L] R <- par[2L] y <- 1 + (1/(pi * kappa * R^2)) * .MatClustgfun(rvals/(2 * R)) return(y) }, Dpcf= function(par,rvals, ...){ ## 'par' is in native format kappa <- par[1L] R <- par[2L] if(any(par <= 0)){ dkappa <- rep.int(Inf, length(rvals)) dR <- rep.int(Inf, length(rvals)) } else { dkappa <- -.MatClustgfun(rvals/(2 * R)) / (pi * kappa^2 * R^2) dR <- -2*.MatClustgfun(rvals/(2 * R))/(pi * kappa * R^3) - (1/(pi * kappa * R^2)) * .MatClustgprime(rvals/(2 * R))*rvals/(2*R^2) } out <- rbind(dkappa, dR) rownames(out) <- c("kappa","R") return(out) }, ## Convert to/from canonical cluster parameters tocanonical = function(par, ...) { ## 'par' is in native format ## convert to experimental 'canonical' format kappa <- par[[1L]] R <- par[[2L]] c(strength=1/(pi * kappa * R^2), scale=R) }, tohuman = function(can, ...) { ## 'can' is in 'canonical' format ## convert to native format strength <- can[[1L]] scale <- can[[2L]] c(kappa=1/(pi * strength * scale^2), R=scale) }, ## sensible starting paramters selfstart = function(X) { ## return 'par' in native format kappa <- intensity(X) R <- 2 * mean(nndist(X)) c(kappa=kappa, R=R) }, ## meaningful model parameters interpret = function(par, lambda) { kappa <- par[["kappa"]] R <- par[["R"]] mu <- if(is.numeric(lambda) && length(lambda) == 1) lambda/kappa else NA c(kappa=kappa, R=R, mu=mu) }, roffspring = function(n, par, ...) { R <- par[["R"]] rad <- R * sqrt(runif(n)) theta <- runif(n, max=2*pi) list(x = rad * cos(theta), y = rad * sin(theta)) } ) #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' >>>>>>>>>>>>>>>>>>>>> Cauchy kernel cluster process <<<<<<<<<<<<<<< #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| .CauchyInfo <- list( modelname = "Neyman-Scott process with Cauchy kernel", # In modelname field of mincon fv obj. descname = "Neyman-Scott process with Cauchy kernel", # In desc field of mincon fv obj. modelabbrev = "Cauchy process", # In fitted obj. printmodelname = function(...) "Cauchy process", # Used by print.kppm parnames = c("kappa", "eta2"), shapenames = NULL, clustargsnames = NULL, checkpar = function(par, native = old, ..., old=TRUE, strict=TRUE){ ## 'par' is in either format if(is.null(par)) par <- c(kappa=1,scale=1) if(strict && any(par<=0)) stop("par values must be positive.", call.=FALSE) fmt <- detect.par.format(par, native=c("kappa", "eta2"), generic=c("kappa", "scale")) if(fmt == "generic" && native) { ## convert generic to native ## eta2 = 4 * scale^2 par[2L] <- (2*par[2L])^2 names(par)[2L] <- "eta2" } else if(fmt == "native" && !native) { ## convert native to generic ## scale = sqrt(eta2/4) par[2L] <- sqrt(par[2L])/2 names(par)[2L] <- "scale" } return(par) }, native2generic = function(par) { par[2L] <- sqrt(par[2L])/2 names(par) <- c("kappa", "scale") return(par) }, outputshape = function(margs, ...) list(), checkclustargs = function(margs, old = TRUE, ...) list(), resolveshape = function(...){ return(list(...)) }, resolvedots = function(...){ return(list(...)) }, parhandler = NULL, ## density function for the distance to offspring ddist = function(r, scale, ...) { ## 'scale' is generic format r/(scale^2) * (1 + (r / scale)^2)^(-3/2) }, ## Practical range of clusters range = function(..., par=NULL, thresh=0.01){ ## 'par' is in generic format thresh <- as.numeric(thresh %orifnull% 0.01) scale <- retrieve.param("scale", character(0), ..., par=par) ## integral of ddist(r) dr is 1 - (1+(r/scale)^2)^(-1/2) ## solve for integral = 1-thresh: rmax <- scale * sqrt(1/thresh^2 - 1) return(rmax) }, kernel = function(par, rvals, ...) { ## 'par' is in native format scale <- sqrt(par[2L])/2 1/(2*pi*scale^2)*((1 + (rvals/scale)^2)^(-3/2)) }, isPCP=TRUE, iscompact=FALSE, roffspring=function(n, par, ...) { ## 'par' is in native format rate <- par[["eta2"]]/8 b <- 1/sqrt(rgamma(n, shape=1/2, rate=rate)) list(x = b * rnorm(n), y = b * rnorm(n)) }, K = function(par,rvals, ...){ ## 'par' is in native format if(any(par <= 0)) return(rep.int(Inf, length(rvals))) pi*rvals^2 + (1 - 1/sqrt(1 + rvals^2/par[2L]))/par[1L] }, pcf= function(par,rvals, ...){ ## 'par' is in native format if(any(par <= 0)) return(rep.int(Inf, length(rvals))) 1 + ((1 + rvals^2/par[2L])^(-1.5))/(2 * pi * par[2L] * par[1L]) }, Dpcf= function(par,rvals, ...){ ## 'par' is in native format if(any(par <= 0)){ dkappa <- rep.int(Inf, length(rvals)) deta2 <- rep.int(Inf, length(rvals)) } else { dkappa <- -(1 + rvals^2/par[2L])^(-1.5)/(2 * pi * par[2L] * par[1L]^2) deta2 <- 1.5 * rvals^2 * (1 + rvals^2/par[2L])^(-2.5)/(2 * par[2L]^3 * par[1L] * pi) - (1 + rvals^2/par[2L])^(-1.5)/(2*pi*par[1L]*par[2L]^2) } out <- rbind(dkappa, deta2) rownames(out) <- c("kappa","eta2") return(out) }, ## Convert to/from canonical cluster parameters tocanonical = function(par, ...) { ## 'par' is in native format ## convert to experimental 'canonical' format kappa <- par[[1L]] eta2 <- par[[2L]] c(strength=1/(2 * pi * kappa * eta2), scale=sqrt(eta2)/2) }, tohuman = function(can, ...) { ## 'can' is in 'canonical' format ## convert to native format strength <- can[[1L]] scale <- can[[2L]] eta2 <- 4 * scale^2 c(kappa=1/(2 * pi * strength * eta2), eta2=eta2) }, selfstart = function(X) { ## return 'par' in native format kappa <- intensity(X) eta2 <- 4 * mean(nndist(X))^2 c(kappa = kappa, eta2 = eta2) }, ## meaningful model parameters interpret = function(par, lambda) { #' par is in native format kappa <- par[["kappa"]] omega <- sqrt(par[["eta2"]])/2 mu <- if(is.numeric(lambda) && length(lambda) == 1) lambda/kappa else NA c(kappa=kappa, omega=omega, mu=mu) }, roffspring = function(n, par, ...) { #' par is in native format rate <- par[["eta2"]]/8 b <- 1/sqrt(rgamma(n, shape=1/2, rate=rate)) list(x = b * rnorm(n), y = b * rnorm(n)) } ) #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' >>>>>>>>>>>>>>>>> Variance Gamma kernel cluster process <<<<<<<<<<< #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' helper functions resolve.vargamma.shape <- function(..., nu.ker=NULL, nu.pcf=NULL, nu = NULL, allow.nu = FALSE, allow.default = FALSE) { ## ingest any kind of 'nu' argument by name if(is.null(nu.ker) && is.null(nu.pcf)) { if(allow.nu && !is.null(nu)) { nu.ker <- nu } else if(allow.default) { nu.ker <- -1/4 } else stop("Must specify nu.ker or nu.pcf", call.=FALSE) } if(!is.null(nu.ker) && !is.null(nu.pcf)) stop("Only one of nu.ker and nu.pcf should be specified", call.=FALSE) if(!is.null(nu.ker)) { check.1.real(nu.ker) stopifnot(nu.ker > -1/2) nu.pcf <- 2 * nu.ker + 1 } else { check.1.real(nu.pcf) stopifnot(nu.pcf > 0) nu.ker <- (nu.pcf - 1)/2 } return(list(nu.ker=nu.ker, nu.pcf=nu.pcf)) } .VarGammaResolveShape <- function(...){ nu.ker <- resolve.vargamma.shape(..., allow.default=TRUE, allow.nu=TRUE)$nu.ker check.1.real(nu.ker) stopifnot(nu.ker > -1/2) margs <- list(nu.ker=nu.ker, nu.pcf=2*nu.ker+1) cmodel <- list(type="Kernel", model="VarGamma", margs=margs) out <- list(margs = margs, covmodel = cmodel) return(out) } .VarGammaOutputShape <- function(margs, ...) { list(nu=margs$nu.ker) } .VarGammaDdist <- function(r, scale, nu, ...) { ## one-dimensional probability density function for the distance to offspring ## 'scale' is generic format numer <- ((r/scale)^(nu+1)) * besselK(r/scale, nu) numer[r==0] <- 0 denom <- (2^nu) * scale * gamma(nu + 1) y <- numer/denom y[!is.finite(y)] <- 0 return(y) } .VarGammaPdist <- function(r, scale, nu, ...) { n <- length(r) z <- numeric(n) for(i in seq_len(n)) z[i] <- integrate(.VarGammaDdist, 0, r[i], scale=scale, nu=nu)$value return(z) } .VarGammaPdistContrast <- function(r, scale, nu, p, ...) { .VarGammaPdist(r, scale, nu, ...) - p } .VarGammaKintegrand <- function(x, par, nu.pcf) { ## x * pcf(x) without check on par values numer <- (x/par[2L])^nu.pcf * besselK(x/par[2L], nu.pcf) denom <- 2^(nu.pcf+1) * pi * par[2L]^2 * par[1L] * gamma(nu.pcf + 1) return(x * (1 + numer/denom)) } #' main list of info #' NOTE: 'nu' represents 'nu.ker', #' the parameter \nu^\prime in equation (12) #' of Jalilian, Guan & Waagepetersen 2013 .VarGammaInfo <- list( modelname = "Neyman-Scott process with Variance Gamma kernel", # In modelname field of mincon fv obj. descname = "Neyman-Scott process with Variance Gamma kernel", # In desc field of mincon fv obj. modelabbrev = "Variance Gamma process", # In fitted obj. printmodelname = function(obj){ # Used by print.kppm paste0("Variance Gamma process (nu=", signif(obj$clustargs[["nu"]], 2), ")") }, parnames = c("kappa", "eta"), shapenames = "nu", clustargsnames = "nu", checkpar = function(par, native = old, ..., old = TRUE, strict=TRUE){ ## 'par' is in either format if(is.null(par)) par <- c(kappa=1,scale=1) if(strict && any(par<=0)) stop("par values must be positive.", call.=FALSE) detect.par.format(par, native=c("kappa", "eta"), generic=c("kappa", "scale")) names(par)[2L] <- if(native) "eta" else "scale" return(par) }, native2generic = function(par) { names(par) <- c("kappa", "scale") return(par) }, outputshape = .VarGammaOutputShape, checkclustargs = function(margs, old = TRUE, ...){ if(!old) margs <- list(nu=margs$nu.ker) return(margs) }, resolveshape = .VarGammaResolveShape, resolvedots = .VarGammaResolveShape, parhandler = function(...){ .VarGammaResolveShape(...)$covmodel }, ddist = .VarGammaDdist, ## Practical range of clusters range = function(..., par=NULL, thresh=0.001){ ## 'par' is in generic format thresh <- as.numeric(thresh %orifnull% 0.001) scale <- retrieve.param("scale", character(0), ..., par=par) ## Find value of nu: margs <- .VarGammaResolveShape(...)$margs nu <- .VarGammaOutputShape(margs)$nu if(is.null(nu)) stop(paste("Argument ", sQuote("nu"), " must be given."), call.=FALSE) rmax <- uniroot(.VarGammaPdistContrast, lower = scale, upper = 1000 * scale, scale=scale, nu=nu, p=1-thresh)$root return(rmax) }, ## kernel function in polar coordinates (no angular argument). kernel = function(par, rvals, ..., margs) { ## 'par' is in native format scale <- as.numeric(par[2L]) nu.ker <- margs$nu.ker %orifnull% margs$nu ## evaluate numer <- ((rvals/scale)^nu.ker) * besselK(rvals/scale, nu.ker) numer[rvals==0] <- if(nu.ker > 0) 2^(nu.ker-1)*gamma(nu.ker) else Inf denom <- pi * (2^(nu.ker+1)) * scale^2 * gamma(nu.ker + 1) numer/denom }, isPCP=TRUE, iscompact=FALSE, roffspring=function(n, par, ..., margs) { ## 'par' is in native format scale <- par[["eta"]] ## eta = omega = scale nu.ker <- margs$nu.ker alpha <- 2 * (nu.ker + 1) beta <- 1/(2 * scale^2) sdee <- sqrt(rgamma(n, shape=alpha/2, rate=beta)) list(x = sdee * rnorm(n), y = sdee * rnorm(n)) }, K = function(par,rvals, ..., margs){ ## 'par' is in native format ## margs = list(.. nu.pcf.. ) ## K function requires integration of pair correlation if(any(par <= 0)) return(rep.int(Inf, length(rvals))) nu.pcf <- margs$nu.pcf out <- numeric(length(rvals)) for (i in which(rvals > 0)) out[i] <- 2 * pi * integrate(.VarGammaKintegrand, lower=0, upper=rvals[i], par=par, nu.pcf=nu.pcf)$value return(out) }, pcf= function(par,rvals, ..., margs){ ## 'par' is in native format ## margs = list(..nu.pcf..) if(any(par <= 0)) return(rep.int(Inf, length(rvals))) nu.pcf <- margs$nu.pcf sig2 <- 1 / (4 * pi * (par[2L]^2) * nu.pcf * par[1L]) denom <- 2^(nu.pcf - 1) * gamma(nu.pcf) rr <- rvals / par[2L] ## Matern correlation function fr <- ifelseXB(rr > 0, (rr^nu.pcf) * besselK(rr, nu.pcf) / denom, 1) return(as.numeric(1 + sig2 * fr)) }, Dpcf = NULL, ## Convert to/from canonical cluster parameters tocanonical = function(par, ..., margs) { ## 'par' is in native format ## convert to experimental 'canonical' format kappa <- par[[1L]] eta <- par[[2L]] nu.pcf <- margs$nu.pcf c(strength=1/(4 * pi * nu.pcf * kappa * eta^2), scale=eta) }, tohuman = function(can, ..., margs) { ## 'can' is in 'canonical' format ## convert to native format strength <- can[[1L]] eta <- scale <- can[[2L]] nu.pcf <- margs$nu.pcf c(kappa=1/(4 * pi * nu.pcf * strength * eta^2), eta=scale) }, ## sensible starting values selfstart = function(X) { ## return 'par' in native format kappa <- intensity(X) eta <- 2 * mean(nndist(X)) c(kappa=kappa, eta=eta) }, ## meaningful model parameters interpret = function(par, lambda) { #' par is in native format kappa <- par[["kappa"]] omega <- par[["eta"]] mu <- if(is.numeric(lambda) && length(lambda) == 1) lambda/kappa else NA c(kappa=kappa, omega=omega, mu=mu) }, roffspring = function(n, par, ..., margs) { #' par is in native format shape <- margs$nu.ker + 1 scale <- par[[2L]] rate <- 1/(2 * scale^2) b <- sqrt(rgamma(n, shape=shape, rate=rate)) list(x= b * rnorm(n), y = b * rnorm(n)) } ) #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' >>>>>>>>>>>>>>>>>> Log-Gaussian Cox process <<<<<<<<<<<<<<<<<<<<<< #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' helper functions .LGCPResolveShape <- function(...){ ## resolve shape parameters for kppm and friends allowing for native/generic par syntax dots <- list(...) nam <- names(dots) out <- list() cmod <- dots$covmodel model <- cmod$model %orifnull% dots$model %orifnull% "exponential" margs <- NULL ## extract shape parameters and validate them switch(model, exponential = , gauss = { ## no shape parameters }, stable = , fastStable = { stuff <- cmod %orifnull% dots ok <- "alpha" %in% names(stuff) if(!ok) stop("Parameter 'alpha' is required") margs <- stuff["alpha"] with(margs, { check.1.real(alpha) stopifnot(0 < alpha && alpha <= 2) }) }, gencauchy = , fastGencauchy = { stuff <- cmod %orifnull% dots ok <- c("alpha", "beta") %in% names(stuff) if(!ok[1]) stop("Parameter 'alpha' is required") if(!ok[2]) stop("Parameter 'beta' is required") margs <- stuff[c("alpha", "beta")] with(margs, { check.1.real(alpha) check.1.real(beta) stopifnot(0 < alpha && alpha <= 2) stopifnot(beta > 0) }) }, matern = { stuff <- cmod %orifnull% dots ok <- "nu" %in% names(stuff) if(!ok) stop("Parameter 'nu' is required") margs <- stuff["nu"] with(margs, { check.1.real(nu) }) }, stop(paste("Covariance model", sQuote(model), "is not yet supported"), call.=FALSE) ) if(length(margs)==0) { margs <- NULL } else { ## detect anisotropic model if("Aniso" %in% names(margs)) stop("Anisotropic covariance models cannot be used", call.=FALSE) } out$margs <- margs out$model <- model out$covmodel <- list(type="Covariance", model=model, margs=margs) return(out) } #' main list of info .LGCPInfo <- list( ## Log Gaussian Cox process: native par = (sigma2, alpha) ## Log Gaussian Cox process: generic par = (var, scale) modelname = "Log-Gaussian Cox process", # In modelname field of mincon fv obj. descname = "LGCP", # In desc field of mincon fv obj. modelabbrev = "log-Gaussian Cox process", # In fitted obj. printmodelname = function(...) "log-Gaussian Cox process", # Used by print.kppm parnames = c("sigma2", "alpha"), checkpar = function(par, native = old, ..., old=TRUE, strict=TRUE){ ## 'par' is in either format if(is.null(par)) par <- c(var=1,scale=1) if(strict && any(par<=0)) stop("par values must be positive.", call.=FALSE) detect.par.format(par, native=c("sigma2", "alpha"), generic=c("var", "scale")) names(par) <- if(native) c("sigma2", "alpha") else c("var","scale") return(par) }, native2generic = function(par) { names(par) <- c("var","scale") return(par) }, outputshape = function(margs, ...) return(margs), checkclustargs = function(margs, old = TRUE, ...) return(margs), resolveshape = .LGCPResolveShape, resolvedots = .LGCPResolveShape, parhandler = function(...) { .LGCPResolveShape(...)$covmodel }, isPCP=FALSE, iscompact=FALSE, roffspring=NULL, K = function(par, rvals, ..., model, margs) { ## 'par' is in native format if(any(par <= 0)) return(rep.int(Inf, length(rvals))) ## Determine covariance function switch(model, exponential = { Cfun <- function(x) exp(-x) }, gauss = , fastGauss = { Cfun <- function(x) exp(-x^2) }, stable = , fastStable = { alpha <- margs[["alpha"]] Cfun <- function(x) exp(-x^alpha) }, gencauchy = , fastGencauchy = { alpha <- margs[["alpha"]] beta <- margs[["beta"]] Cfun <- function(x) { (1 + x^alpha)^(-beta/alpha) } }, matern = { nu <- margs[["nu"]] Cfun <- function(x) { z <- x * sqrt(2 * nu) ifelse(x == 0, 1, (z^nu) * besselK(z, nu) * (2^(1-nu))/gamma(nu)) } }, stop(paste("Model", sQuote(model), "is not recognised")) ) ## hence determine integrand for K function integrand <- function(r) 2 * pi * r * exp(par[1L] * Cfun(r/par[2L])) ## compute indefinite integral imethod <- if(spatstat.options("fastK.lgcp")) "trapezoid" else "quadrature" th <- indefinteg(integrand, rvals, lower=0, method=imethod) return(th) }, pcf= function(par, rvals, ..., model, margs) { ## 'par' is in native format if(any(par <= 0)) return(rep.int(Inf, length(rvals))) ## Determine covariance function switch(model, exponential = { Cfun <- function(x) exp(-x) }, gauss = , fastGauss = { Cfun <- function(x) exp(-x^2) }, stable = , fastStable = { alpha <- margs[["alpha"]] Cfun <- function(x) exp(-x^alpha) }, gencauchy = , fastGencauchy = { alpha <- margs[["alpha"]] beta <- margs[["beta"]] Cfun <- function(x) { (1 + x^alpha)^(-beta/alpha) } }, matern = { nu <- margs[["nu"]] Cfun <- function(x) { z <- x * sqrt(2 * nu) ifelse(x == 0, 1, (z^nu) * besselK(z, nu) * (2^(1-nu))/gamma(nu)) } }, stop(paste("Model", sQuote(model), "is not recognised")) ) ## Hence evaluate pcf gtheo <- exp(par[1L] * Cfun(rvals/par[2L])) return(gtheo) }, Dpcf= function(par,rvals, ..., model){ ## 'par' is in native format if(!(model %in% c("exponential", "stable"))) stop("Gradient of the pcf is not available for this model") if(model=="exponential") { dsigma2 <- exp(-rvals/par[2L]) * exp(par[1L]*exp(-rvals/par[2L])) dalpha <- rvals * par[1L] * exp(-rvals/par[2L]) * exp(par[1L]*exp(-rvals/par[2L]))/par[2L]^2 } else if(model=="stable"){ dsigma2 <- exp(-sqrt(rvals/par[2L])) * exp(par[1L]*exp(-sqrt(rvals/par[2L]))) dalpha <- sqrt(rvals/par[2L]^3) * par[1L] * exp(-sqrt(rvals/par[2L])) * exp(par[1L] * exp(-sqrt(rvals/par[2L]))) } out <- rbind(dsigma2, dalpha) rownames(out) <- c("sigma2","alpha") return(out) }, ## sensible starting values selfstart = function(X) { ## return 'par' in native format alpha <- 2 * mean(nndist(X)) c(sigma2=1, alpha=alpha) }, ## meaningful model parameters interpret = function(par, lambda) { sigma2 <- par[["sigma2"]] alpha <- par[["alpha"]] mu <- if(is.numeric(lambda) && length(lambda) == 1 && lambda > 0) log(lambda) - sigma2/2 else NA c(sigma2=sigma2, alpha=alpha, mu=mu) } ) #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| #' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> #' C O N S T R U C T T A B L E #' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< #' ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| .Spatstat.ClusterModelInfoTable <- list( Thomas = .ThomasInfo, MatClust = .MatClustInfo, Cauchy = .CauchyInfo, VarGamma = .VarGammaInfo, LGCP = .LGCPInfo) spatstatClusterModelInfo <- function(name, onlyPCP = FALSE) { if(inherits(name, "detpointprocfamily")) { if(requireNamespace("spatstat.model")) { return(spatstat.model::spatstatDPPModelInfo(name)) } else { message("The package 'spatstat.model' is required") return(NULL) } } if(!is.character(name) || length(name) != 1) stop("Argument must be a single character string", call.=FALSE) nama2 <- names(.Spatstat.ClusterModelInfoTable) if(onlyPCP){ ok <- sapply(.Spatstat.ClusterModelInfoTable, getElement, name="isPCP") nama2 <- nama2[ok] } if(!(name %in% nama2)) stop(paste(sQuote(name), "is not recognised;", "valid names are", commasep(sQuote(nama2))), call.=FALSE) out <- .Spatstat.ClusterModelInfoTable[[name]] return(out) } spatstat.random/R/randomcircembed.R0000644000176200001440000001424714567023173017056 0ustar liggesusers#' #' randomcircembed.R #' #' Circulant embedding for simulating Gaussian random field #' #' Originally derived from code provided in: #' Tilman M. Davies and David Bryant #' On Circulant Embedding for Gaussian Random Fields in R #' Journal of Statistical Software 55 (2013) issue 9 #' DOI 10.18637/jss.v055.i09 #' #' Modified by Adrian Baddeley #' #' $Revision: 1.7 $ $Date: 2024/02/26 05:33:18 $ #' #' Copyright (c) 2023 Tilman M. Davies, David Bryant and Adrian Baddeley #' GNU Public Licence (>= 2.0) rGRFcircembed <- local({ rGRFcircembed <- function(W=owin(), mu=0, var=1, corrfun, ..., nsim=1, drop=TRUE) { rCircEmbedEngine(W=W, mu=mu, var=var, corrfun=corrfun, ..., nsim=nsim, drop=drop) } rCircEmbedEngine <- function(W=owin(), mu=0, var=1, corrfun, ..., dimyx=NULL, eps=NULL, xy=NULL, rule.eps = c("adjust.eps", "grow.frame", "shrink.frame"), warn=TRUE, maxrelerr=1e-6, nsim=1, drop=TRUE) { ## determine discretisation M <- as.mask(W, dimyx=dimyx, eps=eps, xy=xy, rule.eps=rule.eps) if(needclip <- !is.rectangle(W)) outsideM <- !as.vector(as.matrix(M)) gp <- grid.prep(W, ncol(M), nrow(M)) ## convert 'mu' to an image on same raster (unless it is a single number) if(is.function(mu) || is.im(mu)) mu <- as.im(mu, W=M, ...) ## calculate covariance matrix Sigma <- covariance.prep(gp=gp, var=var, corr.func=corrfun, wrap=TRUE, ...) ## generate (centred) pixel values for all nsim realisations z <- generate.normals(nsim, Sigma, warn, maxrelerr) ## reshape z <- array(as.numeric(z), dim=c(gp$N.ext, gp$M.ext, nsim)) z <- z[1:(gp$N), 1:(gp$M), , drop=FALSE] ## pack up and add 'mu' results <- vector(mode="list", length=nsim) R0 <- as.im(0, W=M) for(isim in 1:nsim) { zmat <- z[,,isim] if(needclip) zmat[outsideM] <- NA R <- R0 R[drop=FALSE] <- zmat results[[isim]] <- R+mu } results <- simulationresult(results, nsim, drop) return(results) } grid.prep <- function(W, M, N, ext = 2) { cell.width <- diff(W$xrange)/M cell.height <- diff(W$yrange)/N mgrid <- seq(W$xrange[1], W$xrange[2], by = cell.width) ngrid <- seq(W$yrange[1], W$yrange[2], by = cell.height) mcens <- (mgrid + 0.5 * cell.width)[-(M + 1)] ncens <- (ngrid + 0.5 * cell.height)[-(N + 1)] if (ext <= 1) { mgrid.ext <- ngrid.ext <- mcens.ext <- ncens.ext <- M.ext <- N.ext <- NULL } else { M.ext <- ext * M N.ext <- ext * N mgrid.ext <- seq(W$xrange[1], W$xrange[2] + (ext - 1) * diff(W$xrange), by = cell.width) ngrid.ext <- seq(W$yrange[1], W$yrange[2] + (ext - 1) * diff(W$yrange), by = cell.height) mcens.ext <- (mgrid.ext + 0.5 * cell.width)[-(M.ext + 1)] ncens.ext <- (ngrid.ext + 0.5 * cell.height)[-(N.ext + 1)] } return(list(M = M, N = N, mgrid = mgrid, ngrid = ngrid, mcens = mcens, ncens = ncens, cell.width = cell.width, cell.height = cell.height, M.ext = M.ext, N.ext = N.ext, mgrid.ext = mgrid.ext, ngrid.ext = ngrid.ext, mcens.ext = mcens.ext, ncens.ext = ncens.ext)) } ## get.EIG <- function(Sigma){ ## eigs <- eigen(Sigma,symmetric=TRUE) ## lambda <- eigs$values ## lambda[lambda < .Machine$double.eps] <- 0 ## result <- eigs$vectors %*% diag(sqrt(lambda)) ## return(result) ## } covariance.prep <- function(gp, var, corr.func, wrap=FALSE, ...){ if(!wrap){ cent <- expand.grid(gp$mcens,gp$ncens) mmat <- matrix(rep(cent[,1],gp$M*gp$N),gp$M*gp$N,gp$M*gp$N) nmat <- matrix(rep(cent[,2],gp$M*gp$N),gp$M*gp$N,gp$M*gp$N) D <- sqrt((mmat-t(mmat))^2+(nmat-t(nmat))^2) covmat <- var*corr.func(D,...) return(covmat) } else { Rx <- gp$M.ext*gp$cell.width Ry <- gp$N.ext*gp$cell.height m.abs.diff.row1 <- abs(gp$mcens.ext[1]-gp$mcens.ext) m.diff.row1 <- pmin(m.abs.diff.row1,Rx-m.abs.diff.row1) n.abs.diff.row1 <- abs(gp$ncens.ext[1]-gp$ncens.ext) n.diff.row1 <- pmin(n.abs.diff.row1,Ry-n.abs.diff.row1) cent.ext.row1 <- expand.grid(m.diff.row1,n.diff.row1) D.ext.row1 <- matrix(sqrt(cent.ext.row1[,1]^2+cent.ext.row1[,2]^2), gp$M.ext,gp$N.ext) C.tilde <- var*corr.func(D.ext.row1,...) return(C.tilde) } } generate.normals <- function(nsim, Sigma, warn=TRUE, maxrelerr=1e-6) { ## calculate fft of covariance matrix refft <- Re(fft(Sigma, inverse=TRUE)) if(min(refft) < 0) { ## in theory this is impossible because Sigma is positive definite, ## but small negative values do occur if(warn) { ra <- range(refft) if(-ra[1]/ra[2] > maxrelerr) { bad <- (refft < 0) warning(paste(sum(bad), "out of", length(bad), "terms", paren(percentage(mean(bad))), "in FFT calculation of matrix square root", "were negative, and were set to zero.", "Range:", prange(signif(ra, 3))), call.=FALSE) } } refft <- pmax(0, refft) } ## fft of square root of matrix Sigma sqrtFFTsigma <- sqrt(refft) ## set up simulation nr <- nrow(Sigma) nc <- ncol(Sigma) ncell <- prod(dim(Sigma)) sqrtncell <- sqrt(ncell) ## run realisations <- matrix(, ncell, nsim) noise <- array(rnorm(ncell * nsim), dim=c(nr, nc, nsim)) for(i in 1:nsim) { field <- sqrtFFTsigma * fft(noise[,,i])/sqrtncell realisations[,i] <- Re(fft(field,inverse=TRUE)/sqrtncell) } return(realisations) } rGRFcircembed }) spatstat.random/R/rmhsnoop.R0000644000176200001440000005223514331654772015610 0ustar liggesusers# # rmhsnoop.R # # visual debug mechanism for rmh # # $Revision: 1.34 $ $Date: 2021/12/24 04:30:06 $ # # When rmh is called in visual debug mode (snooping = TRUE), # it calls e <- rmhSnoopEnv(...) to create an R environment 'e' # containing variables that will represent the current state # of the M-H algorithm with initial state X and model reach R. # # The environment 'e' is passed to the C routine xmethas. # This makes it possible for data to be exchanged between # the C and R code. # # When xmethas reaches the debugger's stopping time, # the current state of the simulation and the proposal # are copied from C into the R environment 'e'. # # Then to execute the visual display, the C code calls # 'eval' to execute the R function rmhsnoop(). # # The function rmhsnoop uses the 'simplepanel' class # to generate a plot showing the state of the simulation # and the proposal, and then wait for point-and-click input using # locator(). # # When rmhsnoop() exits, it returns an integer giving the # (user-specified) next stopping time. This is read back into # the C code. Then xmethas resumes simulations. # # I said it was simple! %^] rmhSnoopEnv <- function(Xinit, Wclip, R) { stopifnot(is.ppp(Xinit)) # Create an environment that will be accessible to R and C code e <- new.env() # initial state (point pattern) X <- Xinit assign("Wsim", as.owin(X), envir=e) assign("xcoords", coords(X)[,1], envir=e) assign("ycoords", coords(X)[,2], envir=e) if(is.multitype(X)) { mcodes <- as.integer(marks(X)) - 1L mlevels <- levels(marks(X)) assign("mcodes", mcodes, envir=e) assign("mlevels", mlevels, envir=e) } else { assign("mcodes", NULL, envir=e) assign("mlevels", NULL, envir=e) } # clipping window assign("Wclip", Wclip, envir=e) # reach of model (could be infinite) assign("R", R, envir=e) # current iteration number assign("irep", 0L, envir=e) # next iteration to be inspected assign("inxt", 1L, envir=e) # next transition to be inspected assign("tnxt", 1L, envir=e) # proposal type assign("proptype", NULL, envir=e) # outcome of proposal assign("itype", NULL, envir=e) # proposal location assign("proplocn", NULL, envir=e) # proposal mark assign("propmark", NULL, envir=e) # index of proposal point in existing pattern assign("propindx", NULL, envir=e) # Hastings ratio assign("numerator", NULL, envir=e) assign("denominator", NULL, envir=e) # Expression actually evaluated to execute visual debug # Expression is evaluated in the environment 'e' snoopexpr <- expression({ rslt <- rmhsnoop(Wsim=Wsim, Wclip=Wclip, R=R, xcoords=xcoords, ycoords=ycoords, mlevels=mlevels, mcodes=mcodes, irep=irep, itype=itype, proptype=proptype, proplocn=proplocn, propmark=propmark, propindx=propindx, numerator=numerator, denominator=denominator) inxt <- rslt$inxt tnxt <- rslt$tnxt itype <- if(rslt$accepted) proptype else 0 storage.mode(tnxt) <- storage.mode(inxt) <- storage.mode(itype) <- "integer" }) assign("snoopexpr", snoopexpr, envir=e) # callback expression assign("callbackexpr", quote(eval(snoopexpr)), envir=e) return(e) } # visual debug display using base graphics rmhsnoop <- local({ rmhsnoop <- function(..., Wsim, Wclip, R, xcoords, ycoords, mlevels=NULL, mcodes, irep, itype, proptype, proplocn, propmark, propindx, numerator, denominator, panel.only=FALSE) { trap.extra.arguments(..., .Context="In rmhsnoop") X <- ppp(xcoords, ycoords, window=Wsim) if(ismarked <- (length(mlevels) > 0)) marks(X) <- factor(mlevels[mcodes+1L], levels=mlevels) Wclip.orig <- Wclip # determine plot arguments if(is.mask(Wclip)) { parg.Wclip <- list(invert=TRUE, col="grey") } else { Wclip <- edges(Wclip) parg.Wclip <- list(lty=3, lwd=2, col="grey") } parg.birth <- list(cols="green", lwd=3) parg.death <- list(cols="red", lwd=3) parg.birthcircle <- list(col="green", lty=3) parg.deathcircle <- list(col="red", lty=3) # assemble a layered object representing the state and the proposal if(is.null(proptype)) { # initial state L <- layered(Wsim, Wclip, X) layerplotargs(L)$Wclip <- parg.Wclip accepted <- TRUE } else { accepted <- (itype == proptype) # add proposal info switch(decode.proptype(proptype), Reject= { propname <- "rejected" L <- layered(Wsim=Wsim, Wclip=Wclip, X=X) layerplotargs(L)$Wclip <- parg.Wclip }, Birth = { propname <- "birth proposal" U <- ppp(proplocn[1L], proplocn[2L], window=Wsim) if(ismarked) marks(U) <- factor(mlevels[propmark+1L], levels=mlevels) D <- if(is.finite(R) && R > 0) { edges(disc(R, proplocn))[Wsim] } else NULL L <- layered(Wsim=Wsim, Wclip=Wclip, PrevState=X, Reach=D, NewPoint=U) layerplotargs(L)$Wclip <- parg.Wclip layerplotargs(L)$NewPoint <- parg.birth }, Death = { propname <- "death proposal" # convert from C to R indexing propindx <- propindx + 1 XminI <- X[-propindx] XI <- X[propindx] D <- if(is.finite(R) && R > 0) { edges(disc(R, c(XI$x, XI$y)))[Wsim] } else NULL L <- layered(Wsim=Wsim, Wclip=Wclip, RetainedPoints=XminI, Reach=D, Deletion=XI) layerplotargs(L)$Wclip <- parg.Wclip layerplotargs(L)$Reach <- parg.deathcircle layerplotargs(L)$Deletion <- parg.death }, Shift = { propname <- "shift proposal" # convert from C to R indexing propindx <- propindx + 1L # make objects XminI <- X[-propindx] XI <- X[propindx] U <- ppp(proplocn[1L], proplocn[2L], window=Wsim) if(ismarked) marks(U) <- factor(mlevels[propmark+1L], levels=mlevels) if(is.finite(R) && R > 0) { DU <- edges(disc(R, proplocn))[Wsim] DXI <- edges(disc(R, c(XI$x, XI$y)))[Wsim] } else { DU <- DXI <- NULL } # make layers L <- layered(Wsim=Wsim, Wclip=Wclip, OtherPoints=XminI, ReachAfter=DU, AfterShift=U, ReachBefore=DXI, BeforeShift=XI) layerplotargs(L)$Wclip <- parg.Wclip layerplotargs(L)$ReachAfter <- parg.birthcircle layerplotargs(L)$AfterShift <- parg.birth layerplotargs(L)$ReachBefore <- parg.deathcircle layerplotargs(L)$BeforeShift <- parg.death }, stop("Unrecognised proposal type") ) } header <- c(paste("Iteration", irep), propname, paste("Hastings ratio =", signif(numerator, 4), "/", signif(denominator, 4), "=", signif(numerator/denominator, 4))) info <- list(irep=irep, Wsim=Wsim, Wclip=Wclip.orig, X=X, proptype=proptype, proplocn=proplocn, propindx=propindx, propmark=propmark, mlevels=mlevels, accepted=accepted, numerator=numerator, denominator=denominator) inspectProposal(L, info, title=header, panel.only=panel.only) } decode.proptype <- function(n) { if(n < 0 || n > 3) stop(paste("Unrecognised proposal type:", n)) switch(n+1, "Reject", "Birth", "Death", "Shift") } encode.proptype <- function(s) { switch(s, Reject=0, Birth=1, Death=2, Shift=3) } inspectProposal <- function(X, info, ..., title, panel.only=FALSE) { if(missing(title)) title <- short.deparse(substitute(X)) if(!inherits(X, "layered")) X <- layered(X) lnames <- names(X) if(sum(nzchar(lnames)) != length(X)) lnames <- paste("Layer", seq_len(length(X))) # Find window and bounding box (validates X) W <- as.owin(X) BX <- as.rectangle(W) # Initialise environment for state variables etc # This environment is accessible to the panel button functions en <- new.env() assign("X", X, envir=en) assign("W", W, envir=en) assign("BX", BX, envir=en) assign("zoomfactor", 1L, envir=en) midX <- unlist(centroid.owin(BX)) assign("midX", midX, envir=en) assign("zoomcentre", midX, envir=en) assign("irep", info$irep, envir=en) assign("inxt", info$irep+1, envir=en) assign("tnxt", -1, envir=en) assign("accepted", info$accepted, envir=en) assign("proplocn", info$proplocn, envir=en) assign("info", info, envir=en) # Build interactive panel # Start with data panel P <- simplepanel(title, BX, list(Data=BX), list(Data=dataclickfun), list(Data=dataredrawfun), snoopexit, en) # Add pan buttons margin <- max(sidelengths(BX))/4 panelwidth <- sidelengths(BX)[1L]/2 P <- grow.simplepanel(P, "top", margin, navfuns["Up"], aspect=1) P <- grow.simplepanel(P, "bottom", margin, navfuns["Down"], aspect=1) P <- grow.simplepanel(P, "left", margin, navfuns["Left"], aspect=1) P <- grow.simplepanel(P, "right", margin, navfuns["Right"], aspect=1) # Zoom/Pan buttons at right P <- grow.simplepanel(P, "right", panelwidth, zoomfuns) # Accept/reject buttons at top P <- grow.simplepanel(P, "top", margin, accept.clicks, accept.redraws) # Dump/print buttons at bottom P <- grow.simplepanel(P, "bottom", margin, dumpfuns) # Jump controls at left maxchars <- max(4, nchar(names(jump.clicks))) P <- grow.simplepanel(P, "left", panelwidth * maxchars/6, jump.clicks) ## exit for debug/test code if(panel.only) return(P) ## go rslt <- run.simplepanel(P, popup=FALSE) clear.simplepanel(P) rm(en) return(rslt) } # button control functions zoomfuns <- rev(list( "Zoom In"=function(env, xy) { z <- get("zoomfactor", envir=env) assign("zoomfactor", z * 2, envir=env) return(TRUE) }, "Zoom Out"=function(env, xy) { z <- get("zoomfactor", envir=env) assign("zoomfactor", z / 2, envir=env) return(TRUE) }, "At Proposal"=function(env, xy) { proplocn <- get("proplocn", envir=env) assign("zoomcentre", proplocn, envir=env) return(TRUE) }, Reset=function(env, xy) { assign("zoomfactor", 1L, envir=env) midX <- get("midX", envir=env) assign("zoomcentre", midX, envir=env) return(TRUE) })) navfuns <- list( Left = function(env, xy) { zoom <- get("zoomfactor", envir=env) ce <- get("zoomcentre", envir=env) BX <- get("BX", envir=env) width <- sidelengths(BX)[1L] stepsize <- (width/4)/zoom ce <- ce - c(stepsize, 0) assign("zoomcentre", ce, envir=env) return(TRUE) }, Right = function(env, xy) { zoom <- get("zoomfactor", envir=env) ce <- get("zoomcentre", envir=env) BX <- get("BX", envir=env) width <- sidelengths(BX)[1L] stepsize <- (width/4)/zoom ce <- ce + c(stepsize, 0) assign("zoomcentre", ce, envir=env) return(TRUE) }, Up = function(env, xy) { zoom <- get("zoomfactor", envir=env) ce <- get("zoomcentre", envir=env) BX <- get("BX", envir=env) height <- sidelengths(BX)[2] stepsize <- (height/4)/zoom ce <- ce + c(0, stepsize) assign("zoomcentre", ce, envir=env) return(TRUE) }, Down = function(env, xy) { zoom <- get("zoomfactor", envir=env) ce <- get("zoomcentre", envir=env) BX <- get("BX", envir=env) height <- sidelengths(BX)[2] stepsize <- (height/4)/zoom ce <- ce - c(0, stepsize) assign("zoomcentre", ce, envir=env) return(TRUE) }) accept.clicks <- rev(list( Accept=function(env, xy) { assign("accepted", TRUE, envir=env) return(TRUE) }, Reject=function(env, xy) { assign("accepted", FALSE, envir=env) return(TRUE) })) accept.redraws <- rev(list( Accept=function(button, name, env) { accepted <- get("accepted", envir=env) if(accepted) { plot(button, add=TRUE, col="green") } else { plot(button, add=TRUE) } text(centroid.owin(button), labels=name) }, Reject=function(button, name, env) { accepted <- get("accepted", envir=env) if(accepted) { plot(button, add=TRUE) } else { plot(button, add=TRUE, col="pink") } text(centroid.owin(button), labels=name) })) jump.clicks <- rev(list( "Next Iteration"=function(env, xy) { irep <- get("irep", envir=env) assign("inxt", irep+1, envir=env) return(FALSE) }, "Skip 10"=function(env, xy) { irep <- get("irep", envir=env) assign("inxt", irep+10, envir=env) return(FALSE) }, "Skip 100"=function(env, xy) { irep <- get("irep", envir=env) assign("inxt", irep+100, envir=env) return(FALSE) }, "Skip 1000"=function(env, xy) { irep <- get("irep", envir=env) assign("inxt", irep+1000, envir=env) return(FALSE) }, "Skip 10,000"=function(env, xy) { irep <- get("irep", envir=env) assign("inxt", irep+10000, envir=env) return(FALSE) }, "Skip 100,000"=function(env, xy) { irep <- get("irep", envir=env) assign("inxt", irep+100000, envir=env) return(FALSE) }, "Next Birth"=function(env, xy) { assign("inxt", -1, envir=env) assign("tnxt", encode.proptype("Birth"), envir=env) return(FALSE) }, "Next Death"=function(env, xy) { assign("inxt", -1, envir=env) assign("tnxt", encode.proptype("Death"), envir=env) return(FALSE) }, "Next Shift"=function(env, xy) { assign("inxt", -1, envir=env) assign("tnxt", encode.proptype("Shift"), envir=env) return(FALSE) }, "Exit Debugger"=function(env, xy) { assign("inxt", -1L, envir=env) return(FALSE) })) dataclickfun <- function(env, xy) { # function for handling clicks in the data window z <- get("zoomfactor", envir=env) ce <- get("zoomcentre", envir=env) midX <- get("midX", envir=env) ce <- ce + (unlist(xy) - midX)/z assign("zoomcentre", ce, envir=env) return(TRUE) } dataredrawfun <- function(button, name, env) { # redraw data window X <- get("X", envir=env) BX <- get("BX", envir=env) W <- get("W", envir=env) midX <- get("midX", envir=env) z <- get("zoomfactor", envir=env) ce <- get("zoomcentre", envir=env) scaleX <- shift(affine(shift(X, -ce), diag(c(z,z))), unlist(midX)) scaleW <- shift(affine(shift(W, -ce), diag(c(z,z))), unlist(midX)) scaleX <- scaleX[, BX] scaleW <- intersect.owin(scaleW, BX, fatal=FALSE) # redraw data in 'BX' if(!is.null(scaleW)) { if(z == 1 && is.rectangle(scaleW)) { plot(scaleW, add=TRUE, lwd=2) } else { plot(BX, add=TRUE, lty=3, border="red") if(!identical(BX, scaleW)) plot(scaleW, add=TRUE, invert=TRUE) } } if(!is.null(scaleX)) plot(scaleX, add=TRUE) invisible(NULL) } # functions to dump the current state, etc dumpfuns <- list( "Dump to file"=function(env, xy) { irep <- get("irep", envir=env) X <- get("X", envir=env) xname <- paste("dump", irep, sep="") assign(xname, X) fname <- paste(xname, ".rda", sep="") eval(substitute(save(x, file=y, compress=TRUE), list(x=xname, y=fname))) splat("Saved to", sQuote(fname)) return(TRUE) }, "Print Info"=function(env, xy) { info <- get("info", envir=env) will.accept <- get("accepted", envir=env) cat("\n\n------------------- \n") with(info, { splat("Iteration", irep) splat("Simulation window:") print(Wsim) splat("Clipping window:") print(Wclip) splat("Current state:") print(X) propname <- decode.proptype(proptype) splat("Proposal type:", propname) switch(propname, Reject = { }, Birth = { splat("Birth of new point at location", pastepoint(proplocn, propmark, mlevels)) }, Death = { Xi <- X[propindx] splat("Death of data point", propindx, "located at", pastepoint(Xi)) }, Shift = { Xi <- X[propindx] splat("Shift data point", propindx, "from current location", pastepoint(Xi), "to new location", pastepoint(proplocn, propmark, mlevels)) }) splat("Hastings ratio = ", numerator, "/", denominator, "=", numerator/denominator) splat("Fate of proposal:", if(will.accept) "Accepted" else "Rejected") return(TRUE) }) }) pastepoint <- function(X, markcode, marklevels) { if(is.ppp(X)) { xy <- coords(X) m <- if(is.marked(X)) dQuote(marks(X)) else NULL } else { xy <- X m <- if(length(marklevels)) dQuote(marklevels[markcode+1L]) else NULL } xy <- signif(as.numeric(xy), 6) paren(paste(c(xy, m), collapse=", ")) } # function to determine return value snoopexit <- function(env) { ans <- eval(quote(list(inxt=inxt, tnxt=tnxt, accepted=accepted)), envir=env) return(ans) } rmhsnoop }) # testit <- function() { # rmhsnoop(Wsim=owin(), Wclip=square(0.7), R=0.1, # xcoords=runif(40), # ycoords=runif(40), # mlevels=NULL, mcodes=NULL, # irep=3, itype=1, # proptype=1, proplocn=c(0.5, 0.5), propmark=0, propindx=0, # numerator=42, denominator=24) # } spatstat.random/R/rshift.R0000644000176200001440000001315614331654772015241 0ustar liggesusers# # rshift.R # # random shift with optional toroidal boundary # # $Revision: 1.19 $ $Date: 2020/04/29 13:20:21 $ # # rshift <- function(X, ...) { UseMethod("rshift") } rshift.splitppp <- function(X, ..., which=seq_along(X), nsim=1, drop=TRUE) { verifyclass(X, "splitppp") check.1.integer(nsim) if("group" %in% names(list(...))) stop(paste("argument", sQuote("group"), "not implemented for splitppp objects")) if(is.null(which)) { iwhich <- which <- seq_along(X) } else { id <- seq_along(X) names(id) <- names(X) iwhich <- id[which] if(length(iwhich) == 0) stop(paste("Argument", sQuote("which"), "did not match any marks")) } # validate arguments and determine common clipping window arglist <- handle.rshift.args(X[[1]]$window, ..., edgedefault="torus") if(!is.null(clip <- arglist$clip)) { # clip the patterns that are not to be shifted if(length(iwhich) < length(X)) X[-iwhich] <- lapply(X[-iwhich], "[.ppp", i=clip) } Xvariable <- X[iwhich] resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { Xsim <- X ## perform shift on selected patterns ## (setting group = NULL ensures each pattern is not split further) shiftXsub <- do.call(lapply, append(list(Xvariable, rshift.ppp, group=NULL), arglist)) ## put back Xsim[iwhich] <- shiftXsub resultlist[[isim]] <- Xsim } return(simulationresult(resultlist, nsim, drop)) } rshift.ppp <- function(X, ..., which=NULL, group, nsim=1, drop=TRUE) { verifyclass(X, "ppp") check.1.integer(nsim) # validate arguments and determine common clipping window arglist <- handle.rshift.args(X$window, ..., edgedefault="torus") # default grouping # (NULL is not the default) # (NULL means all points shifted in parallel) if(missing(group)) group <- if(is.multitype(X)) marks(X) else NULL # if no grouping, use of `which' is undefined if(is.null(group) && !is.null(which)) stop(paste("Cannot apply argument", sQuote("which"), "; no grouping defined")) resultlist <- vector(mode="list", length=nsim) # if grouping, use split if(!is.null(group)) { Y <- split(X, group) splitshifts <- do.call(rshift.splitppp, append(list(Y, which=which, nsim=nsim, drop=FALSE), arglist)) for(isim in seq_len(nsim)) { Xsim <- X split(Xsim, group) <- splitshifts[[isim]] resultlist[[isim]] <- Xsim } return(simulationresult(resultlist, nsim, drop)) } # ungrouped point pattern # shift all points in parallel # recover arguments radius <- arglist$radius width <- arglist$width height <- arglist$height edge <- arglist$edge clip <- arglist$clip W <- rescue.rectangle(Window(X)) if(edge == "torus") { if(!is.rectangle(W)) stop("edge = 'torus' is only meaningful for rectangular windows") xr <- W$xrange yr <- W$yrange Wide <- diff(xr) High <- diff(yr) } ## .......... simulation loop .................. resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { #' generate random translation vector if(!is.null(radius)) { jump <- runifdisc(1, radius=radius) } else { jump <- list(x=runif(1, min=0, max=width), y=runif(1, min=0, max=height)) } #' translate points of X x <- X$x + jump$x y <- X$y + jump$y #' wrap points if(edge == "torus") { x <- xr[1] + (x - xr[1]) %% Wide y <- yr[1] + (y - yr[1]) %% High } #' save as point pattern Xsim <- X Xsim$x <- x Xsim$y <- y #' clip to window if(!is.null(clip)) Xsim <- Xsim[clip] #' save result resultlist[[isim]] <- Xsim } ## ................ end loop .................. return(simulationresult(resultlist, nsim, drop)) } handle.rshift.args <- function(W, ..., radius=NULL, width=NULL, height=NULL, edge=NULL, clip=NULL, edgedefault) { verifyclass(W, "owin") W <- rescue.rectangle(W) if(length(aargh <- list(...)) > 0) stop(paste("Unrecognised arguments:", paste(names(aargh), collapse=","))) if(!is.null(radius)) { # radial generator if(!(is.null(width) && is.null(height))) stop(paste(sQuote("radius"), "is incompatible with", sQuote("width"), "and", sQuote("height"))) } else { # rectangular generator if(is.null(width) != is.null(height)) stop("Must specify both width and height, if one is specified") if(is.null(width)) width <- diff(W$xrange) if(is.null(height)) height <- diff(W$yrange) } if(is.null(edge)) edge <- edgedefault else if(!(edge %in% c("torus", "erode", "none"))) stop(paste("Unrecognised option erode=", sQuote(edge))) # determine whether clipping window is needed if(is.null(clip)) clip <- switch(edge, torus= NULL, none= W, erode={ if(!is.null(radius)) erosion.owin(W, radius) else if(W$type == "rectangle") trim.rectangle(W, width, height) else erosion.owin(W, max(width, height)) }) return(list(radius=radius, width=width, height=height, edge=edge, clip=clip)) } # rtoro <- function(X, which=NULL, radius=NULL, width=NULL, height=NULL) { # .Deprecated("rshift", package="spatstat") # rshift(X, which=which, radius=radius, width=width, height=height) # } spatstat.random/R/pkgRandomFields.R0000644000176200001440000000227014514462531016777 0ustar liggesusers#' #' pkgRandomFields.R #' #' Dealing with the (DEFUNCT) Random Fields package #' #' $Revision: 1.6 $ $Date: 2023/10/20 11:17:19 $ kraeverRandomFields <- function() { stop("The package RandomFields is no longer available.") ## kraever("RandomFieldsUtils") ## kraever("RandomFields") # should no longer be needed: # capture.output(RandomFieldsUtils:::.onLoad()) # capture.output(RandomFields:::.onLoad()) return(invisible(NULL)) } # require a namespace and optionally check whether it is attached kraever <- function(package, fatal=TRUE) { if(!requireNamespace(package, quietly=TRUE)) { if(fatal) stop(paste("The package", sQuote(package), "is required"), call.=FALSE) return(FALSE) } if(spatstat.options(paste("check", package, "loaded", sep=".")) && !isNamespaceLoaded(package)){ if(fatal) stop(paste("The package", sQuote(package), "must be loaded: please type", sQuote(paste0("library", paren(package)))), call.=FALSE) return(FALSE) } return(TRUE) } # legacy functions RandomFieldsSafe <- function() { FALSE } getRandomFieldsModelGen <- function(model) { return(NULL) } spatstat.random/R/multipair.util.R0000644000176200001440000000173014331654772016717 0ustar liggesusers## ## ## multipair.util.R ## ## $Revision: 1.13 $ $Date: 2014/04/29 01:13:35 $ ## ## Utilities for multitype pairwise interactions ## ## ------------------------------------------------------------------- ## MultiPair.checkmatrix <- function(mat, n, matname, naok=TRUE, zerook=TRUE, asymmok=FALSE) { if(missing(matname)) matname <- short.deparse(substitute(mat)) if(!is.matrix(mat)) stop(paste(matname, "must be a matrix")) if(any(dim(mat) != rep.int(n,2))) stop(paste(matname, "must be a square matrix,", "of size", n, "x", n)) isna <- is.na(mat) if(!naok && any(isna)) stop(paste("NA entries not allowed in", matname)) if(any(mat[!isna] < 0)) stop(paste("Negative entries not allowed in", matname)) if(!zerook && any(mat[!isna] == 0)) stop(paste("Zero entries not allowed in", matname)) if(!asymmok && !isSymmetric(mat)) stop(paste(matname, "must be a symmetric matrix")) } spatstat.random/R/rmhtemper.R0000644000176200001440000000430414331654772015740 0ustar liggesusers#' #' rmhtemper.R #' #' $Revision: 1.4 $ $Date: 2018/10/18 02:07:56 $ #' reheat <- local({ expon <- function(x, alpha) { if(is.null(x)) return(NULL) if(is.numeric(x)) return(x^alpha) if(is.im(x)) return(x^alpha) if(is.function(x)) { f <- x g <- function(...) { f(...)^alpha } if(!inherits(f, "funxy")) return(g) return(funxy(g, W=as.owin(f))) } if(is.list(x)) return(lapply(x, expon)) stop("Unrecognised format for x in x^alpha", call.=FALSE) } reheat <- function(model, invtemp) { model <- rmhmodel(model) cif <- model$cif par <- model$par w <- model$w trend <- model$trend types <- model$types newtrend <- expon(trend, invtemp) rules <- lapply(cif, spatstatRmhInfo) temperfuns <- lapply(rules, getElement, name="temper") if(any(bad <- sapply(temperfuns, is.null))) stop(paste("reheating the", commasep(sQuote(cif[bad])), ngettext(sum(bad), "cif", "cifs"), "is not supported")) Ncif <- length(cif) if(Ncif == 1) { newpar <- temperfuns[[1]](par, invtemp) } else { newpar <- par for(i in 1:Ncif) newpar[[i]] <- temperfuns[[i]](par[[i]], invtemp) } newmodel <- rmhmodel(cif=cif, par=newpar, trend=newtrend, w=w, types=types) return(newmodel) } reheat }) rtemper <- function(model, invtemp, nrep, ..., track=FALSE, start=NULL, verbose=FALSE){ df <- data.frame(invtemp, nrep) ndf <- nrow(df) X <- NULL h <- NULL for(i in 1:ndf) { if(verbose) cat(paste("Step", i, "of", paste0(ndf, ":"), "Running", nrep[i], "iterations", "at inverse temperature", signif(invtemp[i], 4), "... ")) model.i <- reheat(model, invtemp[i]) X <- rmh(model.i, nrep=nrep[i], ..., start=start, overrideXstart = X, overrideclip = (i != ndf), track=track, saveinfo = FALSE, verbose=FALSE) if(track) { hnew <- attr(X, "history") h <- rbind(h, hnew) } } if(verbose) cat("Done.\n") if(track) attr(X, "history") <- h return(X) } spatstat.random/R/randomtess.R0000644000176200001440000000307414560117311016102 0ustar liggesusers# # randomtess.R # # Random tessellations # # $Revision: 1.9 $ $Date: 2024/02/04 08:04:51 $ # # Poisson line tessellation rpoislinetess <- function(lambda, win=owin()) { win <- as.owin(win) ## determine circumcircle xr <- win$xrange yr <- win$yrange xmid <- mean(xr) ymid <- mean(yr) width <- diff(xr) height <- diff(yr) rmax <- sqrt(width^2 + height^2)/2 boundbox <- owinInternalRect(xmid + c(-1,1) * rmax, ymid + c(-1,1) * rmax) ## generate poisson lines through circumcircle n <- rpois(1, lambda * 2 * pi * rmax) if(n == 0) { ## single tile if(is.mask(win)) { M <- as.im(factor(1), W=win) return(tess(image=M)) } else { return(tess(tiles=list(win))) } } theta <- runif(n, max= 2 * pi) p <- runif(n, max=rmax) + xmid * cos(theta) + ymid * sin(theta) Y <- infline(p=p, theta=theta) # form the induced tessellation in bounding box Z <- chop.tess(boundbox, Y) # clip to window Z <- intersect.tess(Z, win) attr(Z, "lines") <- Y return(Z) } rMosaicSet <- function(X, p=0.5) { stopifnot(is.tess(X)) Y <- tiles(X) Y <- Y[runif(length(Y)) < p] if(length(Y) == 0) return(NULL) Z <- NULL for(i in seq_along(Y)) Z <- union.owin(Z, Y[[i]]) return(Z) } rMosaicField <- function(X, rgen=function(n) { sample(0:1, n, replace=TRUE)}, ..., rgenargs=NULL ) { stopifnot(is.tess(X)) Y <- as.im(X, ...) ntiles <- length(levels(Y)) values <- do.call(rgen, append(list(ntiles),rgenargs)) Z <- eval.im(values[as.integer(Y)]) return(Z) } spatstat.random/R/random.R0000644000176200001440000010332214560117311015200 0ustar liggesusers## ## random.R ## ## Functions for generating random point patterns ## ## $Revision: 4.118 $ $Date: 2024/02/04 08:04:51 $ ## ## runifpoint() n i.i.d. uniform random points ("binomial process") ## runifdisc() special case of disc (faster) ## ## runifpoispp() uniform Poisson point process ## ## rpoispp() general Poisson point process (thinning method) ## ## rpoint() n independent random points (rejection/pixel list) ## ## rMaternI() Mat'ern model I ## rMaternII() Mat'ern model II ## rMaternInhibition Generalisation ## rSSI() Simple Sequential Inhibition process ## ## rPoissonCluster() generic Poisson cluster process ## rGaussPoisson() Gauss-Poisson process ## ## rthin() independent random thinning ## rcell() Baddeley-Silverman cell process ## ## Examples: ## u01 <- owin(0:1,0:1) ## plot(runifpoispp(100, u01)) ## X <- rpoispp(function(x,y) {100 * (1-x/2)}, 100, u01) ## X <- rpoispp(function(x,y) {ifelse(x < 0.5, 100, 20)}, 100) ## plot(X) ## plot(rMaternI(100, 0.02)) ## plot(rMaternII(100, 0.05)) ## runifdisc <- function(n, radius=1, centre=c(0,0), ..., nsim=1, drop=TRUE) { ## i.i.d. uniform points in the disc of radius r and centre (x,y) check.1.real(radius) stopifnot(radius > 0) if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } disque <- disc(centre=centre, radius=radius, ...) twopi <- 2 * pi rad2 <- radius^2 result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { theta <- runif(n, min=0, max=twopi) s <- sqrt(runif(n, min=0, max=rad2)) result[[isim]] <- ppp(centre[1] + s * cos(theta), centre[2] + s * sin(theta), window=disque, check=FALSE) } result <- simulationresult(result, nsim, drop) return(result) } runifpoint <- function(n, win=owin(c(0,1),c(0,1)), giveup=1000, warn=TRUE, ..., nsim=1, drop=TRUE, ex=NULL) { if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } if(missing(n) && missing(win) && !is.null(ex)) { stopifnot(is.ppp(ex)) n <- npoints(ex) win <- Window(ex) } else if(is.tess(win)) { W <- Window(win) pieces <- tiles(win) ntiles <- length(pieces) check.nvector(n, ntiles, things="tiles", oneok=TRUE) if(length(n) == 1) n <- rep(n, ntiles) Y <- mapply(runifpoint, n=n, win=pieces, MoreArgs=list(nsim=nsim, drop=FALSE, giveup=giveup, warn=warn), SIMPLIFY=FALSE, USE.NAMES=FALSE) result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { result[[isim]] <- superimpose(solapply(Y, "[[", i=isim), W=W, check=FALSE) } result <- simulationresult(result, nsim, drop) return(result) } else { ## usual case win <- as.owin(win) check.1.integer(n) stopifnot(n >= 0) } if(n == 0) { emp <- ppp(window=win) result <- rep(list(emp), nsim) result <- simulationresult(result, nsim, drop) return(result) } if(warn) { nhuge <- spatstat.options("huge.npoints") if(n > nhuge) { whinge <- paste("Attempting to generate", n, "random points") message(whinge) warning(whinge, call.=FALSE) } } switch(win$type, rectangle = { return(runifrect(n, win, nsim=nsim, drop=drop)) }, mask = { dx <- win$xstep dy <- win$ystep ## extract pixel coordinates and probabilities rxy <- rasterxy.mask(win, drop=TRUE) xpix <- rxy$x ypix <- rxy$y ## make a list of nsim point patterns result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## select pixels with equal probability id <- sample(seq_along(xpix), n, replace=TRUE) ## extract pixel centres and randomise within pixels x <- xpix[id] + runif(n, min= -dx/2, max=dx/2) y <- ypix[id] + runif(n, min= -dy/2, max=dy/2) result[[isim]] <- ppp(x, y, window=win, check=FALSE) } }, polygonal={ ## make a list of nsim point patterns result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## rejection method ## initialise empty pattern x <- numeric(0) y <- numeric(0) X <- ppp(x, y, window=win) ## ## rectangle in which trial points will be generated box <- boundingbox(win) ## ntries <- 0 repeat { ntries <- ntries + 1 ## generate trial points in batches of n qq <- runifrect(n, box) ## retain those which are inside 'win' qq <- qq[win] ## add them to result X <- superimpose(X, qq, W=win, check=FALSE) ## if we have enough points, exit if(X$n > n) { result[[isim]] <- X[1:n] break } else if(X$n == n) { result[[isim]] <- X break } else if(ntries >= giveup) { ## otherwise get bored eventually stop(paste("Gave up after", giveup * n, "trials,", X$n, "points accepted")) } } } }, stop("Unrecognised window type") ) ## list of point patterns produced. result <- simulationresult(result, nsim, drop) return(result) } runifpoispp <- function(lambda, win = owin(c(0,1),c(0,1)), ..., nsim=1, drop=TRUE) { win <- as.owin(win) if(!is.numeric(lambda) || length(lambda) > 1 || !is.finite(lambda) || lambda < 0) stop("Intensity lambda must be a single finite number >= 0") if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } if(lambda == 0) { ## return empty pattern emp <- ppp(window=win) result <- rep(list(emp), nsim) result <- simulationresult(result, nsim, drop) return(result) } ## will generate Poisson process in enclosing rectangle and trim it box <- boundingbox(win) meanN <- lambda * area(box) result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { n <- rpois(1, meanN) if(!is.finite(n)) stop(paste("Unable to generate Poisson process with a mean of", meanN, "points")) X <- runifpoint(n, box) ## trim to window if(win$type != "rectangle") X <- X[win] result[[isim]] <- X } result <- simulationresult(result, nsim, drop) return(result) } rpoint <- function(n, f, fmax=NULL, win=unit.square(), ..., giveup=1000, warn=TRUE, verbose=FALSE, nsim=1, drop=TRUE, forcewin=FALSE) { if(missing(f) || (is.numeric(f) && length(f) == 1)) ## uniform distribution return(runifpoint(n, win, giveup=giveup, warn=warn, nsim=nsim, drop=drop)) ## non-uniform distribution.... if(!is.function(f) && !is.im(f)) stop(paste(sQuote("f"), "must be either a function or an", sQuote("im"), "object")) if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } if(is.im(f)) { ## ------------ PIXEL IMAGE --------------------- if(forcewin) { ## force simulation points to lie inside 'win' f <- f[win, drop=FALSE] win.out <- win } else { ## default - ignore 'win' win.out <- as.owin(f) } if(n == 0) { ## return empty pattern(s) emp <- ppp(window=win.out) result <- rep(list(emp), nsim) result <- simulationresult(result, nsim, drop) return(result) } ## need to check simulated point coordinates? checkinside <- forcewin if(checkinside && is.rectangle(win) && is.subset.owin(Frame(f), win)) checkinside <- FALSE ## prepare w <- as.mask(if(forcewin) f else win.out) M <- w$m dx <- w$xstep dy <- w$ystep halfdx <- dx/2.0 halfdy <- dy/2.0 ## extract pixel coordinates and probabilities rxy <- rasterxy.mask(w, drop=TRUE) xpix <- rxy$x ypix <- rxy$y npix <- length(xpix) ppix <- as.vector(f$v[M]) ## not normalised - OK ## generate result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## select pixels id <- sample(npix, n, replace=TRUE, prob=ppix) ## extract pixel centres and randomise location within pixels x <- xpix[id] + runif(n, min= -halfdx, max=halfdx) y <- ypix[id] + runif(n, min= -halfdy, max=halfdy) if(checkinside) { edgy <- which(!inside.owin(x,y,win.out)) ## reject points just outside boundary ntries <- 0 while((nedgy <- length(edgy)) > 0) { ntries <- ntries + 1 ide <- sample(npix, nedgy, replace=TRUE, prob=ppix) x[edgy] <- xe <- xpix[ide] + runif(nedgy, min= -halfdx, max=halfdx) y[edgy] <- ye <- ypix[ide] + runif(nedgy, min= -halfdy, max=halfdy) edgy <- edgy[!inside.owin(xe, ye, win.out)] if(ntries > giveup) break; } } result[[isim]] <- ppp(x, y, window=win.out, check=FALSE) } result <- simulationresult(result, nsim, drop) return(result) } ## ------------ FUNCTION --------------------- ## Establish parameters for rejection method verifyclass(win, "owin") if(n == 0) { ## return empty pattern(s) emp <- ppp(window=win) result <- rep(list(emp), nsim) result <- simulationresult(result, nsim, drop) return(result) } if(is.null(fmax)) { ## compute approx maximum value of f imag <- as.im(f, win, ...) summ <- summary(imag) fmax <- summ$max + 0.05 * diff(summ$range) } irregular <- (win$type != "rectangle") box <- boundingbox(win) result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## initialise empty pattern X <- ppp(numeric(0), numeric(0), window=win) pbar <- 1 nremaining <- n totngen <- 0 ## generate uniform random points in batches ## and apply the rejection method. ## Collect any points that are retained in X ntries <- 0 repeat{ ntries <- ntries + 1 ## proposal points ngen <- nremaining/pbar + 10 totngen <- totngen + ngen prop <- runifrect(ngen, box) if(irregular) prop <- prop[win] if(prop$n > 0) { fvalues <- f(prop$x, prop$y, ...) paccept <- fvalues/fmax u <- runif(prop$n) ## accepted points Y <- prop[u < paccept] if(Y$n > 0) { ## add to X X <- superimpose(X, Y, W=win, check=FALSE) nX <- X$n pbar <- nX/totngen nremaining <- n - nX if(nremaining <= 0) { ## we have enough! if(verbose) splat("acceptance rate = ", round(100 * pbar, 2), "%") result[[isim]] <- if(nX == n) X else X[1:n] break } } } if(ntries > giveup) stop(paste("Gave up after",giveup * n,"trials with", X$n, "points accepted")) } } result <- simulationresult(result, nsim, drop) return(result) } rpoispp <- function(lambda, lmax=NULL, win = owin(), ..., nsim=1, drop=TRUE, ex=NULL, forcewin=FALSE, warnwin=TRUE) { ## arguments: ## lambda intensity: constant, function(x,y,...) or image ## lmax maximum possible value of lambda(x,y,...) ## win default observation window (of class 'owin') ## ... arguments passed to lambda(x, y, ...) ## nsim number of replicate simulations if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } if(missing(lambda) && is.null(lmax) && missing(win) && !is.null(ex)) { lambda <- intensity(unmark(ex)) win <- Window(ex) } else { if(!(is.numeric(lambda) || is.function(lambda) || is.im(lambda))) stop(paste(sQuote("lambda"), "must be a constant, a function or an image")) if(is.numeric(lambda) && !(length(lambda) == 1 && lambda >= 0)) stop(paste(sQuote("lambda"), "must be a single, nonnegative number")) if(!is.null(lmax)) { if(!is.numeric(lmax)) stop("lmax should be a number") if(length(lmax) > 1) stop("lmax should be a single number") } win.given <- !missing(win) && !is.null(win) if(win.given) win <- as.owin(win) if(is.im(lambda)) { if(win.given && forcewin) { ## user-specified 'win' overrides default lambda <- lambda[win, drop=FALSE] } else { ## default win <- rescue.rectangle(as.owin(lambda)) if(win.given && warnwin) warning(paste("Argument", sQuote("win"), "ignored in rpoispp"), call.=FALSE) } } } if(is.numeric(lambda)) { ## uniform Poisson return(runifpoispp(lambda, win, nsim=nsim, drop=drop)) } ## inhomogeneous Poisson ## perform thinning of uniform Poisson ## determine upper bound if(is.null(lmax)) { imag <- as.im(lambda, win, ...) summ <- summary(imag) lmax <- summ$max + 0.05 * diff(summ$range) } if(is.function(lambda)) { ## function lambda #' runifpoispp checks 'lmax' result <- runifpoispp(lmax, win, nsim=nsim, drop=FALSE) #' result is a 'ppplist' with appropriate names for(isim in seq_len(nsim)) { X <- result[[isim]] if(X$n > 0) { prob <- lambda(X$x, X$y, ...)/lmax u <- runif(X$n) retain <- is.finite(prob) & (u <= prob) result[[isim]] <- X[retain] } } return(simulationresult(result, nsim, drop)) } if(is.im(lambda)) { ## image lambda if(spatstat.options("fastpois")) { ## new code: sample pixels directly mu <- integral(lambda) dx <- lambda$xstep/2 dy <- lambda$ystep/2 df <- as.data.frame(lambda) npix <- nrow(df) lpix <- df$value result <- vector(mode="list", length=nsim) nn <- rpois(nsim, mu) if(!all(is.finite(nn))) stop(paste("Unable to generate Poisson process with a mean of", mu, "points")) for(isim in seq_len(nsim)) { ni <- nn[isim] ii <- sample.int(npix, size=ni, replace=TRUE, prob=lpix) xx <- df$x[ii] + runif(ni, -dx, dx) yy <- df$y[ii] + runif(ni, -dy, dy) result[[isim]] <- ppp(xx, yy, window=win, check=FALSE) } result <- simulationresult(result, nsim, drop) return(result) } else { ## old code: thinning result <- runifpoispp(lmax, win, nsim=nsim, drop=FALSE) for(isim in seq_len(nsim)) { X <- result[[isim]] if(X$n > 0) { prob <- lambda[X, drop=FALSE]/lmax u <- runif(X$n) retain <- is.finite(prob) & (u <= prob) result[[isim]] <- X[retain] } } return(simulationresult(result, nsim, drop)) } } stop(paste(sQuote("lambda"), "must be a constant, a function or an image")) } rMaternI <- function(kappa, r, win = owin(c(0,1),c(0,1)), stationary=TRUE, ..., nsim=1, drop=TRUE) { rMaternInhibition(type=1, kappa=kappa, r=r, win=win, stationary=stationary, ..., nsim=nsim, drop=drop) } rMaternII <- function(kappa, r, win = owin(c(0,1),c(0,1)), stationary=TRUE, ..., nsim=1, drop=TRUE) { rMaternInhibition(type=2, kappa=kappa, r=r, win=win, stationary=stationary, ..., nsim=nsim, drop=drop) } rMaternInhibition <- function(type, kappa, r, win = owin(c(0,1),c(0,1)), stationary=TRUE, ..., nsim=1, drop=TRUE) { stopifnot(is.numeric(r) && length(r) == 1) stopifnot(type %in% c(1,2)) if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } ## Resolve window class if(!inherits(win, c("owin", "box3", "boxx"))) { givenwin <- win win <- try(as.owin(givenwin), silent = TRUE) if(inherits(win, "try-error")) win <- try(as.boxx(givenwin), silent = TRUE) if(inherits(win, "try-error")) stop("Could not coerce argument win to a window (owin, box3 or boxx).") } dimen <- spatdim(win) if(dimen == 2) { bigbox <- if(stationary) grow.rectangle(win, r) else win result <- rpoispp(kappa, win = bigbox, nsim = nsim, drop=FALSE) } else if(dimen == 3) { bigbox <- if(stationary) grow.box3(win, r) else win result <- rpoispp3(kappa, domain = bigbox, nsim = nsim, drop=FALSE) } else { bigbox <- if(stationary) grow.boxx(win, r) else win result <- rpoisppx(kappa, domain = bigbox, nsim = nsim, drop=FALSE) } for(isim in seq_len(nsim)) { Y <- result[[isim]] nY <- npoints(Y) if(type == 1) { ## Matern Model I if(nY > 1) { d <- nndist(Y) Y <- Y[d > r] } } else { ## Matern Model II if(nY > 1) { ## matrix of squared pairwise distances d2 <- pairdist(Y, squared=TRUE) close <- (d2 <= r^2) ## random order 1:n age <- sample(seq_len(nY), nY, replace=FALSE) earlier <- outer(age, age, ">") conflict <- close & earlier ## delete <- apply(conflict, 1, any) delete <- matrowany(conflict) Y <- Y[!delete] } } if(stationary) Y <- Y[win] result[[isim]] <- Y } if(nsim == 1 && drop) return(result[[1L]]) if(is.owin(win)) result <- as.ppplist(result) return(result) } rSSI <- function(r, n=Inf, win = square(1), giveup = 1000, x.init=NULL, ..., f=NULL, fmax=NULL, nsim=1, drop=TRUE) { win.given <- !missing(win) && !is.null(win) stopifnot(is.numeric(r) && length(r) == 1 && r >= 0) stopifnot(is.numeric(n) && length(n) == 1 && n >= 0) must.reach.n <- is.finite(n) if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 1) } ## if(!is.null(f)) { stopifnot(is.numeric(f) || is.im(f) || is.function(f)) if(is.null(fmax) && !is.numeric(f)) fmax <- if(is.im(f)) max(f) else max(as.im(f, win)) } ## result <- vector(mode="list", length=nsim) if(!win.given) win <- square(1) ## validate initial state if(is.null(x.init)) { ## start with empty pattern in specified window win <- as.owin(win) x.init <- ppp(numeric(0),numeric(0), window=win) } else { ## start with specified pattern stopifnot(is.ppp(x.init)) if(!win.given) { win <- as.owin(x.init) } else { ## check compatibility of windows if(!identical(win, as.owin(x.init))) warning(paste("Argument", sQuote("win"), "is not the same as the window of", sQuote("x.init"))) x.init.new <- x.init[win] if(npoints(x.init.new) == 0) stop(paste("No points of x.init lie inside the specified window", sQuote("win"))) nlost <- npoints(x.init) - npoints(x.init.new) if(nlost > 0) warning(paste(nlost, "out of", npoints(x.init), "points of the pattern x.init", "lay outside the specified window", sQuote("win"))) x.init <- x.init.new } if(n < npoints(x.init)) stop(paste("x.init contains", npoints(x.init), "points", "but a pattern containing only n =", n, "points", "is required")) if(n == npoints(x.init)) { warning(paste("Initial state x.init already contains", n, "points;", "no further points were added")) result <- rep(list(x.init), nsim) result <- simulationresult(result, nsim, drop) return(result) } } #' validate radius and 'n' r2 <- r^2 winArea <- area(win) discarea <- pi * r2/4 nmelt <- floor(winArea/discarea) packdensity <- pi * sqrt(3)/6 npack <- floor(packdensity * winArea/discarea) if(is.finite(n)) { if(n > nmelt) { warning(paste("Window is too small to fit", n, "points", "at minimum separation", r, paren(paste("absolute maximum number is", nmelt)))) } else if(n > npack) { warning(paste("Window is probably too small to fit", n, "points", "at minimum separation", r, paren(paste("packing limit is", nmelt)))) } } #' start simulation pstate <- list() for(isim in seq_len(nsim)) { if(nsim > 1) pstate <- progressreport(isim, nsim, state=pstate) ## Simple Sequential Inhibition process ## fixed number of points xx <- coords(x.init)$x yy <- coords(x.init)$y nn <- npoints(x.init) ## Naive implementation, proposals are uniform xprop <- yprop <- numeric(0) nblock <- if(is.finite(n)) n else min(1024, nmelt) ntries <- 0 while(ntries < giveup) { ntries <- ntries + 1 if(length(xprop) == 0) { ## generate some more proposal points prop <- if(is.null(f)) runifpoint(nblock, win) else rpoint(nblock, f, fmax, win) xprop <- coords(prop)$x yprop <- coords(prop)$y } ## extract next proposal xnew <- xprop[1L] ynew <- yprop[1L] xprop <- xprop[-1L] yprop <- yprop[-1L] ## check hard core constraint dx <- xnew - xx dy <- ynew - yy if(!any(dx^2 + dy^2 <= r2)) { xx <- c(xx, xnew) yy <- c(yy, ynew) nn <- nn + 1L ntries <- 0 } if(nn >= n) break } if(must.reach.n && nn < n) warning(paste("Gave up after", giveup, "attempts with only", nn, "points placed out of", n)) X <- ppp(xx, yy, window=win, check=FALSE) result[[isim]] <- X } result <- simulationresult(result, nsim, drop) return(result) } rPoissonCluster <- function(kappa, expand, rcluster, win = owin(c(0,1),c(0,1)), ..., nsim=1, drop=TRUE, saveparents=TRUE, kappamax=NULL) { ## Generic Poisson cluster process ## Implementation for bounded cluster radius ## ## 'rcluster' is a function(x,y) that takes the coordinates ## (x,y) of the parent point and generates a list(x,y) of offspring ## ## "..." are arguments to be passed to 'rcluster()' ## if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) } ## Catch old argument name rmax for expand, and allow rmax to be ## passed to rcluster (and then be ignored) if(missing(expand) && !is.null(rmax <- list(...)$rmax)) { warning("outdated usage in rPoissonCluster: 'rmax' should be 'expand'") expand <- rmax } rPoissonClusterEngine(kappa=kappa, expand=expand, rcluster=rcluster, win=win, nsim=nsim, drop=drop, saveparents=saveparents, kappamax=kappamax, ...) } rPoissonClusterEngine <- function(kappa, expand=rmax, rcluster, win, ..., nsim=1, drop=TRUE, saveparents=TRUE, kappamax=lmax, lmax=NULL, rmax=NULL) { ## Generate parents in dilated window win <- as.owin(win) frame <- boundingbox(win) dilated <- owinInternalRect(frame$xrange + c(-expand, expand), frame$yrange + c(-expand, expand)) if(is.im(kappa) && !is.subset.owin(dilated, as.owin(kappa))) stop(paste("The window in which the image", sQuote("kappa"), "is defined\n", "is not large enough to contain the dilation of the window", sQuote("win"))) parentlist <- rpoispp(kappa, lmax=kappamax, win=dilated, nsim=nsim, drop=FALSE) resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { parents <- parentlist[[isim]] result <- NULL ## generate clusters np <- parents$n if(np > 0) { xparent <- parents$x yparent <- parents$y for(i in seq_len(np)) { ## generate random offspring of i-th parent point cluster <- rcluster(xparent[i], yparent[i], ...) if(!inherits(cluster, "ppp")) cluster <- ppp(cluster$x, cluster$y, window=frame, check=FALSE) ## skip if cluster is empty if(cluster$n > 0) { ## trim to window cluster <- cluster[win] if(is.null(result)) { ## initialise offspring pattern and offspring-to-parent map result <- cluster parentid <- rep.int(1, cluster$n) } else { ## add to pattern result <- superimpose(result, cluster, W=win, check=FALSE) ## update offspring-to-parent map parentid <- c(parentid, rep.int(i, cluster$n)) } } } } else { ## no parents - empty pattern result <- ppp(numeric(0), numeric(0), window=win) parentid <- integer(0) } if(saveparents) { attr(result, "parents") <- parents attr(result, "parentid") <- parentid attr(result, "expand") <- expand } resultlist[[isim]] <- result } result <- simulationresult(resultlist, nsim, drop) return(result) } rGaussPoisson <- local({ rGaussPoisson <- function(kappa, r, p2, win=owin(c(0,1), c(0,1)), ..., nsim=1, drop=TRUE) { ## Gauss-Poisson process result <- rPoissonCluster(kappa, 1.05 * r, oneortwo, win, radius=r/2, p2=p2, nsim=nsim, drop=drop) return(result) } oneortwo <- function(x0, y0, radius, p2) { if(runif(1) > p2) ## one point return(list(x=x0, y=y0)) ## two points theta <- runif(1, min=0, max=2*pi) return(list(x=x0+c(-1,1)*radius*cos(theta), y=y0+c(-1,1)*radius*sin(theta))) } rGaussPoisson }) rstrat <- function(win=square(1), nx, ny=nx, k=1, nsim=1, drop=TRUE) { win <- as.owin(win) stopifnot(nx >= 1 && ny >= 1) stopifnot(k >= 1) if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { xy <- stratrand(win, nx, ny, k) Xbox <- ppp(xy$x, xy$y, win$xrange, win$yrange, check=FALSE) result[[isim]] <- Xbox[win] } result <- simulationresult(result, nsim, drop) return(result) } rcellnumber <- local({ rcellnumber <- function(n, N=10, mu=1) { if(missing(mu) || mu == 1) { z <- rCellUnit(n=n, N=N) } else { z <- replicate(n, rCellCumul(x=mu, N=N)) } return(z) } rCellUnit <- function(n, N=10) { if(!missing(N)) { if(round(N) != N) stop("N must be an integer") stopifnot(is.finite(N)) stopifnot(N > 1) } u <- runif(n, min=0, max=1) p0 <- 1/N pN <- 1/(N * (N-1)) k <- ifelse(u < p0, 0, ifelse(u < (1 - pN), 1, N)) return(k) } rCellCumul <- function(x, N=10) { check.1.real(x) n <- ceiling(x) if(n <= 0) return(0) y <- rCellUnit(n=n, N=N) if(n == x) return(sum(y)) p <- x - (n-1) z <- sum(y[-1]) + rbinom(1, size=y[1], prob=p) return(z) } rcellnumber }) rcell <- function(win=square(1), nx=NULL, ny=nx, ..., dx=NULL, dy=dx, N=10, nsim=1, drop=TRUE) { if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) } win <- as.owin(win) xr <- win$xrange yr <- win$yrange ## determine grid coordinates if(missing(ny)) ny <- NULL if(missing(dy)) dy <- NULL g <- xy.grid(xr, yr, nx, ny, dx, dy) nx <- g$nx ny <- g$ny x0 <- g$x0 y0 <- g$y0 dx <- g$dx dy <- g$dy ## generate pattern(s) result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { x <- numeric(0) y <- numeric(0) for(ix in seq_len(nx)) for(iy in seq_len(ny)) { nij <- rcellnumber(1, N) x <- c(x, x0[ix] + runif(nij, min=0, max=dx)) y <- c(y, y0[iy] + runif(nij, min=0, max=dy)) } Xbox <- ppp(x, y, xr, yr, check=FALSE) result[[isim]] <- Xbox[win] } result <- simulationresult(result, nsim, drop) return(result) } thinjump <- function(n, p) { # equivalent to which(runif(n) < p) for constant p stopifnot(length(p) == 1) if(p <= 0) return(integer(0)) if(p >= 1) return(seq_len(n)) if(p > 0.5) { #' for retention prob > 0.5 we find the ones to discard instead discard <- thinjump(n, 1-p) retain <- if(length(discard)) -discard else seq_len(n) return(retain) } guessmaxlength <- ceiling(n * p + 2 * sqrt(n * p * (1-p))) i <- .Call(SR_thinjumpequal, n, p, guessmaxlength, PACKAGE="spatstat.random") return(i) } rthin <- function(X, P, ..., nsim=1, drop=TRUE) { if(!(inherits(X, c("ppp", "lpp", "pp3", "ppx", "psp")) || recognise.spatstat.type(X) == "listxy")) stop(paste("X should be a point pattern (class ppp, lpp, pp3 or ppx)", "or a line segment pattern (class psp)"), call.=FALSE) rthinEngine(X, P, ..., nsim=nsim, drop=drop) } rthinEngine <- function(X, P, ..., nsim=1, drop=TRUE, Pmax=1, na.zero=FALSE, what=c("objects", "fate"), fatal=TRUE, warn=TRUE) { check.1.integer(nsim) stopifnot(nsim >= 0) ## if what = 'objects', return the thinned pattern ## if what = 'fate', return the logical vector (retained/deleted) what <- match.arg(what) ## recognise list(x,y) input if(israwxy <- (recognise.spatstat.type(X) == "listxy")) { xx <- X$x yy <- X$y nX <- length(xx) } else { nX <- nobjects(X) } ## catch trivial cases if(nX == 0 || nsim == 0) { switch(what, objects = { result <- rep(list(X), nsim) }, fate = { result <- rep(list(logical(nX)), nsim) }) result <- simulationresult(result, nsim, drop) return(result) } if(!missing(Pmax)) { check.1.real(Pmax) stopifnot(Pmax > 0) } if(is.numeric(P) && length(P) == 1 && spatstat.options("fastthin")) { ## special fast algorithm for constant probability if(!missing(Pmax)) P <- P/Pmax if(badprobability(P, TRUE)) stop("P is not a valid probability value") result <- vector(mode="list", length=nsim) switch(what, fate = { for(isim in seq_len(nsim)) result[[isim]] <- thinjump(nX, P) }, objects = { for(isim in seq_len(nsim)) { retain <- thinjump(nX, P) if(israwxy) { Y <- list(x=xx[retain], y=yy[retain]) } else { Y <- X[retain] attr(Y, "parents") <- attr(X, "parents") ## also handle offspring-to-parent map if present if(!is.null(parentid <- attr(X, "parentid"))) attr(Y, "parentid") <- parentid[retain] } result[[isim]] <- Y } }) result <- simulationresult(result, nsim, drop) return(result) } #' general case: compute probabilities first if(is.numeric(P)) { ## vector of retention probabilities pX <- P if(length(pX) != nX) { if(length(pX) == 1) pX <- rep.int(pX, nX) else stop("Length of vector P does not match number of points of X") } } else if(is.function(P)) { ## function - evaluate it at points of X if(!(is.ppp(X) || is.lpp(X) || israwxy)) stop(paste("Don't know how to apply a function to an object of class", commasep(sQuote(class(X)))), call.=FALSE) pX <- if(inherits(P, c("linfun", "funxy"))) P(X, ...) else P(X$x, X$y, ...) if(length(pX) != nX) stop("Function P returned a vector of incorrect length") if(!is.numeric(pX)) stop("Function P returned non-numeric values") } else if(is.im(P)) { ## image - look it up if(!(is.ppp(X) || is.lpp(X) || israwxy)) stop(paste("Don't know how to apply image values to an object of class", commasep(sQuote(class(X)))), call.=FALSE) if(!(P$type %in% c("integer", "real"))) stop("Values of image P should be numeric") pX <- P[X, drop=FALSE] } else stop("Unrecognised format for P") if(!all(is.finite(pX))) { if(na.zero) { pX[is.na(pX)] <- 0 } else if(anyNA(pX)) { if(is.function(P)) stop("Function P returned some NA values") if(is.im(P)) stop("Some points lie outside the domain of image P") stop("P contains NA's") } else { if(is.function(P)) stop("Function P returned some NaN or Inf values") if(is.im(P)) stop("Image P contains NaN or Inf values") stop("P contains NaN or Inf values") } } if(fatal || warn) { ## check for bad values of probability ra <- range(pX)/Pmax if(ra[1] < 0) { gripe <- paste("some probabilities are negative", paren(paste("minimum", ra[1]))) if(fatal) stop(gripe) if(warn) stop(gripe) } if(ra[2] > 1) { gripe <- paste("some probabilities are greater than 1", paren(paste("maximum", ra[2]))) if(fatal) stop(gripe) if(warn) warning(gripe) } } #' now simulate result <- vector(mode="list", length=nsim) switch(what, fate = { for(isim in seq_len(nsim)) result[[isim]] <- ((Pmax * runif(length(pX))) < pX) }, objects = { for(isim in seq_len(nsim)) { retain <- ((Pmax * runif(length(pX))) < pX) if(israwxy) { Y <- list(x=xx[retain], y=yy[retain]) } else { Y <- X[retain] attr(Y, "parents") <- attr(X, "parents") ## also handle offspring-to-parent map if present if(!is.null(parentid <- attr(X, "parentid"))) attr(Y, "parentid") <- parentid[retain] } result[[isim]] <- Y } }) result <- simulationresult(result, nsim, drop) return(result) } spatstat.random/R/randomNS.R0000644000176200001440000002127314356000564015451 0ustar liggesusers## ## randomNS.R ## ## Simulating from Neyman-Scott process ## 'Naive' algorithm ## ## $Revision: 1.38 $ $Date: 2023/01/06 10:55:18 $ ## ## Original code for naive simulation of Neyman-Scott by Adrian Baddeley ## Original code for rCauchy and rVarGamma offspring by Abdollah Jalilian ## Other code and modifications by Adrian Baddeley ## Bug fixes by Abdollah, Adrian, and Rolf Turner ## ## Copyright (c) 2000-2023 Adrian Baddeley and Abdollah Jalilian ## GNU Public Licence >= 2.0 rNeymanScott <- function(kappa, expand, rcluster, win = unit.square(), ..., nsim=1, drop=TRUE, nonempty=TRUE, saveparents=TRUE, kappamax=NULL, mumax=NULL) { ## Generic Neyman-Scott process ## Implementation for bounded cluster radius ## check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) ## Catch old argument name 'rmax' if(missing(expand) && !is.null(rmax <- list(...)$rmax)) { warning("outdated usage in rNeymanScott: 'rmax' should be 'expand'") expand <- rmax } ## Catch old argument name 'lmax' if(is.null(kappamax) && !is.null(lmax <- list(...)$lmax)) { warning("outdated usage in rNeymanScott: 'lmax' should be 'kappamax'") kappamax <- lmax } ## 'rcluster' may be ## ## (1) a function(x,y, ...) that takes the coordinates ## (x,y) of the parent point and generates a list(x,y) of offspring ## if(is.function(rcluster)) return(rPoissonCluster(kappa, expand, rcluster, win, ..., kappamax=kappamax, nsim=nsim, drop=drop, saveparents=saveparents)) ## (2) a list(mu, f) where mu is a numeric value, function, or pixel image ## and f is a function(n, ...) generating n i.i.d. offspring at 0,0 if(!(is.list(rcluster) && length(rcluster) == 2)) stop("rcluster should be either a function, or a list of two elements") win <- as.owin(win) mu <- rcluster[[1]] rdisplace <- rcluster[[2]] if(!(is.numeric(mu) || is.im(mu) || is.function(mu))) stop("rcluster[[1]] should be a number, a function or a pixel image") if(is.numeric(mu) && !(length(mu) == 1 && mu >= 0)) stop("rcluster[[1]] should be a single nonnegative number") if(!is.function(rdisplace)) stop("rcluster[[2]] should be a function") if(is.null(mumax)) mumax <- if(is.numeric(mu)) mu else if(is.im(mu)) max(mu) else (1.05 * max(as.im(mu, W=win, ..., strict=TRUE))) ## Generate parents in dilated window frame <- boundingbox(win) dilated <- grow.rectangle(frame, expand) if(is.im(kappa) && !is.subset.owin(dilated, as.owin(kappa))) stop(paste("The window in which the image", sQuote("kappa"), "is defined\n", "is not large enough to contain the dilation of the window", sQuote("win"))) if(nonempty) { if(is.function(kappa)) { kappa <- as.im(kappa, W=dilated, ..., strict=TRUE) kappamax <- NULL } ## intensity of parents with at least one offspring point kappa <- kappa * (1 - exp(-mumax)) } ## generate parentlist <- rpoispp(kappa, lmax=kappamax, win=dilated, nsim=nsim, drop=FALSE, warnwin=FALSE) resultlist <- vector(mode="list", length=nsim) for(i in 1:nsim) { ## if(i > 1) gc(FALSE) parents <- parentlist[[i]] np <- npoints(parents) ## generate cluster sizes if(np == 0) { ## no parents - empty pattern result <- ppp(numeric(0), numeric(0), window=win) parentid <- integer(0) noff <- 0 } else { if(!nonempty) { ## cluster sizes are Poisson csize <- rpois(np, mumax) } else { ## cluster sizes are Poisson conditional on > 0 csize <- qpois(runif(np, min=dpois(0, mumax)), mumax) } noff <- sum(csize) xparent <- parents$x yparent <- parents$y x0 <- rep.int(xparent, csize) y0 <- rep.int(yparent, csize) ## invoke random generator dd <- rdisplace(noff, ...) mm <- if(is.ppp(dd)) marks(dd) else NULL ## validate xy <- xy.coords(dd) dx <- xy$x dy <- xy$y if(!(length(dx) == noff)) stop("rcluster returned the wrong number of points") ## create offspring and offspring-to-parent map xoff <- x0 + dx yoff <- y0 + dy parentid <- rep.int(1:np, csize) ## trim to window retain <- inside.owin(xoff, yoff, win) if(is.im(mu)) retain[retain] <- inside.owin(xoff[retain], yoff[retain], as.owin(mu)) xoff <- xoff[retain] yoff <- yoff[retain] parentid <- parentid[retain] if(!is.null(mm)) mm <- marksubset(mm, retain) ## done result <- ppp(xoff, yoff, window=win, check=FALSE, marks=mm) } if(is.im(mu)) { ## inhomogeneously modulated clusters a la Waagepetersen result <- rthin(result, P=mu, Pmax=mumax) } if(saveparents) { attr(result, "parents") <- parents attr(result, "parentid") <- parentid attr(result, "expand") <- expand attr(result, "cost") <- np + noff } resultlist[[i]] <- result } result <- simulationresult(resultlist, nsim, drop) return(result) } fakeNeyScot <- function(Y, lambda, win, saveLambda, saveparents) { ## Y is a ppp or ppplist obtained from rpoispp ## which will be returned as the realisation of a Neyman-Scott process ## when the process is degenerately close to Poisson. if(saveLambda || saveparents) { if(saveLambda && !is.im(lambda)) lambda <- as.im(lambda, W=win) if(saveparents) emptyparents <- ppp(window=win) # empty pattern if(isSingle <- is.ppp(Y)) Y <- solist(Y) for(i in seq_along(Y)) { Yi <- Y[[i]] if(saveLambda) attr(Yi, "Lambda") <- lambda if(saveparents) { attr(Yi, "parents") <- emptyparents attr(Yi, "parentid") <- integer(0) attr(Yi, "cost") <- npoints(Yi) } Y[[i]] <- Yi } if(isSingle) Y <- Y[[1L]] } return(Y) } thinParents <- function(X, P, Pmax=1) { ## Thin the parents and remove orphans Offspring <- X Parents <- attr(Offspring, "parents") Surname <- attr(Offspring, "parentid") retainparents <- rthin(Parents, P=P, Pmax=Pmax, what="fate", na.zero=TRUE, fatal=FALSE) retainoffspring <- retainparents[Surname] Offspring <- Offspring[retainoffspring] attr(Offspring, "parents") <- list(x=Parents$x[retainparents], y=Parents$y[retainparents]) newserial <- cumsum(retainparents) attr(Offspring, "parentid") <- newserial[Surname[retainoffspring]] return(Offspring) } validate.kappa.mu <- function(kappa, mu, kappamax=NULL, mumax=NULL, win, expand, ..., context="") { #' validate 'kappa' and 'mu' arguments if(!(is.numeric(mu) || is.im(mu) || is.function(mu))) stop(paste(context, "mu should be a number, a function or a pixel image"), call.=FALSE) if(is.numeric(mu)) { check.1.real(mu) check.finite(mu) stopifnot(mu >= 0) } if(!(is.numeric(kappa) || is.im(kappa) || is.function(kappa))) stop(paste(context, "kappa should be a number, a function or a pixel image"), call.=FALSE) if(is.numeric(kappa)) { check.1.real(kappa) check.finite(kappa) stopifnot(kappa >= 0) } if(is.im(kappa)) { #' check domain frame <- boundingbox(win) dilated <- grow.rectangle(frame, expand) if(!is.subset.owin(dilated, as.owin(kappa))) stop(paste("The window in which the image", sQuote("kappa"), "is defined\n", "is not large enough to contain", "the dilation of the window", sQuote("win")), call.=FALSE) } ## get upper bounds on kappa and mu if(is.null(kappamax)) { if(is.numeric(kappa)) { kappamax <- kappa } else if(is.im(kappa)) { kappamax <- max(kappa) } else if(is.function(kappa)) { ## rough upper bound frame <- boundingbox(win) dilated <- grow.rectangle(frame, expand) dotargs <- list(...) kargs <- dotargs[names(dotargs) %in% names(args(kappa))] kim <- do.call(as.im, append(list(kappa, W=dilated, strict=TRUE), kargs)) kra <- range(kim) kappamax <- kra[2] + 0.05 * diff(kra) } } if(is.null(mumax)) { if(is.numeric(mu)) { mumax <- mu } else if(is.im(mu)) { mumax <- max(mu) } else if(is.function(mu)) { ## rough upper bound mim <- as.im(mu, W=win, ..., strict=TRUE) mra <- range(mim) mumax <- mra[2] + 0.05 * diff(mra) } } return(list(kappamax=kappamax, mumax=mumax)) } spatstat.random/R/rmhmodel.R0000644000176200001440000013720514400356000015527 0ustar liggesusers# # # rmhmodel.R # # $Revision: 1.82 $ $Date: 2023/03/03 06:29:14 $ # # rmhmodel <- function(...) { UseMethod("rmhmodel") } rmhmodel.rmhmodel <- function(model, ...) { # Check for outdated internal format # C.par was replaced by C.beta and C.ipar in spatstat 1.22-3 if(outdated <- !is.null(model$C.par)) warning("Outdated internal format of rmhmodel object; rebuilding it") if(outdated || (length(list(...)) > 0)) model <- rmhmodel.list(unclass(model), ...) return(model) } rmhmodel.list <- function(model, ...) { argnames <- c("cif","par","w","trend","types") ok <- argnames %in% names(model) do.call(rmhmodel.default, resolve.defaults(list(...), model[argnames[ok]])) } rmhmodel.default <- local({ rmhmodel.default <- function(..., cif=NULL, par=NULL, w=NULL, trend=NULL, types=NULL) { rmhmodelDefault(..., cif=cif, par=par, w=w, trend=trend, types=types) } rmhmodelDefault <- function(..., cif=NULL, par=NULL, w=NULL, trend=NULL, types=NULL, stopinvalid=TRUE) { if(length(list(...)) > 0) stop(paste("rmhmodel.default: syntax should be", "rmhmodel(cif, par, w, trend, types)", "with arguments given by name if they are present"), call. = FALSE) ## Validate parameters if(is.null(cif)) stop("cif is missing or NULL") if(is.null(par)) stop("par is missing or NULL") if(!is.null(w)) w <- as.owin(w) if(!is.character(cif)) stop("cif should be a character string") betamultiplier <- 1 Ncif <- length(cif) if(Ncif > 1) { ## hybrid ## check for Poisson components ispois <- (cif == 'poisson') if(any(ispois)) { ## validate Poisson components Npois <- sum(ispois) poismodels <- vector(mode="list", length=Npois) parpois <- par[ispois] for(i in 1:Npois) poismodels[[i]] <- rmhmodel(cif='poisson', par=parpois[[i]], w=w, trend=NULL, types=types, stopinvalid=FALSE) ## consolidate Poisson intensity parameters poisbetalist <- lapply(poismodels, getElement, name="C.beta") poisbeta <- Reduce("*", poisbetalist) if(all(ispois)) { ## model collapses to a Poisson process cif <- 'poisson' Ncif <- 1 par <- list(beta=poisbeta) betamultiplier <- 1 } else { ## remove Poisson components cif <- cif[!ispois] Ncif <- sum(!ispois) par <- par[!ispois] if(Ncif == 1) # revert to single-cif format par <- par[[1]] ## absorb beta parameters betamultiplier <- poisbeta } } } if(Ncif > 1) { ## genuine hybrid models <- vector(mode="list", length=Ncif) check <- vector(mode="list", length=Ncif) for(i in 1:Ncif) models[[i]] <- rmhmodel(cif=cif[i], par=par[[i]], w=w, trend=NULL, types=types, stopinvalid=FALSE) C.id <- unlist(lapply(models, getElement, name="C.id")) C.betalist <- lapply(models, getElement, name="C.beta") C.iparlist <- lapply(models, getElement, name="C.ipar") ## absorb beta multiplier into beta parameter of first component C.betalist[[1]] <- C.betalist[[1]] * betamultiplier ## concatenate for use in C C.beta <- unlist(C.betalist) C.ipar <- unlist(C.iparlist) check <- lapply(models, getElement, name="check") maxr <- max(unlist(lapply(models, getElement, name="reach"))) ismulti <- unlist(lapply(models, getElement, name="multitype.interact")) multi <- any(ismulti) ## determine whether model exists integ <- unlist(lapply(models, getElement, name="integrable")) stabi <- unlist(lapply(models, getElement, name="stabilising")) integrable <- all(integ) || any(stabi) stabilising <- any(stabi) ## string explanations of conditions for validity expl <- lapply(models, getElement, name="explainvalid") integ.ex <- unlist(lapply(expl, getElement, name="integrable")) stabi.ex <- unlist(lapply(expl, getElement, name="stabilising")) stabi.oper <- !(stabi.ex %in% c("TRUE", "FALSE")) integ.oper <- !(integ.ex %in% c("TRUE", "FALSE")) compnames <- if(!anyDuplicated(C.id)) paste("cif", sQuote(C.id)) else paste("component", 1:Ncif, paren(sQuote(C.id))) if(!integrable && stopinvalid) { ## model is not integrable: explain why ifail <- !integ & integ.oper ireason <- paste(compnames[ifail], "should satisfy", paren(integ.ex[ifail], "{")) ireason <- verbalogic(ireason, "and") if(sum(ifail) <= 1) { ## There's only one offending cif, so stability is redundant sreason <- "FALSE" } else { sfail <- !stabi & stabi.oper sreason <- paste(compnames[sfail], "should satisfy", paren(stabi.ex[sfail], "{")) sreason <- verbalogic(sreason, "or") } reason <- verbalogic(c(ireason, sreason), "or") stop(paste("rmhmodel: hybrid model is not integrable; ", reason), call.=FALSE) } else { ## construct strings summarising conditions for validity if(!any(integ.oper)) ireason <- as.character(integrable) else { ireason <- paste(compnames[integ.oper], "should satisfy", paren(integ.ex[integ.oper], "{")) ireason <- verbalogic(ireason, "and") } if(!any(stabi.oper)) sreason <- as.character(stabilising) else { sreason <- paste(compnames[stabi.oper], "should satisfy", paren(stabi.ex[stabi.oper], "{")) sreason <- verbalogic(sreason, "or") } ireason <- verbalogic(c(ireason, sreason), "or") explainvalid <- list(integrable=ireason, stabilising=sreason) } out <- list(cif=cif, par=par, w=w, trend=trend, types=types, C.id=C.id, C.beta=C.beta, C.ipar=C.ipar, C.betalist=C.betalist, C.iparlist=C.iparlist, check=check, multitype.interact=multi, integrable=integrable, stabilising=stabilising, explainvalid=explainvalid, reach=maxr) class(out) <- c("rmhmodel", class(out)) return(out) } ## non-hybrid ## Check that this is a recognised model ## and look up the rules for this model rules <- spatstatRmhInfo(cif) ## Map the name of the cif from R to C ## (the names are normally identical in R and C, ## except "poisson" -> NA) C.id <- rules$C.id ## Check that the C name is recognised in C if(!is.na(C.id)) { z <- .C(SR_knownCif, cifname=as.character(C.id), answer=as.integer(0), PACKAGE="spatstat.random") ok <- as.logical(z$answer) if(!ok) stop(paste("Internal error: the cif", sQuote(C.id), "is not recognised in the C code")) } ## Validate the model parameters and reformat them check <- rules$parhandler checkedpar <- if(!rules$multitype) check(par) else if(!is.null(types)) check(par, types) else ## types vector not given - defer checking NULL if(!is.null(checkedpar)) { stopifnot(is.list(checkedpar)) stopifnot(!is.null(names(checkedpar)) && all(nzchar(names(checkedpar)))) stopifnot(names(checkedpar)[[1]] == "beta") C.beta <- unlist(checkedpar[[1]]) C.beta <- C.beta * betamultiplier C.ipar <- as.numeric(unlist(checkedpar[-1])) } else { C.beta <- C.ipar <- NULL } ## Determine whether model is integrable integrable <- rules$validity(par, "integrable") explainvalid <- rules$explainvalid if(!integrable && stopinvalid) stop(paste("rmhmodel: the model is not integrable; it should satisfy", explainvalid$integrable), call.=FALSE) ## Determine whether cif is stabilising ## (i.e. any hybrid including this cif will be integrable) stabilising <- rules$validity(par, "stabilising") ## Calculate reach of model mreach <- rules$reach(par) ################################################################### ## return augmented list out <- list(cif=cif, par=par, w=w, trend=trend, types=types, C.id=C.id, C.beta=C.beta, C.ipar=C.ipar, check= if(is.null(C.ipar)) check else NULL, multitype.interact=rules$multitype, integrable=integrable, stabilising=stabilising, explainvalid=explainvalid, reach=mreach ) class(out) <- c("rmhmodel", class(out)) return(out) } rmhmodel.default }) print.rmhmodel <- function(x, ...) { verifyclass(x, "rmhmodel") splat("Metropolis-Hastings algorithm, model parameters\n") Ncif <- length(x$cif) splat("Conditional intensity:", if(Ncif == 1) "cif=" else "hybrid of cifs", commasep(sQuote(x$cif))) if(!is.null(x$types)) { if(length(x$types) == 1) splat("Univariate process.") else { cat("Multitype process with types =\n") print(x$types) if(!x$multitype.interact) splat("Interaction does not depend on type") } } else if(x$multitype.interact) { splat("Multitype process, types not yet specified.") } else { typ <- try(rmhResolveTypes(x, rmhstart(), rmhcontrol())) if(!inherits(typ, "try-error")) { ntyp <- length(typ) if(ntyp > 1) { splat("Data imply a multitype process with", ntyp, "types of points.") splat("Interaction does not depend on type.") } } } cat("\nNumerical parameters: par =\n") print(x$par) if(is.null(x$C.ipar)) splat("Parameters have not yet been checked for compatibility with types.") if(is.owin(x$w)) print(x$w) else splat("Window: not specified.") cat("\nTrend: ") tren <- x$trend if(is.null(tren)) { cat("none.\n") } else { if(is.list(tren)) cat(paste0("List of ", length(tren), ":\n")) print(tren) } if(!is.null(x$integrable) && !x$integrable) cat("\n*Warning: model is not integrable and cannot be simulated*\n") return(invisible(NULL)) } reach.rmhmodel <- function(x, ...) { if(length(list(...)) == 0) return(x$reach) # reach must be recomputed cif <- x$cif Ncif <- length(cif) pars <- if(Ncif == 1) list(x$par) else x$par maxr <- 0 for(i in seq_len(Ncif)) { cif.i <- cif[i] par.i <- pars[[i]] rules <- spatstatRmhInfo(cif.i) rchfun <- rules$reach if(!is.function(rchfun)) stop(paste("Internal error: reach is unknown for cif=", sQuote(cif.i)), call.=FALSE) r.i <- rchfun(par.i, ...) maxr <- max(maxr, r.i, na.rm=TRUE) } return(maxr) } is.poisson <- function(x) { UseMethod("is.poisson") } is.poisson.rmhmodel <- function(x) { verifyclass(x, "rmhmodel") identical(x$cif, 'poisson') } is.stationary <- function(x) { UseMethod("is.stationary") } is.stationary.rmhmodel <- function(x) { verifyclass(x, "rmhmodel") tren <- x$trend return(is.null(tren) || is.numeric(tren)) } as.owin.rmhmodel <- function(W, ..., fatal=FALSE) { # W is the rmhmodel object. It contains a window w ans <- W$w if(is.owin(ans)) return(ans) if(fatal) stop("rmhmodel object does not contain a window") return(NULL) } domain.rmhmodel <- Window.rmhmodel <- function(X, ...) { as.owin(X) } is.expandable.rmhmodel <- local({ ok <- function(z) { is.null(z) || is.numeric(z) || is.function(z) } is.expandable.rmhmodel <- function(x) { tren <- x$tren ans <- if(!is.list(tren)) ok(tren) else all(sapply(tren, ok)) return(ans) } is.expandable.rmhmodel }) ##### Table of rules for handling rmh models ################## spatstatRmhInfo <- function(cifname) { rules <- .Spatstat.RmhTable[[cifname]] if(is.null(rules)) stop(paste("Unrecognised cif:", sQuote(cifname)), call.=FALSE) return(rules) } .Spatstat.RmhTable <- list( # # 0. Poisson (special case) # 'poisson'= list( C.id=NA, multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the Poisson process" with(par, forbidNA(beta, ctxt)) par <- check.named.list(par, "beta", ctxt, xtitle="par") with(par, explain.ifnot(all(beta >= 0), ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE",stabilising="FALSE"), reach = function(par, ...) { return(0) }, hardcore = function(par, ...) { return(0) }, temper = function(par, invtemp) { return(par^invtemp) } ), # # 1. Strauss. # 'strauss'= list( C.id="strauss", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the strauss cif" par <- check.named.list(par, c("beta","gamma","r"), ctxt, xtitle="par") # treat r=NA as absence of interaction par <- within(par, if(is.na(r)) { r <- 0; gamma <- 1 }) with(par, check.finite(beta, ctxt)) with(par, check.finite(gamma, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.1.real(gamma, ctxt)) with(par, check.1.real(r, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(gamma >= 0, ctxt)) with(par, explain.ifnot(r >= 0, ctxt)) return(par) }, validity=function(par, kind) { gamma <- par$gamma switch(kind, integrable=(gamma <= 1), stabilising=(gamma == 0) ) }, explainvalid=list( integrable="gamma <= 1", stabilising="gamma == 0"), reach = function(par, ...) { r <- par[["r"]] g <- par[["gamma"]] return(if(g == 1) 0 else r) }, hardcore = function(par, ..., epsilon=0) { r <- par[["r"]] g <- par[["gamma"]] return(if(g <= epsilon) r else 0) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 2. Strauss with hardcore. # 'straush' = list( C.id="straush", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the straush cif" par <- check.named.list(par, c("beta","gamma","r","hc"), ctxt, xtitle="par") # treat hc=NA as absence of hard core par <- within(par, if(is.na(hc)) { hc <- 0 } ) # treat r=NA as absence of interaction par <- within(par, if(is.na(r)) { r <- hc; gamma <- 1 } ) with(par, check.finite(beta, ctxt)) with(par, check.finite(gamma, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.finite(hc, ctxt)) with(par, check.1.real(gamma, ctxt)) with(par, check.1.real(r, ctxt)) with(par, check.1.real(hc, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(gamma >= 0, ctxt)) with(par, explain.ifnot(r >= 0, ctxt)) with(par, explain.ifnot(hc >= 0, ctxt)) with(par, explain.ifnot(hc <= r, ctxt)) return(par) }, validity=function(par, kind) { hc <- par$hc gamma <- par$gamma switch(kind, integrable=(hc > 0 || gamma <= 1), stabilising=(hc > 0) ) }, explainvalid=list( integrable="hc > 0 or gamma <= 1", stabilising="hc > 0"), reach = function(par, ...) { h <- par[["hc"]] r <- par[["r"]] g <- par[["gamma"]] return(if(g == 1) h else r) }, hardcore = function(par, ..., epsilon=0) { h <- par[["hc"]] r <- par[["r"]] g <- par[["gamma"]] return(if(g <= epsilon) r else h) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 3. Softcore. # 'sftcr' = list( C.id="sftcr", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the sftcr cif" par <- check.named.list(par, c("beta","sigma","kappa"), ctxt, xtitle="par") with(par, check.finite(beta, ctxt)) with(par, check.finite(sigma, ctxt)) with(par, check.finite(kappa, ctxt)) with(par, check.1.real(sigma, ctxt)) with(par, check.1.real(kappa, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(sigma >= 0, ctxt)) with(par, explain.ifnot(kappa >= 0 && kappa <= 1, ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE",stabilising="FALSE"), reach = function(par, ..., epsilon=0) { if(epsilon==0) return(Inf) kappa <- par[["kappa"]] sigma <- par[["sigma"]] return(sigma/(epsilon^(kappa/2))) }, hardcore = function(par, ..., epsilon=0) { if(epsilon==0) return(0) kappa <- par[["kappa"]] sigma <- par[["sigma"]] return(sigma/((-log(epsilon))^(kappa/2))) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp sigma <- sigma * (invtemp^(kappa/2)) }) } ), # # 4. Multitype Strauss. # 'straussm' = list( C.id="straussm", multitype=TRUE, parhandler=function(par, types) { ctxt <- "For the straussm cif" par <- check.named.list(par, c("beta","gamma","radii"), ctxt, xtitle="par") beta <- par$beta gamma <- par$gamma r <- par$radii ntypes <- length(types) check.finite(beta, ctxt) check.nvector(beta, ntypes, TRUE, "types", vname="beta") MultiPair.checkmatrix(gamma, ntypes, "par$gamma") gamma[is.na(gamma)] <- 1 check.finite(gamma, ctxt) MultiPair.checkmatrix(r, ntypes, "par$radii") if(any(nar <- is.na(r))) { r[nar] <- 0 gamma[nar] <- 1 } check.finite(r, ctxt) explain.ifnot(all(beta >= 0), ctxt) explain.ifnot(all(gamma >= 0), ctxt) explain.ifnot(all(r >= 0), ctxt) par <- list(beta=beta, gamma=gamma, r=r) return(par) }, validity=function(par, kind) { gamma <- par$gamma radii <- par$radii dg <- diag(gamma) dr <- diag(radii) hard <-!is.na(dg) & (dg == 0) & !is.na(dr) & (dr > 0) operative <- !is.na(gamma) & !is.na(radii) & (radii > 0) switch(kind, stabilising=all(hard), integrable=all(hard) || all(gamma[operative] <= 1)) }, explainvalid=list( integrable=paste( "gamma[i,j] <= 1 for all i and j,", "or gamma[i,i] = 0 for all i"), stabilising="gamma[i,i] = 0 for all i"), reach = function(par, ...) { r <- par$radii g <- par$gamma operative <- ! (is.na(r) | (g == 1)) return(max(0, r[operative])) }, hardcore = function(par, ..., epsilon=0) { r <- par$radii g <- par$gamma return(max(0, r[!is.na(r) & g <= epsilon])) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 5. Multitype Strauss with hardcore. # 'straushm' = list( C.id="straushm", multitype=TRUE, parhandler=function(par, types) { ctxt="For the straushm cif" par <- check.named.list(par, c("beta","gamma","iradii","hradii"), ctxt, xtitle="par") beta <- par$beta gamma <- par$gamma iradii <- par$iradii hradii <- par$hradii ntypes <- length(types) check.nvector(beta, ntypes, TRUE, "types", vname="beta") check.finite(beta, ctxt) MultiPair.checkmatrix(gamma, ntypes, "par$gamma") gamma[is.na(gamma)] <- 1 check.finite(gamma, ctxt) MultiPair.checkmatrix(iradii, ntypes, "par$iradii") if(any(nar <- is.na(iradii))) { iradii[nar] <- 0 gamma[nar] <- 1 } check.finite(iradii, ctxt) MultiPair.checkmatrix(hradii, ntypes, "par$hradii") nah <- is.na(hradii) hradii[nah] <- 0 check.finite(hradii, ctxt) explain.ifnot(all(beta >= 0), ctxt) explain.ifnot(all(gamma >= 0), ctxt) explain.ifnot(all(iradii >= 0), ctxt) explain.ifnot(all(hradii >= 0), ctxt) comparable <- !nar & !nah explain.ifnot(all((iradii >= hradii)[comparable]), ctxt) par <- list(beta=beta,gamma=gamma,iradii=iradii,hradii=hradii) return(par) }, validity=function(par, kind) { gamma <- par$gamma iradii <- par$iradii hradii <- par$hradii dh <- diag(hradii) dg <- diag(gamma) dr <- diag(iradii) hhard <- !is.na(dh) & (dh > 0) ihard <- !is.na(dr) & (dr > 0) & !is.na(dg) & (dg == 0) hard <- hhard | ihard operative <- !is.na(gamma) & !is.na(iradii) & (iradii > 0) switch(kind, stabilising=all(hard), integrable={ all(hard) || all(gamma[operative] <= 1) }) }, explainvalid=list( integrable=paste( "hradii[i,i] > 0 or gamma[i,i] = 0 for all i, or", "gamma[i,j] <= 1 for all i and j"), stabilising="hradii[i,i] > 0 or gamma[i,i] = 0 for all i"), reach=function(par, ...) { r <- par$iradii h <- par$hradii g <- par$gamma roperative <- ! (is.na(r) | (g == 1)) hoperative <- ! is.na(h) return(max(0, r[roperative], h[hoperative])) }, hardcore = function(par, ..., epsilon=0) { r <- par$radii h <- par$hradii g <- par$gamma return(max(h[!is.na(h)], r[!is.na(r) & g <= epsilon])) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 6. Diggle-Gates-Stibbard interaction # (function number 1 from Diggle, Gates, and Stibbard) 'dgs' = list( C.id="dgs", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the dgs cif" par <- check.named.list(par, c("beta","rho"), ctxt, xtitle="par") with(par, check.finite(beta, ctxt)) with(par, check.finite(rho, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, check.1.real(rho, ctxt)) with(par, explain.ifnot(rho >= 0, ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE", stabilising="FALSE"), reach=function(par, ...) { return(par[["rho"]]) }, hardcore=function(par, ..., epsilon=0) { if(epsilon == 0) return(0) return(par[["rho"]] * (2/pi) * asin(sqrt(epsilon))) }, temper = NULL # not a loglinear model ), # # 7. Diggle-Gratton interaction # (function number 2 from Diggle, Gates, and Stibbard). 'diggra' = list( C.id="diggra", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the diggra cif" par <- check.named.list(par, c("beta","kappa","delta","rho"), ctxt, xtitle="par") with(par, check.finite(beta, ctxt)) with(par, check.finite(kappa, ctxt)) with(par, check.finite(delta, ctxt)) with(par, check.finite(rho, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, check.1.real(kappa, ctxt)) with(par, check.1.real(delta, ctxt)) with(par, check.1.real(rho, ctxt)) with(par, explain.ifnot(kappa >= 0, ctxt)) with(par, explain.ifnot(delta >= 0, ctxt)) with(par, explain.ifnot(rho >= 0, ctxt)) with(par, explain.ifnot(delta < rho, ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE",stabilising="FALSE"), reach=function(par, ...) { return(par[["rho"]]) }, hardcore=function(par, ..., epsilon=0) { return(par[["delta"]]) }, temper = function(par, invtemp) { within(par, { kappa <- kappa * invtemp }) }), # # 8. Geyer saturation model # 'geyer' = list( C.id="geyer", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the geyer cif" par <- check.named.list(par, c("beta","gamma","r","sat"), ctxt, xtitle="par") with(par, check.1.real(gamma, ctxt)) with(par, check.1.real(r, ctxt)) with(par, check.1.real(sat, ctxt)) par <- within(par, sat <- min(sat, .Machine$integer.max-100)) par <- within(par, if(is.na(gamma)) { r <- 0; gamma <- 1 }) with(par, check.finite(beta, ctxt)) with(par, check.finite(gamma, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.finite(sat, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE", stabilising="FALSE"), reach = function(par, ...) { r <- par[["r"]] g <- par[["gamma"]] return(if(g == 1) 0 else 2 * r) }, hardcore = function(par, ..., epsilon=0) { r <- par[["r"]] g <- par[["gamma"]] return(if(g <= epsilon) r else 0) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 9. The ``lookup'' device. This permits simulating, at least # approximately, ANY pairwise interaction function model # with isotropic pair interaction (i.e. depending only on distance). # The pair interaction function is provided as a vector of # distances and corresponding function values which are used # as a ``lookup table'' by the C code. # 'lookup' = list( C.id="lookup", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the lookup cif" par <- check.named.list(par, c("beta","h"), ctxt, "r", xtitle="par") with(par, check.finite(beta, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) beta <- par[["beta"]] h.init <- par[["h"]] r <- par[["r"]] if(is.null(r)) { if(!is.stepfun(h.init)) stop(paste("For cif=lookup, if component r of", "par is absent then component h must", "be a stepfun object.")) if(!is.cadlag(h.init)) stop(paste("The lookup pairwise interaction step", "function must be right continuous,\n", "i.e. built using the default values of the", sQuote("f"), "and", sQuote("right"), "arguments for stepfun.")) r <- knots(h.init) h0 <- get("yleft",envir=environment(h.init)) h <- h.init(r) nlook <- length(r) if(!isTRUE(all.equal(h[nlook],1))) stop(paste("The lookup interaction step function", "must be equal to 1 for", dQuote("large"), "distances.")) if(r[1] <= 0) stop(paste("The first jump point (knot) of the lookup", "interaction step function must be", "strictly positive.")) h <- c(h0,h) } else { h <- h.init nlook <- length(r) if(length(h) != nlook) stop("Mismatch of lengths of h and r lookup vectors.") if(anyNA(r)) stop("Missing values not allowed in r lookup vector.") if(is.unsorted(r)) stop("The r lookup vector must be in increasing order.") if(r[1] <= 0) stop(paste("The first entry of the lookup vector r", "should be strictly positive.")) h <- c(h,1) } if(any(h < 0)) stop(paste("Negative values in the lookup", "pairwise interaction function.")) if(h[1] > 0 & any(h > 1)) stop(paste("Lookup pairwise interaction function does", "not define a valid point process.")) rmax <- r[nlook] r <- c(0,r) nlook <- nlook+1 deltar <- mean(diff(r)) if(isTRUE(all.equal(diff(r),rep.int(deltar,nlook-1)))) { par <- list(beta=beta,nlook=nlook, equisp=1, deltar=deltar,rmax=rmax, h=h) } else { par <- list(beta=beta,nlook=nlook, equisp=0, deltar=deltar,rmax=rmax, h=h, r=r) } return(par) }, validity=function(par, kind) { h <- par$h if(is.stepfun(h)) h <- eval(expression(c(yleft,y)),envir=environment(h)) switch(kind, integrable={ (h[1] == 0) || all(h <= 1) }, stabilising={ h[1] == 0 }) }, explainvalid=list( integrable="h[1] == 0 or h[i] <= 1 for all i", stabilising="h[1] == 0"), reach = function(par, ...) { r <- par[["r"]] h <- par[["h"]] if(is.null(r)) r <- knots(h) return(max(r)) }, hardcore = function(par, ..., epsilon=0) { r <- par[["r"]] h <- par[["h"]] if(is.null(r)) r <- knots(h) return(max(0, r[h <= epsilon])) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp h <- h^invtemp }) } ), # # 10. Area interaction # 'areaint'= list( C.id="areaint", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the areaint cif" par <- check.named.list(par, c("beta","eta","r"), ctxt, xtitle="par") par <- within(par, if(is.na(r)) { r <- 0 }) with(par, check.finite(beta, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, check.1.real(eta, ctxt)) with(par, check.1.real(r, ctxt)) with(par, check.finite(eta, ctxt)) with(par, check.finite(r, ctxt)) with(par, explain.ifnot(eta >= 0, ctxt)) with(par, explain.ifnot(r >= 0, ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE", stabilising="FALSE"), reach = function(par, ...) { r <- par[["r"]] eta <- par[["eta"]] return(if(eta == 1) 0 else (2 * r)) }, hardcore = function(par, ..., epsilon=0) { r <- par[["r"]] eta <- par[["eta"]] if(eta > epsilon) return(0) if(eta == 0) return(2 * r) # linear approximation return(2 * r * eta/epsilon) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp eta <- eta^invtemp }) } ), # # 11. The ``badgey'' (Baddeley-Geyer) model. # 'badgey' = list( C.id="badgey", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the badgey cif" par <- check.named.list(par, c("beta","gamma","r","sat"), ctxt, xtitle="par") par <- within(par, sat <- pmin(sat, .Machine$integer.max-100)) par <- within(par, gamma[is.na(gamma) | is.na(r)] <- 1) par <- within(par, r[is.na(r)] <- 0) with(par, check.finite(beta, ctxt)) with(par, check.finite(gamma, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.finite(sat, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(all(gamma >= 0), ctxt)) with(par, explain.ifnot(all(r >= 0), ctxt)) with(par, explain.ifnot(all(sat >= 0), ctxt)) with(par, explain.ifnot(length(gamma) == length(r), ctxt)) gamma <- par[["gamma"]] r <- par[["r"]] sat <- par[["sat"]] if(length(sat)==1) sat <- rep.int(sat,length(gamma)) else explain.ifnot(length(sat) == length(gamma), ctxt) mmm <- cbind(gamma,r,sat) mmm <- mmm[fave.order(r),] ndisc <- length(r) par <- list(beta=par$beta,ndisc=ndisc,parms=as.vector(t(mmm))) return(par) }, validity=function(par, kind) { switch(kind, integrable=TRUE, stabilising=FALSE) }, explainvalid=list(integrable="TRUE", stabilising="FALSE"), reach = function(par, ...) { r <- par[["r"]] gamma <- par[["gamma"]] operative <- (gamma != 1) return(if(!any(operative)) 0 else (2 * max(r[operative]))) }, hardcore = function(par, ..., epsilon=0) { r <- par[["r"]] gamma <- par[["gamma"]] return(max(0, r[gamma <= epsilon])) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 12. The hard core process 'hardcore' = list( C.id="hardcore", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the hardcore cif" par <- check.named.list(par, c("beta", "hc"), ctxt, xtitle="par") par <- within(par, if(is.na(hc)) { hc <- 0 }) with(par, check.finite(beta, ctxt)) with(par, check.finite(hc, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, check.1.real(hc, ctxt)) return(par) }, validity=function(par, kind) { hc <- par$hc switch(kind, integrable=TRUE, stabilising=(hc > 0)) }, explainvalid=list(integrable="TRUE", stabilising="hc > 0"), reach = function(par, ...) { hc <- par[["hc"]] return(hc) }, hardcore = function(par, ...) { hc <- par[["hc"]] return(hc) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp }) } ), # # Lucky 13. Fiksel process 'fiksel' = list( C.id="fiksel", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the Fiksel cif" par <- check.named.list(par, c("beta", "r", "hc", "kappa", "a"), ctxt, xtitle="par") with(par, check.finite(beta, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.finite(hc, ctxt)) with(par, check.finite(kappa, ctxt)) with(par, check.finite(a, ctxt)) with(par, check.1.real(r, ctxt)) with(par, check.1.real(hc, ctxt)) with(par, check.1.real(kappa, ctxt)) with(par, check.1.real(a, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(hc >= 0, ctxt)) with(par, explain.ifnot(r > hc, ctxt)) return(par) }, validity=function(par, kind) { hc <- par$hc a <- par$a switch(kind, integrable=(hc > 0 || a <= 0), stabilising=(hc > 0)) }, explainvalid=list( integrable="hc > 0 or a <= 0", stabilising="hc > 0"), reach = function(par, ...) { r <- par[["r"]] hc <- par[["hc"]] a <- par[["a"]] return(if(a != 0) r else hc) }, hardcore = function(par, ...) { return(par[["hc"]]) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp a <- a * invtemp }) } ), # # 14. Lennard-Jones 'lennard' = list( C.id="lennard", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the Lennard-Jones cif" par <- check.named.list(par, c("beta", "sigma", "epsilon"), ctxt, xtitle="par") with(par, check.finite(beta, ctxt)) with(par, check.finite(sigma, ctxt)) with(par, check.finite(epsilon, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, check.1.real(sigma, ctxt)) with(par, check.1.real(epsilon, ctxt)) with(par, explain.ifnot(sigma > 0, ctxt)) with(par, explain.ifnot(epsilon > 0, ctxt)) return(par) }, validity=function(par, kind) { switch(kind, integrable=(par$sigma > 0), stabilising=FALSE) }, explainvalid=list( integrable="sigma > 0", stabilising="FALSE"), reach = function(par, ...) { sigma <- par[["sigma"]] return(2.5 * sigma) }, hardcore = function(par, ...) { sigma <- par[["sigma"]] return(sigma/2.5) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp epsilon <- epsilon * invtemp }) } ), # # 15. Multitype hardcore. # 'multihard' = list( C.id="multihard", multitype=TRUE, parhandler=function(par, types) { ctxt="For the multihard cif" par <- check.named.list(par, c("beta","hradii"), ctxt, xtitle="par") beta <- par$beta hradii <- par$hradii ntypes <- length(types) check.nvector(beta, ntypes, TRUE, "types", vname="beta") check.finite(beta, ctxt) MultiPair.checkmatrix(hradii, ntypes, "par$hradii") hradii[is.na(hradii)] <- 0 check.finite(hradii, ctxt) explain.ifnot(all(beta >= 0), ctxt) explain.ifnot(all(hradii >= 0), ctxt) par <- list(beta=beta,hradii=hradii) return(par) }, validity=function(par, kind) { switch(kind, integrable=return(TRUE), stabilising={ hself <- diag(par$hradii) repel <- !is.na(hself) & (hself > 0) return(all(repel)) }) }, explainvalid=list( integrable="TRUE", stabilising="hradii[i,i] > 0 for all i"), reach=function(par, ...) { return(max(0, par$hradii, na.rm=TRUE)) }, hardcore=function(par, ..., epsilon=0) { return(max(0, par$hradii, na.rm=TRUE)) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp }) } ), # # 16. Triplets. # 'triplets'= list( C.id="triplets", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the triplets cif" par <- check.named.list(par, c("beta","gamma","r"), ctxt, xtitle="par") # treat r=NA as absence of interaction par <- within(par, if(is.na(r)) { r <- 0; gamma <- 1 }) with(par, check.finite(beta, ctxt)) with(par, check.finite(gamma, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.1.real(gamma, ctxt)) with(par, check.1.real(r, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(gamma >= 0, ctxt)) with(par, explain.ifnot(r >= 0, ctxt)) return(par) }, validity=function(par, kind) { gamma <- par$gamma switch(kind, integrable=(gamma <= 1), stabilising=(gamma == 0) ) }, explainvalid=list( integrable="gamma <= 1", stabilising="gamma == 0"), reach = function(par, ...) { r <- par[["r"]] g <- par[["gamma"]] return(if(g == 1) 0 else r) }, hardcore = function(par, ...) { return(0) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ), # # 17. Penttinen. # 'penttinen'= list( C.id="penttinen", multitype=FALSE, parhandler=function(par, ...) { ctxt <- "For the penttinen cif" par <- check.named.list(par, c("beta", "gamma", "r"), ctxt, xtitle="par") # treat r=NA as absence of interaction par <- within(par, if(is.na(r)) { r <- 0; gamma <- 1 }) with(par, check.finite(beta, ctxt)) with(par, check.finite(gamma, ctxt)) with(par, check.finite(r, ctxt)) with(par, check.1.real(gamma, ctxt)) with(par, check.1.real(r, ctxt)) with(par, explain.ifnot(all(beta >= 0), ctxt)) with(par, explain.ifnot(gamma >= 0, ctxt)) with(par, explain.ifnot(r > 0, ctxt)) return(par) }, validity=function(par, kind) { gamma <- par$gamma switch(kind, integrable=(gamma <= 1), stabilising=(gamma == 0) ) }, explainvalid=list( integrable="gamma <= 1", stabilising="gamma == 0"), reach = function(par, ...) { r <- par[["r"]] g <- par[["gamma"]] return(if(g == 1) 0 else (2 * r)) }, hardcore = function(par, ..., epsilon=0) { r <- par[["r"]] g <- par[["gamma"]] return(if(g <= epsilon) (2 * r) else 0) }, temper = function(par, invtemp) { within(par, { beta <- beta^invtemp gamma <- gamma^invtemp }) } ) # end of list '.Spatstat.RmhTable' ) spatstat.random/R/randommk.R0000644000176200001440000004064014331654772015550 0ustar liggesusers# # # randommk.R # # Random generators for MULTITYPE point processes # # $Revision: 1.41 $ $Date: 2022/04/08 06:25:53 $ # # rmpoispp() random marked Poisson pp # rmpoint() n independent random marked points # rmpoint.I.allim() ... internal # rpoint.multi() temporary wrapper # rmpoispp <- local({ ## Argument checking is.numvector <- function(x) {is.numeric(x) && is.vector(x)} is.constant <- function(x) {is.numvector(x) && length(x) == 1} checkone <- function(x) { if(is.constant(x)) { if(x >= 0) return(TRUE) else stop("Intensity is negative!") } return(is.function(x) || is.im(x)) } ## Ensure that m can be passed as a single value to function(x,y,m,...) slice.fun <- function(x,y,fun,mvalue, ...) { m <- if(length(mvalue) == 1) rep.int(mvalue, length(x)) else mvalue result <- fun(x,y,m, ...) return(result) } ## Main function rmpoispp <- function(lambda, lmax=NULL, win = owin(c(0,1),c(0,1)), types, ..., nsim=1, drop=TRUE, warnwin=!missing(win)) { ## arguments: ## lambda intensity: ## constant, function(x,y,m,...), image, ## vector, list of function(x,y,...) or list of images ## ## lmax maximum possible value of lambda ## constant, vector, or list ## ## win default observation window (of class 'owin') ## ## types possible types for multitype pattern ## ## ... extra arguments passed to lambda() ## check.1.integer(nsim) stopifnot(nsim >= 0) if(nsim == 0) return(simulationresult(list())) if(missing(types)) types <- NULL force(warnwin) ## Validate arguments single.arg <- checkone(lambda) vector.arg <- !single.arg && is.numvector(lambda) list.arg <- !single.arg && is.list(lambda) if(! (single.arg || vector.arg || list.arg)) stop(paste("argument", sQuote("lambda"), "not understood")) if(list.arg && !all(unlist(lapply(lambda, checkone)))) stop(paste("Each entry in the list", sQuote("lambda"), "must be either a constant, a function or an image")) if(vector.arg && any(lambda < 0)) stop(paste("Some entries in the vector", sQuote("lambda"), "are negative")) ## Determine & validate the set of possible types if(is.null(types)) { if(single.arg) { stop(paste(sQuote("types"), "must be given explicitly when", sQuote("lambda"), "is a constant, a function or an image")) } else if(!is.null(nama <- names(lambda)) && sum(nzchar(nama)) == length(lambda)) { types <- nama } else { types <- seq_along(lambda) } } ntypes <- length(types) if(!single.arg && (length(lambda) != ntypes)) stop(paste("The lengths of", sQuote("lambda"), "and", sQuote("types"), "do not match")) factortype <- factor(types, levels=types) ## Validate `lmax' if(! (is.null(lmax) || is.numvector(lmax) || is.list(lmax) )) stop(paste(sQuote("lmax"), "should be a constant, a vector, a list or NULL")) ## coerce lmax to a vector, to save confusion if(is.null(lmax)) maxes <- rep(NULL, ntypes) else if(is.numvector(lmax) && length(lmax) == 1) maxes <- rep.int(lmax, ntypes) else if(length(lmax) != ntypes) stop(paste("The length of", sQuote("lmax"), "does not match the number of possible types")) else if(is.list(lmax)) maxes <- unlist(lmax) else maxes <- lmax ## coerce lambda to a list, to save confusion lam <- if(single.arg) rep(list(lambda), ntypes) else if(vector.arg) as.list(lambda) else lambda ## ------------- SIMULATE ---------------------------- resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { for(i in 1:ntypes) { if(single.arg && is.function(lambda)) { ## call f(x,y,m, ...) Y <- rpoispp(slice.fun, lmax=maxes[i], win=win, fun=lambda, mvalue=types[i], ..., warnwin=warnwin) } else { ## call f(x,y, ...) or use other formats Y <- rpoispp(lam[[i]], lmax=maxes[i], win=win, ..., warnwin=warnwin) } Y <- Y %mark% factortype[i] X <- if(i == 1) Y else superimpose(X, Y, W=X$window, check=FALSE) } ## Randomly permute, just in case the order is important permu <- sample(X$n) X <- X[permu] ## save resultlist[[isim]] <- X } return(simulationresult(resultlist, nsim, drop)) } rmpoispp }) ## ------------------------------------------------------------------------ rmpoint <- local({ ## argument validation is.numvector <- function(x) {is.numeric(x) && is.vector(x)} is.constant <- function(x) {is.numvector(x) && length(x) == 1} checkone <- function(x) { if(is.constant(x)) { if(x >= 0) return(TRUE) else stop("Intensity is negative!") } return(is.function(x) || is.im(x)) } # integration.. integratexy <- function(f, win, ...) { imag <- as.im(f, W=win, ...) integral.im(imag) } ## create a counterpart of f(x,y,m) that works when m is a single value funwithfixedmark <- function(xx, yy, ..., m, fun) { mm <- rep.int(m, length(xx)) fun(xx, yy, mm, ...) } integratewithfixedmark <- function(m, fun, win, ...) { integratexy(funwithfixedmark, win=win, m=m, fun=fun, ...) } # Main function rmpoint <- function(n, f=1, fmax=NULL, win = unit.square(), types, ptypes, ..., giveup = 1000, verbose = FALSE, nsim = 1, drop=TRUE) { if(!is.numeric(n)) stop("n must be a scalar or vector") if(any(ceiling(n) != floor(n))) stop("n must be an integer or integers") if(any(n < 0)) stop("n must be non-negative") if(missing(types)) types <- NULL if(missing(ptypes)) ptypes <- NULL check.1.integer(nsim) stopifnot(nsim >= 0) ###### Trivial cases if(nsim == 0) return(simulationresult(list())) if(sum(n) == 0) { ## results are empty patterns nopoints <- ppp(x=numeric(0), y=numeric(0), window=win, check=FALSE) if(!is.null(types)) { nomarks <- factor(types[integer(0)], levels=types) nopoints <- nopoints %mark% nomarks } resultlist <- rep(list(nopoints), nsim) return(simulationresult(resultlist, nsim, drop)) } ####### Validate arguments and determine type of simulation ############## Model <- if(length(n) == 1) { if(is.null(ptypes)) "I" else "II" } else "III" ############## Validate f argument single.arg <- checkone(f) vector.arg <- !single.arg && is.numvector(f) list.arg <- !single.arg && is.list(f) if(! (single.arg || vector.arg || list.arg)) stop(paste("argument", sQuote("f"), "not understood")) if(list.arg && !all(unlist(lapply(f, checkone)))) stop(paste("Each entry in the list", sQuote("f"), "must be either a constant, a function or an image")) if(vector.arg && any(f < 0)) stop(paste("Some entries in the vector", sQuote("f"), "are negative")) ## cases where it's known that all types of points ## have the same conditional density of location (x,y) const.density <- vector.arg || (list.arg && all(unlist(lapply(f, is.constant)))) same.density <- const.density || (single.arg && !is.function(f)) ################ Determine & validate the set of possible types if(is.null(types)) { if(single.arg && length(n) == 1) stop(paste(sQuote("types"), "must be given explicitly when", sQuote("f"), "is a single number, a function or an image and", sQuote("n"), "is a single number")) else { basis <- if(single.arg) n else f if(!is.null(nama <- names(basis)) && sum(nzchar(nama)) == length(basis)) { types <- nama } else { types <- seq_along(basis) } } } ntypes <- length(types) if(!single.arg && (length(f) != ntypes)) stop(paste("The lengths of", sQuote("f"), "and", sQuote("types"), "do not match")) if(length(n) > 1 && ntypes != length(n)) stop(paste("The lengths of", sQuote("n"), "and", sQuote("types"), "do not match")) factortype <- factor(types, levels=types) seqtypes <- seq_len(ntypes) ####################### Validate `fmax' if(! (is.null(fmax) || is.numvector(fmax) || is.list(fmax) )) stop(paste(sQuote("fmax"), "should be a constant, a vector, a list or NULL")) ## coerce fmax to a vector, to save confusion if(is.null(fmax)) maxes <- rep(NULL, ntypes) else if(is.constant(fmax)) maxes <- rep.int(fmax, ntypes) else if(length(fmax) != ntypes) stop(paste("The length of", sQuote("fmax"), "does not match the number of possible types")) else if(is.list(fmax)) maxes <- unlist(fmax) else maxes <- fmax ## coerce f to a list, to save confusion flist <- if(single.arg) rep(list(f), ntypes) else if(vector.arg) as.list(f) else f #################### Finished validating arguments ######################## #################### Handle special case ######################## if(Model == "I" && !same.density && all(sapply(flist, is.im))) { resultlist <- rmpoint.I.allim(n, flist, types, nsim) return(simulationresult(resultlist, nsim, drop)) } #################### Prepare for simulations ######################## ## Set up some data for repeated use in the simulations if(Model == "I") { ## Compute approximate marginal distribution of type if(vector.arg) ptypes <- f/sum(f) else if(list.arg) { fintegrals <- unlist(lapply(flist, integratexy, win=win, ...)) ptypes <- fintegrals/sum(fintegrals) } else { ## single argument if(is.constant(f) || is.im(f)) { ptypes <- rep.int(1/ntypes, ntypes) } else { ## f is a function (x,y,m) ## convert to images and integrate fintegrals <- unlist(lapply(types, integratewithfixedmark, win=win, fun=f, ...)) ## normalise ptypes <- fintegrals/sum(fintegrals) } } } if(Model == "III") { ## multinomial: fixed number n[i] of types[i] repmarks <- factor(rep.int(types, n), levels=types) } #################### RANDOM GENERATION, general case ######################## resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## First generate types, then locations given types switch(Model, I = , II = { ## i.i.d.: n marks with distribution 'ptypes' marques <- sample(factortype, n, prob=ptypes, replace=TRUE) nn <- table(marques) }, III = { ## multinomial: fixed number n[i] of types[i] marques <- sample(repmarks) nn <- n }) ntot <- sum(nn) if(same.density) { ## All types have the same conditional density of location; ## generate the locations using rpoint X <- rpoint(ntot, flist[[1]], maxes[[1]], win=win, ..., giveup=giveup, verbose=verbose) resultlist[[isim]] <- X %mark% marques } else { ## Invoke rpoint() for each type separately ## Set up 'blank' pattern X <- ppp(numeric(ntot), numeric(ntot), window=win, marks=marques, check=FALSE) for(i in seqtypes) { if(verbose) cat(paste("Type", i, "\n")) if(single.arg && is.function(f)) { ## want to call f(x,y,m, ...) Y <- rpoint(nn[i], funwithfixedmark, fmax=maxes[i], win=win, ..., m=factortype[i], fun=f, giveup=giveup, verbose=verbose) } else { ## call f(x,y, ...) or use other formats Y <- rpoint(nn[i], flist[[i]], fmax=maxes[i], win=win, ..., giveup=giveup, verbose=verbose) } Y <- Y %mark% factortype[i] X[marques == factortype[i]] <- Y } resultlist[[isim]] <- X } } return(simulationresult(resultlist, nsim, drop)) } rmpoint }) rmpoint.I.allim <- local({ ## Extract pixel coordinates and probabilities get.stuff <- function(imag) { w <- as.mask(as.owin(imag)) dx <- w$xstep dy <- w$ystep rxy <- rasterxy.mask(w, drop=TRUE) xpix <- rxy$x ypix <- rxy$y ppix <- as.vector(imag$v[w$m]) ## not normalised - OK npix <- length(xpix) return(list(xpix=xpix, ypix=ypix, ppix=ppix, dx=rep.int(dx,npix), dy=rep.int(dy, npix), npix=npix)) } rmpoint.I.allim <- function(n, f, types, nsim=1) { ## Internal use only! ## Generates random marked points (Model I *only*) ## when all f[[i]] are pixel images. ## stuff <- lapply(f, get.stuff) ## Concatenate into loooong vectors xpix <- unlist(lapply(stuff, getElement, name="xpix")) ypix <- unlist(lapply(stuff, getElement, name="ypix")) ppix <- unlist(lapply(stuff, getElement, name="ppix")) dx <- unlist(lapply(stuff, getElement, name="dx")) dy <- unlist(lapply(stuff, getElement, name="dy")) ## replicate types numpix <- unlist(lapply(stuff, getElement, name="npix")) tpix <- rep.int(seq_along(types), numpix) npix <- sum(numpix) ## resultlist <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { ## sample pixels from union of all images id <- sample(npix, n, replace=TRUE, prob=ppix) ## get pixel centre coordinates and randomise within pixel x <- xpix[id] + (runif(n) - 1/2) * dx[id] y <- ypix[id] + (runif(n) - 1/2) * dy[id] ## compute types marx <- factor(types[tpix[id]],levels=types) ## et voila! resultlist[[isim]] <- ppp(x, y, window=as.owin(f[[1]]), marks=marx, check=FALSE) } return(resultlist) } rmpoint.I.allim }) ## ## wrapper for Rolf's function ## rpoint.multi <- function (n, f, fmax=NULL, marks = NULL, win = unit.square(), giveup = 1000, verbose = FALSE, warn=TRUE, nsim=1, drop=TRUE) { check.1.integer(nsim) stopifnot(nsim >= 0) if(is.null(marks) || (is.factor(marks) && length(levels(marks)) == 1)) { ## Unmarked if(is.function(f)) { return(rpoint(n, f, fmax, win, nsim=nsim, warn=warn, giveup=giveup, verbose=verbose)) } else { return(rpoint(n, f, fmax, nsim=nsim, warn=warn, giveup=giveup, verbose=verbose)) } } ## multitype case: validate arguments if(length(marks) != n) stop("length of marks vector != n") if(!is.factor(marks)) stop("marks should be a factor") types <- levels(marks) types <- factor(types, levels=types) nums <- table(marks) if(warn) { nhuge <- spatstat.options("huge.npoints") if(n > nhuge) { whinge <- paste("Attempting to generate", n, "random points") if(nsim > 1) whinge <- paste(whinge, paren(paste(nsim, "times"))) warning(whinge, call.=FALSE) } } ## simulate resultlist <- vector(mode="list", length=nsim) ## generate required number of points of each type Xlist <- rmpoint(nums, f, fmax, win=win, types=types, nsim=nsim, drop=FALSE, giveup=giveup, verbose=verbose) ## Reorder them to correspond to the desired 'marks' vector for(isim in seq_len(nsim)) { X <- Xlist[[isim]] if(any(table(marks(X)) != nums)) stop("Internal error: output of rmpoint illegal") Y <- X Xmarks <- marks(X) for(ty in types) { to <- (marks == ty) from <- (Xmarks == ty) if(sum(to) != sum(from)) stop(paste("Internal error: mismatch for mark =", ty)) if(any(to)) { Y$x[to] <- X$x[from] Y$y[to] <- X$y[from] Y$marks[to] <- ty } } resultlist[[isim]] <- Y } return(simulationresult(resultlist, nsim, drop)) } spatstat.random/R/randomonlines.R0000644000176200001440000001451514331654772016612 0ustar liggesusers# # randomOnLines.R # # $Revision: 1.11 $ $Date: 2022/04/06 07:10:51 $ # # Generate random points on specified lines # runifpointOnLines <- function(n, L, nsim=1, drop=TRUE) { if(!is.numeric(n) || any(n < 0) || any(n %% 1 != 0)) stop("n should be a nonnegative integer or integers") check.1.integer(nsim) stopifnot(nsim >= 0) if(!is.psp(L)) L <- as.psp(L) W <- as.owin(L) result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { X <- datagen.runifpointOnLines(n, L) Y <- ppp(X$x, X$y, marks=X$marks, window=W, check=FALSE) result[[i]] <- Y } result <- simulationresult(result, nsim, drop) return(result) } datagen.runifpointOnLines <- function(n, L) { stopifnot(is.psp(L)) m <- length(n) ismarked <- (m > 1) if(m == 0 || (m == 1 && n == 0)) return(data.frame(x=numeric(0), y=numeric(0), seg=integer(0), tp=numeric(0))) # extract segment information len <- lengths_psp(L) sumlen <- sum(len) cumlen <- cumsum(len) cum0len <- c(0, cumlen) Ldf <- as.data.frame(L) x0 <- with(Ldf, x0) y0 <- with(Ldf, y0) dx <- with(Ldf, x1-x0) dy <- with(Ldf, y1-y0) # determine mark space if(ismarked) { markvalues <- names(n) if(sum(nzchar(markvalues)) < m) markvalues <- paste(1:m) } # initialise output data.frame out <- data.frame(x=numeric(0), y=numeric(0), seg=integer(0), tp=numeric(0)) if(ismarked) out <- cbind(out, data.frame(marks=character(0))) # generate points of each mark in turn for(j in 1:m) { if(n[[j]] > 0) { # generate random positions uu <- runif(n[[j]], min=0, max=sumlen) # identify segment for each point kk <- findInterval(uu, cum0len, rightmost.closed=TRUE, all.inside=TRUE) # parametric position along segment tt <- (uu - cum0len[kk])/len[kk] tt[!is.finite(tt)] <- 0 # convert to (x,y) x <- x0[kk] + tt * dx[kk] y <- y0[kk] + tt * dy[kk] # assemble result if(!ismarked) { out <- data.frame(x=x, y=y, seg=kk, tp=tt) } else { outj <- data.frame(x=x, y=y, seg=kk, tp=tt, marks=markvalues[j]) out <- rbind(out, outj) } } } if(ismarked) out$marks <- factor(out$marks, levels=markvalues) return(out) } runifpoisppOnLines <- function(lambda, L, nsim=1, drop=TRUE) { if(!is.numeric(lambda) || !all(is.finite(lambda) && (lambda >= 0))) stop("lambda should be a finite, nonnegative number or numbers") check.1.integer(nsim) stopifnot(nsim >= 0) if(!is.psp(L)) L <- as.psp(L) W <- as.owin(L) result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { X <- datagen.runifpoisppOnLines(lambda, L) Y <- ppp(X$x, X$y, marks=X$marks, window=W, check=FALSE) result[[i]] <- Y } result <- simulationresult(result, nsim, drop) return(result) } datagen.runifpoisppOnLines <- function(lambda, L) { stopifnot(is.psp(L)) mu <- lambda * sum(lengths_psp(L)) n <- rpois(rep.int(1, length(mu)), mu) if(length(n) > 1) names(n) <- names(lambda) df <- datagen.runifpointOnLines(n, L) return(df) } rpoisppOnLines <- function(lambda, L, lmax=NULL, ..., nsim=1, drop=TRUE) { check.1.integer(nsim) stopifnot(nsim >= 0) if(!is.psp(L)) L <- as.psp(L) W <- as.owin(L) result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { X <- datagen.rpoisppOnLines(lambda, L, lmax=lmax, ...) Y <- ppp(X$x, X$y, marks=X$marks, window=W, check=FALSE) result[[i]] <- Y } result <- simulationresult(result, nsim, drop) return(result) } datagen.rpoisppOnLines <- function(lambda, L, lmax=NULL, ..., check=TRUE) { stopifnot(is.psp(L)) if(is.numeric(lambda)) return(datagen.runifpoisppOnLines(lambda, L)) # ensure lambda is a list if(is.function(lambda) || is.im(lambda)) lambda <- list(lambda) m <- length(lambda) # determine type of argument argtype <- if(all(unlist(lapply(lambda, is.im)))) "im" else if(all(unlist(lapply(lambda, is.function)))) "function" else stop(paste(sQuote("lambda"), "must be a numeric vector, a function, an image,", "a list of functions, or a list of images")) # check values of lambda if(argtype == "im") { for(j in seq_len(m)) { lamj <- lambda[[j]] if(!(lamj$type %in% c("real", "integer"))) stop("lambda must be numeric-valued or integer-valued") lrange <- range(lamj) if(any(is.infinite(lrange))) stop("Infinite pixel values not permitted") if(lrange[1] < 0) stop("Negative pixel values not permitted") } } # determine uniform bound if(!is.null(lmax)) { stopifnot(is.numeric(lmax)) if(length(lmax) != m) { if(length(lmax) == 1) { lmax <- rep.int(lmax, m) } else stop("Length of lmax does not match length of lambda") } } else { # compute lmax lmax <- numeric(m) for(j in seq_len(m)) { lamj <- lambda[[j]] if(is.function(lamj)) { X <- pointsOnLines(L, np=10000) lambdaX <- lamj(X$x, X$y, ...) lmax[j] <- max(lambdaX, na.rm=TRUE) } else if(is.im(lamj)) lmax[j] <- max(lamj) } if(!all(is.finite(lmax))) stop("Infinite values of lambda obtained") if(any(lmax < 0)) stop("Negative upper bound for lambda obtained") names(lmax) <- names(lambda) } # Lewis-Shedler (rejection) method Y <- datagen.runifpoisppOnLines(lmax, L) n <- nrow(Y) if(n == 0) return(Y) # evaluate lambda at each simulated point if(m == 1) { lambda <- lambda[[1]] markindex <- 1 if(is.function(lambda)) lambdaY <- lambda(Y$x, Y$y, ...) else lambdaY <- safelookup(lambda, as.ppp(Y, W=as.owin(L))) } else { lambdaY <- numeric(n) markindex <- as.integer(Y$marks) for(j in seq_len(m)) { lamj <- lambda[[j]] jrows <- (markindex == j) Yj <- Y[jrows, , drop=FALSE] if(is.function(lamj)) lambdaY[jrows] <- lamj(Yj$x, Yj$y, ...) else lambdaY[jrows] <- safelookup(lamj, as.ppp(Yj, W=as.owin(L))) } } lambdaY[is.na(lambdaY)] <- 0 # accept/reject pY <- lambdaY/lmax[markindex] if(check) { if(any(pY < 0)) warning("Negative values of lambda obtained") if(any(pY > 1)) warning("lmax is not an upper bound for lambda") } retain <- (runif(n) < pY) Y <- Y[retain, , drop=FALSE] return(Y) } spatstat.random/R/rPerfect.R0000644000176200001440000002142714331654772015514 0ustar liggesusers# # Perfect Simulation # # $Revision: 1.26 $ $Date: 2022/05/21 08:53:38 $ # # rStrauss # rHardcore # rStraussHard # rDiggleGratton # rDGS # rPenttinen rStrauss <- function(beta, gamma=1, R=0, W=owin(), expand=TRUE, nsim=1, drop=TRUE) { if(!missing(W)) verifyclass(W, "owin") check.1.real(beta) check.1.real(gamma) check.1.real(R) check.finite(beta) check.finite(gamma) check.finite(R) stopifnot(beta > 0) stopifnot(gamma >= 0) stopifnot(gamma <= 1) stopifnot(R >= 0) runif(1) Wsim <- expandwinPerfect(W, expand, rmhexpand(distance=2*R)) xrange <- Wsim$xrange yrange <- Wsim$yrange result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { storage.mode(beta) <- storage.mode(gamma) <- storage.mode(R) <- "double" storage.mode(xrange) <- storage.mode(yrange) <- "double" z <- .Call(SR_PerfectStrauss, beta, gamma, R, xrange, yrange, PACKAGE="spatstat.random") X <- z[[1]] Y <- z[[2]] nout <- z[[3]] times <- c(start=z[[4]], end=z[[5]]) if(nout<0) stop("internal error: copying failed in PerfectStrauss") seqn <- seq_len(nout) P <- ppp(X[seqn], Y[seqn], window=Wsim, check=FALSE) if(attr(Wsim, "changed")) P <- P[W] attr(P, "times") <- times if(nsim == 1 && drop) return(P) result[[i]] <- P } result <- simulationresult(result, nsim, drop) return(result) } # Perfect Simulation of Hardcore process rHardcore <- function(beta, R=0, W=owin(), expand=TRUE, nsim=1, drop=TRUE) { if(!missing(W)) verifyclass(W, "owin") check.1.real(beta) check.1.real(R) check.finite(beta) check.finite(R) stopifnot(beta > 0) stopifnot(R >= 0) runif(1) Wsim <- expandwinPerfect(W, expand, rmhexpand(distance=2*R)) xrange <- Wsim$xrange yrange <- Wsim$yrange result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { storage.mode(beta) <- storage.mode(R) <- "double" storage.mode(xrange) <- storage.mode(yrange) <- "double" z <- .Call(SR_PerfectHardcore, beta, R, xrange, yrange, PACKAGE="spatstat.random") X <- z[[1]] Y <- z[[2]] nout <- z[[3]] if(nout<0) stop("internal error: copying failed in PerfectHardcore") seqn <- seq_len(nout) P <- ppp(X[seqn], Y[seqn], window=Wsim, check=FALSE) if(attr(Wsim, "changed")) P <- P[W] if(nsim == 1 && drop) return(P) result[[i]] <- P } result <- simulationresult(result, nsim, drop) return(result) } # # Perfect simulation of hybrid Strauss-Hardcore # provided gamma <= 1 # rStraussHard <- function(beta, gamma=1, R=0, H=0, W=owin(), expand=TRUE, nsim=1, drop=TRUE) { if(!missing(W)) verifyclass(W, "owin") check.1.real(beta) check.1.real(gamma) check.1.real(R) check.1.real(H) check.finite(beta) check.finite(gamma) check.finite(R) check.finite(H) stopifnot(beta > 0) stopifnot(gamma >= 0) if(gamma > 1) stop("Sorry, perfect simulation is only implemented for gamma <= 1") stopifnot(R >= 0) stopifnot(H >= 0) stopifnot(H <= R) runif(1) Wsim <- expandwinPerfect(W, expand, rmhexpand(distance=2*R)) xrange <- Wsim$xrange yrange <- Wsim$yrange result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { storage.mode(beta) <- storage.mode(gamma) <- storage.mode(R) <- storage.mode(H) <- "double" storage.mode(xrange) <- storage.mode(yrange) <- "double" z <- .Call(SR_PerfectStraussHard, beta, gamma, R, H, xrange, yrange, PACKAGE="spatstat.random") X <- z[[1]] Y <- z[[2]] nout <- z[[3]] if(nout<0) stop("internal error: copying failed in PerfectStraussHard") seqn <- seq_len(nout) P <- ppp(X[seqn], Y[seqn], window=Wsim, check=FALSE) if(attr(Wsim, "changed")) P <- P[W] if(nsim == 1 && drop) return(P) result[[i]] <- P } result <- simulationresult(result, nsim, drop) return(result) } # # Perfect Simulation of Diggle-Gratton process # rDiggleGratton <- function(beta, delta, rho, kappa=1, W=owin(), expand=TRUE, nsim=1, drop=TRUE) { if(!missing(W)) verifyclass(W, "owin") check.1.real(beta) check.1.real(delta) check.1.real(rho) check.1.real(kappa) check.finite(beta) check.finite(delta) check.finite(rho) check.finite(kappa) stopifnot(beta > 0) stopifnot(delta >= 0) stopifnot(rho >= 0) stopifnot(delta <= rho) stopifnot(kappa >= 0) runif(1) Wsim <- expandwinPerfect(W, expand, rmhexpand(distance=2*rho)) xrange <- Wsim$xrange yrange <- Wsim$yrange result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { storage.mode(beta) <- "double" storage.mode(delta) <- storage.mode(rho) <- storage.mode(kappa) <- "double" storage.mode(xrange) <- storage.mode(yrange) <- "double" z <- .Call(SR_PerfectDiggleGratton, beta, delta, rho, kappa, xrange, yrange, PACKAGE="spatstat.random") X <- z[[1]] Y <- z[[2]] nout <- z[[3]] if(nout<0) stop("internal error: copying failed in PerfectDiggleGratton") seqn <- seq_len(nout) P <- ppp(X[seqn], Y[seqn], window=Wsim, check=FALSE) if(attr(Wsim, "changed")) P <- P[W] if(nsim == 1 && drop) return(P) result[[i]] <- P } result <- simulationresult(result, nsim, drop) return(result) } # # Perfect Simulation of Diggle-Gates-Stibbard process # rDGS <- function(beta, rho, W=owin(), expand=TRUE, nsim=1, drop=TRUE) { if(!missing(W)) verifyclass(W, "owin") check.1.real(beta) check.1.real(rho) check.finite(beta) check.finite(rho) stopifnot(beta > 0) stopifnot(rho >= 0) runif(1) Wsim <- expandwinPerfect(W, expand, rmhexpand(distance=2*rho)) xrange <- Wsim$xrange yrange <- Wsim$yrange result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { storage.mode(beta) <- "double" storage.mode(rho) <- "double" storage.mode(xrange) <- storage.mode(yrange) <- "double" z <- .Call(SR_PerfectDGS, beta, rho, xrange, yrange, PACKAGE="spatstat.random") X <- z[[1]] Y <- z[[2]] nout <- z[[3]] if(nout<0) stop("internal error: copying failed in PerfectDGS") seqn <- seq_len(nout) P <- ppp(X[seqn], Y[seqn], window=Wsim, check=FALSE) if(attr(Wsim, "changed")) P <- P[W] if(nsim == 1 && drop) return(P) result[[i]] <- P } result <- simulationresult(result, nsim, drop) return(result) } # # Perfect Simulation of Penttinen process # rPenttinen <- function(beta, gamma=1, R, W=owin(), expand=TRUE, nsim=1, drop=TRUE) { if(!missing(W)) verifyclass(W, "owin") check.1.real(beta) check.1.real(gamma) check.1.real(R) check.finite(beta) check.finite(gamma) check.finite(R) stopifnot(beta > 0) stopifnot(gamma >= 0) stopifnot(gamma <= 1) stopifnot(R >= 0) runif(1) Wsim <- expandwinPerfect(W, expand, rmhexpand(distance=2*R)) xrange <- Wsim$xrange yrange <- Wsim$yrange result <- vector(mode="list", length=nsim) for(i in seq_len(nsim)) { storage.mode(beta) <- storage.mode(gamma) <- storage.mode(R) <- "double" storage.mode(xrange) <- storage.mode(yrange) <- "double" z <- .Call(SR_PerfectPenttinen, beta, gamma, R, xrange, yrange, PACKAGE="spatstat.random") X <- z[[1]] Y <- z[[2]] nout <- z[[3]] if(nout<0) stop("internal error: copying failed in PerfectPenttinen") seqn <- seq_len(nout) P <- ppp(X[seqn], Y[seqn], window=Wsim, check=FALSE) if(attr(Wsim, "changed")) P <- P[W] if(nsim == 1 && drop) return(P) result[[i]] <- P } result <- simulationresult(result, nsim, drop) return(result) } ## ....... utilities ................................. expandwinPerfect <- function(W, expand, amount) { ## expand 'W' if expand=TRUE according to default 'amount' ## or expand 'W' using rmhexpand(expand) if(!is.logical(expand)) { amount <- rmhexpand(expand) expand <- TRUE } changed <- FALSE if(expand) { W <- expand.owin(W, amount) changed <- TRUE } if(!is.rectangle(W)) { W <- as.rectangle(W) changed <- TRUE warning(paste("Simulation will be performed in the containing rectangle", "and clipped to the original window."), call.=FALSE) } attr(W, "changed") <- changed return(W) } spatstat.random/R/defaultwin.R0000644000176200001440000000247514331654772016106 0ustar liggesusers# # # defaultwin.R # # $Revision: 1.11 $ $Date: 2022/01/03 05:43:45 $ # default.expand <- function(object, m=2, epsilon=1e-6, w=Window(object)) { stopifnot(inherits(object, c("ppm", "rmhmodel"))) # no expansion necessary if model is Poisson if(is.poisson(object)) return(.no.expansion) # default is no expansion if model is nonstationary if(!is.stationary(object)) return(.no.expansion) # Redundant since a non-expandable model is non-stationary # if(!is.expandable(object)) # return(.no.expansion) # rule is to expand data window by distance d = m * reach rr <- reach(object, epsilon=epsilon) if(!is.finite(rr)) return(rmhexpand()) if(!is.numeric(m) || length(m) != 1 || m < 1) stop("m should be a single number >= 1") mr <- m * rr rule <- rmhexpand(distance = mr) # if(is.owin(w)) { # apply rule to window wplus <- expand.owin(w, rule) # save as new expansion rule rule <- rmhexpand(wplus) } return(rule) } default.clipwindow <- function(object, epsilon=1e-6) { stopifnot(inherits(object, c("ppm", "rmhmodel"))) # data window w <- as.owin(object) if(is.null(w)) return(NULL) # interaction range of model rr <- reach(object, epsilon=epsilon) if(!is.finite(rr)) return(NULL) if(rr == 0) return(w) else return(erosion(w, rr)) } spatstat.random/R/truncpois.R0000644000176200001440000000772014372414056015762 0ustar liggesusers#' Truncated Poisson random variables #' #' $Revision: 1.5 $ $Date: 2023/02/13 10:57:29 $ #' #' Copyright (C) Adrian Baddeley and Ya-Mei Chang 2022 #' GNU Public Licence >= 2 rpoisnonzero <- function(n, lambda, method=c("harding", "transform"), implem=c("R", "C")) { ## Poisson random variable, conditioned to be nonzero method <- match.arg(method) implem <- match.arg(implem) switch(implem, R = { switch(method, harding = { ## From a post by Ted Harding (2005) lam1 <- lambda + log(runif(n, min=exp(-lambda), max=1)) lam1 <- pmax(0, lam1) ## avoid numerical glitches (lam1 is theoretically > 0) y <- rpois(n, lam1) + 1L }, transform = { ## From a post by Peter Dalgaard (2005) in response to Harding ## Surprisingly, this is 3 times slower! y <- as.integer(qpois(runif(n, min=exp(-lambda), max=1), lambda)) }) }, C = { storage.mode(n) <- "integer" storage.mode(lambda) <- "double" switch(method, harding = { y <- .Call(SR_RrnzpoisHarding, n, lambda, PACKAGE="spatstat.random") }, transform = { y <- .Call(SR_RrnzpoisDalgaard, n, lambda, PACKAGE="spatstat.random") }) }) return(y) } rpoistrunc <- function(n, lambda, minimum=1, method=c("harding", "transform"), implem=c("R", "C")) { ## Poisson random variable, conditioned to be at least 'minimum' stopifnot(all(is.finite(minimum))) minimum <- pmax(0L, as.integer(minimum)) method <- match.arg(method) implem <- match.arg(implem) switch(implem, R = { switch(method, transform = { y <- qpois(runif(n, min=ppois(minimum-1L, lambda), max=1), lambda) }, harding = { if(length(minimum) == 1) { for(k in seq_len(minimum)) lambda <- pmax(0, lambda + log(1 - runif(n) * (1 - exp(-lambda)))) } else if(length(minimum) == n) { if(length(lambda) == 1) lambda <- rep(lambda, n) remaining <- minimum while(any(todo <- (remaining > 0))) { lambda[todo] <- pmax(0, lambda[todo] + log(1 - runif(sum(todo)) * (1 - exp(-lambda[todo])))) remaining[todo] <- remaining[todo] - 1L } } else stop("Argument 'minimum' should be a vector of length 1 or n", call.=FALSE) y <- rpois(n, lambda) + minimum }) }, C = { storage.mode(n) <- "integer" storage.mode(lambda) <- "double" storage.mode(minimum) <- "integer" switch(method, harding = { y <- .Call(SR_RrtruncpoisHarding, n, lambda, minimum, PACKAGE="spatstat.random") }, transform = { y <- .Call(SR_RrtruncpoisDalgaard, n, lambda, minimum, PACKAGE="spatstat.random") }) }) return(y) } recipEnzpois <- function(mu, exact=TRUE) { ## first reciprocal moment of nzpois if(exact && isNamespaceLoaded("gsl")) { gamma <- -digamma(1) ans <- (gsl::expint_Ei(mu) - log(mu) - gamma) * exp(-mu) /(1 - exp(-mu)) return(ans) } else { n <- length(mu) ans <- numeric(n) xx <- 1:max(ceiling(mu + 6 * sqrt(mu)), 100) for(i in 1:n) ans[i] <- sum(dpois(xx, mu[i])/xx)/(1 - exp(-mu[i])) } return(ans) } spatstat.random/R/rknn.R0000644000176200001440000000203214331654772014701 0ustar liggesusers# # rknn.R # # Distribution of distance to k-th nearest point in d dimensions # (Poisson process of intensity lambda) # # $Revision: 1.2 $ $Date: 2009/12/31 01:33:44 $ # dknn <- function(x, k=1, d=2, lambda=1) { validposint(k, "dknn") validposint(d, "dknn") alpha.d <- (2 * pi^(d/2))/(d * gamma(d/2.)) y <- dgamma(x^d, shape=k, rate=lambda * alpha.d) y <- y * d * x^(d-1) return(y) } pknn <- function(q, k=1, d=2, lambda=1) { validposint(k, "pknn") validposint(d, "pknn") alpha.d <- (2 * pi^(d/2))/(d * gamma(d/2.)) p <- pgamma(q^d, shape=k, rate=lambda * alpha.d) return(p) } qknn <- function(p, k=1, d=2, lambda=1) { validposint(k, "qknn") validposint(d, "qknn") alpha.d <- (2 * pi^(d/2))/(d * gamma(d/2.)) y <- qgamma(p, shape=k, rate=lambda * alpha.d) z <- y^(1/d) return(z) } rknn <- function(n, k=1, d=2, lambda=1) { validposint(k, "rknn") validposint(d, "rknn") alpha.d <- (2 * pi^(d/2))/(d * gamma(d/2.)) y <- rgamma(n, shape=k, rate=lambda * alpha.d) x <- y^(1/d) return(x) } spatstat.random/R/rmhResolveTypes.R0000644000176200001440000000612414331654772017112 0ustar liggesusers# # # rmhResolveTypes.R # # $Revision: 1.10 $ $Date: 2019/02/20 03:34:50 $ # # rmhResolveTypes <- function(model, start, control) { # Decide whether a multitype point process is to be simulated. # If so, determine the vector of types. verifyclass(model, "rmhmodel") verifyclass(start, "rmhstart") verifyclass(control, "rmhcontrol") # Different ways of specifying types directly types.model <- model$types types.start <- if(start$given=="x" && is.marked(x.start <- start$x.start)) levels(marks(x.start, dfok=FALSE)) else NULL # Check for inconsistencies if(!is.null(types.model) && !is.null(types.start)) if(!isTRUE(all.equal(types.model, types.start))) stop("marks in start$x.start do not match model$types") types.given <- if(!is.null(types.model)) types.model else types.start types.given.source <- if(!is.null(types.model)) "model$types" else "marks of x.start" # Different ways of implying the number of types ntypes.beta <- length(model$par[["beta"]]) ntypes.ptypes <- length(control$ptypes) ntypes.nstart <- if(start$given == "n") length(start$n.start) else 0 mot <- model$trend ntypes.trend <- if(is.null(mot)) 0 else if(is.im(mot)) 1 else if(is.list(mot) && all(unlist(lapply(mot, is.im)))) length(mot) else 0 # Check for inconsistencies in implied number of types (only for numbers > 1) nty <- c(ntypes.beta, ntypes.ptypes, ntypes.nstart, ntypes.trend) nam <- c("model$par$beta", "control$ptypes", "start$n.start", "model$trend") implied <- (nty > 1) if(!any(implied)) ntypes.implied <- 1 else { if(length(unique(nty[implied])) > 1) stop(paste("Mismatch in numbers of types implied by", commasep(sQuote(nam[implied])))) ntypes.implied <- unique(nty[implied]) ntypes.implied.source <- (nam[implied])[1] } # Check consistency between types.given and ntypes.implied if(!is.null(types.given) && ntypes.implied > 1) if(length(types.given) != ntypes.implied) stop(paste("Mismatch between number of types in", types.given.source, "and length of", ntypes.implied.source)) # Finally determine the types if(model$multitype.interact) { # There MUST be a types vector types <- if(!is.null(types.given)) types.given else if(ntypes.implied > 1) 1:ntypes.implied else stop("Cannot determine types for multitype process") } else { types <- if(!is.null(types.given)) types.given else if(ntypes.implied > 1) 1:ntypes.implied else 1 } ntypes <- length(types) # If we are conditioning on the number of points of each type, # make sure the starting state is appropriate if(control$fixing == "n.each.type") { if(start$given == "n" && ntypes.nstart != ntypes) stop("Length of start$n.start not equal to number of types.\n") else if(start$given == "x" && length(types.given) != ntypes) stop("Marks of start$x.start do not match number of types.\n") } return(types) } spatstat.random/MD50000644000176200001440000002237114570061662013720 0ustar liggesusers350142deec8ceaeae66de992e2488553 *DESCRIPTION 8f3ebf9e451d75b92b35f9e4ffd17930 *NAMESPACE e87717572ec5091b50f95cf38e0a036e *NEWS 5d9344c59bff8a6f68b22efd5a417699 *R/First.R 387e7d55d7abd6f7e540d04e18a4c4e2 *R/clusterfunctions.R 5b15e14699620192b87b9520ea795dec *R/clusterinfo.R 0b6eb3ae590ccc11804eb7f9670d666d *R/clustersiminfo.R 61a36590b162750cf3fa426976b3102f *R/defaultwin.R 123085aba3859361ca3f643e7c956c6f *R/hermite.R 3d716e65c49c9e3adc713dbec35f4772 *R/indefinteg.R 51c369d401fb72499fb7d75b051a63ad *R/is.cadlag.R 23ade743ff6f39f31ff1bf52ee73f088 *R/multipair.util.R 2c8a08c946490c5fcbbdbe1f72ec6f57 *R/pakes.R ba6ac9d4b5ebfe6f21aeb810c9962a5c *R/pkgRandomFields.R cc7fc0270683fcf28f0f85df7986c0cf *R/quadratresample.R 41b71c536a4c385f71e0adbd94cd2844 *R/rLGCP.R 8700883da65cb933e3743867ac12e915 *R/rPSNCP.R 01ae4b025e9c8508678794363d7c7eb7 *R/rPerfect.R 6e0b2255bf8b42f5a236c391b10306de *R/rags.R a315ace083bcf09fbc5fd2ede32e9ab4 *R/random.R 73b70afa74d324923fd971bc1a4f8bbc *R/randomImage.R d0a162aba117a643d524628a74063c71 *R/randomNS.R c6d14da3d2bf295d1b07a4ee811e9803 *R/randomcircembed.R cb784f7fa1b9a4f532e55d92182246b0 *R/randomfields.R fa2a20908845ff06b7c75266fb0a56d9 *R/randommk.R fac172098bc8d921bbee039fa5960a58 *R/randomonlines.R da0a6c487bef4861f02a4b2f2d6e187e *R/randompp3.R 9b1b528a355c12a27ea5f1bf395d06be *R/randomppx.R af08f115480fb435ecb6a98a8fb69fb8 *R/randomseg.R 6639370480c1a574a374d926f2ac2fba *R/randomsets.R a64da31a74883d6fb9e4cb87d6f4a4cd *R/randomtess.R eedacd1030c98a28581e77fdd3705ea3 *R/rcauchy.R 5902102702c79db1d3290e7e2d1a92bf *R/rclusterBKBC.R dd60ae022589a470a663af764cb7574e *R/reach.R f47c0eccaa94d6655967d988635109f5 *R/rknn.R 46885b3952522553234694e60b4bd8e5 *R/rlabel.R b67ff7143d02386e3cde0eaa6f54feea *R/rmatclust.R 35f1e78c4ec615ebdf02bf522d15dbe7 *R/rmh.R 73158a8982726284b0129765db3606a3 *R/rmh.default.R 0605d8f7db7997e78130f55a254d025c *R/rmhResolveTypes.R f38b36afeb02d76d09e32dbe5f7d368e *R/rmhcontrol.R a7ffe5c139a6e0cf993f43da59318ab1 *R/rmhexpand.R 5179e7f91f166e43870bc3b80222a2b4 *R/rmhmodel.R 84aa673b10d202f5ca8d2328ddcfdfd5 *R/rmhsnoop.R 112482932314aa9b1dba3ec93d6d0892 *R/rmhstart.R 6378d22817e69ed8dec33950baa86f63 *R/rmhtemper.R f369866b700d69d132d1735b5ffa68f4 *R/rshift.R d6ba8cf2081775fdeb37cbdc610db598 *R/rshift.psp.R 5a0df3c5a0e34aa6647bbd0f305f47ff *R/rthomas.R 2ac2aa88417d99ec2be3f35ec07d0920 *R/rvargamma.R c5a0753a40db0a65ae4ee2d598a8388c *R/truncpois.R f2d49fc8f50fef7f76bcb3fc7f34efb4 *inst/CITATION 00b8fb76b984dfb3dcd39d1fa7096447 *inst/doc/packagesizes.txt dbe7862892d2639e1ecca3511d68bf69 *man/Window.rmhmodel.Rd da9155cac50c287f7f58564822e06fff *man/as.owin.rmhmodel.Rd 61c0c87549ae2caaa1bbaba32c7006c7 *man/clusterfield.Rd 05d78d37fc21c8ae121529d300632daa *man/clusterkernel.Rd f30e2c9a9684819a17a2ba08e1338ea3 *man/clusterradius.Rd e72f939250e88367ec86b9c186699dd5 *man/default.expand.Rd bdb74e282f4ddbfbdc1f351f1f5e7220 *man/default.rmhcontrol.Rd 8203fba31ada9ac91ebc681f14b3ab27 *man/dmixpois.Rd a69ca6f1fe59a48ae325d252abf25e9a *man/domain.rmhmodel.Rd d08e61ff122629a2fbdf6df56619a222 *man/dpakes.Rd 6e1d4f4674976dcd96b752dcf9063a90 *man/expand.owin.Rd 8786b2679753de57cff66911fd4822a9 *man/gauss.hermite.Rd 461213181774879a7640a252503bf799 *man/indefinteg.Rd 1fbc3bbdb4fff2e7451930a27a991f0f *man/is.stationary.Rd a2f94d84ffd9011c01a6d3e9e9a6c7e8 *man/macros/defns.Rd 72bd20c301c4de55a5a1564a8c12f02f *man/quadratresample.Rd 823c0b02c8475d6fb17b40414e6ffabd *man/rCauchy.Rd 53dbaf7c3e052ee4bbf2b1aa0fdfe246 *man/rDGS.Rd 7269435b2ac3354ee65a8c71c3ac9c83 *man/rDiggleGratton.Rd 08e89870e624574222db2a21bd3cb9b7 *man/rGaussPoisson.Rd 1a3c82b3f5454624af13efe031c33eda *man/rHardcore.Rd 03e72beb2f1ab8938ab38f2962cdc17f *man/rLGCP.Rd 14620f05715818bd68487aae653a461a *man/rMatClust.Rd add9d75ec3e07cf63da3152bc7394790 *man/rMaternI.Rd 197cd3def617904dd5e1674df6277029 *man/rMaternII.Rd dc02e564567ced0333f43690a38768d7 *man/rMosaicField.Rd 97b6dc47ace0aeb7a512c1da8150268d *man/rMosaicSet.Rd df76cdf31a19a0cce7fdb1ff422f4c14 *man/rNeymanScott.Rd 63af320a657cc764b0b99c19834b953b *man/rPSNCP.Rd 96b41ead2b472a820a8d9a0271bba0f1 *man/rPenttinen.Rd c3f967d1debab3c8988ce8bd83bf356c *man/rPoissonCluster.Rd 946044fbcef67d750f2a19149852d447 *man/rSSI.Rd 9b2719db270f33bdfe9f37eef41016dd *man/rStrauss.Rd e7d7db2739548524f747c810060dc23d *man/rStraussHard.Rd 6336331702f723e5dfd4e56ef2e9e284 *man/rThomas.Rd 13f8812734bbca253e338b8c5eee3342 *man/rVarGamma.Rd 06b4734065de51fde94d9942efa1bb21 *man/rags.Rd 8d78be0947bbfa49c8ce09808dac7c07 *man/ragsAreaInter.Rd 5a52a13916cea8fb68a7bcb5c504afc7 *man/ragsMultiHard.Rd f0a1b21eaeb8f224376bdb67a508f030 *man/rcell.Rd 55aeb0c742804dd2fd18971d10ebdce1 *man/rcellnumber.Rd c38987193aaaa852b3064a4d13439232 *man/rclusterBKBC.Rd e209dfd3cd3f8122f80775e4b04a301c *man/reach.Rd d624006fc909a346262d1a4ec681f284 *man/recipEnzpois.Rd 0db3350330da05f76e6f5cf7cef51613 *man/rjitter.psp.Rd 6dc4bbb5b1b2e45f381673a7488bbd44 *man/rknn.Rd 7742b613ad127d747aca21db1001bab5 *man/rlabel.Rd 2e420ef000d9ca0d1ba8527e06d5ad13 *man/rmh.Rd 8b403983996c4e6e1dcbc34f0bc2ed9b *man/rmh.default.Rd fdaddf3b950e9b7e871b06f3f656d303 *man/rmhcontrol.Rd 7fb92fafe4152451c5f54116faae6d69 *man/rmhexpand.Rd 3213174410437397f18cd1167bebbde5 *man/rmhmodel.Rd e209fb2322b5e0f2b76f4372920dca59 *man/rmhmodel.default.Rd d781a6d685c716876c9df633aafd4c85 *man/rmhmodel.list.Rd c90b65188f256e0148e9b4152756a244 *man/rmhstart.Rd 6daa23722b901914bfec1925fe57ec22 *man/rmpoint.Rd 5b656b479bf85f0f5846165093cc8d38 *man/rmpoispp.Rd 00b9cb8b6413301c0182c77f3c7180d6 *man/rnoise.Rd e6e0db24735267a80f8897df31fa4f59 *man/rpoint.Rd b6a91ef76fbc45e3cb1bef941d8e4b83 *man/rpoisline.Rd c255f30dc83d855d2b57e9318ffbb3fb *man/rpoislinetess.Rd bb50b77b0b147bf0c5acf32f70d9f74c *man/rpoispp.Rd 101a4920eb4827793a418f39824f41ea *man/rpoispp3.Rd c0c57551015e5587fae41ec41d2b56bc *man/rpoisppOnLines.Rd a6b80bce2cc88f746bf34ad4e7048d6f *man/rpoisppx.Rd 7e4c57ca8690a2ec179fd8e11333a8f2 *man/rpoistrunc.Rd df2d3a4e251d836e48a93416afc150ce *man/rshift.Rd bbb92658bb476c82b3332fb96991bdd5 *man/rshift.ppp.Rd 7025e64603cca3771c59a17930a9d413 *man/rshift.psp.Rd 6d177c2afb16d6b543f518ec0d2b01ec *man/rshift.splitppp.Rd af9052ff2629fa829c737a30e8d2b1fb *man/rstrat.Rd c4157b8d8685b40d66bf2a8b3c32bc5b *man/rtemper.Rd bfe74e8bbf78cbf76f290ca6d57e7748 *man/rthin.Rd e5f0ef76ed15fe38919f8eaac90df411 *man/rthinclumps.Rd 0f58540ffbc0d6b01fc785934fde788c *man/runifdisc.Rd c6cd0ff924c28e87c8f626eca487c326 *man/runifpoint.Rd b61c30d25084573f922c6620f730753f *man/runifpoint3.Rd dd5048dab20cece81901d32fc828845b *man/runifpointOnLines.Rd a9273f2fccb179783c06c7ff39ec6492 *man/runifpointx.Rd 5181330e2a998278652e6a5ed5a649a7 *man/spatstat.random-internal.Rd 4de27c93808acd9d1e6248f4bb89a844 *man/spatstat.random-package.Rd 70f976c07e44c9fe6bf41b9d55d326cc *man/update.rmhcontrol.Rd 513778fbca80df00f2ea2b710263fe3c *man/will.expand.Rd 158db2ee29e3d11ee619715236d57c3c *src/Perfect.cc 03dff82c055d7d1e868e3e732102694e *src/PerfectDGS.h a8e0e937efc81c2f9035c20ca57e0bf4 *src/PerfectDiggleGratton.h 76cad4da7245795fe2ff420e8b635788 *src/PerfectHardcore.h c2f1cecf3281442fb53825834c278fb8 *src/PerfectPenttinen.h 62f1d9151646a0e7cde183356d8ff5af *src/PerfectStrauss.h 6811bea314793ed000772db2b51f24a8 *src/PerfectStraussHard.h 021f5341bfbef8354d0ceb8c3ef6f32c *src/areaint.c 96edcdc200f7f2700d2218214d5ca101 *src/badgey.c 542e6e474340e0aac3ed97f6a92777b4 *src/chunkloop.h becea4a1ea42b8a39021c01abdc6459d *src/constants.h c54114ead94794266a4966f1c014cf94 *src/dgs.c 0ce51b50c95dca83ba7e45bd4393d607 *src/diggra.c 69f4991661275bb8a06c47cf490119c9 *src/dist2.c bcfef6be58ba5ee2fd30dd3dbd8c216f *src/dist2.h 510fed26942dbced92e341d03fe0b436 *src/fiksel.c 8a4c874bb24d350ebccfe42f43ce8d08 *src/getcif.c 437a7afc64e7fed2e6580add30fdedee *src/geyer.c d8f69df633a78e3209a233670809318d *src/hardcore.c 2caea874a0d66ac1797ad6d1ada79599 *src/init.c bea8dac7a34f45fb243390c12e7ff364 *src/lennard.c 3e4d42cd58b8e5a73a387ba015ab4af8 *src/lookup.c 17db84d711dbc157c18d1193ef9a0427 *src/methas.c 69d57274cda1c955d631a7c241cb9a00 *src/methas.h df2c29d04f2da76a6baffe8117e6cfde *src/mhloop.h e324e8b564460332c1a069f428c92270 *src/mhsnoop.c 81c1a015083476952ee14be55991f2d9 *src/mhsnoop.h cfce4c5e0f35b12efa19c0e5144fa540 *src/mhsnoopdef.h af57f00feb578ceeb59fc71b5056e27f *src/mhv1.h 30677e286f648b6f5cc6a39706fe4130 *src/mhv2.h a1cfccc17f8ec667152b7f04b69cb8e6 *src/mhv3.h d2deceb7ed8f51910ab02b2e550b0779 *src/mhv4.h 8895a12dc3a8b12e2b2fb3842bb10270 *src/mhv5.h 660b5e8eb0bc81c4e39389dde6c4de85 *src/multihard.c ec3581d33e1593f6acbe886a4dc5ab7e *src/penttinen.c 08bd7ecfe7e7d032e31c177a5df49fab *src/proto.h a49ef8f66a841776f171ba0d62b13482 *src/rcauchy.c 8fa087543900603a2f7b8eefab5b6405 *src/rcauchy.h 718cf05cf4a63828607e9572653cd214 *src/rmatclus.c 4ac34288153995cc9f103f8fbb00db7c *src/rmatclus.h 574358e78217dc076352a2d21c782344 *src/rthin.c f6de1db3c4549cfba0456287c5c44e89 *src/rthomas.c 39b50cac401c3c1d3e7de09377156113 *src/rthomas.h 7a8f1e9bb5bb94b395d113015b6d85bb *src/rtruncpois.c 9f05f88262e87e2319a4a96de5f41966 *src/sftcr.c d1e8a99cf85ebb30db9b2dcb8b7493e1 *src/straush.c 5fe7bf28bcf45be044a96c34ef6c503c *src/straushm.c 946c9e82b695f2640b5e092097262eea *src/strauss.c 50c45d1f0ea0b63cad12673524a7f120 *src/straussm.c 37c57420bff9fa1eda217b6a7b98029f *src/triplets.c 5c127a9d5ddeaee8cc8f34b32218a3a5 *src/yesno.h 40790bf66f736b7792c311f8c798c5a6 *tests/RMH.R 562fcde662f402e21576b708013a7d33 *tests/Random.R spatstat.random/inst/0000755000176200001440000000000014164500405014350 5ustar liggesusersspatstat.random/inst/doc/0000755000176200001440000000000014405540771015125 5ustar liggesusersspatstat.random/inst/doc/packagesizes.txt0000755000176200001440000000104214570033472020335 0ustar liggesusersdate version nhelpfiles nobjects ndatasets Rlines srclines "2022-01-05" "2.0-0" 77 141 0 8561 7538 "2022-02-12" "2.1-0" 78 144 0 8711 7538 "2022-03-29" "2.2-0" 78 145 0 8924 7538 "2022-11-02" "3.0-1" 78 145 0 8978 7403 "2022-11-06" "3.0-2" 79 149 0 9158 7403 "2023-01-25" "3.1-3" 80 160 0 11263 9229 "2023-03-13" "3.1-4" 82 163 0 11301 9229 "2023-05-10" "3.1-5" 82 163 0 11303 9229 "2023-10-20" "3.2-0" 82 169 0 11681 9229 "2023-10-21" "3.2-1" 82 169 0 11690 9229 "2023-11-29" "3.2-2" 82 169 0 11690 9201 "2024-02-29" "3.2-3" 82 169 0 11693 9201 spatstat.random/inst/CITATION0000755000176200001440000000357114374301321015515 0ustar liggesusersc( bibentry(bibtype = "Book", title = "Spatial Point Patterns: Methodology and Applications with {R}", author = c(person("Adrian", "Baddeley"), person("Ege", "Rubak"), person("Rolf", "Turner")), year = "2015", publisher = "Chapman and Hall/CRC Press", address = "London", isbn = 9781482210200, url = "https://www.routledge.com/Spatial-Point-Patterns-Methodology-and-Applications-with-R/Baddeley-Rubak-Turner/p/book/9781482210200/", header = "To cite spatstat in publications, please use:" ), bibentry(bibtype = "Article", title = "Hybrids of Gibbs Point Process Models and Their Implementation", author = c(person("Adrian", "Baddeley"), person("Rolf", "Turner"), person("Jorge", "Mateu"), person("Andrew", "Bevan")), journal = "Journal of Statistical Software", year = "2013", volume = "55", number = "11", pages = "1--43", doi = "10.18637/jss.v055.i11", header = "If you use hybrid models, please also cite:" ), bibentry(bibtype = "Article", title = "{spatstat}: An {R} Package for Analyzing Spatial Point Patterns", author = c(person("Adrian", "Baddeley"), person("Rolf", "Turner")), journal = "Journal of Statistical Software", year = "2005", volume = "12", number = "6", pages = "1--42", doi = "10.18637/jss.v012.i06", header = "In survey articles, please also cite the original paper on spatstat:" ) )