.packageName <- "spatstat"
#
#	Fest.S
#
#	S function empty.space()
#	Computes estimates of the empty space function
#
#	$Revision: 4.7 $	$Date: 2004/01/09 13:48:47 $
#
"Fest" <- 	
"empty.space" <-
function(X, eps = NULL, r=NULL, breaks=NULL) {
#
#	pp:		point pattern (an object of class 'ppp')
#	eps:		raster grid mesh size for distance transform
#				(unless specified by pp$window)
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
# First discretise
	dwin <- as.mask(X$window, eps)
        dX <- ppp(X$x, X$y, window=dwin)
#        
# histogram breakpoints 
#
        breaks <- handle.r.b.args(r, breaks, dwin, eps)
#
#  compute distances and censoring distances
	if(X$window$type == "rectangle") {
                # original data were in a rectangle
                # output of exactdt() is sufficient
		e <- exactdt(dX)
		dist <- e$d
		bdry <- e$b
	} else {
                # window is irregular..
          
                # Distance transform & boundary distance for all pixels
		e <- exactdt(dX)
		b <- bdist.pixels(dX$window, coords=FALSE)
                # select only those pixels inside mask
		dist <- e$d[dwin$m]
		bdry <- b[dwin$m]
	} 
# censoring indicators
	d <- (dist <= bdry)
#  observed distances
	o <- pmin(dist, bdry)
#        
#
# calculate Kaplan-Meier and border corrected estimates
	result <- km.rs(o, bdry, d, breaks)

# also calculate UNCORRECTED e.d.f. !!!! use with care
        hh <- hist(dist,breaks=breaks$val,plot=FALSE)$counts
        edf <- cumsum(hh)/sum(hh)
        result$raw <- edf

# append theoretical value for Poisson
        lambda <- X$n/area.owin(X$window)
        result$theo <- 1 - exp( - lambda * pi * result$r^2)

# neaten up and return        
        result$breaks <- NULL

# convert to class "fv"
        result <- as.data.frame(result)
        Z <- result[, c("r", "theo", "rs", "km", "hazard", "raw")]
        alim <- range(result$r[result$km <= 0.9])
        labl <- c("r", "Fpois(r)", "Fbord(r)", "Fkm(r)",
                  "lambda(r)", "Fraw(r)")
        desc <- c("distance argument r",
                  "theoretical Poisson F(r)",
                  "border corrected estimate of F(r)",
                  "Kaplan-Meier estimate of F(r)",
                  "Kaplan-Meier estimate of hazard function lambda(r)",
                  "uncorrected estimate of F(r)")
        Z <- fv(Z, "r", "F(r)", "km", cbind(km, theo) ~ r, alim, labl, desc)
	return(Z)
}

	
.First.lib <- function(lib, pkg) {
    library.dynam("spatstat", pkg, lib)
    cat("spatstat 1.5-4\n")
    cat("Type \"demo(spatstat)\" for a demonstration\n")
    locn <- paste(.path.package(package="spatstat"),
                  "doc", sep=.Platform$file.sep)
    cat(paste("See the Introduction and Quick Reference in\n", locn, "\n"))
}

#
#	Gest.S
#
#	Compute estimates of nearest neighbour distance distribution function G
#
#	$Revision: 4.8 $	$Date: 2004/01/09 13:51:42 $
#
################################################################################
#
"Gest" <-
"nearest.neighbour" <-
function(X, r=NULL, breaks=NULL, ...) {
#	X		point pattern (of class ppp)
#				(unless specified by X$window)
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
	verifyclass(X, "ppp")

#  determine breakpoints for r values
        breaks <- handle.r.b.args(r, breaks, X$window)

# handle special case of empty pattern
        if(X$n == 0) {
          rvalues <- breaks$r
          nr <- length(rvalues)
          zero <- rep(0, nr)
          result <- list(rs     = zero,
                         km     = zero,
                         hazard = zero,
                         r      = rvalues,
                         raw    = zero,
                         theo   = zero)
          return(result)
        }
        
#  compute nearest neighbour distances
	nnd <- nndist(X$x, X$y)
		
#  UNCORRECTED e.d.f. of nearest neighbour distances: use with care
        hh <- hist(nnd,breaks=breaks$val,plot=FALSE)$counts
        edf <- cumsum(hh)/sum(hh)
	
#  distance to boundary
        bdry <- bdist.points(X)

#  observations
	o <- pmin(nnd,bdry)
#  censoring indicators
	d <- (nnd <= bdry)
#
# calculate Kaplan-Meier and border correction (Reduced Sample) estimators
	result <- km.rs(o, bdry, d, breaks)
#        
# append uncorrected e.d.f.        
        result$raw <- edf
# append theoretical value for Poisson
        lambda <- X$n/area.owin(X$window)
        result$theo <- 1 - exp( - lambda * pi * result$r^2)

# neaten up and return        
        result$breaks <- NULL

# convert to class "fv"
        result <- as.data.frame(result)
        Z <- result[, c("r", "theo", "rs", "km", "hazard", "raw")]
        alim <- range(result$r[result$km <= 0.9])
        labl <- c("r", "Gpois(r)", "Gbord(r)", "Gkm(r)",
                  "lambda(r)", "Graw(r)")
        desc <- c("distance argument r",
                  "theoretical Poisson G(r)",
                  "border corrected estimate of G(r)",
                  "Kaplan-Meier estimate of G(r)",
                  "Kaplan-Meier estimate of hazard function lambda(r)",
                  "uncorrected estimate of G(r)")
        Z <- fv(Z, "r", "G(r)", "km", cbind(km, theo) ~ r, alim, labl, desc)
	return(Z)
}	

#	Gmulti.S
#
#	Compute estimates of nearest neighbour distance distribution functions
#	for multitype point patterns
#
#	S functions:	
#		Gcross                G_{ij}
#		Gdot		      G_{i\bullet}
#		Gmulti	              (generic)
#
#	$Revision: 4.6 $	$Date: 2004/01/12 11:19:04 $
#
################################################################################

"Gcross" <-		
function(X, i=1, j=2, r=NULL, breaks=NULL, ...)
{
#	computes G_{ij} estimates
#
#	X		marked point pattern (of class 'ppp')
#	i,j		the two mark values to be compared
#  
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
	X <- as.ppp(X)
	if(!is.marked(X))
		stop("point pattern has no \'marks\'")
	window <- X$window
# 
	I <- (X$marks == i)
	if(sum(I) == 0) stop("No points are of type i")
	J <- (X$marks == j)
	if(sum(J) == 0) stop("No points are of type j")
#
	Gmulti(X, I, J, r, breaks)
}	

"Gdot" <- 	
function(X, i=1, r=NULL, breaks=NULL, ...) {
#  Computes estimate of 
#      G_{i\bullet}(t) = 
#  P( a further point of pattern in B(0,t)| a type i point at 0 )
#	
#	X		marked point pattern (of class ppp)
#  
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
	X <- as.ppp(X)

	if(!is.marked(X))
		stop("point pattern has no \'marks\'")
#
	I <- (X$marks == i)
	if(sum(I) == 0) stop("No points are of type i")
	J <- rep(TRUE, X$n)	# i.e. all points
# 
	Gmulti(X, I, J, r, breaks)
}	

	
##########

"Gmulti" <- 	
function(X, I, J, r=NULL, breaks=NULL, ...) {
#
#  engine for computing the estimate of G_{ij} or G_{i\bullet}
#  depending on selection of I, J
#  
#	X		marked point pattern (of class ppp)
#	
#	I,J		logical vectors of length equal to the number of points
#			and identifying the two subsets of points to be
#			compared.
#  
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
	verifyclass(X, "ppp")
	if(!is.marked(X))
		stop("point pattern has no \'marks\'")
	window <- X$window
        brks <- handle.r.b.args(r, breaks, window)$val        
# Extract points of group I and J
	if(!is.logical(I) || !is.logical(J))
		stop("I and J must be logical vectors")
	if(length(I) != X$n || length(J) != X$n)
		stop("length of I or J does not equal the number of points")
	if(sum(I) == 0) stop("No points satisfy condition I")
	xI <- X$x[I]
	yI <- X$y[I]
	if(sum(J) == 0) stop("No points satisfy condition J")
	xJ <- X$x[J]
	yJ <- X$y[J]
#  compute squared distance from each type i point to
#  the nearest other point of any type
	xIm <- matrix(xI, nrow=length(xI), ncol=length(xJ))
	yIm <- matrix(yI, nrow=length(yI), ncol=length(yJ))
	xJm <- matrix(xJ, nrow=length(xJ), ncol=length(xI))
	yJm <- matrix(yJ, nrow=length(yJ), ncol=length(yI))
	squd <-  (xIm - t(xJm))^2 + (yIm - t(yJm))^2
# identify which pairs in 'squd' correspond to identical points
	dag <- (diag(1, X$n) != 0)
	dag <- dag[I,J]
#  reset this 'diagonal' to a large value
	oo <- (diff(window$xrange) + diff(window$yrange) )^2
	squd[dag] <- oo
#  "type I to type J" nearest neighbour distances
	nnd <- sqrt(apply(squd,1,min))
#  distance to boundary from each type i point
        bdry <- bdist.points(X[I, ])
#  observations
	o <- pmin(nnd,bdry)
#  censoring indicators
	d <- (nnd <= bdry)
#
# calculate
	result <- km.rs(o, bdry, d, brks)
        result$breaks <- NULL

#  UNCORRECTED e.d.f. of I-to-J nearest neighbour distances: use with care
        hh <- hist(nnd,breaks=brks,plot=FALSE)$counts
        result$raw <- cumsum(hh)/sum(hh)

# theoretical value for marked Poisson processes
        lamJ <- sum(J)/area.owin(window)
        result$theo <- 1 - exp( - lamJ * pi * result$r^2)
        
# convert to class "fv"
        result <- as.data.frame(result)
        Z <- result[, c("r", "theo", "rs", "km", "hazard", "raw")]
        alim <- range(result$r[result$km <= 0.9])
        labl <- c("r", "Gpois(r)", "Gbord(r)", "Gkm(r)",
                  "lambda(r)", "Graw(r)")
        desc <- c("distance argument r",
                  "theoretical Poisson G(r)",
                  "border corrected estimate of G(r)",
                  "Kaplan-Meier estimate of G(r)",
                  "Kaplan-Meier estimate of hazard function lambda(r)",
                  "uncorrected estimate of G(r)")
        Z <- fv(Z, "r", "G(r)", "km", cbind(km, theo) ~ r, alim, labl, desc)
	return(Z)
}	


#	Jest.S
#
#	Usual invocation to compute J function
#	if F and G are not required 
#
#	$Revision: 4.5 $	$Date: 2004/01/09 13:59:34 $
#
#
#
"Jest" <-
function(X, eps=NULL, r=NULL, breaks=NULL) {
        X <- as.ppp(X)
        brks <-  handle.r.b.args(r, breaks, X$window)$val
	FF <- Fest(X, eps, breaks=brks)
	G <- Gest(X, breaks=brks)
        ratio <- function(a, b, c) {
          result <- a/b
          result[ b == 0 ] <- c
          result
        }
	Jrs <- ratio(1-G$rs, 1-FF$rs, NA)
	Jkm <- ratio(1-G$km, 1-FF$km, NA)
	Jun <- ratio(1-G$raw, 1-FF$raw, NA)
        theo <- rep(1, length(FF$r))

        rslt <- data.frame(r=FF$r, theo=theo, rs=Jrs, km=Jkm, un=Jun)
# convert to class "fv"
        alim <- range(rslt$r[FF$km <= 0.9])
        labl <- c("r", "Jpois(r)", "Jbord(r)", "Jkm(r)",
                  "Jun(r)")
        desc <- c("distance argument r",
                  "theoretical Poisson J(r) = 1",
                  "border corrected estimate of J(r)",
                  "Kaplan-Meier estimate of J(r)",
                  "uncorrected estimate of J(r)")
        Z <- fv(rslt, "r", "J(r)", "km", cbind(km, 1) ~ r, alim, labl, desc)

# add more info        
        attr(Z, "F") <- FF
        attr(Z, "G") <- G

        return(Z)
}

#	Jmulti.S
#
#	Usual invocations to compute multitype J function(s)
#	if F and G are not required 
#
#	$Revision: 4.6 $	$Date: 2004/01/13 04:34:58 $
#
#
#
"Jcross" <-
function(X, i=1, j=2, eps=NULL, r=NULL, breaks=NULL) {
#
#       multitype J function J_{ij}(r)
#  
#	X:		point pattern (an object of class 'ppp')
#       i, j:           types for which J_{i,j}(r) is calculated  
#	eps:		raster grid mesh size for distance transform
#				(unless specified by X$window)
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
        X <- as.ppp(X)
        if(!is.marked(X))
          stop("point pattern has no \'marks\'")
        I <- (X$marks == i)
        J <- (X$marks == j)
        result <- Jmulti(X, I, J, eps, r, breaks)
	return(result)
}

"Jdot" <-
function(X, i=1, eps=NULL, r=NULL, breaks=NULL) {
#  
#    multitype J function J_{i\dot}(r)
#  
#	X:		point pattern (an object of class 'ppp')
#       i:              mark i for which we calculate J_{i\cdot}(r)  
#	eps:		raster grid mesh size for distance transform
#				(unless specified by X$window)
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#
        X <- as.ppp(X)
        if(!is.marked(X))
          stop("point pattern has no \'marks\'")
        I <- (X$marks == i)
        J <- rep(TRUE, X$n)
        result <- Jmulti(X, I, J, eps, r, breaks)
	return(result)
}

"Jmulti" <- 	
function(X, I, J, eps=NULL, r=NULL, breaks=NULL) {
#  
#    multitype J function (generic engine)
#  
#	X		marked point pattern (of class ppp)
#	
#	I,J		logical vectors of length equal to the number of points
#			and identifying the two subsets of points to be
#			compared.
#  
#	eps:		raster grid mesh size for distance transform
#				(unless specified by X$window)
#  
#       r:              (optional) values of argument r  
#	breaks:		(optional) breakpoints for argument r
#  
#
        X <- as.ppp(X)
        brks <- handle.r.b.args(r, breaks, X$window, eps)$val
	FJ <- Fest(X[J], eps, breaks=brks)
	GIJ <- Gmulti(X, I, J, breaks=brks)
        ratio <- function(a, b, c) {
          result <- a/b
          result[ b == 0 ] <- c
          result
        }
	Jkm <- ratio(1-GIJ$km, 1-FJ$km, NA)
	Jrs <- ratio(1-GIJ$rs, 1-FJ$rs, NA)
	Jun <- ratio(1-GIJ$raw, 1-FJ$raw, NA)
        theo <- rep(1, length(FJ$r))
        
	result <- data.frame(r=FJ$r,theo=theo,rs=Jrs,km=Jkm,un=Jun)

        alim <- range(result$r[FJ$km <= 0.9])
        labl <- c("r", "Jpois(r)", "Jbord(r)", "Jkm(r)", "Jun(r)")
        desc <- c("distance argument r",
                  "theoretical Poisson J(r)=1",
                  "border corrected estimate of J(r)",
                  "Kaplan-Meier estimate of J(r)",
                  "uncorrected estimate of J(r)")
        Z <- fv(result,
                "r", "J(r)", "km", cbind(km, theo) ~ r, alim, labl, desc)
        
        attr(Z, "G") <- GIJ
        attr(Z, "F") <- FJ
        return(Z)
}
#
#	Kest.S		Estimation of K function
#
#	$Revision: 5.7 $	$Date: 2004/08/31 10:26:13 $
#
#
# -------- functions ----------------------------------------
#	Kest()		compute estimate of K
#                       using various edge corrections
#
#       Kount()         internal routine for border correction
#
# -------- standard arguments ------------------------------	
#	X		point pattern (of class 'ppp')
#
#	r		distance values at which to compute K	
#
# -------- standard output ------------------------------
#      A data frame (class "fv") with columns named
#
#	r:		same as input
#
#	trans:		K function estimated by translation correction
#
#	iso:		K function estimated by Ripley isotropic correction
#
#	theo:		K function for Poisson ( = pi * r ^2 )
#
#	border:		K function estimated by border method
#			using standard formula (denominator = count of points)
#
#       bord.modif:	K function estimated by border method
#			using modified formula 
#			(denominator = area of eroded window
#
# ------------------------------------------------------------------------

"Kest"<-
function(X, r=NULL, breaks=NULL, slow=FALSE,
         correction=c("border", "isotropic", "Ripley", "translate"), ...)
{
	verifyclass(X, "ppp")

	npoints <- X$n
        W <- X$window
	area <- area.owin(W)
	lambda <- npoints/area
	lambda2 <- (npoints * (npoints - 1))/(area^2)

        breaks <- handle.r.b.args(r, breaks, W)
        r <- breaks$r

        # available selection of edge corrections depends on window
        if(W$type != "rectangle") {
           iso <- (correction == "isotropic") | (correction == "Ripley")
           if(any(iso)) {
             if(!missing(correction))
               warning("Isotropic correction not implemented for non-rectangular windows")
             correction <- correction[!iso]
           }
        }

        # recommended range of r values
        alim <- c(0, min(diff(X$window$xrange), diff(X$window$yrange))/4)
        
        # this will be the output data frame
        K <- data.frame(r=r, theo= pi * r^2)
        desc <- c("distance argument r", "theoretical Poisson K(r)")
        K <- fv(K, "r", "K(r)", "theo", , alim, c("r","Kpois(r)"), desc)

        # pairwise distance
	d <- pairdist(X$x, X$y)

        offdiag <- (row(d) != col(d))
        
        if(any(correction == "border" | correction == "bord.modif")) {
          # border method
          # Compute distances to boundary
          b <- bdist.points(X)
          # Ignore pairs (i,i)
          diag(d) <- Inf
          # apply reduced sample algorithm
          RS <- Kount(d, b, breaks, slow)
          if(any(correction == "bord.modif")) {
            denom.area <- eroded.areas(W, r)
            Kbm <- RS$numerator/(lambda2 * denom.area)
            K <- bind.fv(K, data.frame(bord.modif=Kbm), "Kbord*(r)",
                         "modified border-corrected estimate of K(r)",
                         "bord.modif")
          }
          if(any(correction == "border")) {
            Kb <- RS$numerator/(lambda * RS$denom.count)
            K <- bind.fv(K, data.frame(border=Kb), "Kbord(r)",
                         "border-corrected estimate of K(r)",
                         "border")
          }
          # reset diagonal to original values
          diag(d) <- 0
        }
        if(any(correction == "translate")) {
          # translation correction
            edgewt <- edge.Trans(X)
            wh <- whist(d[offdiag], breaks$val, edgewt[offdiag])
            Ktrans <- cumsum(wh)/(lambda2 * area)
            rmax <- diameter(W)/2
            Ktrans[r >= rmax] <- NA
            K <- bind.fv(K, data.frame(trans=Ktrans), "Ktrans(r)",
                         "translation-corrected estimate of K(r)",
                         "trans")
        }
        if(any(correction == "isotropic" | correction == "Ripley")) {
          # Ripley isotropic correction
            edgewt <- edge.Ripley(X, d)
            wh <- whist(d[offdiag], breaks$val, edgewt[offdiag])
            Kiso <- cumsum(wh)/(lambda2 * area)
            rmax <- diameter(W)/2
            Kiso[r >= rmax] <- NA
            K <- bind.fv(K, data.frame(iso=Kiso), "Kiso(r)",
                         "Ripley isotropic correction estimate of K(r)",
                         "iso")
        }

        # which corrections have been computed?
        nama2 <- names(K)
        corrxns <- rev(nama2[nama2 != "r"])

        # default is to display them all
        attr(K, "fmla") <- as.formula(paste(
                       "cbind(",
                        paste(corrxns, collapse=","),
                        ") ~ r"))
        return(K)
}
	
Kount <- function(d, b, breaks, slow=FALSE) {
  #
  # "internal" routine to compute border-correction estimate of K or Kij
  #
  # d : matrix of pairwise distances
  #                  (to exclude diagonal entries, set diag(d) = Inf)
  # b : column vector of distances to window boundary
  # breaks : breakpts object
  #

  if(slow) { ########## slow ##############
          
       r <- breaks$r
       
       nr <- length(r)
       numerator <- numeric(nr)
       denom.count <- numeric(nr)

       for(i in 1:nr) {
         close <- (d <= r[i])
         nclose <- matrowsum(close) # assumes diag(d) set to Inf
         bok <- (b > r[i])
         numerator[i] <- sum(nclose[bok])
         denom.count[i] <- sum(bok)
       }
	
  } else { ############# fast ####################

        # determine which distances d_{ij} were observed without censoring
        bb <- matrix(b, nrow=nrow(d), ncol=ncol(d))
        uncen <- (d <= bb)
        #
        # histogram of noncensored distances
        nco <- whist(d[uncen], breaks$val)
        # histogram of censoring times for noncensored distances
        ncc <- whist(bb[uncen], breaks$val)
        # histogram of censoring times (yes, this is a different total size)
        cen <- whist(b, breaks$val)
        # go
        RS <- reduced.sample(nco, cen, ncc, show=TRUE)
        # extract results
        numerator <- RS$numerator
        denom.count <- RS$denominator
        # check
        if(length(numerator) != breaks$ncells)
          stop("internal error: length(numerator) != breaks$ncells")
        if(length(denom.count) != breaks$ncells)
          stop("internal error: length(denom.count) != breaks$ncells")
  }
  
  return(list(numerator=numerator, denom.count=denom.count))
}
#
#	Kinhom.S	Estimation of K function for inhomogeneous patterns
#
#	$Revision: 1.5 $	$Date: 2004/08/31 10:26:31 $
#
#	Kinhom()	compute estimate of K_inhom
#
#       Currently uses border method and slow code...
#                       
#       Reference:
#            Non- and semiparametric estimation of interaction
#	     in inhomogeneous point patterns
#            A.Baddeley, J.Moller, R.Waagepetersen
#            Statistica Neerlandica 54 (2000) 329--350.
#
# -------- functions ----------------------------------------
#	Kinhom()	compute estimate of K
#                       using various edge corrections
#
#       Kwtsum()         internal routine for border correction
#
# -------- standard arguments ------------------------------	
#	X		point pattern (of class 'ppp')
#
#	r		distance values at which to compute K	
#
#       lambda          either a vector of intensity values for points of X
#                       or a matrix of two-point conditional intensities
#                       for pairs of points of X
#
# -------- standard output ------------------------------
#      A data frame (class "fv") with columns named
#
#	r:		same as input
#
#	trans:		K function estimated by translation correction
#
#	iso:		K function estimated by Ripley isotropic correction
#
#	theo:		K function for Poisson ( = pi * r ^2 )
#
#	border:		K function estimated by border method
#			(denominator = sum of weights of points)
#
#       bord.modif:	K function estimated by border method
#			(denominator = area of eroded window)
#
# ------------------------------------------------------------------------

"Kinhom"<-
  function (X, lambda, r = NULL, breaks = NULL, slow=FALSE,
         correction=c("border", "isotropic", "Ripley", "translate"), ...)
{
    verifyclass(X, "ppp")
    W <- X$window
    npoints <- X$n
    area <- area.owin(W)
    breaks <- handle.r.b.args(r, breaks, X$window)
    r <- breaks$r
    if(is.vector(lambda)) {
      if (length(lambda) != npoints) 
        stop("The length of the vector \'lambda\' should equal the number of data points")
      weight <- 1/outer(lambda, lambda, "*")
    } else if(is.matrix(lambda)) {
      if(any(dim(lambda) != npoints))
        stop("The matrix \'lambda\' should be n x n where n is the number of data points")
      weight <- 1/lambda
    }

    # available selection of edge corrections depends on window
    if(W$type != "rectangle") {
      iso <- (correction == "isotropic") | (correction == "Ripley")
      if(any(iso)) {
        if(!missing(correction))
          warning("Isotropic correction not implemented for non-rectangular windows")
        correction <- correction[!iso]
      }
    }

    # recommended range of r values
    alim <- c(0, min(diff(X$window$xrange), diff(X$window$yrange))/4)
        
    # this will be the output data frame
    K <- data.frame(r=r, theo= pi * r^2)
    desc <- c("distance argument r", "theoretical Poisson K(r)")
    K <- fv(K, "r", "K(r)", "theo", , alim, c("r","Kpois(r)"), desc)
        
    # pairwise distance
    d <- pairdist(X$x, X$y)
    
    offdiag <- (row(d) != col(d))
        
    if(any(correction == "border" | correction == "bord.modif")) {
      # border method
      # Compute distances to boundary
      b <- bdist.points(X)
      # Ignore pairs (i,i)
      diag(d) <- Inf
      # apply reduced sample algorithm
      RS <- Kwtsum(d, b, weight, breaks, slow)
      if(any(correction == "border")) {
        Kb <- area * RS$numerator/RS$denom.sum
        K <- bind.fv(K, data.frame(border=Kb), "Kbord(r)",
                     "border-corrected estimate of K(r)",
                     "border")
      }
      if(any(correction == "bord.modif")) {
        denom.area <- eroded.areas(W, r)
        Kbm <- RS$numerator/denom.area
        K <- bind.fv(K, data.frame(bord.modif=Kbm), "Kbord*(r)",
                     "modified border-corrected estimate of K(r)",
                     "bord.modif")
      }
      # reset diagonal to original values
      diag(d) <- 0
    }
    if(any(correction == "translate")) {
      # translation correction
      edgewt <- edge.Trans(X)
      allweight <- edgewt * weight
      wh <- whist(d[offdiag], breaks$val, allweight[offdiag])
      Ktrans <- cumsum(wh)/area
      rmax <- diameter(W)/2
      Ktrans[r >= rmax] <- NA
      K <- bind.fv(K, data.frame(trans=Ktrans), "Ktrans(r)",
                   "translation-correction estimate of K(r)",
                   "trans")
    }
    if(any(correction == "isotropic" | correction == "Ripley")) {
      # Ripley isotropic correction
      edgewt <- edge.Ripley(X, d)
      allweight <- edgewt * weight
      wh <- whist(d[offdiag], breaks$val, allweight[offdiag])
      Kiso <- cumsum(wh)/area
      rmax <- diameter(W)/2
      Kiso[r >= rmax] <- NA
      K <- bind.fv(K, data.frame(iso=Kiso), "Kiso(r)",
                   "Ripley isotropic correction estimate of K(r)",
                   "iso")
    }

    # which corrections have been computed?
    nama2 <- names(K)
    corrxns <- rev(nama2[nama2 != "r"])

    # default is to display them all
    attr(K, "fmla") <- as.formula(paste(
                       "cbind(",
                        paste(corrxns, collapse=","),
                        ") ~ r"))

    return(K)
}


Kwtsum <- function(d, b, weight, breaks, slow=FALSE) {
  #
  # "internal" routine to compute border-correction estimate of Kinhom
  #
  # d : matrix of pairwise distances
  #                  (to exclude diagonal entries, set diag(d) = Inf)
  # b : column vector of distances to window boundary
  # weight: matrix of weights for x[i], x[j] pairs
  # breaks : breakpts object
  #

  if(!is.matrix(d))
    stop("\'d\' must be a matrix")
  if(!is.matrix(weight))
    stop("\'weight\' must be a matrix")
  if(any(dim(d) != dim(weight)))
    stop("matrices \'d\' and \'weight\' have different dimensions")
  if(length(b) != nrow(d))
    stop("length(b) does not match nrow(d)")
  
  weightmargin <- matrowsum(weight)

  if(slow) { ########## slow ##############
          
       r <- breaks$r
       
       nr <- length(r)
       numerator <- numeric(nr)
       denom.sum <- numeric(nr)

       for(i in 1:nr) {
         close <- (d <= r[i])
         numer <- matrowsum(close * weight) # assumes diag(d) set to Inf
         bok <- (b > r[i])
         numerator[i] <- sum(numer[bok])
         denom.sum[i] <- sum(weightmargin[bok])
       }
	
  } else { ############# fast ####################

        # determine which distances d_{ij} were observed without censoring
        bb <- matrix(b, nrow=nrow(d), ncol=ncol(d))
        uncen <- (d <= bb)
        #
        # histogram of noncensored distances
        nco <- whist(d[uncen], breaks$val, weight[uncen])
        # histogram of censoring times for noncensored distances
        ncc <- whist(bb[uncen], breaks$val, weight[uncen])
        # histogram of censoring times (yes, this is a different total size)
        cen <- whist(b, breaks$val, weightmargin)
        # go
        RS <- reduced.sample(nco, cen, ncc, show=TRUE)
        # extract results
        numerator <- RS$numerator
        denom.sum <- RS$denominator
        # check
        if(length(numerator) != breaks$ncells)
          stop("internal error: length(numerator) != breaks$ncells")
        if(length(denom.sum) != breaks$ncells)
          stop("internal error: length(denom.count) != breaks$ncells")
  }
  
  return(list(numerator=numerator, denom.sum=denom.sum))
}
	
#
#           Kmeasure.R
#
#           $Revision: 1.5 $    $Date: 2004/01/12 11:06:05 $
#
#     pixellate()        convert a point pattern to a pixel image
#
#     Kmeasure()         compute an estimate of the second order moment measure
#
#     Kest.fft()        use Kmeasure() to form an estimate of the K-function
#
#     second.moment.calc()    underlying algorithm
#
#     This file uses the temporary 'image' class defined in images.R

pixellate <- function(x, ..., weights=NULL)
{
    verifyclass(x, "ppp")
    w <- as.mask(x$window, ...)
    pixels <- nearest.raster.point(x$x, x$y, w)
    nr <- w$dim[1]
    nc <- w$dim[2]
    if(missing(weights)) {
    ta <- table(row = factor(pixels$row, levels = 1:nr), col = factor(pixels$col,
        levels = 1:nc))
    } else {
        ta <- tapply(weights, list(row = factor(pixels$row, levels = 1:nr),
                    col = factor(pixels$col, levels=1:nc)), sum)
        ta[is.na(ta)] <- 0
    }
    out <- im(ta, xcol = w$xcol, yrow = w$yrow)
    return(out)
}

Kmeasure <- function(X, sigma, edge=TRUE) {
  second.moment.calc(X, sigma, edge, "Kmeasure")
}

second.moment.calc <- function(x, sigma, edge=TRUE,
                               what="Kmeasure", debug=FALSE, ...) {
  choices <- c("kernel", "smooth", "Kmeasure", "Bartlett", "edge")
  if(!(what %in% choices))
    stop(paste("Unknown choice: what = \"", what, "\"; available options are:", paste(choices, collapse=",")))
  # convert list of points to mass distribution 
  X <- pixellate(x, ...)
  Y <- X$v
  xw <- X$xrange
  yw <- X$yrange
  # pad with zeroes
  nr <- nrow(Y)
  nc <- ncol(Y)
  Ypad <- matrix(0, ncol=2*nc, nrow=2*nr)
  Ypad[1:nr, 1:nc] <- Y
  lengthYpad <- 4 * nc * nr
  # corresponding coordinates
  xw.pad <- xw[1] + 2 * c(0, diff(xw))
  yw.pad <- yw[1] + 2 * c(0, diff(yw))
  xcol.pad <- xw[1] + X$xstep * (1/2 + 0:(2*nc-1))
  yrow.pad <- yw[1] + X$ystep * (1/2 + 0:(2*nr-1))
  # set up Gauss kernel
  if(max(abs(diff(xw)),abs(diff(yw))) < 6 * sigma)
    warning("sigma is too large for this window")
  xcol.G <- X$xstep * c(0:(nc-1),-(nc:1))
  yrow.G <- X$ystep * c(0:(nr-1),-(nr:1))
  xx <- matrix(xcol.G[col(Ypad)], ncol=2*nc, nrow=2*nr)
  yy <- matrix(yrow.G[row(Ypad)], ncol=2*nc, nrow=2*nr)
  Kern <- exp(-(xx^2 + yy^2)/(2 * sigma^2))/(2 * pi * sigma^2) * X$xstep * X$ystep
  if(what=="kernel") {
    # return the kernel
    # first rearrange it into spatially sensible order (monotone x and y)
    rtwist <- ((-nr):(nr-1)) %% (2 * nr) + 1
    ctwist <- (-nc):(nc-1) %% (2*nc) + 1
    if(debug) {
      if(any(order(xcol.G) != rtwist))
        cat("something round the twist\n")
    }
    Kermit <- Kern[ rtwist, ctwist]
    ker <- im(Kermit, xcol.G[ctwist], yrow.G[ rtwist])
    return(ker)
  }
  # convolve using fft
  fY <- fft(Ypad)
  fK <- fft(Kern)
  sm <- fft(fY * fK, inverse=TRUE)/lengthYpad
  if(debug) {
    cat(paste("smooth: maximum imaginary part=", signif(max(Im(sm)),3), "\n"))
    cat(paste("smooth: mass error=", signif(sum(Mod(sm))-x$n,3), "\n"))
  }
  if(what=="smooth") {
    # return the smoothed point pattern
    smo <- im(Re(sm)[1:nr, 1:nc], xcol.pad[1:nc], yrow.pad[1:nr])
    return(smo)
  }

  bart <- Mod(fY)^2 * fK
  if(what=="Bartlett") {
     # rearrange into spatially sensible order (monotone x and y)
    rtwist <- ((-nr):(nr-1)) %% (2 * nr) + 1
    ctwist <- (-nc):(nc-1) %% (2*nc) + 1
    bart <- bart[ rtwist, ctwist]
    return(im(Mod(bart),(-nc):(nc-1), (-nr):(nr-1)))
  }
  
  mom <- fft(bart, inverse=TRUE)/lengthYpad
  if(debug) {
    cat(paste("2nd moment measure: maximum imaginary part=",
              signif(max(Im(mom)),3), "\n"))
    cat(paste("2nd moment measure: mass error=",
              signif(sum(Mod(mom))-x$n^2, 3), "\n"))
  }
  mom <- Mod(mom)
  # subtract (delta_0 * kernel) * npoints
#  browser()
  mom <- mom - x$n * Kern
  # edge correction
  if(edge) {
    # compute kernel-smoothed set covariance
    M <- as.mask(x$window, dimyx=c(nr, nc))$m
    # previous line ensures M has same dimensions and scale as Y 
    Mpad <- matrix(0, ncol=2*nc, nrow=2*nr)
    Mpad[1:nr, 1:nc] <- M
    lengthMpad <- 4 * nc * nr
    fM <- fft(Mpad)
    co <- fft(Mod(fM)^2 * fK, inverse=TRUE)/lengthMpad
    co <- Mod(co) 
    a <- sum(M)
    wt <- a/co
    me <- spatstat.options("maxedgewt")[[1]]
    weight <- matrix(pmin(me, wt), ncol=2*nc, nrow=2*nr)
    if(debug) browser()
    mom <- mom * weight
  # set to NA outside 'reasonable' region
    mom[wt > 10] <- NA
  }
 # rearrange into spatially sensible order (monotone x and y)
  rtwist <- ((-nr):(nr-1)) %% (2 * nr) + 1
  ctwist <- (-nc):(nc-1) %% (2*nc) + 1
  mom <- mom[ rtwist, ctwist]
  if(debug) {
    if(any(order(xcol.G) != rtwist))
      cat("something round the twist\n")
  }
  if(what=="edge") {
    # return convolution of window with kernel
    # (evaluated inside window only)
    con <- fft(fM * fK, inverse=TRUE)/lengthMpad
    return(Mod(con[1:nr, 1:nc]))
  }
  # divide by number of points * lambda
  mom <- mom * area.owin(x$window) / x$n^2
  # return it
  mm <- im(mom, xcol.G[ctwist], yrow.G[rtwist])
  return(mm)
}

Kest.fft <- function(X, sigma, r=NULL, breaks=NULL) {
  verifyclass(X, "ppp")
  bk <- handle.r.b.args(r, breaks, X$window)
  breaks <- bk$val
  rvalues <- bk$r
  u <- Kmeasure(X, sigma)
  xx <- rasterx.im(u)
  yy <- rastery.im(u)
  rr <- sqrt(xx^2 + yy^2)
  tr <- whist(rr, breaks, u$v)
  K  <- cumsum(tr)
  rmax <- min(rr[is.na(u$v)])
  K[rvalues >= rmax] <- NA
  result <- data.frame(r=rvalues,border=K,theo=pi * rvalues^2)
  w <- X$window
  alim <- c(0, min(diff(w$xrange), diff(w$yrange))/4)
  out <- fv(result,
            "r", "Kinhom(r)", "border",
              cbind(border, theo) ~ r, alim,
              c("r", "Kpois(r)", "Kinhom(r)"),
              c("distance argument r",
                "theoretical Poisson K(r)",
                "border-corrected estimate of Kinhom(r)"))
  return(out)
}


ksmooth.ppp <- function(x, sigma, ..., edge=TRUE) {
  verifyclass(x, "ppp")
  if(missing(sigma))
    sigma <- 0.1 * diameter(x$window)
  smo <- second.moment.calc(x, sigma=sigma, what="smooth", ...)
  edg <- second.moment.calc(x, sigma, what="edge")
  smo$v <- smo$v/(smo$xstep * smo$ystep)
  if(edge)
    smo$v <- smo$v/edg
  sub <- smo[x$window, drop=FALSE]
  return(sub)
}
  
#
#	Kmulti.S		
#
#	Compute estimates of cross-type K functions
#	for multitype point patterns
#
#	$Revision: 5.4 $	$Date: 2004/01/13 05:57:54 $
#
#
# -------- functions ----------------------------------------
#	Kcross()	cross-type K function K_{ij}
#                       between types i and j
#
#	Kdot()          K_{i\bullet}
#                       between type i and all points regardless of type
#
#       Kmulti()        (generic)
#
#	crossdist()	compute matrix of distances between 	
#			  each pair of data points 
#			  in two separate lists of points
#
# -------- standard arguments ------------------------------	
#	X		point pattern (of class 'ppp')
#				including 'marks' vector
#	r		distance values at which to compute K	
#
# -------- standard output ------------------------------
#      A data frame with columns named
#
#	r:		same as input
#
#	trans:		K function estimated by translation correction
#
#	iso:		K function estimated by Ripley isotropic correction
#
#	theo:		K function for Poisson ( = pi * r ^2 )
#
#	border:		K function estimated by border method
#			using standard formula (denominator = count of points)
#
#       bord.modif:	K function estimated by border method
#			using modified formula 
#			(denominator = area of eroded window
#
# ------------------------------------------------------------------------

"crossdist"<-
function(x1, y1, x2, y2)
{
        # returns matrix[i,j] = distance from (x1[i],y1[i]) to (x2[j],y2[j])
	if(length(x1) != length(y1))
		stop("lengths of x1 and y1 do not match")
	if(length(x2) != length(y2))
		stop("lengths of x2 and y2 do not match")
	n1 <- length(x1)
	n2 <- length(x2)
	X1 <- matrix(rep(x1, n2), ncol = n2)
	Y1 <- matrix(rep(y1, n2), ncol = n2)
	X2 <- matrix(rep(x2, n1), ncol = n1)
	Y2 <- matrix(rep(y2, n1), ncol = n1)
	d <- sqrt((X1 - t(X2))^2 + (Y1 - t(Y2))^2)
	return(d)
}

"Kcross" <- 
function(X, i=1, j=2, r=NULL, breaks=NULL,
         correction =c("border", "isotropic", "Ripley", "translate") , ...)
{
    
	verifyclass(X, "ppp")
	if(!is.marked(X))
		stop("point pattern has no marks (no component 'marks')")
	
	I <- (X$marks == i)
	J <- (X$marks == j)
	
	if(!any(I)) stop(paste("No points have mark i =", i))
	if(!any(J)) stop(paste("No points have mark j =", j))
	
	Kmulti(X, I, J, r, breaks)
}

"Kdot" <- 
function(X, i=1, r=NULL, breaks=NULL,
         correction = c("border", "isotropic", "Ripley", "translate") , ...)
{
	verifyclass(X, "ppp")
	if(!is.marked(X))
		stop("point pattern has no marks (no component 'marks')")
	
	I <- (X$marks == i)
	J <- rep(TRUE, X$n)  # i.e. all points
	
	if(!any(I)) stop(paste("No points have mark i =", i))
	
	Kmulti(X, I, J, r, breaks)
}


"Kmulti"<-
function(X, I, J, r=NULL, breaks=NULL,
         correction = c("border", "isotropic", "Ripley", "translate") , ...)
{
	verifyclass(X, "ppp")

	npoints <- X$n
	x <- X$x
	y <- X$y
        W <- X$window
	area <- area.owin(W)

        breaks <- handle.r.b.args(r, breaks, W)
        r <- breaks$r
        
        # available selection of edge corrections depends on window
        if(W$type != "rectangle") {
           iso <- (correction == "isotropic") | (correction == "Ripley")
           if(all(iso))
             stop("Isotropic correction not implemented for non-rectangular windows")
           if(any(iso)) {
             if(!missing(correction))
               warning("Isotropic correction not implemented for non-rectangular windows")
             correction <- correction[!iso]
           }
        }
         
	if(!is.logical(I) || !is.logical(J))
		stop("I and J must be logical vectors")
	if(length(I) != npoints || length(J) != npoints)
	     stop("The length of I and J must equal \
 the number of points in the pattern")
	
	if(!any(I)) stop("no points satisfy I")
	if(!any(J)) stop("no points satisfy J")
		
	nI <- sum(I)
	nJ <- sum(J)
	lambdaI <- nI/area
	lambdaJ <- nJ/area

        # recommended range of r values
        alim <- c(0, min(diff(X$window$xrange), diff(X$window$yrange))/4)
        
        # this will be the output data frame
        # It will be given more columns later
        K <- data.frame(r=r, theo= pi * r^2)
        desc <- c("distance argument r", "theoretical Poisson K(r)")
        K <- fv(K, "r", "K(r)", "theo", , alim, c("r","Kpois(r)"), desc)

# interpoint distances		
	d <- crossdist(x[I], y[I], x[J], y[J])
# distances to boundary	
	b <- (bdist.points(X))[I]
        
# Determine which interpoint distances d[i,j] refer to the same point
# (not just which distances are zero)        
        identical <- matrix(FALSE, nrow=nI, ncol=nJ)
        common <- I & J
        if(any(common)) {
          Irow <- cumsum(I)
          Jcol <- cumsum(J)
          icommon <- (1:npoints)[common]
          for(i in icommon)
            identical[Irow[i], Jcol[i]] <- TRUE
        }

# Compute estimates by each of the selected edge corrections.
        
        if(any(correction == "border" | correction == "bord.modif")) {
          # border method
          # Compute distances to boundary
          b <- bdist.points(X[I])
          # Distances corresponding to identical pairs
          # are excluded from consideration
          d[identical] <- Inf
          # apply reduced sample algorithm
          RS <- Kount(d, b, breaks, slow=FALSE)
          if(any(correction == "bord.modif")) {
            denom.area <- eroded.areas(W, r)
            Kbm <- RS$numerator/(denom.area * nI * nJ)
            K <- bind.fv(K, data.frame(bord.modif=Kbm), "Kbord*(r)",
                         "modified border-corrected estimate of K(r)",
                         "bord.modif")
          }
          if(any(correction == "border")) {
            Kb <- RS$numerator/(lambdaJ * RS$denom.count)
            K <- bind.fv(K, data.frame(border=Kb), "Kbord(r)",
                         "border-corrected estimate of K(r)",
                         "border")
          }
          # reset identical pairs to original values
          d[identical] <- 0
        }
        if(any(correction == "translate")) {
          # translation correction
            edgewt <- edge.Trans(X[I], X[J])
            wh <- whist(d[!identical], breaks$val, edgewt[!identical])
            Ktrans <- cumsum(wh)/(lambdaI * lambdaJ * area)
            rmax <- diameter(W)/2
            Ktrans[r >= rmax] <- NA
            K <- bind.fv(K, data.frame(trans=Ktrans), "Ktrans(r)",
                         "translation-corrected estimate of K(r)",
                         "trans")
        }
        if(any(correction == "isotropic" | correction == "Ripley")) {
          # Ripley isotropic correction
            edgewt <- edge.Ripley(X[I], d)
            wh <- whist(d[!identical], breaks$val, edgewt[!identical])
            Kiso <- cumsum(wh)/(lambdaI * lambdaJ * area)
            rmax <- diameter(W)/2
            Kiso[r >= rmax] <- NA
            K <- bind.fv(K, data.frame(iso=Kiso), "Kiso(r)",
                         "Ripley isotropic correction estimate of K(r)",
                         "iso")
        }
        # which corrections have been computed?
        nama2 <- names(K)
        corrxns <- nama2[nama2 != "r"]

        # default is to display them all
        attr(K, "fmla") <- as.formula(paste(
                       "cbind(",
                        paste(corrxns, collapse=","),
                        ") ~ r"))

        return(K)
          
}
#
#	affine.S
#
#	$Revision: 1.3 $	$Date: 2003/03/11 01:20:27 $
#

affinexy <- function(X, mat=diag(c(1,1)), vec=c(0,0)) {
  if(length(X$x) == 0 && length(X$y) == 0)
    return(list(x=c(),y=c()))
  # Y = M X + V
  ans <- mat %*% rbind(X$x, X$y) + matrix(vec, nrow=2, ncol=length(X$x))
  return(list(x = ans[1,],
              y = ans[2,]))
}

"affine.owin" <- function(X,  mat=diag(c(1,1)), vec=c(0,0), ...) {
  verifyclass(X, "owin")
  # Inspect the determinant
  detmat <- det(mat)
  if(abs(detmat) < .Machine$double.eps)
    stop("Matrix of linear transformation is singular")
  #
  switch(X$type,
         rectangle={
           # convert rectangle to polygon
           P <- owin(X$xrange, X$yrange, poly=
                     list(x=X$xrange[c(1,2,2,1)],
                          y=X$yrange[c(1,1,2,2)]))
           # call polygonal case
           return(affine.owin(P, mat, vec))
         },
         polygonal={
           # First transform the polygonal boundaries
           bdry <- lapply(X$bdry, affinexy, mat=mat, vec=vec)
           # If determinant < 0, traverse polygons in reverse direction
           if(detmat < 0)
             bdry <- lapply(bdry, reverse.xypolygon)
           # Compute bounding box of new polygons
           xr <- range(unlist(lapply(bdry, function(a) a$x)))
           yr <- range(unlist(lapply(bdry, function(a) a$y)))
           # wrap up
           return(owin(xr, yr, poly=bdry))
         },
         mask={
           stop("Sorry, \'affine.owin\' is not yet implemented for masks")
         },
         stop("Unrecognised window type")
         )
}

"affine.ppp" <- function(X, mat=diag(c(1,1)), vec=c(0,0), ...) {
  verifyclass(X, "ppp")
  r <- affinexy(X, mat, vec)
  w <- affine.owin(X$window, mat, vec)
  return(ppp(r$x, r$y, window=w, marks=X$marks))
}


"affine" <- function(X, ...) {
  UseMethod("affine")
}

### ---------------------- shift ----------------------------------

"shift" <- function(X, ...) {
  UseMethod("shift")
}

shiftxy <- function(X, vec=c(0,0)) {
  list(x = X$x + vec[1],
       y = X$y + vec[2])
}

"shift.owin" <- function(X,  vec=c(0,0), ...) {
  verifyclass(X, "owin")
  # Shift the bounding box
  X$xrange <- X$xrange + vec[1]
  X$yrange <- X$yrange + vec[2]
  switch(X$type,
         rectangle={
         },
         polygonal={
           # Shift the polygonal boundaries
           X$bdry <- lapply(X$bdry, shiftxy, vec=vec)
         },
         mask={
           # Shift the pixel coordinates
           X$xcol <- X$xcol + vec[1]
           X$yrow <- X$yrow + vec[2]
           # That's all --- the mask entries are unchanged
         },
         stop("Unrecognised window type")
         )
  return(X)
}

"shift.ppp" <- function(X, vec=c(0,0), ...) {
  verifyclass(X, "ppp")
  r <- shiftxy(X, vec)
  w <- shift.owin(X$window, vec)
  return(ppp(r$x, r$y, window=w, marks=X$marks))
}


#
#
#   allstats.R
#
#   $Revision: 1.10 $   $Date: 2004/01/13 06:59:57 $
#
#
allstats <- function(pp,dataname=NULL,verb=FALSE) {
#
# Function allstats --- to calculate the F, G, K, and J functions
# for an unmarked point pattern.
#
  verifyclass(pp,"ppp")
  if(is.marked(pp))
    stop("This function is applicable only to unmarked patterns.\n")

# get sensible r values
  brks <- handle.r.b.args(r=NULL, breaks=NULL, pp$window, eps=NULL)
  r    <- brks$r

# initialise  
  fns <- list()
  titles <- list()
  deform <- list()
  
# estimate F, G and J 
  if(verb) cat("Calculating F, G, J ...")
  Jout <- Jest(pp,eps=NULL,breaks=brks)
  if(verb) cat("ok.\n")

# extract empty space function F
  Fout <- attr(Jout, "F")
  fns[[1]] <- Fout
  titles[[1]] <- "F function"
  deform[[1]] <- attr(Fout, "fmla")
  if(verb) cat("F done.\n")

# extract Nearest neighbour distance distribution function G
  Gout <- attr(Jout, "G")
  fns[[2]] <- Gout
  titles[[2]] <- "G function"
  deform[[2]] <- attr(Gout, "fmla")
  if(verb) cat("G done.\n")

# extract J function
  attr(Jout, "F") <- NULL
  attr(Jout, "G") <- NULL
  fns[[3]] <- Jout
  titles[[3]] <- "J function"
  deform[[3]] <- attr(Jout, "fmla")
  if(verb) cat("J done.\n")

# compute second moment function K
  fns[[4]] <- Kout <- Kest(pp,eps=NULL,breaks=brks)
  titles[[4]] <- "K function"
  deform[[4]] <- attr(Kout, "fmla")
  if(verb) cat("K done.\n")

# wrap into 'fasp' object
  
  witch <- matrix(1:4,2,2,byrow=TRUE)

  if(is.null(dataname))
    dataname <- deparse(substitute(pp))
  title <- paste("Four summary functions for ",
              	dataname,".",sep="")

  rslt <- fasp(fns, titles, deform, witch, dataname, title)
  return(rslt)
}
#
#      alltypes.R
#
#   $Revision: 1.9 $   $Date: 2004/01/13 10:05:46 $
#
#
alltypes <- function(pp, fun="K", dataname=NULL,verb=FALSE) {
#
# Function 'alltypes' --- calculates a summary function for
# each type, or each pair of types, in a multitype point pattern
#
  verifyclass(pp,"ppp")

# validate 'fun'
  switch(fun, F={}, G={}, J={}, K={},
         stop("Unrecognized function name: ",fun,".\n"))
  wrong <- function(...) {stop("Internal error!")}

# list all possible types  
  if(!is.marked(pp)) {
    um <- 1
    nm <- 1
  } else {
    if(!is.factor(pp$marks))
      stop("the marks must be a factor")
    um <- levels(pp$marks)
    nm <- length(um)
  }
  
# get sensible 'r' values
  brks <- handle.r.b.args(r=NULL, breaks=NULL, pp$window, eps=NULL)
  r    <- brks$r

  # select appropriate statistics
  F1 <- switch(fun,F=Fest,G=Gest,J=Jest,K=Kest, wrong)
  F2 <- switch(fun,F={},G=Gcross,J=Jcross,K=Kcross, wrong)

# build 'fasp' object
  fns  <- list()
  deform <- list()
  
  if(fun=="F") {
    witch <- matrix(1:nm,ncol=1,nrow=nm)
    names(witch) <- um
    titles <- if(nm > 1) as.list(paste("mark =", um)) else list("")
  } else {
    witch <- matrix(1:(nm^2),ncol=nm,nrow=nm,byrow=TRUE)
    dimnames(witch) <- list(um, um)
    titles <- if(nm > 1)
      as.list(paste("(", um[t(row(witch))], ",", um[t(col(witch))], ")", sep=""))
    else
      list("")
  }

  # compute function array
  k   <- 0

  for(i in 1:nrow(witch)) {
	for(j in 1:ncol(witch)) {
          if(verb) cat("i =",i,"j =",j,"\n")
          k <- k+1
          fns[[k]] <- currentfv <- 
            if(nm == 1) # univariate pattern
              F1(pp,eps=NULL,breaks=brks)
            else if(fun=="F" | i==j) # F_i or G_ii, J_ii, K_ii
              F1(pp[pp$marks==um[i]], eps=NULL,breaks=brks)
            else 
              F2(pp,um[i],um[j], eps=NULL, breaks=brks)
          deform[[k]] <- attr(currentfv, "fmla")
        }
      }

  # wrap up into 'fasp' object
  if(is.null(dataname)) dataname <- deparse(substitute(pp))

  if(nm > 1)
	title <- paste("Array of ",fun," functions for ",
              	dataname,".",sep="")
  else
	title <- paste(fun," function for ",dataname,".",sep="")

  rslt <- fasp(fns, titles, deform, witch, dataname, title)
  return(rslt)
}
# 	applynbd.R
#
#     $Revision: 1.1 $     $Date: 2002/07/18 10:53:11 $
#
#
# For each point, identify either
#	 - all points within distance R
#        - the closest N points  
#        - those points satisfying some constraint
# and apply the function FUN to them
#
#################################################################


applynbd <- function(X, FUN, N, R, criterion, exclude=FALSE, ...) {

     nopt <- (!missing(N)) + (!missing(R)) + (!missing(criterion))
     if(nopt > 1)
       stop("exactly one of the arguments \"N\", \"R\", \"criterion\" must be given")
     else if(nopt == 0)
       stop("must specify one of the arguments \"N\", \"R\" or \"criterion\"")
     
     X <- as.ppp(X)
     npts <- X$n

     # compute matrix of pairwise distances
     dist <- pairdist(X$x,X$y)	

     # compute row ranks (avoid ties)
     rankit <- function(x) {  u <- numeric(length(x)); u[order(x)] <- seq(x); return(u) }
     drank <- t(apply(dist, 1, rankit)) - 1

     if(!missing(R)) {
	     # select points closer than R
	     included <- (dist <= R)
     } else if(!missing(N)) {
	     # select N closest points
	     if(N < 1)
		stop("Value of N must be at least 1")
	     if(exclude)
		included <- (drank <= N) 
	     else
		included <- (drank <= N-1)
     } else {
            # some funny criterion
	    included <- matrix(, nrow=npts, ncol=npts)
	    for(i in 1:npts) 
		included[i,] <- criterion(dist[i,], drank[i,])
     }
     
    if(exclude) 
	diag(included) <- FALSE

     # bind into an array
     a <- array(c(included, dist, drank, row(included)), dim=c(npts,npts,4))

     # what to do with a[i, , ]
     go <- function(ai, Z, fun, ...) { 
	which <- as.logical(ai[,1])
        distances <- ai[,2]
	dranks <- ai[,3]
        here <- ai[1,4]	
	fun(Z[which], c(x=Z$x[here], y=Z$y[here]), distances[which], dranks[which], ...) 
     }

     result <- apply(a, 1, go, Z=X, fun=FUN, ...)
  
     return(result)
}

#
#    as.im.R
#
#    conversion to class "im"
#
#    $Revision: 1.1 $   $Date: 2004/01/06 10:17:04 $
#
#    as.im()
#
as.im <- function(X, W, ...) {

  x <- X
  
  if(verifyclass(x, "im", fatal=FALSE))
    return(x)

  if(verifyclass(x, "owin", fatal=FALSE)) {
    w <- as.mask(x)
    m <- w$m
    v <- m * 1
    v[!m] <- NA
    return(im(v, w$xcol, w$yrow))
  }

  if(is.numeric(x) && length(x) == 1) {
    xvalue <- x
    x <- function(xx, yy, ...) { rep(xvalue, length(xx)) }
  }
  
  if(is.function(x)) {
    f <- x 
    w <- as.owin(W)
    w <- as.mask(w)
    m <- w$m
    funnywindow <- !all(m)
    xx <- raster.x(w)
    yy <- raster.y(w)
    if(!funnywindow) {
      values <- f(xx, yy, ...)
      v <- matrix(values, nrow=nrow(m), ncol=ncol(m))
    } else {
      xx <- xx[m]
      yy <- yy[m]
      values <- f(xx, yy, ...)
      v <- matrix(, nrow=nrow(m), ncol=ncol(m))
      v[m] <- values
      v[!m] <- NA
    }
    return(im(v, w$xcol, w$yrow))
  }

  stop("Can't convert x to a pixel image")
}
#
#	breakpts.S
#
#	A simple class definition for the specification
#       of histogram breakpoints in the special form we need them.
#
#	even.breaks()
#
#	$Revision: 1.6 $	$Date: 2002/05/13 12:41:10 $
#
#
#       Other functions in this directory use the standard Splus function
#	hist() to compute histograms of distance values.
#       One argument of hist() is the vector 'breaks'
#	of breakpoints for the histogram cells. 
#
#       The breakpoints must
#            (a) span the range of the data
#            (b) be given in increasing order
#            (c) satisfy breaks[2] = 0,
#
#	The function make.even.breaks() will create suitable breakpoints.
#
#       Condition (c) means that the first histogram cell has
#       *right* endpoint equal to 0.
#
#       Since all our distance values are nonnegative, the effect of (c) is
#       that the first histogram cell counts the distance values which are
#       exactly equal to 0. Hence F(0), the probability P{X = 0},
#       is estimated without a discretisation bias.
#
#	We assume the histograms have followed the default counting rule
#	in hist(), which is such that the k-th entry of the histogram
#	counts the number of data values in 
#		I_k = ( breaks[k],breaks[k+1] ]	for k > 1
#		I_1 = [ breaks[1],breaks[2]   ]
#
#	The implementations of estimators of c.d.f's in this directory
#       produce vectors of length = length(breaks)-1
#       with value[k] = estimate of F(breaks[k+1]),
#       i.e. value[k] is an estimate of the c.d.f. at the RIGHT endpoint
#       of the kth histogram cell.
#
#       An object of class 'breakpts' contains:
#
#              $val     the actual breakpoints
#              $max     the maximum value (= last breakpoint)
#              $ncells  total number of histogram cells
#              $r       right endpoints, r = val[-1]
#              $even    logical = TRUE if cells known to be evenly spaced
#              $npos    number of histogram cells on the positive halfline
#                        = length(val) - 2,
#                       or NULL if cells not evenly spaced
#              $step    histogram cell width
#                       or NULL if cells not evenly spaced
#       
# --------------------------------------------------------------------
breakpts <- function(val, maxi, even=FALSE, npos=NULL, step=NULL) {
  out <- list(val=val, max=maxi, ncells=length(val)-1, r = val[-1],
              even=even, npos=npos, step=step)
  class(out) <- "breakpts"
  out
}

"make.even.breaks" <- 
function(bmax, npos, bstep) {
        if(missing(bstep) && missing(npos))
          stop("Must specify either \'bstep\' or \'npos\'")
        if(!missing(npos)) {
          bstep <- bmax/npos
          val <- seq(0, bmax, length=npos+1)
          val <- c(-bstep,val)
        } else {
          val <- seq(0, bmax, by=bstep)
          val <- c(-bstep,val)
          npos <- length(val) - 2
        }
        breakpts(val, bmax, TRUE, npos, bstep)
}

"as.breakpts" <- function(...) {

  XL <- list(...)

  if(length(XL) == 1) {
    # single argument
    X <- XL[[1]]

    if(!is.null(class(X)) && class(X) == "breakpts")
    # X already in correct form
      return(X)
  
    if(is.vector(X) && length(X) > 2) {
    # it's a vector
      if(X[2] != 0)
        stop("breakpoints do not satisfy breaks[2] = 0")
      steps <- diff(X)
      if(all(steps == mean(steps)))
        # equally spaced
        return(breakpts(X, max(X), TRUE, length(X)-2, steps[1]))
      else
        # unknown spacing
        return(breakpts(X, max(X), FALSE))
    }
  } else {

    # There are multiple arguments.
  
    # exactly two arguments - interpret as even.breaks()
    if(length(XL) == 2)
      return(make.even.breaks(XL[[1]], XL[[2]]))

    # two arguments 'max' and 'npos'
  
    if(!is.null(XL$max) && !is.null(XL$npos))
      return(make.even.breaks(XL$max, XL$npos))

    # otherwise
    stop("Don't know how to convert these data to breakpoints")
  }
  # never reached
}


check.hist.lengths <- function(hist, breaks) {
  verifyclass(breaks, "breakpts")
  nh <- length(hist)
  nb <- breaks$ncells
  if(nh != nb)
    stop(paste("Length of histogram =", nh,
               "not equal to number of histogram cells =", nb))
}

breakpts.from.r <- function(r) {
        if(r[1] != 0)
          stop("First r value must be 0")
        dr <- r[2] - r[1]
        b <- c(-dr, r)
        return(as.breakpts(b))
}

handle.r.b.args <- function(r=NULL, breaks=NULL, window, eps=NULL) {

        if(!is.null(r) && !is.null(breaks))
          stop("Do not specify both \'r\' and \'breaks\'")
  
        if(!is.null(breaks)) {
          breaks <- as.breakpts(breaks)
        } else if(!is.null(r)) {
          breaks <- breakpts.from.r(r)
	} else {
          # both 'r' and 'breaks' are missing
          if(is.null(eps)) {
            if(!is.null(window$xstep))
              eps <- window$xstep
            else 
              eps <- diff(window$xrange)/100
          }
          # warning(paste("step size for argument \'r\' defaults to", eps/4))
          breaks <- make.even.breaks( diameter(window), bstep=eps/4)
        }

        return(breaks)
}
#
#	centroid.S	Centroid of a window
#			and related operations
#
#	$Revision: 1.1 $	$Date: 2002/04/07 09:15:39 $
#
# Function names (followed by "xypolygon" or "owin")
#	
#	intX            integral of x dx dy
#	intY            integral of y dx dy
#	meanX           mean of x dx dy
#	meanY           mean of y dx dy
#       centroid        (meanX, meanY)
#		
#-------------------------------------

intX.xypolygon <- function(polly) {
  #
  # polly: list(x,y) vertices of a single polygon (n joins to 1)
  #
  verify.xypolygon(polly)
  
  x <- polly$x
  y <- polly$y
  
  nedges <- length(x)   # sic
  
  # place x axis below polygon
  y <- y - min(y) 

  # join vertex n to vertex 1
  xr <- c(x, x[1])
  yr <- c(y, y[1])

  # slope
  dx <- diff(xr)
  dy <- diff(yr)
  slope <- ifelse(dx == 0, 0, dy/dx)

  # integrate
  integrals <- x * y * dx + (y + slope * x) * (dx^2)/2 + slope * (dx^3)/3

  -sum(integrals)
}
		
intX.owin <- function(w) {
	verifyclass(w, "owin")
        switch(w$type,
               rectangle = {
		width  <- abs(diff(w$xrange))
		height <- abs(diff(w$yrange))
		answer <- width * height * mean(w$xrange)
               },
               polygonal = {
                 answer <- sum(unlist(lapply(w$bdry, intX.xypolygon)))
               },
               mask = {
                 pixelarea <- abs(w$xstep * w$ystep)
		 npixels <- sum(w$m)
		 area <- npixels * pixelarea
		 x <- raster.x(w)[w$m]
                 answer <- area * mean(x)
               },
               stop("Unrecognised window type")
        )
        return(answer)
}

meanX.owin <- function(w) {
	verifyclass(w, "owin")
        switch(w$type,
               rectangle = {
		answer <- mean(w$xrange)
               },
               polygonal = {
	         area <- sum(unlist(lapply(w$bdry, area.xypolygon)))
                 integrated <- sum(unlist(lapply(w$bdry, intX.xypolygon)))
		 answer <- integrated/area
               },
               mask = {
		 x <- raster.x(w)[w$m]
                 answer <- mean(x)
               },
               stop("Unrecognised window type")
        )
        return(answer)
}

intY.xypolygon <- function(polly) {
  #
  # polly: list(x,y) vertices of a single polygon (n joins to 1)
  #
  verify.xypolygon(polly)
  
  x <- polly$x
  y <- polly$y
  
  nedges <- length(x)   # sic
  
  # place x axis below polygon
  yadjust <- min(y)
  y <- y - yadjust 

  # join vertex n to vertex 1
  xr <- c(x, x[1])
  yr <- c(y, y[1])

  # slope
  dx <- diff(xr)
  dy <- diff(yr)
  slope <- ifelse(dx == 0, 0, dy/dx)

  # integrate
  integrals <- (1/2) * (dx * y^2 + slope * y * dx^2 + slope^2 * dx^3/3)
  total <- sum(integrals) - yadjust * area.xypolygon(polly)

  # change sign to adhere to anticlockwise convention
  -total
}
		
intY.owin <- function(w) {
	verifyclass(w, "owin")
        switch(w$type,
               rectangle = {
		width  <- abs(diff(w$xrange))
		height <- abs(diff(w$yrange))
		answer <- width * height * mean(w$yrange)
               },
               polygonal = {
                 answer <- sum(unlist(lapply(w$bdry, intY.xypolygon)))
               },
               mask = {
                 pixelarea <- abs(w$xstep * w$ystep)
		 npixels <- sum(w$m)
		 area <- npixels * pixelarea
		 y <- raster.y(w)[w$m]
                 answer <- area * mean(y)
               },
               stop("Unrecognised window type")
        )
        return(answer)
}

meanY.owin <- function(w) {
	verifyclass(w, "owin")
        switch(w$type,
               rectangle = {
		answer <- mean(w$yrange)
               },
               polygonal = {
	         area <- sum(unlist(lapply(w$bdry, area.xypolygon)))
                 integrated <- sum(unlist(lapply(w$bdry, intY.xypolygon)))
		 answer <- integrated/area
               },
               mask = {
		 y <- raster.y(w)[w$m]
                 answer <- mean(y)
               },
               stop("Unrecognised window type")
        )
        return(answer)
}

centroid.owin <- function(w) {
	verifyclass(w, "owin")
	return(list(x=meanX.owin(w), y=meanY.owin(w)))
}

	
#
#
#	classes.S
#
#	$Revision: 1.6 $	$Date: 2004/01/05 08:01:17 $
#
#	Generic utilities for classes
#
#
#--------------------------------------------------------------------------

verifyclass <- function(X, C, N=deparse(substitute(X)), fatal=TRUE) {
  if(!inherits(X, C)) {
    if(fatal) {
        gripe <- paste("argument \'", N,
                       "\' is not of class \'", C, "\'", sep="")
	stop(gripe)
    } else 
	return(FALSE)
  }
  return(TRUE)
}

#--------------------------------------------------------------------------

checkfields <- function(X, L) {
	  # X is a list, L is a vector of strings
	  # Checks for presence of field named L[i] for all i
	return(all(!is.na(match(L,names(X)))))
}

getfields <- function(X, L, fatal=TRUE) {
	  # X is a list, L is a vector of strings
	  # Extracts all fields with names L[i] from list X
	  # Checks for presence of all desired fields
	  # Returns the sublist of X with fields named L[i]
	absent <- is.na(match(L, names(X)))
	if(any(absent)) {
		gripe <- paste("Needed the following components:",
				paste(L, collapse=", "),
				"\nThese ones were missing: ",
				paste(L[absent], collapse=", "))
		if(fatal)
			stop(gripe)
		else 
			warning(gripe)
	} 
	return(X[L[!absent]])
}



#
#   When the package is installed, this tells us 
#   the directory where the .tab files are stored
#
#   Typically data/murgatroyd.R reads data-raw/murgatroyd.tab
#   and applies special processing
#
spatstat.rawdata.location <- function() {
    locn <- paste(.path.package(package="spatstat"),
                  "data-raw", sep=.Platform$file.sep)
    return(locn)
}
#
#     dg.S
#
#    $Revision: 1.2 $	$Date: 2004/01/27 10:17:59 $
#
#     Diggle-Gratton pair potential
#
#
DiggleGratton <- function(delta, rho) {
  out <- 
  list(
         name     = "Diggle-Gratton process",
         family    = pairwise.family,
         pot      = function(d, par) {
                       delta <- par$delta
                       rho <- par$rho
                       above <- (d > rho)
                       inrange <- (!above) & (d > delta)
                       h <- above + inrange * (d - delta)/(rho - delta)
                       return(log(h))
                    },
         par      = list(delta=delta, rho=rho),
         parnames = list("lower limit delta", "upper limit rho"),
         init     = function(self) {
                      r <- self$par$delta
                      r <- self$par$rho
                      if(!is.numeric(delta) || length(delta) != 1)
                       stop("lower limit delta must be a single number")
                      if(!is.numeric(rho) || length(rho) != 1)
                       stop("upper limit rho must be a single number")
                      stopifnot(delta >= 0)
                      stopifnot(rho > delta)
                      stopifnot(is.finite(rho))
                    },
         update = NULL,  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           kappa <- coeffs[["Interaction"]]
           return(list(param=list(kappa=kappa),
                       inames="exponent kappa",
                       printable=round(kappa,4)))
         },
         valid = function(coeffs, self) {
           kappa <- ((self$interpret)(coeffs, self))$param$kappa
           return(is.finite(kappa) && (kappa >= 0))
         },
         project = function(coeffs, self) {
           kappa <- coeffs[["Interaction"]]
           coeffs[["Interaction"]] <-
             if(is.na(kappa)) 0 else max(0, kappa)
           return(coeffs)
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#      distances.R
#
#      $Revision: 1.3 $     $Date: 2004/03/08 21:08:30 $
#
#
#      Interpoint distances
#
#

"pairdist"<-
function(x, y=NULL, method="C")
{
  # extract x and y coordinate vectors
  if(verifyclass(x, "ppp", fatal=FALSE)) 
    xy <- list(x=x$x, y=x$y)
  else 
    xy <- xy.coords(x,y)[c("x","y")]
  x <- xy$x
  y <- xy$y

  n <- length(x)
  if(length(y) != n)
    stop("lengths of x and y do not match")

  # special cases
  if(n == 0)
    return(numeric(0))
  else if(n == 1)
    return(matrix(1,nrow=1,ncol=1))
  
  switch(method,
         interpreted={
           xx <- matrix(rep(x, n), nrow = n)
           yy <- matrix(rep(y, n), nrow = n)
           d <- sqrt((xx - t(xx))^2 + (yy - t(yy))^2)
         },
         C={
           d <- numeric( n * n)
           z<- .C("pairdist", n = as.integer(n),
                  x= as.double(x), y= as.double(y), d= as.double(d),
                  PACKAGE="spatstat")
           d <- matrix(z$d, nrow=n, ncol=n)
         },
         stop(paste("Unrecognised method \"", method, "\"", sep=""))
       )
  invisible(d)
}

"nndist"<-
function(x, y=NULL, method="C")
{
	#  computes the vector of nearest-neighbour distances 
	#  for the pattern of points (x[i],y[i])
	#
  # extract x and y coordinate vectors
  if(verifyclass(x, "ppp", fatal=FALSE)) 
    xy <- list(x=x$x, y=x$y)
  else 
    xy <- xy.coords(x,y)[c("x","y")]
  x <- xy$x
  y <- xy$y

  # validate
  n <- length(x)
  if(length(y) != n)
    stop("lengths of x and y do not match")

  # special cases
  if(n == 0)
    return(numeric(0))
  else if(n == 1)
    return(Inf)
  
  switch(method,
         interpreted={
           #  matrix of squared distances between all pairs of points
           sq <- function(a, b) { (a-b)^2 }
           squd <-  outer(x, x, sq) + outer(y, y, sq)
           #  reset diagonal to a large value so it is excluded from minimum
           diag(squd) <- Inf
           #  nearest neighbour distances
           nnd <- sqrt(apply(squd,1,min))
         },
         C={
           n <- length(x)
           nnd<-numeric(n)
           o <- order(y)
           big <- sqrt(.Machine$double.xmax)
           z<- .C("nndistsort",
                  n= as.integer(n),
                  x= as.double(x[o]), y= as.double(y[o]), nnd= as.double(nnd),
                  as.double(big),
                  PACKAGE="spatstat")
           nnd[o] <- z$nnd
         },
         stop(paste("Unrecognised method \"", method, "\"", sep=""))
         )
  invisible(nnd)
}


#
#	distbdry.S		Distance to boundary
#
#	$Revision: 4.4 $	$Date: 2003/03/11 03:04:14 $
#
# -------- functions ----------------------------------------
#
#	bdist.points()
#                       compute vector of distances 
#			from each point of point pattern
#                       to boundary of window
#
#       bdist.pixels()
#                       compute matrix of distances from each pixel
#                       to boundary of window
#
#       erode.mask()    erode the window mask by a distance r
#                       [yields a new window]
#
#       erode.owin()    erode the window by a distance r
#                       [yields a new window]
#
#
# 
"bdist.points"<-
function(X)
{
	verifyclass(X, "ppp") 
	x <- X$x
	y <- X$y
	window <- X$window
        switch(window$type,
               rectangle = {
		xmin <- min(window$xrange)
		xmax <- max(window$xrange)
		ymin <- min(window$yrange)
		ymax <- max(window$yrange)
		result <- pmin(x - xmin, xmax - x, y - ymin, ymax - y)
               },
               polygonal = {
                 xy <- cbind(x,y)
                 result <- rep(Inf, X$n)
                 bdry <- window$bdry
                 for(i in seq(bdry)) {
                   polly <- bdry[[i]]
                   nsegs <- length(polly$x)
                   for(j in 1:nsegs) {
                     j1 <- if(j < nsegs) j + 1 else 1
                     seg <- c(polly$x[j],  polly$y[j],
                              polly$x[j1], polly$y[j1])
                     result <- pmin(result, distppl(xy, seg))
                   }
                 }
               },
               mask = {
                 b <- bdist.pixels(window, coords=FALSE)
                 loc <- nearest.raster.point(x,y,window)
                 result <- numeric(X$n)
                 for(i in 1:(X$n)) 
			result[i] <- b[loc$row[i],loc$col[i]]
               },
               stop("Unrecognised window type", window$type)
               )
        return(result)
}

"bdist.pixels" <- function(w, ..., coords=TRUE) {
	verifyclass(w, "owin")

        masque <- as.mask(w, ...)
        
        switch(w$type,
               mask = {
                 neg <- complement.owin(masque)
                 m <- exactPdt(neg)
                 b <- pmin(m$d,m$b)
               },
               rectangle = {
                 x <- raster.x(masque)
                 y <- raster.y(masque)
                 xmin <- w$xrange[1]
                 xmax <- w$xrange[2]
                 ymin <- w$yrange[1]
                 ymax <- w$yrange[2]
                 b <- pmin(x - xmin, xmax - x, y - ymin, ymax - y)
               },
               polygonal = {
                 # set up pixel raster
                 x <- as.vector(raster.x(masque))
                 y <- as.vector(raster.y(masque))
                 b <- rep(0, length(x))
                 # test each pixel in/out, analytically
                 inside <- inside.owin(x, y, w)
                 # compute distances for these pixels
                 xy <- cbind(x[inside], y[inside])
                 dxy <- rep(Inf, sum(inside))
                 bdry <- w$bdry
                 for(i in seq(bdry)) {
                   polly <- bdry[[i]]
                   nsegs <- length(polly$x)
                   for(j in 1:nsegs) {
                     j1 <- if(j < nsegs) j + 1 else 1
                     seg <- c(polly$x[j],  polly$y[j],
                              polly$x[j1], polly$y[j1])
                     dxy <- pmin(dxy, distppl(xy, seg))
                   }
                 }
                 b[inside] <- dxy
               },
               stop("unrecognised window type", w$type)
               )

        # reshape it
        b <- matrix(b, nrow=masque$dim[1], ncol=masque$dim[2])
        
        if(coords)
          # return in a format which can be plotted by image(), persp() etc
          return(list(x=masque$xcol, y=masque$yrow, z=t(b)))
        else
          # return matrix (for internal use by package)
          return(b)
} 

erode.mask <- function(w, r) {
  # erode a binary image mask without changing any other entries
  
	verifyclass(w, "owin")
        if(w$type != "mask")
          stop("window w is not of type \'mask\'")
        
	bb <- bdist.pixels(w, coords=FALSE)

        if(r > max(bb))
          warning("eroded mask is empty")

        w$m <- (bb >= r)
        return(w)
}

        
erode.owin <- function(w, r, shrink.frame=TRUE, ...) {
	verifyclass(w, "owin")

        if(2 * r >= max(diff(w$xrange), diff(w$yrange)))
          stop("erosion distance r too large for frame of window")

        # compute the dimensions of the eroded frame
        exr <- w$xrange + c(r, -r)
        eyr <- w$yrange + c(r, -r)
        ebox <- list(x=exr[c(1,2,2,1)], y=eyr[c(1,1,2,2)])

        if(w$type == "rectangle") {
          # result is a smaller rectangle
          if(shrink.frame)
            return(owin(exr, eyr))  # type 'rectangle' 
          else
            return(owin(w$xrange, w$yrange, poly=ebox)) # type 'polygonal'
        }

        # otherwise erode the window in pixel image form
        if(w$type != "mask") 
          w <- as.mask(w, ...)
        
        wnew <- erode.mask(w, r)

        if(shrink.frame) {
          # trim off some rows & columns of pixel raster
          keepcol <- (wnew$xcol >= exr[1] & wnew$xcol <= exr[2])
          keeprow <- (wnew$yrow >= eyr[1] & wnew$yrow <= eyr[2])
          wnew$xcol <- w$xcol[keepcol]
          wnew$yrow <- w$yrow[keeprow]
          wnew$dim <- c(sum(keeprow), sum(keepcol))
          wnew$m <- wnew$m[keeprow, keepcol]
        }

        return(wnew)
}	
#
#	dummy.S
#
#	Utilities for generating patterns of dummy points
#
#       $Revision: 4.11 $     $Date: 2004/06/22 02:42:33 $
#
#	corners()	corners of window
#	gridcenters()	points of a rectangular grid
#	stratrand()	random points in each tile of a rectangular grid
#	spokes()	Rolf's 'spokes' arrangement
#	
#	concatxy()	concatenate any lists of x, y coordinates
#
#	default.dummy()	Default action to create a dummy pattern
#		
	
corners <- function(window) {
	window <- as.owin(window)
	x <- window$xrange[c(1,2,1,2)]
	y <- window$yrange[c(1,1,2,2)]
	return(list(x=x, y=y))
}

gridcenters <-	
gridcentres <- function(window, nx, ny) {
	window <- as.owin(window)
	xr <- window$xrange
	yr <- window$yrange
	x <- seq(xr[1], xr[2], length = 2 * nx + 1)[2 * (1:nx)]
	y <- seq(yr[1], yr[2], length = 2 * ny + 1)[2 * (1:ny)]
	x <- rep(x, ny)
	y <- rep(y, rep(nx, ny))
	return(list(x=x, y=y))
}

stratrand <- function(window,nx,ny, k=1) {
	
	# divide window into an nx * ny grid of tiles
	# and place k points at random in each tile
	
	window <- as.owin(window)

	wide  <- diff(window$xrange)/(nx - 1)
	high  <- diff(window$yrange)/(ny - 1)
        cent <- gridcentres(window, nx, ny)
	cx <- rep(cent$x, k)
	cy <- rep(cent$y, k)
	n <- nx * ny * k
	x <- cx + runif(n, min = -wide/2, max = wide/2)
	y <- cy + runif(n, min = -high/2, max = high/2)
	return(list(x=x,y=y))
}

tilecentroids <- function (W, nx, ny)
{
  W <- as.owin(W)
  if(W$type == "rectangle")
    return(gridcentres(W, nx, ny))
  else {
    # approximate
    W   <- as.mask(W)
    xx  <- as.vector(raster.x(W)[W$m])
    yy  <- as.vector(raster.y(W)[W$m])
    pid <- gridindex(xx,yy,W$xrange,W$yrange,nx,nx)$index
    x   <- tapply(xx,pid,mean)
    y   <- tapply(yy,pid,mean)
    return(list(x=x,y=y))
  }
}

tilemiddles <- function (W, nx, ny)
{
    if(W$type == "rectangle")
      return(gridcentres(W, nx, ny))
    
    # pixel approximation to window
    # This matches the pixel approximation used to compute tile areas
    # and ensures that dummy points are generated only inside those tiles
    # that have nonzero digital area
    M   <- as.mask(W)
    xx  <- as.vector(raster.x(M))[M$m]
    yy  <- as.vector(raster.y(M))[M$m]
    # label the pixels by tile index
    pid <- gridindex(xx,yy,W$xrange,W$yrange,nx,ny)$index
    pidvalues <- levels(as.factor(pid))
    # Latter is for comparison with the output of tapply( ..., pid, ...)
    
    ######## 1st try: centroids of tiles
    # (usually inside tile, e.g. if it's convex, but not always inside)
    cx <- tapply(xx, pid, mean)
    cy <- tapply(yy, pid, mean)
    # centroids which are inside window
    cok <- inside.owin(cx, cy, W)
    x <- cx[cok]
    y <- cy[cok]
    # tiles for which this strategy did not work
    nbg <- pidvalues[!cok]
    
    ######### 2nd try: middle point in list of pixels in each tile
    # (always inside tile, by construction)
    todo <- pid %in% nbg
    xx <- xx[todo]
    yy <- yy[todo]
    pid <- pid[todo]
    middle <- function(v) { n <- length(v); mid <- ceiling(n/2); v[mid]}
    mx   <- tapply(xx,pid,middle)
    my   <- tapply(yy,pid,middle)
    
    x <- c( x, mx)
    y <- c( y, my)
    return(list(x=x,y=y))
}

spokes <- function(x, y, nrad = 3, nper = 3, fctr = 1.5, Mdefault=1) {
	#
	# Rolf Turner's "spokes" arrangement
	#
	# Places dummy points on radii of circles 
	# emanating from each data point x[i], y[i]
	#
	#       nrad:    number of radii from each data point
	#       nper:	 number of dummy points per radius
	#       fctr:	 length of largest radius = fctr * M
	#                where M is mean nearest neighbour distance in data
	#
        pat <- inherits(x,"ppp")
        if(pat) w <- x$w
        if(checkfields(x,c("x","y"))) {
          y <- x$y
          x <- x$x
        }
        M <- if(length(x) > 1) mean(nndist(x,y)) else Mdefault
	lrad  <- fctr * M / nper
	theta <- 2 * pi * (1:nrad)/nrad
	cs    <- cos(theta)
	sn    <- sin(theta)
	xt    <- lrad * as.vector((1:nper) %o% cs)
	yt    <- lrad * as.vector((1:nper) %o% sn)
	xd    <- as.vector(outer(x, xt, "+"))
	yd    <- as.vector(outer(y, yt, "+"))
	
        tmp <- list(x = xd, y = yd)
        if(pat) return(as.ppp(tmp,W=w)[,w]) else return(tmp)
}
	
# concatenate any number of list(x,y) into a list(x,y)
		
concatxy <- function(...) {
	x <- unlist(lapply(list(...), function(w) {w$x}))
	y <- unlist(lapply(list(...), function(w) {w$y}))
	if(length(x) != length(y))
		stop("Internal error: lengths of x and y unequal")
	return(list(x=x,y=y))
}

#------------------------------------------------------------

default.dummy <- function(X, nd=NULL, random=FALSE, ntile=NULL, ..., verbose=FALSE) {
	# default action to create dummy points.
	# regular grid of nd[1] * nd[2] points
	# plus corner points of window frame,
        # all clipped to window.
	# 
	X <- as.ppp(X)
	win <- X$window
        # default dimensions
        if(is.null(nd)) 
          nd <- if(!is.null(ntile)) ntile else default.ngrid(X)
        if(length(nd) == 1)
          nd <- rep(nd, 2)
        if(verbose)
          cat(paste("dummy point grid", nd[1], "x", nd[2], "\n"))
        # make dummy points
        dummy <- if(random) 
                  stratrand(win, nd[1], nd[2], 1)
                else
                  tilemiddles(win, nd[1], nd[2])
        # add corner points
	dummy <- concatxy(dummy, corners(win))
	# restrict to window 
	ok <- inside.owin(dummy$x, dummy$y, win)
        if(sum(ok) == 0)
          stop("None of the dummy points lies inside the window")
	x <- dummy$x[ok]
	y <- dummy$y[ok]
        X <- ppp(x, y, window=win)
        # pass parameters for computing weights
        if(is.null(ntile))
          ntile <- nd
        attr(X, "dummy.parameters") <- list(nd=nd, verbose=verbose)
        attr(X, "weight.parameters") <-
          append(list(...), list(ntile=ntile, verbose=verbose))
        return(X)
}


default.ngrid <- function(X) {
	# default dimensions of rectangular grid of dummy points
        # for data pattern X
  X <- as.ppp(X)
  max(30, 10 * ceiling(2 * sqrt(X$n)/10))
}

#
#        edgeRipley.R
#
#    $Revision: 1.1 $    $Date: 2002/04/07 11:14:43 $
#
#    Ripley isotropic edge correction weights
#
#  edge.Ripley(X, r, W)      compute isotropic correction weights
#                            for centres X[i], radii r[i,j], window W
#
#  To estimate the K-function see the idiom in "Kest.S"
#
#######################################################################

edge.Ripley <- function(X, r, W=X$window) {
  # X is a point pattern, or equivalent
  X <- as.ppp(X, W)
  W <- X$window
  if(W$type != "rectangle")
	stop("sorry, Ripley isotropic correction is only implemented\
for rectangular windows")

  if(!is.matrix(r) || nrow(r) != X$n)
    stop("r should be a matrix with nrow(r) = length(X$x)")

  x <- X$x
  y <- X$y

  # perpendicular distance from point to each edge of rectangle
  # L = left, R = right, D = down, U = up
  dL  <- x - W$xrange[1]
  dR  <- W$xrange[2] - x
  dD  <- y - W$yrange[1]
  dU  <- W$yrange[2] - y

  # detect whether any points are corners of the rectangle
  small <- function(x) { abs(x) < .Machine$double.eps }
  corner <- (small(dL) + small(dR) + small(dD) + small(dU) >= 2)
  
  # angle between (a) perpendicular to edge of rectangle
  # and (b) line from point to corner of rectangle
  bLU <- atan2(dU, dL)
  bLD <- atan2(dD, dL)
  bRU <- atan2(dU, dR)
  bRD <- atan2(dD, dR)
  bUL <- atan2(dL, dU)
  bUR <- atan2(dR, dU)
  bDL <- atan2(dL, dD)
  bDR <- atan2(dR, dD)

 # The above are all vectors [i]
 # Now we compute matrices [i,j]

  # half the angle subtended by the intersection between
  # the circle of radius r[i,j] centred on point i
  # and each edge of the rectangle (prolonged to an infinite line)

  hang <- function(d, r) {
    answer <- matrix(0, nrow=nrow(r), ncol=ncol(r))
    # replicate d[i] over j index
    d <- matrix(d, nrow=nrow(r), ncol=ncol(r))
    hit <- (d < r)
    answer[hit] <- acos(d[hit]/r[hit])
    answer
  }

  aL <- hang(dL, r)
  aR <- hang(dR, r)
  aD <- hang(dD, r) 
  aU <- hang(dU, r)

  # apply maxima
  # note: a* are matrices; b** are vectors;
  # b** are implicitly replicated over j index
  cL <- pmin(aL, bLU) + pmin(aL, bLD)
  cR <- pmin(aR, bRU) + pmin(aR, bRD)
  cU <- pmin(aU, bUL) + pmin(aU, bUR)
  cD <- pmin(aD, bDL) + pmin(aD, bDR)

  # total exterior angle
  ext <- cL + cR + cU + cD

  # add pi/2 for corners 
  if(any(corner))
    ext[corner,] <- ext[corner,] + pi/2

  # OK, now compute weight
  weight <- 1 / (1 - ext/(2 * pi))

  return(weight)
}
#
#        edgeTrans.R
#
#    $Revision: 1.5 $    $Date: 2002/08/12 03:51:52 $
#
#    Translation edge correction weights
#
#  edge.Trans(X)      compute translation correction weights
#                     for each pair of points from point pattern X 
#
#  edge.Trans(X, Y, W)   compute translation correction weights
#                        for all pairs of points X[i] and Y[j]
#                        (i.e. one point from X and one from Y)
#                        in window W
#
#  To estimate the K-function see the idiom in "Kest.S"
#
#######################################################################

edge.Trans <- function(X, Y=X, W=X$window, exact=FALSE,
                       trim=spatstat.options("maxedgewt")[[1]]) {

  X <- as.ppp(X, W)

  W <- X$window
  x <- X$x
  y <- X$y

  Y <- as.ppp(Y, W)
  xx <- Y$x
  yy <- Y$y
  
  # For irregular polygons, exact evaluation is very slow;
  # so use pixel approximation, unless exact=TRUE
  if(W$type == "polygonal" && !exact)
    W <- as.mask(W)

  switch(W$type,
         rectangle={
           # Fast code for this case
           wide <- diff(W$xrange)
           high <- diff(W$yrange)
           DX <- abs(outer(x,xx,"-"))
           DY <- abs(outer(y,yy,"-"))
           weight <- wide * high / ((wide - DX) * (high - DY))
         },
         polygonal={
           # This code is SLOW
           a <- area.owin(W)
           weight <- matrix(, nrow=X$n, ncol=Y$n)
           for(i in seq(X$n)) {
             for(j in seq(Y$n)) {
               shiftvector <- c(x[i],y[i]) - c(xx[j],yy[j])
               Wshift <- shift(W, shiftvector)
               b <- overlap.owin(W, Wshift)
               weight[i,j] <- a/b
             }
           }
         },
         mask={
           # make difference vectors
           DX <- outer(x,xx,"-")
           DY <- outer(y,yy,"-")
           # compute set covariance of window
           g <- setcov(W)
           # evaluate set covariance at these vectors
           gvalues <- lookup.im(g, as.vector(DX), as.vector(DY))
           # reshape
           gvalues <- matrix(gvalues, nrow=X$n, ncol=Y$n)
           weight <- area.owin(W)/gvalues
         }
         )
  weight <- matrix(pmin(weight, trim), nrow=X$n, ncol=Y$n)
  return(weight)
}
#
#	exactPdt.S
#	S function exactPdt() for exact distance transform of pixel image
#
#	$Revision: 4.3 $	$Date: 2004/03/08 21:06:43 $
#

"exactPdt"<-
function(im)
{
#
        verifyclass(im, "owin")
        if(im$type != "mask")
          stop("Input must be a window of type \'mask\'")
#	
	nr <- im$dim[1]
	nc <- im$dim[2]
# pad out the input image with a margin of width 1 on all sides
	x <- im$m
	x <- cbind(FALSE, x, FALSE)
	x <- rbind(FALSE, x, FALSE)
#	
	res <- .C("ps_exact_dt_S",
		as.double(im$xrange[1]),
		as.double(im$yrange[1]),
		as.double(im$xrange[2]),
		as.double(im$yrange[2]),
		nr = as.integer(nr),
		nc = as.integer(nc),
		as.logical(t(x)),
		dd = as.double (matrix(0, ncol = nc + 2, nrow = nr + 2)),
		rr = as.integer(matrix(0, ncol = nc + 2, nrow = nr + 2)),
		cc = as.integer(matrix(0, ncol = nc + 2, nrow = nr + 2)),
		bb = as.double (matrix(0, ncol = nc + 2, nrow = nr + 2)),
                PACKAGE="spatstat"
		)
	dist <- matrix(res$dd, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]
	rows <- matrix(res$rr, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]
	cols <- matrix(res$cc, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]
	bdist<- matrix(res$bb, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]

        # convert from C to S
        rows <- rows + 1
        cols <- cols + 1
        
	out <- im
	out$m <- NULL
	out <- append(out, list(d=dist,row=rows,col=cols,b=bdist))
	invisible(out)
}
#
#	exactdt.S
#	S function exactdt() for exact distance transform
#
#	$Revision: 4.3 $	$Date: 2004/03/08 21:06:55 $
#

"exactdt"<-
function(X, ...)
{
	verifyclass(X, "ppp")

        w <- as.mask(X$window, ...)

#
	nr <- w$dim[1]
	nc <- w$dim[2]
#	
	res <- .C("exact_dt_S",
		as.double(X$x),
		as.double(X$y),
		as.integer(X$n),
		as.double(w$xrange[1]),
		as.double(w$yrange[1]),
		as.double(w$xrange[2]),
		as.double(w$yrange[2]),
		nr = as.integer(nr),
		nc = as.integer(nc),
		d = as.double(matrix(0, ncol = nc + 2, nrow = nr + 2)),
		i = as.integer(matrix(0, ncol = nc + 2, nrow = nr + 2)),
		b = as.double(matrix(0, ncol = nc + 2, nrow = nr + 2)),
                PACKAGE="spatstat")
	dist <- matrix(res$d, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]
	inde <- matrix(res$i, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]
	bdry <- matrix(res$b, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)]

        inde <- inde + 1    # convert from C to S indexing
        
	result <- list(d = dist, i = inde, b = bdry)
	append(result, w)
}
#
#	fasp.R
#
#	$Revision: 1.10 $	$Date: 2004/01/13 09:56:35 $
#
#
#-----------------------------------------------------------------------------
#

# creator
fasp <- function(fns, titles, formulae, which,
                 dataname=NULL, title=NULL) {
  stopifnot(is.matrix(which))
  stopifnot(is.list(fns))
  stopifnot(length(fns) == length(which))

  fns <- lapply(fns, as.fv)

  if(!missing(titles)) 
    stopifnot(length(titles) == length(which))
  else
    titles <- lapply(seq(length(which)), function(i) NULL)

  if(!missing(formulae)) {
    if(inherits(formulae, "formula")) 
      # single formula 
      # make it a list of same length as "fns"
      formulae <- lapply(seq(length(which)),
                                 function(i, f) {f}, f=formulae)
    else {
      # list of formulae
      stopifnot(is.list(formulae))
      if(!all(unlist(lapply(formulae, inherits, what="formula"))))
        stop("The entries of \`formulae\' should all be formulae")
      if(length(formulae) == 1 && length(which) != 1)
        # list of length 1 - replicate
        formulae <- lapply(seq(length(which)),
                                 function(i, f) {f}, f=formulae[[1]])
      else 
        stopifnot(length(formulae) == length(which))
    }
  }

  rslt <- list(fns=fns, titles=titles, default.formula=formulae,
               which=which, dataname=dataname, title=title)
  class(rslt) <- "fasp"
  return(rslt)
}

# subset operator

"[.fasp" <-
"subset.fasp" <-
  function(x, I, J, drop, ...) {

        verifyclass(x, "fasp")
        
        m <- nrow(x$which)
        n <- ncol(x$which)
        
        if(missing(I)) I <- 1:m
        if(missing(J)) J <- 1:n

        # determine index subset for lists 'fns', 'titles' etc
        included <- rep(FALSE, length(x$fns))
        w <- as.vector(x$which[I,J])
        if(!any(w))
          stop("result is empty")
        included[w] <- TRUE

        # determine positions in shortened lists
        whichIJ <- x$which[I,J,drop=FALSE]
        newk <- cumsum(included)
        newwhich <- matrix(newk[whichIJ],
                           ncol=ncol(whichIJ), nrow=nrow(whichIJ))

        # create new fasp object
        Y <- fasp(fns      = x$fns[included],
                  titles   = x$titles[included],
                  formulae = x$default.formula[included],
                  which    = newwhich,
                  dataname = x$dataname,
                  title    = x$title)
        return(Y)
}


print.fasp <- function(x, ...) {
  verifyclass(x, "fasp")
  cat("Function array (class \"fasp\")\n")
  dim <- dim(x$which)
  cat(paste("Dimensions: ", dim[1], "x", dim[2], "\n"))
  cat(paste("Title:", if(is.null(x$title)) "(None)" else x$title, "\n"))
  invisible(NULL)
}
#
#
#   formulae.S
#
#   Functions for manipulating model formulae
#
#	$Revision: 1.8 $	$Date: 2004/06/01 11:14:42 $
#
#   identical.formulae()
#          Test whether two formulae are identical
#
#   termsinformula()
#          Extract the terms from a formula
#
#   sympoly()
#          Create a symbolic polynomial formula
#
#   polynom()
#          Analogue of poly() but without dynamic orthonormalisation
#
# -------------------------------------------------------------------
#	

identical.formulae <- function(x, y) {
  return(identical(all.equal(x,y), TRUE))
}

termsinformula <- function(x) {
  if(is.null(x)) return(character(0))
  if(class(x) != "formula")
    stop("argument is not a formula")
  attr(terms(x), "term.labels")
}

sympoly <- function(x,y,n) {

   if(nargs()<2) stop("Degree must be supplied.")
   if(nargs()==2) n <- y
   eps <- abs(n%%1)
   if(eps > 0.000001 | n <= 0) stop("Degree must be a positive integer")
   
   x <- deparse(substitute(x))
   temp <- NULL
   left <- "I("
   rght <- ")"
   if(nargs()==2) {
	for(i in 1:n) {
		xhat <- if(i==1) "" else paste("^",i,sep="")
		temp <- c(temp,paste(left,x,xhat,rght,sep=""))
	}
   }
   else {
	y <- deparse(substitute(y))
	for(i in 1:n) {
		for(j in 0:i) {
			k <- i-j
			xhat <- if(k<=1) "" else paste("^",k,sep="")
			yhat <- if(j<=1) "" else paste("^",j,sep="")
			xbit <- if(k>0) x else ""
			ybit <- if(j>0) y else ""
			star <- if(j*k>0) "*" else ""
			term <- paste(left,xbit,xhat,star,ybit,yhat,rght,sep="")
			temp <- c(temp,term)
		}
	}
      }
   as.formula(paste("~",paste(temp,collapse="+")))
 }


polynom <- function(x, ...) {
  rest <- list(...)
  # degree not given
  if(length(rest) == 0)
    stop("degree of polynomial must be given")
  #call with single variable and degree
  if(length(rest) == 1) {
    degree <- ..1
    if((degree %% 1) != 0 || length(degree) != 1 || degree < 1)
      stop("degree of polynomial should be a positive integer")

    # compute values
    result <- outer(x, 1:degree, "^")

    # compute column names - the hard part !
    namex <- deparse(substitute(x))
    # check whether it needs to be parenthesised
    if(!is.name(substitute(x))) 
      namex <- paste("(", namex, ")", sep="")
    # column names
    namepowers <- if(degree == 1) namex else 
                       c(namex, paste(namex, "^", 2:degree, sep=""))
    namepowers <- paste("[", namepowers, "]", sep="")
    # stick them on
    dimnames(result) <- list(NULL, namepowers)
    return(result)
  }
  # call with two variables and degree
  if(length(rest) == 2) {

    y <- ..1
    degree <- ..2

    # list of exponents of x and y, in nice order
    xexp <- yexp <- numeric()
    for(i in 1:degree) {
      xexp <- c(xexp, i:0)
      yexp <- c(yexp, 0:i)
    }
    nterms <- length(xexp)
    
    # compute 

    result <- matrix(, nrow=length(x), ncol=nterms)
    for(i in 1:nterms) 
      result[, i] <- x^xexp[i] * y^yexp[i]

    #  names of these terms
    
    namex <- deparse(substitute(x))
    # namey <- deparse(substitute(..1)) ### seems not to work in R
    zzz <- as.list(match.call())
    namey <- deparse(zzz[[3]])

    # check whether they need to be parenthesised
    # if so, add parentheses
    if(!is.name(substitute(x))) 
      namex <- paste("(", namex, ")", sep="")
    if(!is.name(zzz[[3]])) 
      namey <- paste("(", namey, ")", sep="")

    nameXexp <- c("", namex, paste(namex, "^", 2:degree, sep=""))
    nameYexp <- c("", namey, paste(namey, "^", 2:degree, sep=""))

    # make the term names
       
    termnames <- paste(nameXexp[xexp + 1],
                       ifelse(xexp > 0 & yexp > 0, ".", ""),
                       nameYexp[yexp + 1],
                       sep="")
    termnames <- paste("[", termnames, "]", sep="")

    dimnames(result) <- list(NULL, termnames)
    # 
    return(result)
  }
  stop("Can't deal with more than 2 variables yet")
}
#
#
#    fv.R
#
#    class "fv" of function value objects
#
#    $Revision: 1.9 $   $Date: 2004/01/13 13:09:29 $
#
#
#    An "fv" object represents one or more related functions
#    of the same argument, such as different estimates of the K function.
#
#    It is a data.frame with additional attributes
#    
#         argu       column name of the function argument (typically "r")
#
#         valu       column name of the recommended function
#
#         ylab       generic label for y axis e.g. K(r)
#
#         fmla       default plot formula
#
#         alim       recommended range of function argument
#
#         labl       recommended xlab/ylab for each column
#
#         desc       longer description for each column
#                     
#    Objects of this class are returned by Kest(), etc
#
##################################################################
# creator

fv <- function(x, argu="r", ylab=NULL, valu, fmla=NULL,
               alim=NULL, labl=names(x), desc=NULL) {
  stopifnot(is.data.frame(x))
  # check arguments
  stopifnot(is.character(argu))
  if(!is.null(ylab)) stopifnot(is.character(ylab))
  stopifnot(is.character(valu))
  
  if(!(argu %in% names(x)))
    stop("\`argu\' must be the name of a column of x")

  if(!(valu %in% names(x)))
    stop("\`valu\' must be the name of a column of x")

  if(is.null(fmla))
    fmla <- as.formula(paste(valu, "~", argu))
  else if(!inherits(fmla, "formula"))
    stop("\`fmla\' should be a formula")
  if(is.null(alim)) {
    argue <- x[[argu]]
    xlim <- range(argue[is.finite(argue)], na.rm=TRUE)
  }
  if(!is.numeric(alim) || length(alim) != 2)
    stop("\`alim\' should be a vector of length 2")
  if(!is.character(labl))
    stop("\`labl\' should be a vector of strings")
  stopifnot(length(labl) == ncol(x))
  if(is.null(desc))
    desc <- character(ncol(x))
  else {
    stopifnot(is.character(desc))
    stopifnot(length(desc) == ncol(x))
    nbg <- is.na(desc)
    if(any(nbg)) desc[nbg] <- ""
  }
  # pack attributes
  attr(x, "argu") <- argu
  attr(x, "valu") <- valu
  attr(x, "ylab") <- ylab
  attr(x, "fmla") <- fmla
  attr(x, "alim") <- alim
  attr(x, "labl") <- labl
  attr(x, "desc") <- desc
  # 
  class(x) <- c("fv", class(x))
  return(x)
}

is.fv <- function(x) {
  inherits(x, "fv")
}

as.fv <- function(x) {
  if(is.fv(x))
    return(x)
  else if(inherits(x, "data.frame"))
    return(fv(x, names(x)[1], , names(x)[2]))
  else if(inherits(x, "fasp") && length(which) == 1)
    return(x$funs[[1]])
  else
    stop("Don't know how to convert this to an \"fv\" object")
}

print.fv <- function(x, ...) {
  verifyclass(x, "fv")
  nama <- names(x)
  a <- attributes(x)
  cat("Function value object (class \"fv\")\n")
  if(!is.null(a$ylab))
    cat(paste("for the function", a$argu, "->", a$ylab, "\n"))
  cat("Entries:\n")
  len <- nchar(a$labl)
  tabjump <- max(c(len, 5)) + 3
  pad <- function(n) { paste(character(n),collapse=" ") }
  cat("id\tlabel", pad(tabjump - 5), "description\n", sep="")
  cat("--\t-----", pad(tabjump - 5), "-----------\n", sep="")
  for(j in seq(ncol(x))) 
    cat(paste(nama[j],"\t",
              a$labl[j],pad(tabjump - len[j]),
              a$desc[j],"\n", sep=""))
  cat("--------------------------------------\n\n")
  cat("Default plot formula:\n\t")
  print.formula(a$fmla)
  cat(paste("\nRecommended range of argument ", a$argu,
            ": [", a$alim[1], ", ", a$alim[2], "]\n", sep=""))
  invisible(NULL)
}

bind.fv <- function(x, y, labl, desc, preferred) {
  verifyclass(x, "fv")
  y <- as.data.frame(y)
  a <- attributes(x)
  
  if(length(labl) != ncol(y))
    stop("length of \`labl\' does not match number of columns of y")
  if(missing(desc) || is.null(desc))
    desc <- character(ncol(y))
  else if(length(desc) != ncol(y))
    stop("length of \`desc\' does not match number of columns of y")
  if(missing(preferred))
    preferred <- a$valu

  xy <- cbind(as.data.frame(x), y)
  z <- fv(xy, a$argu, a$ylab, preferred, a$fmla, a$alim,
          c(attr(x, "labl"), labl),
          c(attr(x, "desc"), desc))
  return(z)
}

"[.fv" <- subset.fv <- function(x, i, j, ..., drop=FALSE)
{
  Nindices <- !missing(i) + !missing(j)
  if(Nindices == 0)
    return(x)
  y <- as.data.frame(x)
  if(Nindices == 2)
    z <- y[i, j, drop=FALSE]
  else if(!missing(i))
    z <- y[i, , drop=FALSE]
  else
    z <- y[ , j, drop=FALSE]

  nama <- names(z)
  argu <- attr(x, "argu")
  if(!(argu %in% nama))
    stop(paste("The function argument \`", argu, "\' must not be removed",
               sep=""))
  valu <- attr(x, "valu")
  if(!(valu %in% nama))
    stop(paste("The default column of function values \'", valu,
                  "\' must not be removed"))

  # If range of argument was implicitly changed, adjust "alim"
  alim <- attr(x, "alim")
  rang <- range(z[[argu]])
  alim <- c(max(alim[1], rang[1]),
            min(alim[2], rang[2]))
  
  return(fv(z, argu=attr(x, "argu"),
               ylab=attr(x, "ylab"),
               valu=attr(x, "valu"),
               fmla=attr(x, "fmla"),
               alim=alim,
               labl=attr(x, "labl"),
               desc=attr(x, "desc")))
}  


#
#
#    geyer.S
#
#    $Revision: 2.1 $	$Date: 2004/01/27 08:06:38 $
#
#    Geyer's saturation process
#
#    Geyer()    create an instance of Geyer's saturation process
#                 [an object of class 'interact']
#
# ------------------------------------------------------------------
#    Note: if you want to imitate this, remember that 'pairsat.family'
#    expects the saturation parameter 'sat' to be called $par$saturate
#    in this 'interact' object.
# -------------------------------------------------------------------
#	

Geyer <- function(r, sat) {
  out <- 
  list(
         name     = "Geyer saturation process",
         family    = pairsat.family,
         pot      = function(d, par) {
                         ifelse(d <= par$r, 1, 0)  # same as for Strauss
                    },
         par      = list(r = r, saturate=sat),
         parnames = c("interaction distance","saturation parameter"),
         init     = function(self) {
                      r <- self$par$r
                      sat <- self$par$saturate
                      if(!is.numeric(r) || length(r) != 1 || r <= 0)
                       stop("interaction distance r must be a positive number")
                      if(!is.numeric(sat) || length(sat) != 1 || sat < 1)
                       stop("saturation parameter sat must be a number >= 1")
                    },
         update = NULL,  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           loggamma <- coeffs[["Interaction"]]
           gamma <- exp(loggamma)
           return(list(param=list(gamma=gamma),
                       inames="interaction parameter gamma",
                       printable=round(gamma,4)))
         },
         valid = function(coeffs, self) {
           gamma <- (self$interpret)(coeffs, self)$param$gamma
           return(is.finite(gamma))
         },
         project = function(coeffs, self) {
           gamma <- (self$interpret)(coeffs, self)$param$gamma
           if(is.na(gamma)) 
             coeffs[["Interaction"]] <- 0
           else if(!is.finite(gamma)) 
             coeffs[["Interaction"]] <-
               log(.Machine$double.xmax)/self$par$saturate
           return(coeffs)
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#   harmonic.R
#
#	$Revision: 1.2 $	$Date: 2004/01/07 08:57:39 $
#
#   harmonic()
#          Analogue of polynom() for harmonic functions only
#
# -------------------------------------------------------------------
#	

harmonic <- function(x,y,n) {
  if(missing(n))
    stop("the order n must be specified")
  n <- as.integer(n)
  if(is.na(n) || n <= 0)
    stop("n must be a positive integer")

  if(n > 3)
    stop("Sorry, harmonic() is not implemented for degree > 3")

  namex <- deparse(substitute(x))
  namey <- deparse(substitute(y))
  if(!is.name(substitute(x))) 
      namex <- paste("(", namex, ")", sep="")
  if(!is.name(substitute(y))) 
      namey <- paste("(", namey, ")", sep="")
  
  switch(n,
         {
           result <- cbind(x, y)
           names <- c(namex, namey)
         },
         {
           result <- cbind(x, y,
                           x*y, x^2-y^2)
           names <- c(namex, namey,
                      paste("(", namex, ".", namey, ")", sep=""),
                      paste("(", namex, "^2-", namey, "^2)", sep=""))
         },
         {
           result <- cbind(x, y,
                           x * y, x^2-y^2, 
                           x^3 - 3 * x * y^2, y^3 - 3 * x^2 * y)
           names <- c(namex, namey,
                      paste("(", namex, ".", namey, ")", sep=""),
                      paste("(", namex, "^2-", namey, "^2)", sep=""),
                      paste("(", namex, "^3-3", namex, ".", namey, "^2)",
                            sep=""),
                      paste("(", namey, "^3-3", namex, "^2.", namey, ")",
                            sep="")
                      )
         }
         )
  dimnames(result) <- list(NULL, names)
  return(result)
}
#
#       images.R
#
#         $Revision: 1.11 $     $Date: 2004/08/30 05:25:56 $
#
#      The class "im" of raster images
#
# Temporary code until we sort out the class structure
#
#     im()     object creator
#
#     is.im()   tests class membership
#
#     plot.im(), image.im(), contour.im(), persp.im()
#                      plotting functions
#
#     rasterx.im(), rastery.im()    
#                      raster X and Y coordinates
#
#     nearest.pixel()   
#     lookup.im()
#                      facilities for looking up pixel values
#
################################################################
########   basic support for class "im"
################################################################
#
#   creator 

im <- function(mat, xcol=seq(ncol(mat)), yrow=seq(nrow(mat))) {
  nr <- nrow(mat)
  nc <- ncol(mat)
  if(length(xcol) != nc)
    stop("Length of xcol does not match ncol(x)")
  if(length(yrow) != nr)
    stop("Length of yrow does not match nrow(x)")
  xstep <- diff(xcol)[1]
  ystep <- diff(yrow)[1]
  xrange <- range(xcol) + c(-1,1) * xstep/2
  yrange <- range(yrow) + c(-1,1) * ystep/2
  out <- list(v   = mat,
              dim = c(nr, nc),
              xrange   = xrange,
              yrange   = yrange,
              xstep    = xstep,
              ystep    = ystep,
              xcol    = xcol,
              yrow    = yrow)
  class(out) <- "im"
  return(out)
}

is.im <- function(x) {
inherits(x,"im")
}

################################################################
########   methods for class "im"
################################################################

image.im <- function(x, ...) {
  main <- deparse(substitute(x))
  do.call("image",
          resolve.defaults(list(x$xcol, x$yrow, t(x$v)),
                           list(...),
                           list(xlab="x", ylab="y", asp=1.0, main=main)))
}

persp.im <- function(x, ...) {
  xname <- deparse(substitute(x))
  do.call("persp",
          resolve.defaults(list(x$xcol, x$yrow, t(x$v)),
                           list(...),
                           list(xlab="x", ylab="y", zlab=xname),
                           list(main=xname)))
}

contour.im <- function (x, ...)
{
  main <- deparse(substitute(x))
  add <- resolve.defaults(list(...), list(add=FALSE))$add
  if(!add) 
    do.call("plot",
            resolve.defaults(list(range(x$xcol), range(x$yrow), type="n"),
                             list(...),
                             list(asp = 1, xlab="x", ylab="y", main=main)))
  do.call("contour",
          resolve.defaults(list(x$xcol, x$yrow, t(x$v), add=TRUE),
                           list(...)))
}

plot.im <- image.im


################################################################
########   other stuff
################################################################

#
# This function is similar to nearest.raster.point except for
# the third argument 'im' and the different idiom for calculating
# row & column - which could be used in nearest.raster.point()

nearest.pixel <- function(x,y,im) {
  verifyclass(im, "im")
  nr <- im$dim[1]
  nc <- im$dim[2]
  cc <- round(1 + (x - im$xcol[1])/im$xstep)
  rr <- round(1 + (y - im$yrow[1])/im$ystep)
  cc <- pmax(1,pmin(cc, nc))
  rr <- pmax(1,pmin(rr, nr))
  return(list(row=rr, col=cc))
}

# This function is a generalisation of inside.owin()
# to images other than binary-valued images.

lookup.im <- function(im, x, y, naok=FALSE) {
  verifyclass(im, "im")

  if(length(x) != length(y))
    stop("x and y must be numeric vectors of equal length")
  value <- rep(NA, length(x))
               
  # test whether inside bounding rectangle
  xr <- im$xrange
  yr <- im$yrange
  frameok <- (xr[1] <= x) & (x <= xr[2]) & (yr[1] <= y) & (y <= yr[2])
  value[!frameok] <- 0
  
  if(!any(frameok))  # all points OUTSIDE range - no further work needed
    return(value)  # all zero

  # consider only those points which are inside the frame
  xf <- x[frameok]
  yf <- y[frameok]
  # map locations to raster (row,col) coordinates
  loc <- nearest.pixel(xf,yf,im)
  # look up image values
  vf <- im$v[cbind(loc$row, loc$col)]
  
  # insert into 'ok' vector
  value[frameok] <- vf

  if(!naok && any(is.na(value)))
    warning("Internal error: NA's generated")
  
  return(value)
}
  

rasterx.im <- function(x) {
  verifyclass(x, "im")
  v <- x$v
  xx <- x$xcol
  matrix(xx[col(v)], ncol=ncol(v), nrow=nrow(v))
}

rastery.im <- function(x) {
  verifyclass(x, "im")
  v <- x$v
  yy <- x$yrow
  matrix(yy[row(v)], ncol=ncol(v), nrow=nrow(v))
}

##############

shift.im <- function(X, vec=c(0,0), ...) {
  verifyclass(X, "im")
  X$xrange <- X$xrange + vec[1]
  X$yrange <- X$yrange + vec[2]
  X$xcol <- X$xcol + vec[1]
  X$yrow <- X$yrow + vec[2]
  return(X)
}

"[.im" <- subset.im <-
function(x, i, j, drop=TRUE, ...) {
  if(verifyclass(i, "ppp", fatal=FALSE) && missing(j)) {
    # 'i' is a point pattern
    # Look up the greyscale values for the points of the pattern
    values <- lookup.im(x, i$x, i$y, naok=TRUE)
    if(drop) return(values[!is.na(values)]) else return(values)
  }
  if(verifyclass(i, "owin", fatal=FALSE) && missing(j)) {
    # 'i' is a window
    # if drop = FALSE, just set values outside window to NA
    # if drop = TRUE, extract values for all pixels inside window
    #                 as an image (if 'i' is a rectangle)
    #                 or as a vector (otherwise)

    xy <- expand.grid(y=x$yrow,x=x$xcol)
    inside <- inside.owin(xy$x, xy$y, i)
    if(!drop) { 
      x$v[!inside] <- NA
      return(x)
    } else if(i$type != "rectangle") {
      return(x$v[inside])
    } else {
      disjoint <- function(r, s) { (r[2] < s[1]) || (r[1] > s[2])  }
      clip <- function(r, s) { c(max(r[1],s[1]), min(r[2],s[2])) }
      inrange <- function(x, r) { (x >= r[1]) & (x <= r[2]) }
      if(disjoint(i$xrange, x$xrange) || disjoint(i$yrange, x$yrange))
        # empty intersection
        return(numeric(0))
      xr <- clip(i$xrange, x$xrange)
      yr <- clip(i$yrange, x$yrange)
      colsub <- inrange(x$xcol, xr)
      rowsub <- inrange(x$yrow, yr)
      return(im(x$v[rowsub,colsub], x$xcol[colsub], x$yrow[rowsub]))
    } 
  }
  stop("The subset operation is undefined for this type of index")
}


#
#	interact.S
#
#
#	$Revision: 1.7 $	$Date: 2004/06/08 10:48:08 $
#
#	Class 'interact' representing the interpoint interaction
#               of a point process model
#              (e.g. Strauss process with a given threshold r)
#
#       Class 'isf' representing a generic interaction structure
#              (e.g. pairwise interactions)
#
#	These do NOT specify the "trend" part of the model,
#	only the "interaction" component.
#
#               The analogy is:
#
#                       glm()             ppm()
#
#                       model formula     trend formula
#
#                       family            interaction
#
#               That is, the 'systematic' trend part of a point process
#               model is specified by a 'trend' formula argument to ppm(),
#               and the interpoint interaction is specified as an 'interact'
#               object.
#
#       You only need to know about these classes if you want to
#       implement a new point process model.
#
#       THE DISTINCTION:
#       An object of class 'isf' describes an interaction structure
#       e.g. pairwise interaction, triple interaction,
#       pairwise-with-saturation, Dirichlet interaction.
#       Think of it as determining the "order" of interaction
#       but not the specific interaction potential function.
#
#       An object of class 'interact' completely defines the interpoint
#       interactions in a specific point process model, except for the
#       regular parameters of the interaction, which are to be estimated
#       by ppm() or otherwise. An 'interact' object specifies the values
#       of all the 'nuisance' or 'irregular' parameters. An example
#       is the Strauss process with a given, fixed threshold r
#       but with the parameters beta and gamma undetermined.
#
#       DETAILS:
#
#       An object of class 'isf' contains the following:
#
#	     $name               Name of the interaction structure         
#                                        e.g. "pairwise"
#
#	     $print		 How to 'print()' this object
#				 [A function; invoked by the 'print' method
#                                 'print.isf()']
#
#            $eval               A function which evaluates the canonical
#                                sufficient statistic for an interaction
#                                of this general class (e.g. any pairwise
#                                interaction.)
#
#       If lambda(u,X) denotes the conditional intensity at a point u
#       for the point pattern X, then we assume
#                  log lambda(u, X) = theta . S(u,X)
#       where theta is the vector of regular parameters,
#       and we call S(u,X) the sufficient statistic.
#
#       A typical calling sequence for the $eval function is
#
#            (f$eval)(X, U, E, potentials, potargs, correction)
#
#       where X is the data point pattern, U is the list of points u
#       at which the sufficient statistic S(u,X) is to be evaluated,
#       E is a logical matrix equivalent to (X[i] == U[j]),
#       $potentials defines the specific potential function(s) and
#       $potargs contains any nuisance/irregular parameters of these
#       potentials [the $potargs are passed to the $potentials without
#       needing to be understood by $eval.]
#       $correction is the name of the edge correction method.
#
#
#       An object of class 'interact' contains the following:
#
#
#            $name               Name of the specific potential
#                                        e.g. "Strauss"
#
#            $family              Object of class "isf" describing
#                                the interaction structure
#
#            $pot	         The interaction potential function(s)
#                                -- usually a function or list of functions.
#                                (passed as an argument to $family$eval)
#
#            $par                list of any nuisance/irregular parameters
#                                (passed as an argument to $family$eval)
#
#            $parnames           vector of long names/descriptions
#                                of the parameters in 'par'
#
#            $init()             initialisation action
#                                or NULL indicating none required
#
#            $update()           A function to modify $par
#                                [Invoked by 'update.interact()']
#                                or NULL indicating a default action
#
#	     $print		 How to 'print()' this object
#				 [Invoked by 'print' method 'print.interact()']
#                                or NULL indicating a default action
#
# --------------------------------------------------------------------------

print.isf <- function(x, ...) {
  verifyclass(x, "isf")
  if(!is.null(x$print))
    (x$print)(x)
  invisible(NULL)
}

print.interact <- function(x, ...) {
  verifyclass(x, "interact")
  if(!is.null(x$print))
     (x$print)(x)
  else {
    # default
    print.isf(x$family)
    cat(paste("Interaction:", x$name, "\n"))
    # just print the parameter names and their values
    cat(paste(x$parnames, ":\t", x$par, "\n", sep=""))
  }
  invisible(NULL)
}

update.interact <- function(object, ...) {
  verifyclass(object, "interact")
  if(!is.null(object$update))
    (object$update)(object, ...)
  else {
    # Default
    # just match the arguments in "..."
    # with those in object$par and update them
    want <- list(...)
    m <- match(names(want),names(object$par))
    nbg <- is.na(m)
    if(any(nbg)) {
        which <- paste((names(want))[nbg])
        warning(paste("Arguments not matched: ", which))
    }
    m <- m[!nbg]
    object$par[m] <- u
    # call object's own initialisation routine
    if(!is.null(object$init))
      (object$init)(object)
    object
  }    
}

is.cadlag <- function (s) 
{
if(!is.stepfun(s)) stop("s is not a step function.\n")
r <- knots(s)
h <- s(r)
n <- length(r)
r1 <- c(r[-1],r[n]+1)
rm <- (r+r1)/2
hm <- s(rm)
identical(all.equal(h,hm),TRUE)
}
#
#  is.subset.owin.R
#
#  $Revision: 1.2 $   $Date: 2004/02/09 13:33:09 $
#
#  Determine whether a window is a subset of another window
#
#  is.subset.owin()
#
is.subset.owin <- function(A, B) {
  A <- as.owin(A)
  B <- as.owin(B)

  if(B$type == "rectangle") {
    # Some cases can be resolved using convexity of B
    
    # (1) A is also a rectangle
   if(A$type == "rectangle") {
     xx <- A$xrange[c(1,2,2,1)]
     yy <- A$yrange[c(1,1,2,2)]
     ok <- inside.owin(xx, yy, B)
     return(all(ok))
   } 
    # (2) A is polygonal
    # Then A is a subset of B iff,
    # for every constituent polygon of A with positive sign,
    # the vertices are all in B
   if(A$type == "polygonal") {
     okpolygon <- function(a, B) {
       if(area.xypolygon(a) < 0) return(TRUE)
       ok <- inside.owin(a$x, a$y, B)
       return(all(ok))
     }
     ok <- unlist(lapply(A$bdry, okpolygon, B=B))
     return(all(ok))
   }
    # (3) Feeling lucky
    # Test whether the bounding box of A is a subset of B
    # Then a fortiori, A is a subset of B
   AA <- bounding.box(A)
   if(is.subset.owin(AA, B))
     return(TRUE)
   
 }
 # In all other cases, convexity cannot be invoked
 # Discretise
  a <- as.mask(A)
  xx <- as.vector(raster.x(a)[a$m])
  yy <- as.vector(raster.y(a)[a$m])
  ok <- inside.owin(xx, yy, B)
  return(all(ok))

}
#
#	kmrs.S
#
#	S code for Kaplan-Meier and reduced sample
#	estimates of a distribution function
#	from _histograms_ of censored data.
#
#	kaplan.meier()
#	reduced.sample()
#       km.rs()
#
#	$Revision: 3.4 $	$Date: 2002/05/13 12:41:10 $
#
#	The functions in this file produce vectors `km' and `rs'
#	where km[k] and rs[k] are estimates of F(breaks[k+1]),
#	i.e. an estimate of the c.d.f. at the RIGHT endpoint of the interval.
#

"kaplan.meier" <-
function(obs, nco, breaks) {
#	obs: histogram of all observations : min(T_i,C_i)
#	nco: histogram of noncensored observations : T_i such that T_i <= C_i
# 	breaks: breakpoints (vector or 'breakpts' object, see breaks.S)
#
        breaks <- as.breakpts(breaks)

	n <- length(obs)
	if(n != length(nco)) 
		stop("lengths of histograms do not match")
	check.hist.lengths(nco, breaks)
#
#	
#   reverse cumulative histogram of observations
	d <- cumsum(obs[n:1])[n:1]
#
#  product integrand
	s <- ifelse(d > 0, 1 - nco/d, 1)
#
	km <- 1 - cumprod(s)
#  km has length n;  km[i] is an estimate of F(r) for r=breaks[i+1]
#	
	widths <- diff(breaks$val)
	lambda <-  - log(ifelse(s > 0, s, 1))/widths 
#  lambda has length n; lambda[i] is an estimate of
#  the average of \lambda(r) over the interval (breaks[i],breaks[i+1]).
#	
	return(list(km=km, lambda=lambda))
}

"reduced.sample" <-
function(nco, cen, ncc, show=FALSE)
#	nco: histogram of noncensored observations: T_i such that T_i <= C_i
#	cen: histogram of all censoring times: C_i
#	ncc: histogram of censoring times for noncensored obs:
#		C_i such that T_i <= C_i
#
#	Then nco[k] = #{i: T_i <= C_i, T_i \in I_k}
#	     cen[k] = #{i: C_i \in I_k}
#	     ncc[k] = #{i: T_i <= C_i, C_i \in I_k}.
#
{
	n <- length(nco)
	if(n != length(cen) || n != length(ncc))
		stop("histogram lengths do not match")
#
#	denominator: reverse cumulative histogram of censoring times
#		denom(r) = #{i : C_i >= r}
#	We compute 
#		cc[k] = #{i: C_i > breaks[k]}	
#	except that > becomes >= for k=0.
#
	cc <- cumsum(cen[n:1])[n:1]
#
#
#	numerator
#	#{i: T_i <= r <= C_i }
#	= #{i: T_i <= r, T_i <= C_i} - #{i: C_i < r, T_i <= C_i}
#	We compute
#		u[k] = #{i: T_i <= C_i, T_i <= breaks[k+1]}
#			- #{i: T_i <= C_i, C_i <= breaks[k]}
#		     = #{i: T_i <= C_i, C_i > breaks[k], T_i <= breaks[k+1]}
#	this ensures that numerator and denominator are 
#	comparable, u[k] <= cc[k] always.
#
	u <- cumsum(nco) - c(0,cumsum(ncc)[1:(n-1)])
	rs <- u/cc
#
#	Hence rs[k] = u[k]/cc[k] is an estimator of F(r) 
#	for r = breaks[k+1], i.e. for the right hand end of the interval.
#
        if(!show)
          return(rs)
        else
          return(list(rs=rs, numerator=u, denominator=cc))
}

"km.rs" <-
function(o, cc, d, breaks) {
#	o: censored lifetimes min(T_i,C_i)
#	cc: censoring times C_i
#	d: censoring indicators 1(T_i <= C_i)
#	breaks: histogram breakpoints (vector or 'breakpts' object)
#
        breaks <- as.breakpts(breaks)
# compile histograms
	obs <- hist( o,		breaks=breaks$val,plot=FALSE,probability=FALSE)$counts
	nco <- hist( o[d], 	breaks=breaks$val,plot=FALSE,probability=FALSE)$counts
	cen <- hist( cc,	breaks=breaks$val,plot=FALSE,probability=FALSE)$counts
	ncc <- hist( cc[d],	breaks=breaks$val,plot=FALSE,probability=FALSE)$counts
# go
	km <- kaplan.meier(obs, nco, breaks)
	rs <- reduced.sample(nco, cen, ncc)
#
	return(list(rs=rs, km=km$km, hazard=km$lambda,
                    r=breaks$val[-1], breaks=breaks$val))
}
#
#
#    lennard.R
#
#    $Revision: 1.3 $	$Date: 2004/08/11 07:45:49 $
#
#    Lennard-Jones potential
#
#
# -------------------------------------------------------------------
#	

LennardJones <- function() {
  out <- 
  list(
         name     = "Lennard-Jones potential",
         family    = pairwise.family,
         pot      = function(d, par) {
                         array(c(d^{-12},-d^{-6}),dim=c(dim(d),2))
                    },
         par      = list(),
         parnames = character(),
         init     = function(...){}, # do nothing
         update = function(...){},  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           theta1 <- coeffs[["Interact.1"]]
           theta2 <- coeffs[["Interact.2"]]
           if(theta1 <= 0) {
             # Fitted regular parameter sigma^12 is negative
             sigma <- NA
             tau <- NA
           }
           else {
             sigma <- theta1^(1/12)
             tau <- theta2/sqrt(theta1)
           }
           return(list(param=list(sigma=sigma, tau=tau),
                       inames="interaction parameters",
                       printable=round(c(sigma=sigma,tau=tau),4)))
         },
         valid = function(coeffs, self) {
           p <- self$interpret(coeffs, self)$param
           return(!any(is.na(p)))
         },
         project = function(coeffs, self) {
           p <- self$interpret(coeffs, self)$param
           if(any(is.na(p)))
             stop("Don't know how to project Lennard-Jones models")
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#     markcorr.R
#
#     $Revision: 1.4 $ $Date: 2004/06/01 04:44:01 $
#
#    Estimate the mark correlation function
#
#
# ------------------------------------------------------------------------

"markcorr"<-
function(X, f = function(m1,m2) { m1 * m2}, r=NULL, slow=FALSE,
         correction=c("border", "isotropic", "Ripley", "translate"),
         method="density", ...)
{
	verifyclass(X, "ppp")
        if(!is.function(f))
          stop("Second argument f must be a function")

	npoints <- X$n
        W <- X$window

        breaks <- handle.r.b.args(r, NULL, W)
        r <- breaks$r

        if(length(method) > 1)
          stop("Select only one method, please")
        if(method=="density" && !breaks$even)
          stop("Evenly spaced r values are required if method=\"density\"")
        
        # available selection of edge corrections depends on window
        if(W$type != "rectangle") {
          iso <- (correction == "isotropic") | (correction == "Ripley")
          if(any(iso)) {
            if(!missing(correction))
              warning("Isotropic correction not implemented for non-rectangular windows")
            correction <- correction[!iso]
          }
        }
         
        # this will be the output data frame
        result <- data.frame(r=r, theo= rep(1,length(r)))
        desc <- c("distance argument r", "theoretical Poisson m(r)=1")
        alim <- c(0, min(diff(X$window$xrange),diff(X$window$yrange))/4)
        result <- fv(result,
                     "r", "m(r)", "theo", , alim, c("r","mpois(r)"), desc)


        # pairwise distances
	d <- pairdist(X$x, X$y)
        offdiag <- (row(d) != col(d))

        # apply f to each combination of marks
        # mm[i,j] = mark[i]
        mm <- matrix(X$marks,nrow=npoints,ncol=npoints)
        mr <- as.vector(mm)
        mc <- as.vector(t(mm))
        ff <- f(mr, mc)
        ff <- matrix(ff, nrow=npoints, ncol=npoints)
        # so ff[i,j] = f(mark[i], mark[j])

        Ef <- mean(ff)
        
        if(any(correction == "border")) {
          # border method
          # Compute distances to boundary
          b <- bdist.points(X)
          bb <- matrix(b, nrow=npoints, ncol=npoints)
          # set edge correction weight = 1 iff b > d
          ok <- 1 * (bb > d)
          # get smoothed estimate of mcf
          Mborder <- mkcor(d[offdiag], ff[offdiag], ok[offdiag],
                                 Ef, r, method, ...)
          result <- bind.fv(result,
                            data.frame(border=Mborder), "mbord(r)",
                            "border-corrected estimate of m(r)",
                            "border")
        }
        if(any(correction == "translate")) {
          # translation correction
            edgewt <- edge.Trans(X, exact=slow)
          # get smoothed estimate of mark covariance
            Mtrans <- mkcor(d[offdiag], ff[offdiag], edgewt[offdiag],
                                  Ef, r, method, ...)
            result <- bind.fv(result,
                              data.frame(trans=Mtrans), "mtrans(r)",
                              "translation-corrected estimate of m(r)",
                              "trans")
        }
        if(any(correction == "isotropic" | correction == "Ripley")) {
          # Ripley isotropic correction
            edgewt <- edge.Ripley(X, d)
          # get smoothed estimate of mark covariance
            Miso <- mkcor(d[offdiag], ff[offdiag], edgewt[offdiag],
                                Ef, r, method, ...)
            result <- bind.fv(result,
                              data.frame(iso=Miso), "miso(r)",
                              "Ripley isotropic correction estimate of m(r)",
                              "iso")
        }
        return(result)
}
	
mkcor <- function(d, ff, wt, Ef, rvals, method="smrep", ..., nwtsteps=500) {
  d <- as.vector(d)
  ff <- as.vector(ff)
  wt <- as.vector(wt)
  switch(method,
         density={
           # use replication to effect the weights
           # (there's no weights argument to density()
           nw <- round(nwtsteps * wt/max(wt))
           drep.w <- rep(d, nw)
           fw <- ff * wt
           nfw <- round(nwtsteps * fw/max(fw))
           drep.fw <- rep(d, nfw)
           # smooth estimate of kappa_f
           est <- density(drep.fw,
                          from=min(rvals), to=max(rvals), n=length(rvals),
                          ...)$y
           numerator <- est * sum(fw)/sum(est)
           # smooth estimate of kappa_1
           est0 <- density(drep.w,
                          from=min(rvals), to=max(rvals), n=length(rvals),
                          ...)$y
           denominator <- est0 * (sum(wt)/ sum(est0)) * Ef
           result <- numerator/denominator
         },
         sm={
           # This is slow!
           require(sm)
           # smooth estimate of kappa_f
           fw <- ff * wt
           est <- sm.density(d, weights=fw,
                             eval.points=rvals,
                             display="none", nbins=0, ...)$estimate
           numerator <- est * sum(fw)/sum(est)
           # smooth estimate of kappa_1
           est0 <- sm.density(d, weights=wt,
                              eval.points=rvals,
                              display="none", nbins=0, ...)$estimate
           denominator <- est0 * (sum(wt)/ sum(est0)) * Ef
           result <- numerator/denominator
         },
         smrep={
           require(sm)
           # use replication to effect the weights (it's faster)
           nw <- round(nwtsteps * wt/max(wt))
           drep.w <- rep(d, nw)
           fw <- ff * wt
           nfw <- round(nwtsteps * fw/max(fw))
           drep.fw <- rep(d, nfw)
           # smooth estimate of kappa_f
           est <- sm.density(drep.fw,
                             eval.points=rvals,
                             display="none", ...)$estimate
           numerator <- est * sum(fw)/sum(est)
           # smooth estimate of kappa_1
           est0 <- sm.density(drep.w,
                              eval.points=rvals,
                              display="none", ...)$estimate
           denominator <- est0 * (sum(wt)/ sum(est0)) * Ef
           result <- numerator/denominator
         },
         loess = {
           if(!exists("R.Version") ||
              ((virg <- R.Version())$major == "1" && as.numeric(virg$minor) < 9))
             require(modreg)
           # set up data frame
           df <- data.frame(d=d, ff=ff, wt=wt)
           # fit curve to numerator using loess
           fitobj <- loess(ff ~ d, data=df, weights=wt, ...)
           # evaluate fitted curve at desired r values
           Eff <- predict(fitobj, newdata=data.frame(d=rvals))
           # normalise:
           # denominator is the sample mean of all ff[i,j],
           # an estimate of E(ff(M1,M2)) for M1,M2 independent marks
           result <- Eff/Ef
         },
         )
  return(result)
}

#    mpl.R
#
#	$Revision: 5.14 $	$Date: 2004/09/23 01:15:45 $
#
#    mpl.engine()
#          Fit a point process model to a two-dimensional point pattern
#          by maximum pseudolikelihood
#
#    mpl.prepare()
#          set up data for glm procedure
#
# -------------------------------------------------------------------
#

"mpl" <- function(Q,
         trend = ~1,
	 interaction = NULL,
         data = NULL,
	 correction="border",
	 rbord = 0,
         use.gam=FALSE) {
   .Deprecated("ppm", package="spatstat")
   ppm(Q, trend, interaction, data, correction, rbord, use.gam, method="mpl")
}

"mpl.engine" <- 
function(Q,
         trend = ~1,
	 interaction = NULL,
         covariates = NULL,
	 correction="border",
	 rbord = 0,
         use.gam=FALSE
) {
#
# Extract quadrature scheme 
#
	if(verifyclass(Q, "ppp", fatal = FALSE)) {
#		warning("using default quadrature scheme")
		Q <- quadscheme(Q)   
	} else if(!verifyclass(Q, "quad", fatal=FALSE))
		stop("First argument Q should be a quadrature scheme")
#
# Data points
  X <- Q$data
#
# Data and dummy points together 
  P <- union.quad(Q)
#
#
# Interpret the call
want.trend <- !is.null(trend) && !identical.formulae(trend, ~1)
want.inter <- !is.null(interaction) && !is.null(interaction$family)

the.version <- list(major=1,
                    minor=5,
                    release=4,
                    date="$Date: 2004/09/23 01:15:45 $")

if(use.gam && exists("is.R") && is.R()) 
  require(mgcv)
        
if(!want.trend && !want.inter) {
  # the model is the uniform Poisson process
  # The MPLE (= MLE) can be evaluated directly
  npts <- X$n
  volume <- area.owin(X$window) * markspace.integral(X)
  lambda <- npts/volume
  theta <- list("log(lambda)"=log(lambda))
  maxlogpl <- npts * (log(lambda) - 1)
  rslt <- list(
               method      = "mpl",
               theta       = theta,
               coef        = theta,
               trend       = NULL,
               interaction = NULL,
               Q           = Q,
               maxlogpl    = maxlogpl,
               internal    = list(),
	       correction  = correction,
               rbord       = rbord,
               version     = the.version)
  class(rslt) <- "ppm"
  return(rslt)
}

        
#################  P r e p a r e    D a t a   ######################
        
prep <- mpl.prepare(Q, X, P, trend, interaction,
                    covariates, want.trend, want.inter, correction, rbord)

fmla <- prep$fmla
glmdata <- prep$glmdata

        
################# F i t    i t   ####################################

# Fit the generalized linear/additive model.

if(want.trend && use.gam)
  FIT  <- gam(fmla, family=quasi(link=log, var=mu), weights=.mpl.W,
              data=glmdata, subset=(.mpl.SUBSET=="TRUE"),
              control=gam.control(maxit=50))
else
  FIT  <- glm(fmla, family=quasi(link=log, var=mu), weights=.mpl.W,
              data=glmdata, subset=(.mpl.SUBSET=="TRUE"),
              control=glm.control(maxit=50))
  
################  I n t e r p r e t    f i t   #######################

# Fitted coefficients

co <- FIT$coef
theta <- if(exists("is.R") && is.R()) NULL else dummy.coef(FIT)

     W <- glmdata$.mpl.W
SUBSET <- glmdata$.mpl.SUBSET        
     Z <- is.data(Q)
Vnames <- prep$Vnames
        
# attained value of max log pseudolikelihood
maxlogpl <-  -(deviance(FIT)/2 + sum(log(W[Z & SUBSET])) + sum(Z & SUBSET))

######################################################################
# Clean up & return 

rslt <- list(
             method       = "mpl",
             theta        = theta,
             coef         = co,
             trend        = if(want.trend) trend       else NULL,
             interaction  = if(want.inter) interaction else NULL,
             Q            = Q,
             maxlogpl     = maxlogpl, 
             internal     = list(glmfit=FIT, glmdata=glmdata, Vnames=Vnames),
             covariates   = covariates,
             correction   = correction,
             rbord        = rbord,
             version      = the.version)
class(rslt) <- "ppm"
return(rslt)
}  


##########################################################################
### /////////////////////////////////////////////////////////////////////
##########################################################################


mpl.prepare <- function(Q, X, P, trend, interaction, covariates, 
                        want.trend, want.inter, correction, rbord) {

# Validate/evaluate covariates
if(want.trend && !is.null(covariates))
  covariates.df <- mpl.get.covariates(covariates, P, "quadrature points")

################ C o m p u t e     d a t a  ####################

        
### Form the weights and the ``response variable''.

.mpl <- list()
.mpl$W <- w.quad(Q)
.mpl$Z <- is.data(Q)
.mpl$Y <- .mpl$Z/.mpl$W
.mpl$MARKS <- marks.quad(Q)  # is NULL for unmarked patterns

glmdata <- data.frame(.mpl.W = .mpl$W,
                      .mpl.Y = .mpl$Y)
        
n <- nrow(glmdata)
.mpl$SUBSET <- rep(TRUE, n)
	
internal.names <- c(".mpl.W", ".mpl.Y", ".mpl.Z", ".mpl.SUBSET",
                    "SUBSET", ".mpl")

reserved.names <- c("x", "y", "marks", internal.names)
                    
zeroes <- attr(.mpl$W, "zeroes")
if(!is.null(zeroes))
	.mpl$SUBSET <-  !zeroes

####################### T r e n d ##############################

  check.clashes <- function(forbidden, offered, where) {
    name.match <- outer(forbidden, offered, "==")
    if(any(name.match)) {
      is.matched <- apply(name.match, 2, any)
      matched.names <- (offered)[is.matched]
      if(sum(is.matched) == 1) {
        return(paste("The variable \"",
                   matched.names,
                   "\" in ", where,
                   " is a reserved name", sep=""))
      } else {
        return(paste("The variables \"",
                   paste(matched.names, collapse="\", \""),
                   "\" in ", where,
                   " are reserved names", sep=""))
      }
    }
    return("")
  }
  
if(want.trend) {
  # Check for use of internal names in trend
  cc <- check.clashes(internal.names, termsinformula(trend),
                      "the model formula")
  if(cc != "") stop(cc)
  # Default explanatory variables for trend
  glmdata <- data.frame(glmdata, x=P$x, y=P$y)
  if(!is.null(.mpl$MARKS))
    glmdata <- data.frame(glmdata, marks=.mpl$MARKS)
  # 
  if(!is.null(covariates)) {
#   Check for duplication of reserved names
    cc <- check.clashes(reserved.names, names(covariates), "\'covariates\'")
    if(cc != "") stop(cc)
#   Append `covariates.df' to `glmdata'
    glmdata <- data.frame(glmdata,covariates.df)
  }
}

###################### I n t e r a c t i o n ####################

Vnames <- NULL

if(want.inter) {

  verifyclass(interaction, "interact")
  
  # Calculations require a matrix (data) x (data + dummy) indicating equality
  E <- equals.quad(Q)
  
  # Form the matrix of "regression variables" V.
  # The rows of V correspond to the rows of P (quadrature points)
  # while the column(s) of V are the regression variables (log-potentials)

  V <- interaction$family$eval(X, P, E,
                        interaction$pot,
                        interaction$par,
                        correction)

  if(!is.matrix(V))
    stop("interaction evaluator did not return a matrix")

  # Augment data frame by appending the regression variables for interactions.
  #
  # If there are no names provided for the columns of V,
  # call them "Interact.1", "Interact.2", ...

  if(is.null(dimnames(V)[[2]])) {
    # default names
    nc <- ncol(V)
    dimnames(V) <- list(dimnames(V)[[1]], 
      if(nc == 1) "Interaction" else paste("Interact.", 1:nc, sep=""))
  }

  # List of interaction variable names
  Vnames <- dimnames(V)[[2]]
  
  #   Check for name clashes between the interaction variables
  #   and the formula
  cc <- check.clashes(Vnames, termsinformula(trend), "model formula")
  if(cc != "") stop(cc)
  #   and with the variables in 'covariates'
  if(!is.null(covariates)) {
    cc <- check.clashes(Vnames, names(covariates), "\'covariates\'")
    if(cc != "") stop(cc)
  }

  # OK. append variables.
  glmdata <- data.frame(glmdata, V)   

# Keep only those quadrature points for which the
# conditional intensity is nonzero. 

#KEEP  <- apply(V != -Inf, 1, all)
.mpl$KEEP  <- matrowall(V != -Inf)

.mpl$SUBSET <- .mpl$SUBSET & .mpl$KEEP

if(any(.mpl$Z & !.mpl$KEEP)) {
        howmany <- sum(.mpl$Z & !.mpl$KEEP)
	warning(paste(howmany, "data point(s) are illegal (zero conditional intensity under the model)"))
#	browser()
}

}

##################   D a t a    f r a m e   ###################

# Determine the domain of integration for the pseudolikelihood.

if(correction == "border") {
	bd <- bdist.points(P)
	.mpl$DOMAIN <- (bd >= rbord)
	.mpl$SUBSET <- .mpl$DOMAIN & .mpl$SUBSET
}

glmdata <- data.frame(glmdata, .mpl.SUBSET=.mpl$SUBSET)

#################  F o r m u l a   ##################################

if(!want.trend) trend <- ~1 
trendpart <- paste(as.character(trend), collapse=" ")
rhs <- paste(c(trendpart, Vnames), collapse= "+")
fmla <- paste(".mpl.Y ", rhs)
fmla <- as.formula(fmla)

#### 

return(list(fmla=fmla, glmdata=glmdata, Vnames=Vnames))

}


####################################################################
####################################################################

mpl.get.covariates <- function(covariates, locations, type="") {
  x <- locations$x
  y <- locations$y
  if(is.null(x) || is.null(y)) {
    xy <- xy.coords(locations)
    x <- xy$x
    y <- xy$y
  }
  if(is.null(x) || is.null(y))
    stop("Can't interpret \`locations\' as x,y coordinates")
  n <- length(x)
  if(is.data.frame(covariates)) {
    if(nrow(covariates) != n)
      stop(paste("Number of rows in \`covariates\' != number of", type))
    return(covariates)
  } else if(is.list(covariates)) {
    if(!all(unlist(lapply(covariates, is.im))))
      stop("Some entries in the list \`covariates\' are not images")
    if(any(names(covariates) == ""))
      stop("Some entries in the list \`covariates\' are un-named")
    # look up values of each covariate image at the quadrature points
    values <- lapply(covariates, lookup.im, x=x, y=y, naok=TRUE)
    return(as.data.frame(values))
  } else
    stop("\`covariates\' must be either a data frame or a list of images")
}

#
#
#    multipair.family.S
#
#    $Revision: 1.5 $	$Date: 2003/03/11 07:46:50 $
#
#    Pairwise interaction class for multitype point processes
#    i.e. marked point processes with a finite number of possible types
#
#    multipair.family:      object of class 'isf' defining
#                           pairwise interaction for multitype point processes
#	
# -------------------------------------------------------------------
#	

multipair.family <-
  list(
         name  = "multipair",
         print = function(self) {
                      cat("Multitype pairwise interaction family\n")
         },
         eval  = function(X,U,Equal,pairpot,potpars,correction) {
  #
  # multipair.family$eval
  #
  #  $Revision: 1.5 $  $Date: 2003/03/11 07:46:50 $
  #         
  # This auxiliary function is not meant to be called by the user.
  # It computes the distances between points,
  # evaluates the pair potential and applies edge corrections.
  #
  # Arguments:
  #   X           data point pattern (marked)             'ppp' object
  #   U           points at which to evaluate potential   list(x,y,marks)
  #   Equal       logical matrix X[i] == U[j]             matrix or NULL
  #                      (NB: equality only if marks are equal too)
  #                      NULL means all comparisons are FALSE
  #   pairpot     potential function (see above)          function()
  #   potpars     auxiliary parameters for pairpot        list(......)
  #   correction  edge correction type                    (string)
  #
  # Value:
  #    matrix of values of the total pair potential
  #    induced by the pattern X at each location given in U.
  #    The rows of this matrix correspond to the rows of U (the sample points);
  #    the k columns are the coordinates of the k-dimensional potential.
  #
  # Note:
  # The pair potential function 'pairpot' will be called as
  #    pairpot(M, V1, V2, potpars)
  # where M is a matrix of interpoint distances,
  #       V1 and V2 are vectors of marks for the rows and columns of M resp.
  # It must return a matrix with the same dimensions as M
  # or an array with its first two dimensions the same as the dimensions of M.
  ##########################################################################

# coercion should be unnecessary..
# X <- as.ppp(X)
# U <- as.ppp(U, X$window)   # i.e. X$window is DEFAULT window

x <- X$x
y <- X$y
m <- X$marks

xx <- U$x
yy <- U$y
mm <- U$marks

if(!any(correction == c(
          "periodic",
          "border",
          "translate",
          "isotropic", "Ripley",
          "none")))
  stop(paste("Unrecognised edge correction \'", correction, "\'", sep=""))
          
#  
# Form the matrix of distances
	
sqdif <- function(u,v) {(u-v)^2}

MX <- outer(x,xx,sqdif)
MY <- outer(y,yy,sqdif)

if(correction=="periodic") {
	if(X$window$type != "rectangle")
          stop("Periodic edge correction can't be applied",
               "in an irregular window")
	wide <- diff(X$window$xrange)
	high <- diff(X$window$yrange)
	MX1 <- outer(x,xx-wide,sqdif)
	MX2 <- outer(x,xx+wide,sqdif)
	MX <- pmin(MX, MX1, MX2)
	MY1 <- outer(y,yy-high,sqdif)
	MY2 <- outer(y,yy+high,sqdif)
	MY <- pmin(MY, MY1, MY2)
}
M <- sqrt(MX + MY)

# Evaluate the pairwise potential 

POT <- pairpot(M, m, mm, potpars)
if(length(dim(POT)) == 1 || any(dim(POT)[1:2] != dim(M))) {
        whinge <- paste(
           "The pair potential function ",deparse(substitute(pairpot)),
           "must produce a matrix or array with its first two dimensions\n",
           "the same as the dimensions of its input.\n", sep="")
	stop(whinge)
}

# make it a 3D array
if(length(dim(POT))==2)
        POT <- array(POT, dim=c(dim(POT),1), dimnames=NULL)
                          
if(correction == "translate") {
        edgewt <- edge.Trans(X, U)
        # sanity check ("everybody knows there ain't no...")
        if(!is.matrix(edgewt))
          stop("internal error: edge.Trans() did not yield a matrix")
        if(nrow(edgewt) != X$n || ncol(edgewt) != length(U$x))
          stop("internal error: edge weights matrix returned by edge.Trans() has wrong dimensions")
        POT <- c(edgewt) * POT
} else if(correction == "isotropic" || correction == "Ripley") {
        # weights are required for contributions from QUADRATURE points
        edgewt <- t(edge.Ripley(U, t(M), X$window))
        if(!is.matrix(edgewt))
          stop("internal error: edge.Ripley() did not return a matrix")
        if(nrow(edgewt) != X$n || ncol(edgewt) != length(U$x))
          stop("internal error: edge weights matrix returned by edge.Ripley() has wrong dimensions")
        POT <- c(edgewt) * POT
}

# No pair potential term between a point and itself
if(!is.null(Equal))
  POT[Equal] <- 0

# Sum the pairwise potentials 

V <- apply(POT, c(2,3), sum)

return(V)

}
######### end of function $eval                            
)
######### end of list

class(multipair.family) <- "isf"





###########    utilities for this family  #######################


MultiPair.checkmatrix <-
  function(mat, n, name) {
    if(!is.matrix(mat))
      stop(paste(name, "must be a matrix"))
    if(any(dim(mat) != rep(n,2)))
      stop(paste(name, "must be a square matrix,",
                 "of size", n, "x", n))
    isna <- is.na(mat)
    if(any(mat[!isna] <= 0))
      stop(paste("Entries of", name,
                 "must be positive numbers or NA"))
    if(any(isna != t(isna)) ||
       any(mat[!isna] != t(mat)[!isna]))
      stop(paste(name, "must be a symmetric matrix"))
  }

#
#
#    multistrauss.S
#
#    $Revision: 2.3 $	$Date: 2004/08/11 07:20:36 $
#
#    The multitype Strauss process
#
#    MultiStrauss()    create an instance of the multitype Strauss process
#                 [an object of class 'interact']
#	
# -------------------------------------------------------------------
#	

MultiStrauss <- function(types, radii) {
  if(length(types) == 1)
    stop("The \`types\' argument should be a vector of all possible types")
  if(is.factor(types)) {
    types <- levels(types)
  } else {
    types <- levels(factor(types, levels=types))
  }
  dimnames(radii) <- list(types, types)
  out <- 
  list(
         name     = "Multitype Strauss process",
         family    = multipair.family,
         pot      = function(d, tx, tu, par) {
     # arguments:
     # d[i,j] distance between points X[i] and U[j]
     # tx[i]  type (mark) of point X[i]
     # tu[j]  type (mark) of point U[j]
     #
     # get matrix of interaction radii r[ , ]
     r <- par$radii
     #
     # get possible marks and validate
     if(!is.factor(tx) || !is.factor(tu))
	stop("marks of data and dummy points must be factor variables")
     lx <- levels(tx)
     lu <- levels(tu)
     if(length(lx) != length(lu) || any(lx != lu))
	stop("marks of data and dummy points do not have same possible levels")

     if(!identical(lx, par$types))
        stop("data and model do not have the same possible levels of marks")
     if(!identical(lu, par$types))
        stop("dummy points and model do not have the same possible levels of marks")

     # list all UNORDERED pairs of types to be checked
     # (the interaction must be symmetric in type, and scored as such)
     uptri <- (row(r) <= col(r)) & !is.na(r)
     mark1 <- (lx[row(r)])[uptri]
     mark2 <- (lx[col(r)])[uptri]
     vname <- apply(cbind(mark1,mark2), 1, paste, collapse="x")
     vname <- paste("mark", vname, sep="")
     npairs <- length(vname)
     # list all ORDERED pairs of types to be checked
     # (to save writing the same code twice)
     different <- mark1 != mark2
     mark1o <- c(mark1, mark2[different])
     mark2o <- c(mark2, mark1[different])
     nordpairs <- length(mark1o)
     # unordered pair corresponding to each ordered pair
     ucode <- c(1:npairs, (1:npairs)[different])
     #
     # go....
     # assemble the relevant interaction distance for each pair of points
     rxu <- r[ tx, tu ]
     # apply relevant threshold to each pair of points
     str <- (d <= rxu)
     # create logical array for result
     z <- array(FALSE, dim=c(dim(d), npairs),
                dimnames=list(character(0), character(0), vname))
     # assign str[i,j] -> z[i,j,k] where k is relevant interaction code
     for(i in 1:nordpairs) {
       # data points with mark m1
       Xsub <- (tx == mark1o[i])
       # quadrature points with mark m2
       Qsub <- (tu == mark2o[i])
       # assign
       z[Xsub, Qsub, ucode[i]] <- str[Xsub, Qsub]
     }
     return(z)
   },
     #### end of 'pot' function ####
     #       
         par      = list(types=types, radii = radii),
         parnames = c("possible types", "interaction distances"),
         init     = function(self) {
                      r <- self$par$radii
                      nt <- length(self$par$types)
                      MultiPair.checkmatrix(r, nt, "\`radii\'")
                    },
         update = NULL,  # default OK
         print = function(self) {
           print.isf(self$family)
           cat(paste("Interaction:\t", self$name, "\n"))
           cat(paste(length(self$par$types), "types of points\n"))
           cat("Possible types: \n")
           print(self$par$types)
           cat("Interaction radii:\n")
           print(self$par$radii)
           invisible()
         },
        interpret = function(coeffs, self) {
          # get possible types
          typ <- self$par$types
          ntypes <- length(typ)
          # get matrix of Strauss interaction radii
          r <- self$par$radii
          # list all unordered pairs of types
          uptri <- (row(r) <= col(r)) & (!is.na(r))
          mark1 <- (typ[row(r)])[uptri]
          mark2 <- (typ[col(r)])[uptri]
          # names of coefficients
          basename <- apply(cbind(mark1,mark2), 1, paste, collapse="x")
          thetaname <- paste("mark", basename, sep="")
          npairs <- length(basename)
          # extract canonical parameters; shape them into a matrix
          gammas <- matrix(, ntypes, ntypes)
          dimnames(gammas) <- list(typ, typ)
          for(i in 1:npairs) {
            theta <- coeffs[thetaname[i]]
            gamma <- exp(theta)
            gammas[mark1[i], mark2[i]] <- gamma
            gammas[mark2[i], mark1[i]] <- gamma
          }
          #
          return(list(param=list(gammas=gammas),
                      inames="interaction parameters gamma_ij",
                      printable=round(gammas,4)))
        },
         valid = function(coeffs, self) {
           # interaction parameters gamma[i,j]
           gamma <- (self$interpret)(coeffs, self)$param$gammas
           # interaction radii
           radii <- self$par$radii
           # parameters to estimate
           required <- !is.na(radii)
           gr <- gamma[required]
           return(all(is.finite(gr) & gamma <= 1))
         },
         project  = function(coeffs, self) {
           # interaction parameters gamma[i,j]
           gamma <- (self$interpret)(coeffs, self)$param$gammas
           # remove NA's
           gamma[is.na(gamma)] <- 1
           # constrain them
           gamma <- matrix(pmin(gamma, 1),
                           nrow=nrow(gamma), ncol=ncol(gamma))
           # now put them back ... :-(
           # get possible types
           typ <- self$par$types
           ntypes <- length(typ)
           # get matrix of Strauss interaction radii
           r <- self$par$radii
           # list all unordered pairs of types
           uptri <- (row(r) <= col(r)) & (!is.na(r))
           mark1 <- (typ[row(r)])[uptri]
           mark2 <- (typ[col(r)])[uptri]
           # names of coefficients
           basename <- apply(cbind(mark1,mark2), 1, paste, collapse="x")
           thetaname <- paste("mark", basename, sep="")
           npairs <- length(basename)
           # reassign 
           coeffs[thetaname] <- log(gamma[uptri])
           return(coeffs)
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#    multistrhard.S
#
#    $Revision: 2.4 $	$Date: 2004/09/01 04:04:41 $
#
#    The multitype Strauss/hardcore process
#
#    MultiStraussHard()
#                 create an instance of the multitype Strauss/ harcore
#                 point process
#                 [an object of class 'interact']
#	
# -------------------------------------------------------------------
#	

MultiStraussHard <- function(types, iradii, hradii) {
  if(length(types) == 1)
    stop("The \`types\' argument should be a vector of all possible types")
  if(is.factor(types)) {
    types <- levels(types)
  } else {
    types <- levels(factor(types, levels=types))
  }
  dimnames(iradii) <- dimnames(hradii) <- list(types, types)
  out <- 
  list(
         name     = "Multitype Strauss Hardcore process",
         family    = multipair.family,
         pot      = function(d, tx, tu, par) {
     # arguments:
     # d[i,j] distance between points X[i] and U[j]
     # tx[i]  type (mark) of point X[i]
     # tu[i]  type (mark) of point U[j]
     #
     # get matrices of interaction radii
     r <- par$iradii
     h <- par$hradii

     # get possible marks and validate
     if(!is.factor(tx) || !is.factor(tu))
	stop("marks of data and dummy points must be factor variables")
     lx <- levels(tx)
     lu <- levels(tu)
     if(length(lx) != length(lu) || any(lx != lu))
	stop("marks of data and dummy points do not have same possible levels")

     if(!identical(lx, par$types))
        stop("data and model do not have the same possible levels of marks")
     if(!identical(lu, par$types))
        stop("dummy points and model do not have the same possible levels of marks")
                   
     # list all UNORDERED pairs of types to be checked
     # (the interaction must be symmetric in type, and scored as such)
     uptri <- (row(r) <= col(r)) & (!is.na(r) | !is.na(h))
     mark1 <- (lx[row(r)])[uptri]
     mark2 <- (lx[col(r)])[uptri]
     vname <- apply(cbind(mark1,mark2), 1, paste, collapse="x")
     vname <- paste("mark", vname, sep="")
     npairs <- length(vname)
     # list all ORDERED pairs of types to be checked
     # (to save writing the same code twice)
     different <- mark1 != mark2
     mark1o <- c(mark1, mark2[different])
     mark2o <- c(mark2, mark1[different])
     nordpairs <- length(mark1o)
     # unordered pair corresponding to each ordered pair
     ucode <- c(1:npairs, (1:npairs)[different])
     #
     # go....
     # apply the relevant interaction distance to each pair of points
     rxu <- r[ tx, tu ]
     str <- (d < rxu)
     str[is.na(str)] <- FALSE
     # and the relevant hard core distance
     hxu <- h[ tx, tu ]
     forbid <- (d < hxu)
     forbid[is.na(forbid)] <- FALSE
     # form the potential 
     value <- ifelse(forbid, -Inf, str)
     # create numeric array for result
     z <- array(0, dim=c(dim(d), npairs),
                dimnames=list(character(0), character(0), vname))
     # assign value[i,j] -> z[i,j,k] where k is relevant interaction code
     for(i in 1:nordpairs) {
       # data points with mark m1
       Xsub <- (tx == mark1o[i])
       # quadrature points with mark m2
       Qsub <- (tu == mark2o[i])
       # assign
       z[Xsub, Qsub, ucode[i]] <- value[Xsub, Qsub]
     }     
     return(z)
     },
     #### end of 'pot' function ####
     #       
         par      = list(types=types, iradii = iradii, hradii = hradii),
         parnames = c("possible types", "interaction distances", "hardcore distances"),
         init     = function(self) {
                      r <- self$par$iradii
                      h <- self$par$hradii
                      nt <- length(self$par$types)

                      MultiPair.checkmatrix(r, nt, "\`iradii\'")
                      MultiPair.checkmatrix(h, nt, "\`hradii\'")

                      ina <- is.na(iradii)
                      hna <- is.na(hradii)
                      if(all(ina))
                        stop("All entries of \`iradii\' are NA")
                      both <- !ina & !hna
                      if(any(iradii[both] <= hradii[both]))
                        stop("iradii must be larger than hradii")
                    },
         update = NULL,  # default OK
         print = function(self) {
           print.isf(self$family)
           cat(paste("Interaction:\t", self$name, "\n"))
           cat(paste(length(self$par$types), "types of points\n"))
           cat("Possible types: \n")
           print(self$par$types)
           cat("Interaction radii:\n")
           print(self$par$iradii)
           cat("Hardcore radii:\n")
           print(self$par$hradii)
           invisible()
         },
        interpret = function(coeffs, self) {
          # get possible types
          typ <- self$par$types
          ntypes <- length(typ)
          # get matrices of interaction radii
          r <- self$par$iradii
          h <- self$par$hradii
          # list all unordered pairs of types
          uptri <- (row(r) <= col(r)) & (!is.na(r) | !is.na(h))
          mark1 <- (typ[row(r)])[uptri]
          mark2 <- (typ[col(r)])[uptri]
          # names of coefficients
          basename <- apply(cbind(mark1,mark2), 1, paste, collapse="x")
          thetaname <- paste("mark", basename, sep="")
          npairs <- length(basename)
          # extract canonical parameters; shape them into a matrix
          gammas <- matrix(, ntypes, ntypes)
          dimnames(gammas) <- list(typ, typ)
          for(i in 1:npairs) {
            theta <- coeffs[thetaname[i]]
            gamma <- exp(theta)
            gammas[mark1[i], mark2[i]] <- gamma
            gammas[mark2[i], mark1[i]] <- gamma
          }
          #
          return(list(param=list(gammas=gammas),
                      inames="interaction parameters gamma_ij",
                      printable=round(gammas,4)))
        },
        valid = function(coeffs, self) {
           # interaction radii r[i,j]
           iradii <- self$par$iradii
           # hard core radii r[i,j]
           hradii <- self$par$hradii
           # interaction parameters gamma[i,j]
           gamma <- (self$interpret)(coeffs, self)$param$gammas
           # Check that we managed to estimate all required parameters
           required <- !is.na(iradii)
           if(!all(is.finite(gamma[required])))
             return(FALSE)
           # Check that the model is integrable
           # inactive hard cores ...
           ihc <- (is.na(hradii) | hradii == 0)
           # .. must have gamma <= 1
           return(all(gamma[required & ihc] <= 1))
         },
         project = function(coeffs, self) {
           # interaction radii r[i,j]
           iradii <- self$par$iradii
           # hard core radii r[i,j]
           hradii <- self$par$hradii
           # interaction parameters gamma[i,j]
           gamma <- (self$interpret)(coeffs, self)$param$gammas
           # remove NA's
           gamma[is.na(gamma)] <- 1
           # inactive hard cores?
           ihc <- (is.na(hradii) | hradii == 0)
           if(any(ihc & (gamma > 1))) 
               gamma[ihc] <- pmin(gamma[ihc], 1)
           # now put them back... %^[
           # get possible types
           typ <- self$par$types
           ntypes <- length(typ)
           # get matrices of interaction radii
           r <- self$par$iradii
           h <- self$par$hradii
           # list all unordered pairs of types
           uptri <- (row(r) <= col(r)) & (!is.na(r) | !is.na(h))
           mark1 <- (typ[row(r)])[uptri]
           mark2 <- (typ[col(r)])[uptri]
           # names of coefficients
           basename <- apply(cbind(mark1,mark2), 1, paste, collapse="x")
           thetaname <- paste("mark", basename, sep="")
           npairs <- length(basename)
           # reassign 
           coeffs[thetaname] <- log(gamma[uptri])
           return(coeffs)
        }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#     options.R
#
#     Spatstat Options
#
#    $Revision: 1.2 $   $Date: 2003/07/22 18:23:31 $
#
#
".Spatstat.Options" <-
  list(npixel = 100,
       maxedgewt=100.0,
       par.binary=list(),
       par.persp=list()
       )

"spatstat.options" <-
function (...) 
{
    called <- list(...)    

    if(length(called) == 0)
    	return(.Spatstat.Options)

    if(is.null(names(called)) && length(called)==1) {
      # spatstat.options(x) 
      x <- called[[1]]
      if(is.null(x))
        return(.Spatstat.Options)  # spatstat.options(NULL)
      if(is.list(x))
        called <- x 
    }
    
    if(is.null(names(called))) {
        # spatstat.options("par1", "par2", ...)
	ischar <- unlist(lapply(called, is.character))
	if(all(ischar)) {
		choices <- unlist(called)
		ok <- choices %in% names(.Spatstat.Options)
		if(all(ok))
			return(.Spatstat.Options[choices])
		else
			stop(paste("Unrecognised option(s):",
			called[!ok]))	
	} else {
	   wrong <- called[!ischar]
	   offending <- unlist(lapply(wrong,
	   		function(x) { y <- x;
	     		deparse(substitute(y)) }))
	   offending <- paste(offending, collapse=",")
           stop(paste("Unrecognised mode of argument(s) [",
		offending,
	   "]: should be character string or name=value pair"))
    	}
    }
# spatstat.options(name=value, name2=value2,...)
    assignto <- names(called)
    if (is.null(assignto) || any(assignto == "")) 
        stop("options must all be identified by name=value")
    ok <- assignto %in% names(.Spatstat.Options)
    if(!all(ok))
	stop(paste("Unrecognised option(s):", assignto[!ok]))
# reassign
    changed <- .Spatstat.Options[assignto]
    .Spatstat.Options[assignto] <<- called
# return 
    invisible(changed)
}

#
#
#    ord.S
#
#    $Revision: 1.2 $	$Date: 2001/08/07 11:52:17 $
#
#    Ord process with user-supplied potential
#
#    Ord()  create an instance of the Ord process
#                 [an object of class 'interact']
#                 with user-supplied potential
#	
#
# -------------------------------------------------------------------
#	

Ord <- function(pot, name) {
  if(missing(name))
    name <- "Ord process with user-defined potential"
  
  out <- 
  list(
         name     = name,
         family    = ord.family,
         pot      = pot,
         par      = NULL,
         parnames = NULL,
         init     = NULL,
         update   = NULL, 
         print = function(self) {
           cat(paste(self$name, "\n"))
           cat("Potential function:\n")
           print(self$pot)
           invisible()
         }
  )
  class(out) <- "interact"
  return(out)
}
#
#
#    ord.family.S
#
#    $Revision: 1.10 $	$Date: 2002/08/05 14:18:50 $
#
#    The Ord model (family of point process models)
#
#    ord.family:      object of class 'isf' defining Ord model structure
#	
#
# -------------------------------------------------------------------
#	

ord.family <-
  list(
         name  = "ord",
         print = function(self) {
                      cat("Ord model family\n")
         },
         eval  = function(X, U, Equal, pot, pars, ...) {
  #
  # This auxiliary function is not meant to be called by the user.
  # It computes the distances between points,
  # evaluates the pair potential and applies edge corrections.
  #
  # Arguments:
  #   X           data point pattern                      'ppp' object
  #   U           points at which to evaluate potential   list(x,y) suffices
  #   Equal       logical matrix X[i] == U[j]             matrix or NULL
  #   pot         potential function                      function(d, p)
  #   pars        auxiliary parameters for pot            list(......)
  #   ...         IGNORED                             
  #
  # Value:
  #    matrix of values of the potential
  #    induced by the pattern X at each location given in U.
  #    The rows of this matrix correspond to the rows of U (the sample points);
  #    the k columns are the coordinates of the k-dimensional potential.
  #
  # Note:
  # The potential function 'pot' will be called as
  #    pot(M, pars)   where M is a vector of tile areas.
  # It must return a vector of the same length as M
  # or a matrix with number of rows equal to the length of M
  ##########################################################################

nall <- length(U$x)       # number of data + dummy points

# determine which points in the combined list are data points
if(!is.null(Equal))           
  #is.data <- apply(Equal, 2, any)
  is.data <- matcolany(Equal)
else
  is.data <- rep(FALSE, nall)

#############################################################################
# First compute Dirichlet tessellation of data
# and its total potential (which could be vector-valued)
#############################################################################

Wdata <- dirichlet.weights(X)   # sic - these are the tile areas.
Pdata <- pot(Wdata, pars)
summa <- function(P) {
  if(is.matrix(P))
    matrowsum(P)
  else if(is.vector(P) || length(dim(P))==1 )
    sum(P)
  else
    stop("Don't know how to take row sums of this object")
}
total.data.potential <- summa(Pdata)

# Initialise V

dimpot <- dim(Pdata)[-1]  # dimension of each value of the potential function
                          # (= numeric(0) if potential is a scalar)

dimV <- c(nall, dimpot)
if(length(dimV) == 1)
  dimV <- c(dimV, 1)

V <- array(0, dim=dimV)

rowV <- array(1:nall, dim=dimV)

#################### Next, evaluate V for the data points.  ###############
# For each data point, compute Dirichlet tessellation
# of the data with this point removed.
# Compute difference of total potential.
#############################################################################


for(j in seq(X$n)) {
        #  Dirichlet tessellation of data without point j
  Wminus <- dirichlet.weights(X[-j])
        #  regressor is the difference in total potential
  V[rowV == j] <- total.data.potential - summa(pot(Wminus, pars))
}


#################### Next, evaluate V for the dummy points   ################
# For each dummy point, compute Dirichlet tessellation
# of (data points together with this dummy point) only. 
# Take difference of total potential.
#############################################################################

for(j in seq(U$x)[!is.data]) {
                Xplus <- superimpose(X, list(x=U$x[j], y=U$y[j]))
                     #  compute Dirichlet tessellation (of these points only!)
                Wplus <- dirichlet.weights(Xplus)
                     #  regressor is difference in total potential
                V[rowV == j] <- summa(pot(Wplus, pars)) - total.data.potential
}

cat("dim(V) = \n")
print(dim(V))

return(V)

} ######### end of function $eval                            

) ######### end of list

class(ord.family) <- "isf"
#
#
#    ordthresh.S
#
#    $Revision: 1.2 $	$Date: 2002/08/05 14:18:50 $
#
#    Ord process with threshold potential
#
#    OrdThresh()  create an instance of the Ord process
#                 [an object of class 'interact']
#                 with threshold potential
#	
#
# -------------------------------------------------------------------
#	

OrdThresh <- function(r) {
  out <- 
  list(
         name     = "Ord process with threshold potential",
         family    = ord.family,
         pot      = function(d, par) {
                         ifelse(d <= par$r, 1, 0)
                    },
         par      = list(r = r),
         parnames = "threshold distance",
         init     = function(self) {
                      r <- self$par$r
                      if(!is.numeric(r) || length(r) != 1 || r <= 0)
                       stop("threshold distance r must be a positive number")
                    },
         update = NULL,  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           loggamma <- coeffs[["Interaction"]]
           gamma <- exp(loggamma)
           return(list(param=list(gamma=gamma),
                       inames="interaction parameter gamma",
                       printable=round(gamma,4)))
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#    pairpiece.S
#
#    $Revision: 1.7 $	$Date: 2004/08/20 02:42:21 $
#
#    A pairwise interaction process with piecewise constant potential
#
#    PairPiece()   create an instance of the process
#                 [an object of class 'interact']
#	
#
# -------------------------------------------------------------------
#	

PairPiece <- function(r) {
  out <- 
  list(
         name     = "Piecewise constant pairwise interaction process",
         family    = pairwise.family,
         pot      = function(d, par) {
                       r <- par$r
                       nr <- length(r)
                       out <- array(FALSE, dim=c(dim(d), nr))
                       out[,,1] <-  ifelse(d < r[1], 1, 0)
                       if(nr > 1) {
                         for(i in 2:nr) 
                           out[,,i] <- ifelse((d >= r[i-1]) & (d < r[i]), 1, 0)
                       }
                       out
                    },
         par      = list(r = r),
         parnames = "interaction thresholds",
         init     = function(self) {
                      r <- self$par$r
                      if(!is.numeric(r) || !all(r > 0))
                       stop("interaction thresholds r must be positive numbers")
                      if(length(r) > 1 && !all(diff(r) > 0))
                        stop("interaction thresholds r must be strictly increasing")
                    },
         update = NULL,  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           r <- self$par$r
           npiece <- length(r)
           # extract coefficients
           vnames <- if(npiece == 1) "Interaction" else
                      paste("Interact.", 1:npiece, sep="")
           thetas <- coeffs[vnames]
           gammas <- exp(thetas)
           # name them
           gn <- gammas
           names(gn) <- paste("[", c(0,r[-npiece]),",", r, ")", sep="")
           #
           return(list(param=list(gammas=gammas),
                       inames="interaction parameters gamma_i",
                       printable=round(gn,4)))
         },
        valid = function(coeffs, self) {
           # interaction parameters gamma
           gamma <- (self$interpret)(coeffs, self)$param$gammas
           return(all(gamma <= 1) || gamma[1] == 0)
        },
        project = function(coeffs, self){
           # interaction parameters gamma
           gamma <- (self$interpret)(coeffs, self)$param$gammas
           if(all(gamma <= 1))
             return(coeffs)
           # clip to 1
           r <- self$par$r
           npiece <- length(r)
           vnames <- if(npiece == 1) "Interaction" else
                     paste("Interact.", 1:npiece, sep="")
           coeffs[vnames] <- pmin(0, coeffs[vnames])
           return(coeffs)
        }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#    pairsat.family.S
#
#    $Revision: 1.15 $	$Date: 2004/01/08 15:02:42 $
#
#    The saturated pairwise interaction family of point process models
#
#    (an extension of Geyer's saturation process to all pairwise interactions)
#
#    pairsat.family:         object of class 'isf'
#                     defining saturated pairwise interaction
#	
#
# -------------------------------------------------------------------
#	

pairsat.family <-
  list(
         name  = "saturated pairwise",
         print = function(self) {
                      cat("Saturated pairwise interaction family\n")
         },
         eval  = function(X,U,Equal,pairpot,potpars,correction) {
  #
  # This auxiliary function is not meant to be called by the user.
  # It computes the distances between points,
  # evaluates the pair potential and applies edge corrections.
  #
  # Arguments:
  #   X           data point pattern                      'ppp' object
  #   U           points at which to evaluate potential   list(x,y) suffices
  #   Equal       logical matrix X[i] == U[j]             matrix or NULL
  #   pairpot     potential function (see above)          function(d, p)
  #   potpars     auxiliary parameters for pairpot        list(......)
  #   correction  edge correction type                    (string)
  #
  #   Note the Geyer saturation threshold must be given in 'potpars$saturate'
  #
  # Value:
  #    matrix of values of the total pair potential
  #    induced by the pattern X at each location given in U.
  #    The rows of this matrix correspond to the rows of U (the sample points);
  #    the k columns are the coordinates of the k-dimensional potential.
  #
  # Note:
  # The pair potential function 'pairpot' will be called as
  #    pairpot(M, potpars)   where M is a matrix of interpoint distances.
  # It must return a matrix with the same dimensions as M
  # or an array with its first two dimensions the same as the dimensions of M.
  ##########################################################################

# coercion should be unnecessary, but this is useful for debugging
X <- as.ppp(X)
U <- as.ppp(U, X$window)   # i.e. X$window is DEFAULT window

# saturation parameter
saturate <- potpars$saturate

if(is.null(saturate)) {
  # pairwise interaction 
  V <- pairwise.family$eval(X, U, Equal, pairpot, potpars, correction)
  return(V)
}

# first check that all data points are included in the quadrature points
missingdata <- !as.vector(matrowany(Equal))
somemissing <- any(missingdata)
if(somemissing) {
  # add the missing data points
  U <- superimpose(U, X[missingdata])
  # extend the equality matrix to maintain Equal[i,j] = (X[i] == U[j])
  originalcolumns <- seq(ncol(Equal))
  sn <- seq(X$n)
  id <- outer(sn, sn[missingdata], "==")
  Equal <- cbind(Equal, id)
}

# compute the pair potentials POT and the unsaturated potential sums V

V <- pairwise.family$eval(X, U, Equal, pairpot, potpars, correction)
POT <- attr(V, "POT")

#################################################################
################## saturation part ##############################
#################################################################

#
# (a) compute SATURATED potential sums
V.sat <- array(pmin(saturate, V), dim=dim(V))

#
# (b) compute effect of addition/deletion of dummy/data point j
# on the UNSATURATED potential sum of each data point i
#
# Identify data points
     # is.data <- apply(Equal, 2, any)
is.data <- as.vector(matcolany(Equal))  # logical vector corresp. to rows of V

# Extract potential sums for data points only
V.data <- V[is.data, , drop=FALSE]

# replicate them so that V.dat.rep[i,j,k] = V.data[i, k]
V.dat.rep <- aperm(array(V.data, dim=c(dim(V.data), U$n)), c(1,3,2))

# make a logical array   col.is.data[i,j,k] = is.data[j]
dip <- dim(POT)
mat <- matrix(, nrow=dip[1], ncol=dip[2])
izdat <- is.data[col(mat)] 
col.is.data <- array(izdat, dim=dip) # automatically replicates

# compute value of unsaturated potential sum for each data point i
# obtained after addition/deletion of each dummy/data point j
                                  
V.after <- V.dat.rep + ifelse(col.is.data, -POT, POT)
#
#
# (c) difference of SATURATED potential sums for each data point i
# before & after increment/decrement of each dummy/data point j
#
# saturated values after increment/decrement
V.after.sat <- array(pmin(saturate, V.after), dim=dim(V.after))
# saturated values before
V.dat.rep.sat <- array(pmin(saturate, V.dat.rep), dim=dim(V.dat.rep))
# difference
V.delta <- V.after.sat - V.dat.rep.sat
V.delta <- ifelse(col.is.data, -V.delta, V.delta)
#
# (d) Sum (c) over all data points i
V.delta.sum <- apply(V.delta, c(2,3), sum)
#
# (e) Result
V <- V.sat + V.delta.sum

##########################################
# remove any columns that were added
if(somemissing)
      V <- V[originalcolumns, , drop=FALSE]

return(V)

}     ######### end of function $eval                            

)     ######### end of list

class(pairsat.family) <- "isf"
#
#
#    pairwise.S
#
#    $Revision: 1.3 $	$Date: 2002/04/07 10:44:48 $
#
#    Pairwise()    create a user-defined pairwise interaction process
#                 [an object of class 'interact']
#	
# -------------------------------------------------------------------
#	

Pairwise <- function(pot, name = "user-defined pairwise interaction process",
                     par = NULL, parnames=NULL,
                     printfun) {

  if(missing(printfun))
    printfun <- function(self) {
           cat(paste(self$name, "\n"))
           cat("Potential function:\n")
           print(self$pot)
         }

  out <- 
  list(
         name     = name,
         family   = pairwise.family,
         pot      = pot,
         par      = par,
         parnames = parnames,
         init     = NULL,
         update   = NULL,  
         print    = printfun
  )
  class(out) <- "interact"
  return(out)
}



#
#
#    pairwise.family.S
#
#    $Revision: 1.7 $	$Date: 2004/01/07 12:09:21 $
#
#    The pairwise interaction family of point process models
#
#    pairwise.family:      object of class 'isf' defining pairwise interaction
#	
#
# -------------------------------------------------------------------
#	

pairwise.family <-
  list(
         name  = "pairwise",
         print = function(self) {
                      cat("Pairwise interaction family\n")
         },
         eval  = function(X,U,Equal,pairpot,potpars,correction) {
  #
  # This auxiliary function is not meant to be called by the user.
  # It computes the distances between points,
  # evaluates the pair potential and applies edge corrections.
  #
  # Arguments:
  #   X           data point pattern                      'ppp' object
  #   U           points at which to evaluate potential   list(x,y) suffices
  #   Equal        logical matrix X[i] == U[j]             matrix or NULL
  #   pairpot     potential function (see above)          function(d, p)
  #   potpars     auxiliary parameters for pairpot        list(......)
  #   correction  edge correction type                    (string)
  #
  # Value:
  #    matrix of values of the total pair potential
  #    induced by the pattern X at each location given in U.
  #    The rows of this matrix correspond to the rows of U (the sample points);
  #    the k columns are the coordinates of the k-dimensional potential.
  #
  # Note:
  # The pair potential function 'pairpot' will be called as
  #    pairpot(M, potpars)   where M is a matrix of interpoint distances.
  # It must return a matrix with the same dimensions as M
  # or an array with its first two dimensions the same as the dimensions of M.
  ##########################################################################

# coercion should be unnecessary..
# X <- as.ppp(X)
# U <- as.ppp(U, X$window)   # i.e. X$window is DEFAULT window

x <- X$x
y <- X$y
xx <- U$x
yy <- U$y

if(length(correction) > 1)
  stop("Only one edge correction allowed at a time!")

if(!any(correction == c("periodic", "border", "translate", "isotropic", "Ripley", "none")))
  stop(paste("Unrecognised edge correction \'", correction, "\'", sep=""))
          
#  
# Form the matrix of distances
	
sqdif <- function(u,v) {(u-v)^2}

MX <- outer(x,xx,sqdif)
MY <- outer(y,yy,sqdif)

if(correction=="periodic") {
	if(X$window$type != "rectangle")
		stop("Periodic edge correction can't be applied",
                     "in an irregular window")
	wide <- diff(X$window$xrange)
	high <- diff(X$window$yrange)
	MX1 <- outer(x,xx-wide,sqdif)
	MX2 <- outer(x,xx+wide,sqdif)
	MX <- pmin(MX, MX1, MX2)
	MY1 <- outer(y,yy-high,sqdif)
	MY2 <- outer(y,yy+high,sqdif)
	MY <- pmin(MY, MY1, MY2)
}
M <- sqrt(MX + MY)

# Evaluate the pairwise potential 

POT <- pairpot(M, potpars)
if(length(dim(POT)) == 1 || any(dim(POT)[1:2] != dim(M))) {
        whinge <- paste(
           "The pair potential function ",deparse(substitute(pairpot)),
           "must produce a matrix or array with its first two dimensions\n",
           "the same as the dimensions of its input.\n", sep="")
	stop(whinge)
}

# make it a 3D array
if(length(dim(POT))==2)
        POT <- array(POT, dim=c(dim(POT),1), dimnames=NULL)
                          
if(correction == "translate") {
        edgewt <- edge.Trans(X, U)
        # sanity check ("everybody knows there ain't no...")
        if(!is.matrix(edgewt))
          stop("internal error: edge.Trans() did not yield a matrix")
        if(nrow(edgewt) != X$n || ncol(edgewt) != length(U$x))
          stop("internal error: edge weights matrix returned by edge.Trans() has wrong dimensions")
        POT <- c(edgewt) * POT
} else if(correction == "isotropic" || correction == "Ripley") {
        # weights are required for contributions from QUADRATURE points
        edgewt <- t(edge.Ripley(U, t(M), X$window))
        if(!is.matrix(edgewt))
          stop("internal error: edge.Ripley() did not return a matrix")
        if(nrow(edgewt) != X$n || ncol(edgewt) != length(U$x))
          stop("internal error: edge weights matrix returned by edge.Ripley() has wrong dimensions")
        POT <- c(edgewt) * POT
}

# No pair potential term between a point and itself
if(!is.null(Equal) && any(Equal))
  POT[Equal] <- 0

# Sum the pairwise potentials 

V <- apply(POT, c(2,3), sum)

# attach the original pair potentials
attr(V, "POT") <- POT

return(V)

}
######### end of function $eval                            
)
######### end of list

class(pairwise.family) <- "isf"
#
#   pcf.R
#
#   $Revision: 1.7 $   $Date: 2004/06/01 04:44:14 $
#
#
#   calculate pair correlation function
#   from estimate of K or Kcross
#
#

"pcf" <-
function(X, ..., method="c") {
        if(!exists("R.Version") ||
           ((virg <- R.Version())$major == "1" && as.numeric(virg$minor) < 9))
             require(modreg)

	if(verifyclass(X, "ppp", fatal=FALSE))
        # point pattern - estimate K and continue
		X <- Kest(X)

        if(verifyclass(X, "fasp", fatal=FALSE)) {
          # function array - go to work on each function
          Y <- X
          Y$title <- paste("Array of pair correlation functions",
                           if(!is.null(X$dataname)) "for",
                           X$dataname)
          n <- length(X$fns)
          for(i in 1:n) {
            Xi <- X$fns[[i]]
            PCFi <- pcf(Xi, ..., method=method)
            Y$fns[[i]] <- as.fv(PCFi)
            if(is.fv(PCFi))
               Y$default.formula[[i]] <- attr(PCFi, "fmla")
          }
          return(Y)
        }

        if(is.fv(X)) {
          # extract r and the recommended estimate of K
          r <- X[[attr(X, "argu")]]
          K <- X[[attr(X, "valu")]]
          alim <- attr(X, "alim")
        } else if(inherits(X, "data.frame")) {
          # guess 
          r <- X$r
          K <- X$border
          alim <- NULL
        } else
          stop("X should be either a point pattern or the value returned by Kest() or Kcross() or alltypes(..., \"K\")")

	# remove NA's
	ok <- !is.na(K)
        K <- K[ok]
        r <- r[ok]
	switch(method,
		a = { 
			ss <- smooth.spline(r, K, ...)
			dK <- predict(ss, r, deriv=1)$y
			g <- dK/(2 * pi * r)
		},
		b = {
			y <- K/(2 * pi * r)
			y[is.nan(y)] <- 0
			ss <- smooth.spline(r, y, ...)
			dy <- predict(ss, r, deriv=1)$y
			g <- dy + y/r
		},
		c = {
			z <- K/(pi * r^2)
			z[is.nan(z)] <- 1
			ss <- smooth.spline(r, z, ...)
			dz <- predict(ss, r, deriv=1)$y
			g <- (r/2) * dz + z
		},
		stop(paste("unrecognised method \"", method, "\""))
	)

        # pack result into "fv" data frame
        Z <- fv(data.frame(r=r, pcf=g, theo=rep(1, length(r))),
                "r", "pcf(r)", "pcf", cbind(pcf, theo) ~ r, alim,
                c("r", "pcf(r)", "1"),
                c("distance argument r",
                  "estimate of pair correlation function pcf(r)",
                  "theoretical Poisson value, pcf(r) = 1"))
	return(Z)
}
#
#   plot.fasp.R
#
#   $Revision: 1.8 $   $Date: 2004/01/13 08:38:41 $
#
plot.fasp <- function(x,formula=NULL,subset=NULL,lty=NULL,
                      col=NULL,title=NULL,...) {

# If the formula is null, look for a default formula in x:
	if(is.null(formula)) {
		if(is.null(x$default.formula))
			stop("No formula supplied.\n")
		formula <- x$default.formula
	}
# The formula should be a single formula or a list of formulae.
# If it is a single formula, wrap it up in a list so that all
# formula arguments can be treated consistently.
        if(!is.list(formula)) formula <- list(formula)

# Check on the length of the formula argument.
nf <- length(formula)
if(nf > 1) {
	if(nf != length(x$fns))
		stop("Wrong number of entries in formula argument.\n")
	mfor <- TRUE
} else mfor <- FALSE

# Check on the length of the subset argument.
ns <- length(subset)
if(ns > 1) {
	if(ns != length(x$fns))
		stop("Wrong number of entries in subset argument.\n")
	msub <- TRUE
} else msub <- FALSE

# Set up the array of plotting regions.
	mfrow.save <- par("mfrow")
	oma.save   <- par("oma")
	on.exit(par(mfrow=mfrow.save,oma=oma.save))
	which <- x$which
	m  <- nrow(which)
	n  <- ncol(which)
	nm <- n * m
	par(mfrow=c(m,n))
        # decide whether panels require subtitles
        subtit <- (nm > 1) || !(is.null(x$titles[[1]]) || x$titles[[1]] == "")
	if(nm>1) par(oma=c(0,3,4,0))
        else if(subtit) par(oma=c(3,3,4,0))
        
# Run through the components of the structure x, plotting each
# in the appropriate region, according to the formula.
	k <- 0
	for(i in 1:m) {
		for(j in 1:n) {
# Now do the actual plotting.
			k <- which[i,j]
			if(is.na(k)) plot(0,0,type='n',xlim=c(0,1),
					  ylim=c(0,1),axes=FALSE,xlab='',ylab='', ...)
			else {
				fun <- as.fv(x$fns[[k]])
				fmla <- if(mfor) formula[[k]] else formula[[1]]
				sub <- if(msub) subset[[k]] else subset
				plot(fun, fmla, sub, lty,col, ...)

# Add the (sub)title of each plot.
				if(!is.null(x$titles[[k]]))
					title(main=x$titles[[k]])
			}
		}
	}

# Add an overall title.
	if(!is.null(title)) overall <- title
	else if(!is.null(x$title)) overall <- x$title
	else {
		if(nm > 1)
			overall <- "Array of diagnostic functions"
		else
			overall <- "Diagnostic function"
		if(is.null(x$dataname)) overall <- paste(overall,".",sep="")
		else overall <- paste(overall," for ",x$dataname,".",sep="")
		
	}
	if(nm > 1 || subtit)
          mtext(side=3,outer=TRUE,line=1,text=overall,cex=1.2)
	else title(main=overall)
	invisible()
}
#
#       plot.fv.R   (was: conspire.S)
#
#  $Revision: 1.7 $    $Date: 2004/09/21 20:01:12 $
#
#

conspire <- function(...) {
  .Deprecated("plot.fv")
  plot.fv(...)
}

plot.fv <- function(x, fmla, subset=NULL, lty=NULL, col=NULL,
                     xlim, ylim, xlab, ylab, ...) {

  verifyclass(x, "fv")
  indata <- as.data.frame(x)

  defaultplot <- missing(fmla)
  if(defaultplot)
    fmla <- attr(x, "fmla")

  lhs <- fmla[[2]]
  rhs <- fmla[[3]]

  # evaluate expression a in data frame b
  evaluate <- function(a,b) {
    if(exists("is.R") && is.R())
      eval(a, envir=b)
    else
      eval(a, local=b)
  }
  
  lhsdata <- evaluate(lhs, indata)
  rhsdata <- evaluate(rhs, indata)
  
  if(is.vector(lhsdata))
    lhsdata <- matrix(lhsdata, ncol=1)

  if(!is.vector(rhsdata))
    stop("rhs of formula seems not to be a vector")

  # restrict data to subset if desired
  if(!is.null(subset)) {
    keep <- if(is.character(subset))
		evaluate(parse(text=subset), indata)
            else
                evaluate(subset, indata)
    lhsdata <- lhsdata[keep, , drop=FALSE]
    rhsdata <- rhsdata[keep]
  } 

  # determine x and y limits and clip data to these limits
  if(!missing(xlim)) {
    ok <- (xlim[1] <= rhsdata & rhsdata <= xlim[2])
    rhsdata <- rhsdata[ok]
    lhsdata <- lhsdata[ok, , drop=FALSE]
  } else {
    # if we're using the default argument, use its recommended range
    if(rhs == attr(x, "argu")) {
      xlim <- attr(x,"alim")
      ok <- is.finite(rhsdata) & rhsdata >= xlim[1] & rhsdata <= xlim[2]
      rhsdata <- rhsdata[ok]
      lhsdata <- lhsdata[ok, , drop=FALSE]
    } else { # actual range of values to be plotted
      xlim <- range(rhsdata[is.finite(rhsdata)],na.rm=TRUE)
      rok <- is.finite(rhsdata) & rhsdata >= xlim[1] & rhsdata <= xlim[2]
      lok <- apply(is.finite(lhsdata), 1, any)
      ok <- lok & rok
      rhsdata <- rhsdata[ok]
      lhsdata <- lhsdata[ok, , drop=FALSE]
      xlim <- range(rhsdata)
    }
  }
  
  if(missing(ylim))
    ylim <- range(lhsdata,na.rm=TRUE)

  # work out how to label the plot
  if(missing(xlab))
    xlab <- as.character(fmla)[3]

  if(missing(ylab)) {
    yl <- attr(x, "ylab")
    if(!is.null(yl) && defaultplot)
      ylab <- yl
    else {
      yname <- paste(lhs)
      if(length(yname) > 1 && yname[[1]] == "cbind")
        ylab <- paste(yname[-1], collapse=" , ")
      else
        ylab <- as.character(fmla)[2]
    }
  }

  # check for argument "add"=TRUE
  dotargs <- list(...)
  v <- match("add", names(dotargs))
  if(is.na(v) || !(addit <- as.logical(dotargs[[v]])))
    plot(xlim, ylim, type="n", xlab=xlab, ylab=ylab, ...)

  nplots <- ncol(lhsdata)

  if(is.null(lty))
    lty <- 1:nplots
  else if(length(lty) == 1)
    lty <- rep(lty, nplots)
  else if(length(lty) != nplots)
    stop("Length of \`lty\' does not match number of curves to be plotted")
  
  if(is.null(col))
    col <- 1:nplots
  else if(length(col) == 1)
    col <- rep(col, nplots)
  else if(length(col) != nplots)
    stop("Length of \`col\' does not match number of curves to be plotted")
  
  for(i in 1:nplots)
    lines(rhsdata, lhsdata[,i], lty=lty[i], col=col[i])

  if(nplots == 1)
    return(invisible(NULL))
  else 
    return(data.frame(lty=lty, col=col, row.names=colnames(lhsdata)))
}


#
#	plot.owin.S
#
#	The 'plot' method for observation windows (class "owin")
#
#	$Revision: 1.9 $	$Date: 2002/07/18 10:18:45 $
#
#
#

plot.owin <- function(x, main, add=FALSE, ..., box=TRUE, edge=0.04)
{
#
# Function plot.owin.  A method for plot.
#
# argument must be called 'x' for compatibility with plot()
  W <- x
  if(missing(main))
    main <- deparse(substitute(x))
# no, this cannot be inserted in the argument list!!!
  verifyclass(W, "owin")

#########        
  x <- W$xrange
  y <- W$yrange

####################################################  
  if(!add) {
# create new plotting region    
# check whether argument 'asp' is recognised
    plargs <- names(formals(plot.default))
    if(!is.null(plargs) && "asp" %in% plargs) {
# set up plot with equal scales
      plot(x, y, type="n", ...,
           main=main, axes=FALSE, xlab="", ylab="", xaxs="i", yaxs="i",
           asp=1.0)
    } else {
# D.I.Y.            
# see 'help(par)' under 'xaxs': default is xaxs="r";
# we seize full control by setting xaxs="i",
# but mimic the extra 4% space allocated when xaxs="r"
        
      blowup <- function(v, s) { mean(v) + s * (v - mean(v)) }
      xlim <- blowup(x, 1+edge)
      ylim <- blowup(y, 1+edge)

# Constrain X scale = Y scale        
      pin <- par("pin")  #physical size of plot region
      xscale <- pin[1]/diff(xlim)
      yscale <- pin[2]/diff(ylim)
      sc <- min(xscale,yscale)
      if(xscale > sc) xlim <- blowup(xlim, xscale/sc)
      if(yscale > sc) ylim <- blowup(ylim, yscale/sc) 

# Commit scales
      plot(x, y, xlim=xlim, ylim=ylim, type="n", ...,
           main=main, axes=FALSE, xlab="", ylab="", xaxs="i", yaxs="i")

    }
  }
# Draw window

  switch(W$type,
         rectangle = {
         },
         polygonal = {
           p <- W$bdry
           if(exists("is.R") && is.R()) {
             for(i in seq(p))
               polygon(p[[i]], ...)
           } else {
             for(i in seq(p))
               polygon(p[[i]], density=0, ...)
           }
         },
         mask = {
           # image(W$xcol, W$yrow, !t(W$m), add=TRUE, ...)
           arg1 <- list(W$xcol, W$yrow, !t(W$m), add=TRUE)
           arg2 <- spatstat.options("par.binary")[[1]]
           arg3 <- list(...)
           argue <- append(arg1, append(arg2, arg3))
           do.call("image", argue)
         },
         stop("Don't know how to plot image type", W$type)
         )

# Draw surrounding box
  wantbox <- (!missing(box) && box) || (missing(box) && W$type == "rectangle")
  if(wantbox)
    segments(x[c(1,2,2,1)],
             y[c(1,1,2,2)],
             x[c(2,2,1,1)],
             y[c(1,2,2,1)], ...)

  invisible()
}





#
# plot.plotppm.R
#
# engine of plot method for ppm
#
# $Revision: 1.3 $  $Date: 2004/08/30 04:55:22 $
#
#

plot.plotppm <- function(x,data=NULL,trend=TRUE,cif=TRUE,pause=TRUE,
                         how=c("persp","image","contour"), ...)
{
  verifyclass(x,"plotppm")
  
  # determine main plotting actions
  superimpose <- !is.null(data)
  if(!missing(trend) && (trend & is.null(x[["trend"]])))
    stop("No trend to plot.\n")
  trend <- trend & !is.null(x[["trend"]])
  if(!missing(cif) && (cif & is.null(x[["cif"]])))
    stop("No cif to plot.\n")
  cif <- cif & !is.null(x[["cif"]])
  surftypes <- c("trend", "cif")[c(trend, cif)]

  # marked point process?
  mrkvals <- attr(x,"mrkvals")
  marked <- (length(mrkvals) > 1)
  if(marked & superimpose) {
    data.types <- levels(data$marks)
    if(any(sort(data.types) != sort(mrkvals)))
      stop(paste("Data marks are different from mark",
                 "values for argument x.\n"))
  }

  # plotting style
  howmat <- outer(how, c("persp", "image", "contour"), "==")
  howmatch <- apply(howmat, 1, any)
  if (any(!howmatch)) 
    stop(paste("unrecognised option", how[!howmatch]))

  # start plotting
  if(pause)
    oldpar <- par(ask = TRUE)
  on.exit(if(pause) par(oldpar))

  
  for(ttt in surftypes) {
    xs <- x[[ttt]]
    for (i in seq(mrkvals)) {
      level <- mrkvals[i]
      main <- if(marked) paste("mark =", level) else ""
      for (style in how) {
        switch(style,
               persp = {
                 do.call("persp",
                         resolve.defaults(list(xs[[i]]),
                                          list(...), 
                                          spatstat.options("par.persp")[[1]],
                                          list(xlab="x", main=main)))
               },
               image = {
                 do.call("image",
                         resolve.defaults(list(xs[[i]]),
                                          list(...),
                                          list(main=main)))
                 if(superimpose) {
                   if(marked) plot(data[data$marks == level],
                                   add = TRUE)
                   else plot(data,add=TRUE)
                 }
               },
               contour = {
                 do.call("contour",
                         resolve.defaults(list(xs[[i]]),
                                          list(...),
                                          list(main=main)))
                 if (superimpose) {
                   if(marked) plot(data[data$marks == level],
                                   add = TRUE)
                   else plot(data,add=TRUE)
                 }
               },
               {
                 stop(paste("Unrecognised plot style", style))
               })
      }
    }
  }
  return(invisible())
}
#
#    plot.ppm.S
#
#    $Revision: 2.1 $    $Date: 2004/07/26 05:33:01 $
#
#    plot.ppm()
#         Plot a point process model fitted by ppm().
#        
#
#
plot.ppm <- function(x, ngrid = c(40,40),
		     superimpose = TRUE,
                     trend = TRUE, cif = TRUE, pause = TRUE,
                     how=c("persp","image", "contour"),
                     plot.it=TRUE,
                     locations=NULL, covariates=NULL, ...)
{
  model <- x
#       Plot a point process model fitted by ppm().
#
  verifyclass(model, "ppm")
#
#       find out what kind of model it is
#
  mod <- summary(model)
  stationary <- mod$stationary
  poisson    <- mod$poisson
  marked     <- mod$marked
  multitype  <- mod$multitype
  data       <- mod$entries$data
        
  if(marked) {
    if(!multitype)
      stop("Not implemented for general marked point processes")
    else
      mrkvals <- levels(data$marks)
  } else mrkvals <- 1
  ntypes <- length(mrkvals)
        
#
#        Interpret options
#        -----------------
#        
#        Whether to plot trend, cif
        
  if(!trend && !cif) {
    cat("Nothing plotted - both \'trend\' and \'cif\' are FALSE\n")
    return(invisible(NULL))
  }
#        Suppress uninteresting plots
#        unless explicitly instructed otherwise
  if(missing(trend))
    trend <- !stationary
  if(missing(cif))
    cif <- !poisson
        
  if(!trend && !cif) {
    cat("Nothing plotted -- all plots selected are flat surfaces.\n")
    return(invisible())
  }

#
#        Do the prediction
#        ------------------

  out <- list()
  surftypes <- c("trend","cif")[c(trend,cif)]
  ng <- if(missing(ngrid) && !missing(locations)) NULL else ngrid

  for (ttt in surftypes) {
    p <- predict(model,
                   ngrid=ng, locations=locations, covariates=covariates,
                   type = ttt)
    if(is.im(p))
      p <- list(p)
    out[[ttt]] <- p
  }

#        Make it a plotppm object
#        ------------------------  
  
  class(out) <- "plotppm"
  attr(out, "mrkvals") <- mrkvals

#        Actually plot it if required
#        ----------------------------  
  if(plot.it) {
    if(!superimpose)
      data <- NULL
    plot(out,data=data,trend=trend,cif=cif,how=how, ...)
  }

  
  return(invisible(out)) 
}

#
#	plot.ppp.S
#
#	$Revision: 1.13 $	$Date: 2003/03/11 02:55:10 $
#
#
#--------------------------------------------------------------------------

plot.ppp <-
  function(x, main, ..., chars, cols, use.marks=TRUE, add=FALSE, maxsize)
{
#
# Function plot.ppp.
# A plot() method for the class 'ppp'
#
  if(missing(main))
    main <- deparse(substitute(x))

  x <- as.ppp(x)
  
  if(!add)
    plot.owin(x$window, ..., main=main)

  if(x$n == 0)
    return(invisible())

        
  if(is.null(x$marks) || !use.marks) {
    points(x$x, x$y, ...)
    return(invisible())
  }

  # marked point pattern

  marks <- x$marks

  if(is.numeric(marks)) {
    # real-valued marks
    ok <- !(any(is.na(marks)) || any(is.infinite(marks)))
    if(ok) {
      # guess appropriate max physical size of symbols
      if (missing(maxsize)) {
        maxsize <- 1.4/sqrt(pi * x$n/area.owin(x$window))
        maxsize <- min(maxsize, diameter(x$window) * 0.07)
      }
      # find range of values
      mr <- range(c(0,marks))
      maxabs <- max(abs(mr))
      # determine physical scale and apply it
      if (diff(mr) < 4 * .Machine$double.eps
          || maxabs < 4 * .Machine$double.eps)
        {
          # constant values - plot at half maxsize
          ms <- rep(0.5 * maxsize, length(marks))
          mp.value <- mr[1]
          mp.plotted <- 0.5 * maxsize
        } else {
          # scale to [0,maxsize]
          scal <- maxsize/maxabs
          ms <- marks * scal
          mp.value <- pretty(mr)
          mp.plotted <- mp.value * scal
        }
      # plot positive values as circles
      neg <- (marks < 0)
      if(any(!neg))
        symbols(x$x[!neg], x$y[!neg],
                circles = ms[!neg],
                inches = FALSE, add = TRUE, ...)
      # plot negative values as squares
      if(any(neg))
        symbols(x$x[neg], x$y[neg],
                squares = - ms[neg],
                inches = FALSE, add = TRUE, ...)

      # return a plottable scale bar
      names(mp.plotted) <- paste(mp.value)
      return(mp.plotted)
    } else {
      warning("Some marks are NA or Inf; treating marks as non-numeric")
    }
  }
  
  um <- if(is.factor(x$marks))
    levels(x$marks)
  else
    sort(unique(x$marks))

  if(missing(chars))
    chars <- seq(um)

  # generic argument 'col' conflicts with 'cols'
  col.given <- ("col" %in% names(list(...)))
  cols.given <- !missing(cols)
  if(cols.given && col.given)
    stop("Only one of the arguments \"col\" and \"cols\" should be given")
  
  for(i in seq(um)) {
    relevant <- (x$marks == um[i])
    if(any(relevant)) {
      if(cols.given)
        points(x$x[relevant], x$y[relevant], pch = chars[i], col=cols[i], ...)
      else
        points(x$x[relevant], x$y[relevant], pch = chars[i], ...)
    }
  }
  names(chars) <- um
  if(length(chars) < 20)
    return(chars)
  else
    return(invisible(chars))
}
#
plot.splitppp <- function(x, ..., arrange=TRUE) {
  n <- length(x)
  m <- as.integer(floor(sqrt(n)))
  k <- as.integer(ceiling(n/m))
  if(arrange)
    opa <- par(mfrow=c(k, m))
  lapply(names(x),
         function(l, x, ...){plot(x[[l]], main=l, ...)},
         x=x, ...) 
  if(arrange)
    par(opa)
  return(invisible(NULL))
}
  
#
#
#    poisson.S
#
#    $Revision: 1.3 $	$Date: 2001/08/07 11:52:17 $
#
#    The Poisson process
#
#    Poisson()    create an object of class 'interact' describing
#                 the (null) interpoint interaction structure
#                 of the Poisson process.
#	
#
# -------------------------------------------------------------------
#	

Poisson <- function() {
  out <- 
  list(
         name     = "Poisson process",
         family   = NULL,
         pot      = NULL,
         par      = NULL,
         parnames = NULL,
         init     = function(...) { },
         update   = function(...) { },
         print    = function(self) {
           cat("Poisson process\n")
           invisible()
         }
  )
  class(out) <- "interact"
  return(out)
}
#
#	$Revision: 1.2 $	$Date: 2004/06/09 10:58:18 $
#
#    ppm()
#          Fit a point process model to a two-dimensional point pattern
#
#

"ppm" <- 
function(Q,
         trend = ~1,
	 interaction = NULL,
         covariates = NULL,
	 correction="border",
	 rbord = 0,
         use.gam=FALSE,
         method = "mpl"
) {
  if(method != "mpl")
    stop(paste("Unrecognised fitting method \"", method, "\"", sep=""))

  fit <- mpl.engine(Q=Q, trend=trend,
                    interaction=interaction,
                    covariates=covariates,
                    correction=correction,
                    rbord=rbord, use.gam=use.gam)
  fit$call <- deparse(sys.call())
  return(fit)
}

#
#	ppmclass.R
#
#	Class 'ppm' representing fitted point process models.
#
#
#	$Revision: 2.2 $	$Date: 2004/06/09 06:02:28 $
#
#       An object of class 'ppm' contains the following:
#
#            $method           model-fitting method (currently "mpl")
#
#            $coef             vector of fitted regular parameters
#                              as given by coef(glm(....))
#
#            $theta            vector of fitted regular parameters
#                              as given by dummy.coef(glm(....))
#
#            $trend            the trend formula
#                              or NULL 
#
#            $interaction      the interaction family 
#                              (an object of class 'interact') or NULL
#
#            $Q                the quadrature scheme used
#
#            $maxlogpl         the maximised value of log pseudolikelihood
#
#            $internal         list of internal calculation results
#
#            $correction       name of edge correction method used
#            $rbord            erosion distance for border correction (or NULL)
#
#            $the.call         the originating call to ppm()
#
#            $the.version      version of mpl() which yielded the fit
#
#
#------------------------------------------------------------------------

is.ppm <- function(x) { inherits(x, "ppm") }

print.ppm <- function(x, ...) {
	verifyclass(x, "ppm")

        s <- summary.ppm(x)
        
        notrend <-    s$no.trend
	stationary <- s$stationary
	poisson <-    s$poisson
        markeddata <- s$marked
        multitype  <- s$multitype
        
        markedpoisson <- poisson && markeddata

        # names of interaction variables if any
        Vnames <- s$Vnames
        # their fitted coefficients
        theta <- s$theta

        # ----------- Print model type -------------------
        
	cat(s$name)
        cat("\n")
        
        if(markeddata) mrk <- s$entries$marks
        if(multitype) {
            cat("Possible marks: \n")
            cat(paste(levels(mrk)))
          }

        # ----- trend --------------------------

        cat(paste("\n", s$trend$name, ":\n", sep=""))

	if(!notrend) {
		cat("Trend formula: ")
		print(s$trend$formula)
        }
        
        cat(paste("\n", s$trend$label, ":\n", sep=""))

        tv <- s$trend$value
        if(!is.list(tv))
          print(tv)
        else 
          for(i in seq(tv))
            print(tv[[i]])
        
        # ---- Interaction ----------------------------

	if(!poisson) {
          cat("\nInteraction:\n")
          print(s$entries$interaction)
        
          cat(paste(s$interaction$header, ":\n", sep=""))
          print(s$interaction$printable)
        }

	invisible(NULL)
}

quad.ppm <- function(object) {
  verifyclass(object, "ppm")
  object$Q
}

data.ppm <- function(object) { 
  verifyclass(object, "ppm")
  object$Q$data
}

dummy.ppm <- function(object) { 
  verifyclass(object, "ppm")
  object$Q$dummy
}
  
# method for 'coef'
coef.ppm <- function(object, ...) {
  verifyclass(object, "ppm")
  object$coef
}

# method for 'fitted'
fitted.ppm <- function(object, ..., type="lambda") {
  verifyclass(object, "ppm")
  
  uniform <- is.poisson.ppm(object) && no.trend.ppm(object)

  typelist <- c("lambda", "cif",    "trend")
  typevalu <- c("lambda", "lambda", "trend")
  if(is.na(m <- pmatch(type, typelist)))
    stop(paste("Unrecognised choice of \`type\':", type))
  type <- typevalu[m]

  if(uniform) {
    fitcoef <- coef.ppm(object)
    lambda <- exp(fitcoef[[1]])
    Q <- quad.ppm(object)
    lambda <- rep(lambda, n.quad(Q))
  } else {
    glmfit  <- object$internal$glmfit
    glmdata <- object$internal$glmdata
    if(type == "trend") {
      # first zero the interaction statistics
      Vnames <- object$internal$Vnames
      glmdata[ , Vnames] <- 0
    }
    lambda <- predict(glmfit, newdata=glmdata, type="response")
    # Note: the `newdata' argument is necessary in order to obtain predictions
    # at all quadrature points. If it is omitted then we would only get
    # predictions at the quadrature points j where glmdata$SUBSET[j]=TRUE.
  }
  
  return(lambda)
}

# ??? method for 'effects' ???



#
#	ppp.S
#
#	A class 'ppp' to define point patterns
#	observed in arbitrary windows in two dimensions.
#
#	$Revision: 4.22 $	$Date: 2004/09/02 04:18:53 $
#
#	A point pattern contains the following entries:	
#
#		$window:	an object of class 'owin'
#				defining the observation window
#
#		$n:	the number of points (for efficiency)
#	
#		$x:	
#		$y:	vectors of length n giving the Cartesian
#			coordinates of the points.
#
#	It may also contain the entry:	
#
#		$marks:	a vector of length n
#			whose entries are interpreted as the
#			'marks' attached to the corresponding points.	
#	
#--------------------------------------------------------------------------
ppp <- function(x, y, ..., window, marks ) {
	# Constructs an object of class 'ppp'
	#
        if(!missing(window))
          verifyclass(window, "owin")
        else
          window <- owin(...)
          
	n <- length(x)
	if(length(y) != n)
		stop("coordinate vectors x and y are not of equal length")
        # validate x, y coordinates
        stopifnot(is.numeric(x))
        stopifnot(is.numeric(y))
        names(x) <- NULL
        names(y) <- NULL
        # initialise ppp object
	pp <- list(window=window, n=n, x=x, y=y)
        # add marks if any
	if(!missing(marks) && !is.null(marks)) {
                if(is.matrix(marks) || is.data.frame(marks))
                  stop(paste("Attempted to create point pattern with",
                             ncol(marks), "columns of mark data;",
                             "multidimensional marks are not yet implemented"))
		if(length(marks) != n)
			stop("length of marks vector != length of x and y")
                names(marks) <- NULL
		pp$marks <- marks
	}
	class(pp) <- "ppp"
	pp
}
#
#--------------------------------------------------------------------------
#

is.ppp <- function(x) { inherits(x, "ppp") }

as.ppp <- function(X, W = NULL, fatal=TRUE) {
	# tries to coerce data X to a point pattern
	# X may be:
	#	1. an object of class 'ppp'
	#	2a. a structure with entries x, y, xl, xu, yl, yu
	#	2b. a structure with entries x, y, area where
        #                    'area' has entries xl, xu, yl, yu
	#	3. a two-column matrix
	#	4. a structure with entries x, y
        #       5. a quadrature scheme (object of class 'quad')
	# In cases 3 and 4, we need the second argument W
	# which is coerced to an object of class 'owin' by the 
	# function "as.owin" in window.S
        # In cases 2 and 4, if X also has an entry X$marks
        # then this will be interpreted as the marks vector for the pattern.
	#
	if(verifyclass(X, "ppp", fatal=FALSE))
		return(X)
        else if(verifyclass(X, "quad", fatal=FALSE))
                return(union.quad(X))
	else if(checkfields(X, 	c("x", "y", "xl", "xu", "yl", "yu"))) {
		xrange <- c(X$xl, X$xu)
		yrange <- c(X$yl, X$yu)
		if(is.null(X$marks))
			Z <- ppp(X$x, X$y, xrange, yrange)
		else
			Z <- ppp(X$x, X$y, xrange, yrange, 
				marks=X$marks)
		return(Z)
        } else if(checkfields(X, c("x", "y", "area"))
                  && checkfields(X$area, c("xl", "xu", "yl", "yu"))) {
                win <- as.owin(X$area)
                if (is.null(X$marks))
                  Z <- ppp(X$x, X$y, window=win)
                else
                  Z <- ppp(X$x, X$y, window=win, marks = X$marks)
                return(Z)
	} else if(is.matrix(X) && is.numeric(X)) {
		if(is.null(W)) {
                  if(fatal)
                    stop("x,y coords given but no window specified")
                  else
                    return(NULL)
                }
		win <- as.owin(W)
		Z <- ppp(X[,1], X[,2], window = win)
		return(Z)
	} else if(checkfields(X, c("x", "y"))) {
		if(is.null(W)) {
                  if(fatal)
                    stop("x,y coords given but no window specified")
                  else
                    return(NULL)
                }
		win <- as.owin(W)
		if(is.null(X$marks))
                  Z <- ppp(X$x, X$y, window=win)
                else
                  Z <- ppp(X$x, X$y, window=win, marks=X$marks)
                return(Z)
	} else {
          if(fatal)
            stop("Can't interpret X as a point pattern")
          else
            return(NULL)
        }
}

# --------------------------------------------------------------

"[.ppp" <-
"subset.ppp" <-
  function(x, subset, window, drop, ...) {

        verifyclass(x, "ppp")

        trim <- !missing(window)
        thin <- !missing(subset)
        if(!thin && !trim)
          stop("Please specify a subset (to thin the pattern) or a window (to trim it)")

        # thin first, according to 'subset'
        if(!thin)
          Y <- x
        else
          Y <- ppp(x$x[subset],
                   x$y[subset],
                   window=x$window,
                   marks=if(is.null(x$marks)) NULL else x$marks[subset])

        # now trim to window 
        if(trim) {
          ok <- inside.owin(Y$x, Y$y, window)
          Y <- ppp(Y$x[ok], Y$y[ok],
                   window=window,  # SIC
                   marks=if(is.null(Y$marks)) NULL else Y$marks[ok])
        }
        
        return(Y)
}

# ------------------------------------------------------------------

cut.ppp <- function(x, ...) {
  x <- as.ppp(x)
  if(!is.marked(x))
    stop("x has no marks to cut")
  x$marks <- cut(x$marks, ...)
  return(x)
}

# ------------------------------------------------------------------
#
#
scanpp <- function(filename, window, header=TRUE, dir="", multitype=FALSE) {
  filename <- if(dir=="") filename else
              paste(dir, filename, sep=.Platform$file.sep)
  df <- read.table(filename, header=header)
  if(header) {
    x <- df$x
    y <- df$y
    colnames <- dimnames(df)[[2]]
    xycolumns <- match(colnames, c("x","y"), 0)
  } else {
    # assume x, y given in columns 1, 2 respectively
    x <- df[,1]
    y <- df[,2]
    xycolumns <- c(1,2)
  }
  if(ncol(df) == 2) 
      X <- ppp(x, y, window=window)
  else {
    marks <- df[ , -xycolumns]
    if(multitype) 
      marks <- factor(marks)
    X <- ppp(x, y, window=window, marks = marks)
  }
  X
}

#-------------------------------------------------------------------

"is.marked.ppp" <-
function(X, na.action="warn", ...) {
    verifyclass(X, "ppp")
    if(is.null(X$marks))
      return(FALSE)
    if(any(is.na(X$marks)))
      switch(na.action,
             warn = {
               warning(paste("some mark values are NA in the point pattern",
                    deparse(substitute(X))))
             },
             fatal = {
               return(FALSE)
             },
             ignore = {
               return(TRUE)
             }
      )
    return(TRUE)
}

"is.marked" <-
function(X, ...) {
  UseMethod("is.marked")
}

"is.marked.default" <-
  function(...) { return(FALSE) }

"unmark" <-
function(X) {
  if(inherits(X, "ppp")) {
    X$marks <- NULL
    return(X)
  } else if(inherits(X, "splitppp")) {
    Y <- lapply(X, unmark)
    class(Y) <- c("splitppp", class(Y))
    return(Y)
  } else
    stop(paste("X must be a point pattern (class \"ppp\")\n",
               "or a list of point patterns (class \"splitppp\")"))
}

"markspace.integral" <-
  function(X) {
  verifyclass(X, "ppp")
  if(!is.marked(X))
    return(1)
  if(is.factor(X$marks))
    return(length(levels(X$marks)))
  else
    stop("Don't know how to compute total mass of mark space")
}

#-------------------------------------------------------------------

print.ppp <- function(x, ...) {
  verifyclass(x, "ppp")
  ism <- is.marked(x)
  cat(paste(if(ism) "marked" else NULL,
            "planar point pattern:",
            x$n,
            "points\n"))
  if(ism) {
    mks <- x$marks
    if(is.factor(mks)) {
      cat("multitype, with ")
      cat(paste("levels =", paste(levels(mks), collapse="\t"),"\n"))
    } else {
      cat(paste("marks are ",
                if(is.numeric(mks)) "numeric, ",
                "of type \"", typeof(mks),
                "\"\n", sep=""))
    }
  }
  print(x$window)
  return(invisible(NULL))
}

summary.ppp <- function(object, ...) {
  verifyclass(object, "ppp")
  result <- list()
  result$is.marked <- is.marked(object)
  result$n <- object$n
  result$window <- summary(object$window)
  result$intensity <- result$n/result$window$area
  if(result$is.marked) {
    mks <- object$marks
    result$is.multitype <- is.factor(mks)
    result$is.numeric <- is.numeric(mks)
    result$marktype <- typeof(mks)
    if(result$is.multitype) {
      tm <- as.vector(table(mks))
      tfp <- data.frame(frequency=tm,
                        proportion=tm/sum(tm),
                        intensity=tm/result$window$area,
                        row.names=levels(mks))
      result$marks <- tfp
    } else 
      result$marks <- summary(mks)
  }
  class(result) <- "summary.ppp"
  return(result)
}

print.summary.ppp <- function(x, ..., dp=3) {
  verifyclass(x, "summary.ppp")
  cat(paste(if(x$is.marked) "Marked planar " else "Planar ",
            "point pattern: ",
            x$n,
            " points\n",
            sep=""))
  cat(paste("Average intensity",
            signif(x$intensity,dp), "points per unit area\n"))
  if(x$is.marked)
    if(x$is.multitype) {
      cat("Marks:\n")
      print(signif(x$marks,dp))
    } else {
      cat(paste("marks are ",
                if(x$is.numeric) "numeric, ",
                "of type \"", x$marktype,
                "\"\n", sep=""))
      cat("summary:\n")
      print(x$marks)
    }
  cat("\n")
  print(x$window)
  return(invisible(x))
}

# ---------------------------------------------------------------

"%mark%" <-
setmarks <- function(X, m) {
  verifyclass(X, "ppp")
  if(length(m) == 1) m <- rep(m, X$n)
  else if(X$n == 0) m <- rep(m, 0) # ensures marked pattern is obtained
  else if(length(m) != X$n) stop("number of points != number of marks")
  Y <- ppp(X$x,X$y,window=X$window,marks=m)
  return(Y)
}

identify.ppp <- function(x, ...) {
  verifyclass(x, "ppp")
  if(!is.marked(x) || "labels" %in% names(list(...)))
    identify(x$x, x$y, ...)
  else {
    marx <- x$marks
    marques <- if(is.numeric(marx)) paste(signif(marx, 3)) else paste(marx)
    id <- identify(x$x, x$y, labels=marques, ...)
    mk <- marx[id]
    if(is.factor(marx)) mk <- levels(marx)[mk]
    cbind(id=id, marks=mk)
  }
}


#
#    predict.ppm.S
#
#	$Revision: 1.27 $	$Date: 2004/08/30 05:27:45 $
#
#    predict.ppm()
#	   From fitted model obtained by ppm(),	
#	   evaluate the fitted trend or conditional intensity 
#	   at a grid/list of other locations 
#
#
# -------------------------------------------------------------------

predict.ppm <-
function(object, window, ngrid=NULL, locations=NULL,
         covariates=NULL, type="trend", ...) {
#
# guard against mistakes
  dotargs <- list(...)
  nama <- names(dotargs)
  if(!is.null(nama) && any(nama == "newdata"))
    warning("The use of the argument \`newdata\' is out-of-date. See help(predict.ppm)")
  else if(length(dotargs) > 0)
    warning("Some arguments were ignored by predict.ppm")
  
#
#	'object' is the output of ppm()
#
  model <- object
  verifyclass(model, "ppm")
#
#       find out what kind of model it is
#
  mod <- summary(model, quick="no prediction")  # undocumented hack!
  stationary <- mod$stationary
  poisson    <- mod$poisson
  marked     <- mod$marked
  multitype  <- mod$multitype
  notrend    <- mod$no.trend
  trivial    <- poisson && notrend

  need.covariates <- mod$has.covars

  if(mod$antiquated)
    warning("The model was fitted by an out-of-date version of spatstat")
  
#
#       determine mark space
#  
  if(marked) {
    if(!multitype)
      stop("Prediction not yet implemented for general marked point processes")
    else 
      types <- levels(mod$entries$data$marks)
  }
#
#      determine what kind of output is required:
#      (arguments present)    (output)  
#         window, ngrid    ->   image
#         locations (mask) ->   image
#         locations (other) ->  data frame
#
  if(!is.null(ngrid) && !is.null(locations))
    stop("Only one of \`ngrid\' and \`locations\' should be specified")

  if(is.null(ngrid) && is.null(locations)) 
    # use ngrid 
    ngrid <- 50
    
  want.image <- is.null(locations) ||
                    (is.owin(locations) && locations$type == "mask")
  make.grid <- !is.null(ngrid)
#
#
################   Determine prediction points  #####################
#  
  if(!want.image) {
    # (A) list of (x,y) coordinates given by `locations'
    xpredict <- locations$x
    ypredict <- locations$y
    if(is.null(xpredict) || is.null(ypredict)) {
      xy <- xy.coords(locations)
      xpredict <- xy$x
      xpredict <- xy$y
    }
    if(is.null(xpredict) || is.null(ypredict))
      stop("Don't know how to extract x,y coordinates from \`locations\'")
    # marks if required
    if(marked)
      mpredict <- locations$marks
  } else {
    # (B) pixel grid of points
    #
    if(!make.grid) 
    #    (B)(i) The grid is given in `locations'
      masque <- locations
    else {
    #    (B)(ii) We have to make the grid ourselves  
    #    Validate ngrid
    #  
      if(!is.null(ngrid)) {
        if(!is.numeric(ngrid))
          stop("ngrid should be a numeric vector")
        nn <- length(ngrid)
        if(nn < 1 || nn > 2)
          stop("ngrid should be a vector of length 1 or 2")
        if(nn == 1)
          ngrid <- rep(ngrid,2)
      }
      if(missing(window))
        window <- mod$entries$data$window
      masque <- as.mask(window, dimyx=ngrid)
    }
    # Hack -----------------------------------------------
    # gam with lo() will not allow extrapolation beyond the range of x,y
    # values actually used for the fit. Check this:
    tums <- termsinformula(model$trend)
    if(any(
           tums == "lo(x)" |
           tums == "lo(y)" |
           tums == "lo(x,y)" |
           tums == "lo(y,x)")
       ) {
      # determine range of x,y used for fit
      gg <- model$internal$glmdata
      gxr <- range(gg$x[gg$SUBSET])
      gyr <- range(gg$y[gg$SUBSET])
      # trim window to this range
      masque <- intersect.owin(masque, owin(gxr, gyr))
    }
    # ------------------------------------ End Hack
    #
    # Finally, determine x and y vectors for grid
    xx <- raster.x(masque)
    yy <- raster.y(masque)
    xpredict <- xx[masque$m]
    ypredict <- yy[masque$m]
  }

#
##################  CREATE DATA FRAME  ##########################
#                           ... to be passed to predict.glm()  
#
# First the x, y coordinates
  
    if(!marked) 
      newdata <- data.frame(x=xpredict, y=ypredict)
    else if(!want.image) 
      newdata <- data.frame(x=xpredict, y=ypredict, marks=mpredict)
    else {
      # replicate
      nt <- length(types)
      np <- length(xpredict)
      xpredict <- rep(xpredict,nt)
      ypredict <- rep(ypredict,nt)
      newdata <- data.frame(x = xpredict,
                            y = ypredict,
                            marks=rep(types, rep(np, nt)))
    }

#### Next the external covariates, if any
#
   if(need.covariates) {
     if(is.null(covariates)) {
       # Extract covariates from fitted model object
       # They have to be images.
       oldcov <- model$covariates
       if(is.null(oldcov))
         stop("External covariates are required, and are not available")
       if(is.data.frame(oldcov))
         stop(paste("External covariates are required.",
                    "Prediction is not possible at new locations"))
       covariates <- oldcov
     }
     covariates.df <-  mpl.get.covariates(covariates,
                       list(x=xpredict, y=ypredict), "prediction points")
     newdata <- cbind(newdata, covariates.df)
   }
#
######## Set up prediction variables ################################
#
#
# Provide SUBSET variable
#
        if(is.null(newdata$SUBSET))
          newdata$SUBSET <- rep(TRUE, nrow(newdata))
#
# Dig out information used in the original call to ppm().
#        Vnames:     the names for the ``interaction variables''
#        glmdata:    the data frame used for the glm fit
#
  if(!trivial) {
	Vnames <- model$internal$Vnames

        if(exists("is.R") && is.R())
	    glmdata <- model$internal$glmdata
        else        
            assign("glmdata", model$internal$glmdata, f = 1)
  }
  
############  COMPUTE PREDICTION ##############################
#
#   Compute the predicted value z[i] for each row of 'newdata'
#   Store in a vector z and reshape it later
#

###############################################################  
  if(trivial) {
#############  COMPUTE CONSTANT INTENSITY #####################

    lambda <- exp(model$theta[[1]])
    z <- rep(lambda, nrow(newdata))
    
################################################################
  } else if(type == "trend" || poisson) {
#
#############  COMPUTE TREND ###################################
#	
#   set explanatory variables to zero
#	
    zeroes <- rep(0, nrow(newdata))    
    for(vn in Vnames)    
      newdata[[vn]] <- zeroes
#
#   invoke predict.glm()
#  
    z <- predict(model$internal$glmfit, newdata, type="response")

##############################################################  
  } else if(type == "cif" || type =="lambda") {
######### COMPUTE FITTED CONDITIONAL INTENSITY ################
#
# 	
  # set up arguments
    inter <- model$interaction
    X <- model$Q$data
    U <- list(x=newdata$x, y=newdata$y)
    Equal <- outer(X$x, U$x, "==") & outer(X$y, U$y, "==")
    if(marked) {
      U$marks <- newdata$marks
      Equal <- Equal & outer(X$marks, U$marks, "==")
    }
  # compute values of potential at the new sample points
    Vnew <- inter$family$eval(X, U, Equal,
                              inter$pot, inter$par, model$correction)
    if(!is.matrix(Vnew))
      stop("internal error: eval.pair.inter() did not return a matrix")

  # Negative infinite values signify cif = zero
    cif.equals.zero <- matrowany(Vnew == -Inf)
    
  # Insert the potential into the relevant column(s) of `newdata'
    if(ncol(Vnew) == 1)
      # Potential is real valued (Vnew is a column vector)
      # Assign values to a column of the same name in newdata
      newdata[[Vnames]] <- as.vector(Vnew)
      #
    else if(is.null(dimnames(Vnew)[[2]])) {
      # Potential is vector-valued (Vnew is a matrix)
      # with unnamed components.
      # Assign the components, in order of their appearance,
      # to the columns of newdata labelled Vnames[1], Vnames[2],... 
      for(i in seq(Vnames))
        newdata[[Vnames[i] ]] <- Vnew[,i]
      #
    } else {
      # Potential is vector-valued (Vnew is a matrix)
      # with named components.
      # Match variables by name
      for(vn in Vnames)    
        newdata[[vn]] <- Vnew[,vn]
      #
    }
  # invoke predict.glm
  z <- predict(model$internal$glmfit, newdata, type="response")

  # reset to zero if potential was zero
  if(any(cif.equals.zero))
    z[cif.equals.zero] <- 0
    
#################################################################    
  } else
     stop(paste("Unrecognised type \'", type, "\'\n", sep=""))

#################################################################
#
# reshape the result
#
    if(!want.image) 
      out <- as.vector(z)
    else {
      # make an image of the right shape
      imago <- as.im(masque)
      if(!marked) {
        # single image
        out <- imago
        # set entries
        out$v[masque$m] <- z
      } else {
        # list of images
        out <- list()
        for(i in seq(types)) {
          outi <- imago
          # set entries
          outi$v[masque$m] <- z[newdata$marks == types[i]]
          out[[i]] <- outi
        }
      }
    }

####################################################################
#
#  
  invisible(out)
}

#
#	quadclass.S
#
#	Class 'quad' to define quadrature schemes
#	in (rectangular) windows in two dimensions.
#
#	$Revision: 4.7 $	$Date: 2004/01/27 07:03:53 $
#
# An object of class 'quad' contains the following entries:
#
#	$data:	an object of class 'ppp'
#		defining the OBSERVATION window, 
#		giving the locations (& marks) of the data points.
#
#	$dummy:	object of class 'ppp'
#		defining the QUADRATURE window, 
#		giving the locations (& marks) of the dummy points.
#	
#	$w: 	vector giving the nonnegative weights for the
#		data and dummy points (data first, followed by dummy)
#
#		w may also have an attribute attr(w, "zeroes")
#               equivalent to (w == 0). If this is absent
#               then all points are known to have positive weights.
#
#       $param:
#               parameters that were used to compute the weights
#               and possibly to create the dummy points (see below).
#              
#       The combined (data+dummy) vectors of x, y coordinates of the points, 
#       and their weights, are extracted using standard functions 
#       x.quad(), y.quad(), w.quad() etc.
#
# ----------------------------------------------------------------------
#  Note about parameters:
#
#       If the quadrature scheme was created by quadscheme(),
#       then $param contains
#
#           $param$weight
#                list containing the values of all parameters
#                actually used to compute the weights.
#
#           $param$dummy
#                list containing the values of all parameters
#                actually used to construct the dummy pattern
#                via default.dummy();
#                or NULL if the dummy pattern was provided externally
#
#   If you constructed the quadrature scheme manually, this
#   structure may not be present.
#
#-------------------------------------------------------------

quad <- function(data, dummy, w, param=NULL) {
  
  data <- as.ppp(data)
  dummy <- as.ppp(dummy)

  n <- data$n + dummy$n
	
  if(missing(w))
    w <- rep(1, n)
  else {
    w <- as.vector(w)
    if(length(w) != n)
      stop("length of weights vector w is not equal to total number of points")
  }

  if(is.null(attr(w, "zeroes")) && any( w == 0))
	attr(w, "zeroes") <- (w == 0)

  Q <- list(data=data, dummy=dummy, w=w, param=param)
  class(Q) <- "quad"

  invisible(Q)
}

# ------------------ extractor functions ----------------------

x.quad <- function(Q) {
  verifyclass(Q, "quad")
  c(Q$data$x, Q$dummy$x)
}

y.quad <- function(Q) {
  verifyclass(Q, "quad")
  c(Q$data$y, Q$dummy$y)
}

w.quad <- function(Q) {
  verifyclass(Q, "quad")
  Q$w
}

param.quad <- function(Q) {
  verifyclass(Q, "quad")
  Q$param
}
 
n.quad <- function(Q) {
  verifyclass(Q, "quad")
  Q$data$n + Q$dummy$n
}

marks.quad <- function(Q) {
  verifyclass(Q, "quad")
  mdat <- Q$data$marks
  mdum <- Q$dummy$marks
  if(is.null(mdat) && is.null(mdum))
    return(NULL)
  if(is.null(mdat))
    mdat <- rep(NA, Q$data$n)
  if(is.null(mdum))
    mdum <- rep(NA, Q$dummy$n)
  mall <- c(mdat, mdum)
  if(is.factor(mdat) && is.factor(mdum) && all(levels(mdat) == levels(mdum))) {
    mall <- factor(mall)
    levels(mall) <- levels(mdat)
  }
  return(mall)
}

is.data <- function(Q) {
  verifyclass(Q, "quad")
  return(c(rep(TRUE, Q$data$n),
	   rep(FALSE, Q$dummy$n)))
}

equals.quad <- function(Q) {
    # return matrix E such that E[i,j] = (X[i] == U[j])
    # where X = Q$data and U = union.quad(Q)
    n <- Q$data$n
    m <- Q$dummy$n
    E <- matrix(FALSE, nrow=n, ncol=n+m)
    diag(E) <- TRUE
    E
}

  
union.quad <- function(Q) {
  verifyclass(Q, "quad")
  ppp(x= c(Q$data$x, Q$dummy$x),
      y= c(Q$data$y, Q$dummy$y),
      window=Q$dummy$window,
      marks=marks.quad(Q))
}
	
#
#   Plot a quadrature scheme
#
#
plot.quad <- function(x, ..., main=deparse(substitute(x)), dum=list()) {
  verifyclass(x, "quad")
  data <- x$data
  dummy <- x$dummy
  dummyplot <- function(x, ..., pch=".", add=TRUE) {
    plot(x, pch=pch, add=add, ...)
  }
  if(!is.marked(data)) {
    plot(data, main=main, ...)
    do.call("dummyplot", append(list(
                                     dummy,
                                     main=paste(main, "\n dummy points")
                                     ),
                                dum))
  } else if(is.factor(data$marks)) {
    oldpar <- par(ask = interactive() &&
            (.Device %in% c("X11", "GTK", "windows", "Macintosh")))
    on.exit(par(oldpar))
    types <- levels(data$marks)
    for(k in types) {
      maink <- paste(main, "\n mark = ", k, sep="")
      plot(unmark(data[data$marks == k]), main=maink, ...)
      do.call("dummyplot", append(list(unmark(dummy[dummy$marks == k])), dum))
    }
  } else {
    plot(data, ..., main=main)
    addplot <- function(x, ..., add=TRUE, main=deparse(substitute(x))) {
      plot(x, ..., main=main, add=add)
    }
    do.call("addplot", append(list(dummy), dum))
  }
  invisible(NULL)
}
#
#
#      quadscheme.S
#
#      $Revision: 4.6 $    $Date: 2004/01/27 07:04:36 $
#
#      quadscheme()    generate a quadrature scheme from 
#		       data and dummy point patterns.
#
#      quadscheme.spatial()    case where both patterns are unmarked
#
#      quadscheme.replicated() case where data are multitype
#
#
#---------------------------------------------------------------------

quadscheme <- function(data, dummy, method="grid", ...) {
        #
	# generate a quadrature scheme from data and dummy patterns.
	#
	# Other arguments control how the quadrature weights are computed
        #

  data <- as.ppp(data)

  if(missing(dummy)) {
    # create dummy points
    dummy <- default.dummy(data, method=method, ...)
    # extract full set of parameters used to create dummy points
    dp <- attr(dummy, "dummy.parameters")
    # extract recommended parameters for computing weights
    wp <- attr(dummy, "weight.parameters")
  } else {
    # use existing dummy points
    dummy <- as.ppp(dummy, data$window)
		# note data$window is the DEFAULT quadrature window
		# applicable when 'dummy' does not contain a window
    dp <- NULL
    # use given weight parameters without inspection
    wp <- append(list(method=method), list(...))
  }
  
  mX <- is.marked(data)
  mD <- is.marked(dummy)

  if(!mX && !mD)
    Q <- do.call("quadscheme.spatial", append(list(data, dummy), wp))
  else if(mX && !mD)
    Q <- do.call("quadscheme.replicated", append(list(data, dummy), wp))
  else if(!mX && mD)
    stop("dummy points are marked but data are unmarked")
  else
    stop("marked data and marked dummy points -- sorry, this case is not implemented")

  # record parameters used to make dummy points
  Q$param$dummy <- dp

  return(Q)
}

quadscheme.spatial <-
  function(data, dummy, method="grid", ...) {
        #
	# generate a quadrature scheme from data and dummy patterns.
	#
	# The 'method' may be "grid" or "dirichlet"
	#
	# '...' are passed to gridweights() or dirichlet.weights()
        #
        # quadscheme.spatial:
        #       for unmarked point patterns.
        #
        #       weights are determined only by spatial locations
        #       (i.e. weight computations ignore any marks)
	#
        # No two points should have the same spatial location
        # 

	data <- as.ppp(data)
        dummy <- as.ppp(dummy, data$window)
		# note data$window is the DEFAULT quadrature window
		# applicable when 'dummy' does not contain a window

        if(is.marked(data))
          warning("marks in data pattern - ignored")
        if(is.marked(dummy))
          warning("marks in dummy pattern - ignored")
        
	both <- as.ppp(concatxy(data, dummy), dummy$window)
	switch(method,
		grid={
			w <- gridweights(both, window= dummy$window, ...)
		},
		dirichlet = {
			w <- dirichlet.weights(both, window=dummy$window, ...)
		},
		{ 
			stop(paste("unrecognised method \'", method, "\'")) 
		}
	)

        # parameters actually used to make weights
        wp <- attr(w, "weight.parameters")
        param <- list(weight = wp, dummy = NULL)

	Q <- quad(data, dummy, w, param)
        return(Q)
}

"quadscheme.replicated" <-
  function(data, dummy, method="grid", ...) {
        #
	# generate a quadrature scheme from data and dummy patterns.
	#
	# The 'method' may be "grid" or "dirichlet"
	#
	# '...' are passed to gridweights() or dirichlet.weights()
        #
        # quadscheme.replicated:
        #       for multitype point patterns.
        #
        # No two points in 'data'+'dummy' should have the same spatial location

	data <- as.ppp(data)
	dummy <- as.ppp(dummy, data$window)
		# note data$window is the DEFAULT quadrature window
		# unless otherwise specified in 'dummy'

        if(!is.marked(data))
          stop("data pattern does not have marks")
        if(is.marked(dummy))
          warning("dummy points have marks --- ignored")

        # first, ignore marks and compute spatial weights
        P <- quadscheme.spatial(unmark(data), dummy, method, ...)
        W <- w.quad(P)
        iz <- is.data(P)
        Wdat <- W[iz]
        Wdum <- W[!iz]

        # find the set of all possible marks

        if(!is.factor(data$marks))
          stop("data$marks is not a factor")
        markset <- levels(data$marks)
        nmarks <- length(markset)
        
        # replicate dummy points, one copy for each possible mark
        # -> dummy x {1,..,K}
        
        dumdum <- cartesian(dummy, markset)
        Wdumdum <- rep(Wdum, nmarks)
        
        # also make dummy marked points at same locations as data points
        # but with different marks

        dumdat <- cartesian(unmark(data), markset)
        Wdumdat <- rep(Wdat, nmarks)
        Mdumdat <- dumdat$marks
        
        Mrepdat <- rep(data$marks, nmarks)

        ok <- (Mdumdat != Mrepdat)
        dumdat <- dumdat[ok,]
        Wdumdat <- Wdumdat[ok]

        # combine the two dummy patterns

        dumb <- superimpose(dumdum, dumdat)
        Wdumb <- c(Wdumdum, Wdumdat)

        # record the quadrature parameters
        param <- list(weight = P$param$weight, dummy = NULL)

        # wrap up
	Q <- quad(data, dumb, c(Wdat, Wdumb), param)
        return(Q)
}


"cartesian" <-
function(pp, markset, fac=TRUE) {
  # given an unmarked point pattern 'pp'
  # and a finite set of marks,
  # create the marked point pattern which is
  # the Cartesian product, consisting of all pairs (u,k)
  # where u is a point of 'pp' and k is a mark in 'markset'
  nmarks <- length(markset)
  result <- ppp(
                rep(pp$x, nmarks),
                rep(pp$y, nmarks),
                window=pp$window,
                marks=rep(markset, rep(pp$n, nmarks))
  )
  if(fac)
    result$marks <- factor(result$marks, levels=markset)
  result
}
#
#    random.S
#
#    Functions for generating random point patterns
#
#    $Revision: 4.12 $   $Date: 2004/01/27 07:05:16 $
#
#
#    runifpoint()      n i.i.d. uniform random points ("binomial process")
#
#    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
#    rSSI()            Simple Sequential Inhibition process
#
#    rNeymanScott()    Neyman-Scott process (generic)
#    rMatClust()       Mat'ern cluster process
#    rThomas()         Thomas 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))
#

"runifrect" <-
  function(n, win=owin(c(0,1),c(0,1)))
{
  # no checking
      x <- runif(n, min=win$xrange[1], max=win$xrange[2])
      y <- runif(n, min=win$yrange[1], max=win$yrange[2])  
      return(ppp(x, y, window=win))
}

"runifdisc" <-
  function(n, r=1, x=0, y=0)
{
  # i.i.d. uniform points in the disc of radius r and centre (x,y)
  theta <- runif(n, min=0, max= 2 * pi)
  s <- sqrt(runif(n, min=0, max=r^2))
  return(list(x = x + s * cos(theta), y = y + s * sin(theta)))
}


"runifpoint" <-
  function(n, win=owin(c(0,1),c(0,1)), giveup=1000)
{
    win <- as.owin(win)

    switch(win$type,
           rectangle = {
             return(runifrect(n, win))
           },
           mask = {
             dx <- win$xstep
             dy <- win$ystep
             # extract pixel coordinates and probabilities
             xpix <- as.vector(raster.x(win)[win$m])
             ypix <- as.vector(raster.y(win)[win$m])
             # select pixels with equal probability
             id <- sample(seq(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)
             return(ppp(x, y, window=win))
           },
           polygonal={
             # 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 <- bounding.box(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)
               # if we have enough points, exit
               if(X$n > n) 
                 return(X[1:n])
               else if(X$n == n)
                 return(X)
               # otherwise get bored eventually
               else if(ntries >= giveup)
                 stop(paste("Gave up after", giveup * n, "trials,",
                            np, "points accepted"))
             }
           })
    stop("Unrecognised window type")
}

"runifpoispp" <-
function(lambda, win = owin(c(0,1),c(0,1))) {
    win <- as.owin(win)
    if(!is.numeric(lambda) || length(lambda) > 1 || lambda < 0)
      stop("Intensity lambda must be a single number >= 0")

    if(lambda == 0) # return empty pattern
      return(ppp(numeric(0), numeric(0), window=win))

    # generate Poisson process in enclosing rectangle 
    box <- bounding.box(win)
    mean <- lambda * area.owin(box)
    n <- rpois(1, mean)
    X <- runifpoint(n, box)

    # trim to window
    if(win$type != "rectangle")
      X <- X[, win]  

    return(X)
}

rpoint <- function(n, f, fmax=NULL,
                   win=unit.square(), ..., giveup=1000,verbose=FALSE) {
  
  if(missing(f) || (is.numeric(f) && length(f) == 1))
    # uniform distribution
    return(runifpoint(n, win, giveup))
  
  # non-uniform distribution....
  
  if(!is.function(f) && !is.im(f))
    stop("\`f\' must be either a function or an \`im\' object")
  
  if(is.im(f)) {
    # ------------ PIXEL IMAGE ---------------------
    w <- as.mask(as.owin(f))
    dx <- w$xstep
    dy <- w$ystep
    # extract pixel coordinates and probabilities
    xpix <- as.vector(raster.x(w)[w$m])
    ypix <- as.vector(raster.y(w)[w$m])
    ppix <- as.vector(f$v[w$m]) # not normalised - OK
    # select pixels
    id <- sample(length(xpix), n, replace=TRUE, prob=ppix)
    # 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)
    return(ppp(x, y, window=as.owin(f)))
  }

  # ------------ FUNCTION  ---------------------  
  # Establish parameters for rejection method

  verifyclass(win, "owin")
  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 <- bounding.box(win)
  X <- ppp(numeric(0), numeric(0), window=win)
  
  ntries <- 0

  # generate uniform random points in batches
  # and apply the rejection method.
  # Collect any points that are retained in X

  repeat{
    ntries <- ntries + 1
    # proposal points
    prop <- runifrect(n, 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)
        if(X$n >= n) {
          # we have enough!
          if(verbose)
            cat(paste("acceptance rate = ",
                      round(100 * X$n/(ntries * n), 2), "\%\n"))
          return(X[1:n])
        }
      }
    }
    if(ntries > giveup)
      stop(paste("Gave up after",giveup * n,"trials with",
                 X$n, "points accepted"))
  }
  invisible(NULL)
}

"rpoispp" <-
  function(lambda, lmax=NULL, win = owin(c(0,1),c(0,1)), ...) {
    # 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, ...)

    win <- if(is.im(lambda)) as.owin(lambda) else as.owin(win)
    
    if(is.numeric(lambda)) 
      # uniform Poisson
      return(runifpoispp(lambda, win))

    # inhomogeneous Poisson
    # perform thinning of uniform Poisson

    if(is.null(lmax)) {
      imag <- as.im(lambda, win, ...)
      summ <- summary(imag)
      lmax <- summ$max + 0.05 * diff(summ$range)
    }

    if(is.function(lambda)) {
      X <- runifpoispp(lmax, win)  # includes sanity checks on `lmax'
      if(X$n == 0) return(X)
      prob <- lambda(X$x, X$y, ...)/lmax
      u <- runif(X$n)
      retain <- (u <= prob)
      X <- X[retain, ]
      return(X)
    }
    if(is.im(lambda)) {
      X <- runifpoispp(lmax, win)
      if(X$n == 0) return(X)
      prob <- lambda[X]/lmax
      u <- runif(X$n)
      retain <- (u <= prob)
      X <- X[retain, ]
      return(X)
    }
    stop("\'lambda\' must be a constant, a function or an image")
}
    
"rMaternI" <-
  function(lambda, r, win = owin(c(0,1),c(0,1)))
{
    X <- rpoispp(lambda, win=win)
    if(X$n <= 1) return(X)
    d <- nndist(X$x, X$y)
    qq <- X[d > r]
    return(qq)
}
    
"rMaternII" <-
  function(lambda, r, win = owin(c(0,1),c(0,1)))
{
    X <- rpoispp(lambda, win=win)
    
    if(X$n <= 1) return(X)
    
    # matrix of pairwise distances
    d <- pairdist(X$x, X$y)
    close <- (d <= r)

    # random order 1:n
    age <- sample(seq(X$n), X$n, replace=FALSE)
    earlier <- outer(age, age, ">")

    conflict <- close & earlier
    # delete <- apply(conflict, 1, any)
    delete <- matrowany(conflict)
    
    qq <- X[ !delete]
    return(qq)
}
  
"rSSI" <-
  function(r, n, win = owin(c(0,1),c(0,1)), giveup = 1000)
{
     # Simple Sequential Inhibition process
     # fixed number of points
     # Naive implementation, proposals are uniform
     win <- as.owin(win)
     X <- ppp(numeric(0),numeric(0), window=win)
     r2 <- r^2
     if(n * pi * r2/4  > area.owin(win))
       stop(paste("Window is too small to fit", n, "points",
                  "at minimum separation", r))
     ntries <- 0
     while(ntries < giveup) {
       ntries <- ntries + 1
       qq <- runifpoint(1, win)
       x <- qq$x[1]
       y <- qq$y[1]
       if(X$n == 0 || all(((x - X$x)^2 + (y - X$y)^2) > r2))
         X <- superimpose(X, qq)
       if(X$n == n)
         return(X)
     }
     warning(paste("Gave up after", giveup,
                "attempts with only", X$n, "points placed out of", n))
     return(X)
}

"rNeymanScott" <-
  function(lambda, rmax, rcluster, win = owin(c(0,1),c(0,1)), ..., lmax=NULL)
{
  # Generic Neyman-Scott 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()'
  #

  win <- as.owin(win)
  
  # Generate parents in dilated window
  frame <- bounding.box(win)
  dilated <- owin(frame$xrange + c(-rmax, rmax),
                  frame$yrange + c(-rmax, rmax))
  if(is.im(lambda) && !is.subset.owin(as.owin(lambda), dilated))
    stop("The window in which the image \'lambda\' is defined\n\
is not large enough to contain the dilation of the window \'win\'")
  parents <- rpoispp(lambda, lmax=lmax, win=dilated)
  #
  result <- ppp(numeric(0), numeric(0), window = win)
  
  if(parents$n == 0)
    return(result)
  
  for(i in seq(parents$n)) {
    # generate random offspring of i-th parent point
    cluster <- rcluster(parents$x[i], parents$y[i], ...)
    cluster <- ppp(cluster$x, cluster$y, window=frame)
    # trim to window
    cluster <- cluster[,win]
    # add to pattern
    result <- superimpose(result, cluster)
  }
  return(result)
}  

"rMatClust" <-
  function(lambda, r, mu, win = owin(c(0,1),c(0,1)))
{
  # Matern Cluster Process with Poisson (mu) offspring distribution
  #
  poisclus <-  function(x0, y0, radius, mu) {
                           n <- rpois(1, mu)
                           return(runifdisc(n, radius, x0, y0))
                         }
  result <- rNeymanScott(lambda, r, poisclus,
                         win, radius=r, mu=mu)
  return(result)
}
    
"rThomas" <-
  function(lambda, sigma, mu, win = owin(c(0,1),c(0,1)))
{
  # Thomas process with Poisson(mu) number of offspring
  # at isotropic Normal(0,sigma^2) displacements from parent
  #
  thomclus <-  function(x0, y0, sigma, mu) {
                           n <- rpois(1, mu)
                           x <- rnorm(n, mean=x0, sd=sigma)
                           y <- rnorm(n, mean=y0, sd=sigma)
                           return(list(x=x, y=y))
                         }
  result <- rNeymanScott(lambda, 4 * sigma, thomclus,
                         win, sigma=sigma, mu=mu)
  return(result)
}
  
#
#
#   randommk.R
#
#   Random generators for MULTITYPE point processes
#
#   $Revision: 1.7 $   $Date: 2004/01/08 10:24:31 $
#
#   rmpoispp()   random marked Poisson pp
#   rmpoint()    n independent random marked points
#   rmpoint.I.allim()  ... internal
#   rpoint.multi()   temporary wrapper 
#
"rmpoispp" <-
  function(lambda, lmax=NULL, win = owin(c(0,1),c(0,1)),
           types, ...) {
    # 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()
    #

    # Validate arguments
    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))
    }
    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("argument \'lambda\' not understood")
    
    if(list.arg && !all(unlist(lapply(lambda, checkone))))
      stop("Each entry in the list \'lambda\' must be either a constant, a function or an image")
    if(vector.arg && any(lambda < 0))
      stop("Some entries in the vector \'lambda\' are negative")


    # Determine & validate the set of possible types
    if(missing(types)) {
      if(single.arg)
        stop("\'types\' must be given explicitly\
 when \'lambda\' is a constant, a function or an image")
      else
        types <- seq(lambda)
    } 

    ntypes <- length(types)
    if(!single.arg && (length(lambda) != ntypes))
      stop("The lengths of \'lambda\' and \'types\' do not match")

    factortype <- factor(types, levels=types)

    # Validate `lmax'
    if(! (is.null(lmax) || is.numvector(lmax) || is.list(lmax) ))
      stop("\'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(lmax, ntypes)
    else if(length(lmax) != ntypes)
      stop("The length of \'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) lapply(1:ntypes, function(x, y){y}, y=lambda)
           else if(vector.arg) as.list(lambda) else lambda
    
    # Simulate
    for(i in 1:ntypes) {
      if(single.arg && is.function(lambda))
        # call f(x,y,m, ...)
        Y <- rpoispp(lambda, lmax=maxes[i], win=win, types[i], ...)
      else
        # call f(x,y, ...) or use other formats
        Y <- rpoispp(lam[[i]], lmax=maxes[i], win=win, ...)
      Y <- Y %mark% factortype[i]
      X <- if(i == 1) Y else superimpose(X, Y)
    }

    # Randomly permute, just in case the order is important
    permu <- sample(X$n)
    return(X[permu])
}

# ------------------------------------------------------------------------

"rmpoint" <- function(n, f=1, fmax=NULL, 
                      win = unit.square(), 
                      types, ptypes, ...,
                      giveup = 1000, verbose = FALSE) {
  if(!is.numeric(n))
    stop("n must be a scalar or vector")

  Model <- if(length(n) == 1) {
    if(missing(ptypes)) "I" else "II"
  } else "III"
  
  ##############  Validate f argument
  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))
  }

  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("argument \'f\' not understood")
    
  if(list.arg && !all(unlist(lapply(f, checkone))))
    stop("Each entry in the list \'f\' must be either a constant, a function or an image")
  if(vector.arg && any(f < 0))
    stop("Some entries in the vector \'f\' are negative")


  ################   Determine & validate the set of possible types
  if(missing(types)) {
    if(single.arg && length(n) == 1)
      stop("\'types\' must be given explicitly\
 when \'f\' is a single number, a function or an image\
 and \`n\' is a single number")
    else if(single.arg)
      types <- seq(n)
    else 
      types <- seq(f)
  }

  ntypes <- length(types)
  if(!single.arg && (length(f) != ntypes))
    stop("The lengths of \'f\' and \'types\' do not match")
  if(length(n) > 1 && ntypes != length(n))
    stop("The lengths of \'n\' and \'types\' do not match")

  factortype <- factor(types, levels=types)
  
  #######################  Validate `fmax'
  if(! (is.null(fmax) || is.numvector(fmax) || is.list(fmax) ))
    stop("\'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(fmax, ntypes)
  else if(length(fmax) != ntypes)
    stop("The length of \'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) lapply(1:ntypes, function(i, f){f}, f=f)
         else if(vector.arg) as.list(f) else f

  #################### START ##################################

  ## special algorithm for Model I when all f[[i]] are images

  if(Model == "I" && all(unlist(lapply(f, is.im))))
    return(rmpoint.I.allim(n, f, types))

  ## otherwise, first select types, then locations given types
  
  if(Model == "I") {
    # Compute approximate marginal distribution of type
    integratexy <- function(f, win, ...) {
      imag <- as.im(f, win, ...)
      summ <- summary(imag)
      summ$integral
    }
    integratexyi <- function(i, f, win, ...) { integratexy(f, win, i, ...) }
    
    fintegrals <- if(vector.arg) f * area.owin(win) else
       if(list.arg) unlist(lapply(flist, integratexy, win=win, ...)) else
       unlist(lapply(1:ntypes, integratexyi, f=f, win=win, ...))
    ptypes <- fintegrals/sum(fintegrals)
  }

  # Generate number of points of each type

  if(Model == "I" || Model == "II") {
    randomtypes <- sample(types, n, prob=ptypes, replace=TRUE)
    nn <- table(randomtypes)
  } else
    nn <- n

  # Simulate !!!
  # Invoke rpoint() for each type separately
  for(i in 1:ntypes) {
    if(verbose) cat(paste("Type", i, "\n"))
    if(single.arg && is.function(f))
      # call f(x,y,m, ...)
      Y <- rpoint(nn[i], f, fmax=maxes[i], win=win,
                  types[i], ..., 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 <- if(i == 1) Y else superimpose(X, Y)
  }
  
  # Randomly permute, in case the order is important
  permu <- sample(X$n)
  return(X[permu])
}

rmpoint.I.allim <- function(n, f, types) {
  # Internal use only!
  # Generates random marked points (Model I *only*)
  # when all f[[i]] are pixel images.
  #
  # Extract pixel coordinates and probabilities
  get.stuff <- function(imag) {
    w <- as.mask(as.owin(imag))
    dx <- w$xstep
    dy <- w$ystep
    xpix <- as.vector(raster.x(w)[w$m])
    ypix <- as.vector(raster.y(w)[w$m])
    ppix <- as.vector(imag$v[w$m]) # not normalised - OK
    npix <- length(xpix)
    return(list(xpix=xpix, ypix=ypix, ppix=ppix,
                dx=rep(dx,npix), dy=rep(dy, npix),
                npix=npix))
  }
  stuff <- lapply(f, get.stuff)
  # Concatenate into loooong vectors
  xpix <- unlist(lapply(stuff, function(z) { z$xpix }))
  ypix <- unlist(lapply(stuff, function(z) { z$ypix }))
  ppix <- unlist(lapply(stuff, function(z) { z$ppix }))
  dx <- unlist(lapply(stuff, function(z) { z$dx }))
  dy <- unlist(lapply(stuff, function(z) { z$dy }))
  # replicate types
  numpix <- unlist(lapply(stuff, function(z) { z$npix }))
  tpix <- rep(seq(types), numpix)
  #
  # sample pixels from union of all images
  #
  npix <- sum(numpix)
  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!
  return(ppp(x, y, window=as.owin(f[[1]]), marks=marx))
}

#
#     wrapper for Rolf's function
#
rpoint.multi <- function (n, f, fmax=NULL, marks = NULL, win =
                    unit.square(), giveup = 1000, verbose = FALSE) {
  # unmarked case
  if (length(marks) <= 1) {
    if(is.function(f))
      return(rpoint(n, f, fmax, win, giveup=giveup, verbose=verbose))
    else
      return(rpoint(n, f, fmax, giveup=giveup, verbose=verbose))
  }
  # multitype case
  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)
  # generate required number of points of each type
  nums <- table(marks)
  X <- rmpoint(nums, f, fmax, win=win, types=types,
               giveup=giveup, verbose=verbose)
  if(any(table(X$marks) != nums))
    stop("Internal error: output of rmpoint illegal")
  # reorder them to correspond to the desired 'marks' vector
  Y <- X
  for(ty in types) {
    to   <- (marks == ty)
    from <- (X$marks == 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
    }
  }
  return(Y)
}


  
  

    
#
#   resolve.defaults.R
#
#  $Revision: 1.1 $ $Date: 2004/08/30 04:58:34 $
#
# Resolve conflicts between several sets of defaults
# Usage:
#     resolve.defaults(list1, list2, list3, .......)
# where the earlier lists have priority 
#
resolve.defaults <- function(...) {
  arglist <- list(...)
  argue <- list()
  if((n <- length(arglist)) > 0)  {
    for(i in seq(n))
      argue <- append(argue, arglist[[i]])
  }
  if(!is.null(nam <- names(argue))) {
    named <- (nam != "")
    arg.unnamed <- argue[!named]
    arg.named <-   argue[named]
    if(any(discard <- duplicated(names(arg.named)))) 
      arg.named <- arg.named[!discard]
    argue <- append(arg.unnamed, arg.named)
  }
  return(argue)
}



  
#
#	ripras.S	Ripley-Rasson estimator of domain
#
#
#	$Revision: 1.1 $	$Date: 2002/04/07 09:15:39 $
#
#
#
#
#-------------------------------------
ripras <- function(x, y=NULL) {
  # extract x, y coordinates
  z <- xy.coords(x, y)
  x <- z$x
  y <- z$y
  # convex hull
  h <- rev(chull(x, y))  # must be anticlockwise
  # temporary window
  w <- owin(poly=list(x=x[h], y=y[h]))
  # centroid
  ce <- centroid.owin(w)
  # expansion factor
  f <- 1/sqrt(1 - length(h)/length(x))
  # new polygon
  xp <- f * (x[h] - ce$x) + ce$x
  yp <- f * (y[h] - ce$y) + ce$y
  W <- owin(poly=list(x=xp, y=yp))
  return(W)
}
rmh <- function(model, ...){
     UseMethod("rmh")
}
#
# $Id: rmh.default.R,v 1.17 2004/08/23 04:12:18 adrian Exp adrian $
#
rmh.default <- function(model,start,control=NULL, verbose=TRUE, ...) {
#
# Function rmh.  To simulate realizations of 2-dimensional point
# patterns, given the conditional intensity function of the 
# underlying process, via the Metropolis-Hastings algorithm.
#
# model:   cif par w trend types
# start:   n.start x.start iseed
# control: p q nrep expand periodic ptypes fixall nverb
#==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===

# Name lists --- these will need to be modified when new
# conditional intensity functions are added to the repertoire.
cif.list <- c('strauss','straush','sftcr','straussm','straushm',
               'dgs','diggra','geyer','lookup')
mt.list <- c("straussm","straushm")

# Check that cif is available:
cif <- model$cif
if(!is.loaded(symbol.For(cif)))
	stop(paste("Unrecognized cif: ",cif,".\n",sep=""))

# Turn the name of the cif into a number
nmbr <- match(cif,cif.list)
if(is.na(nmbr)) stop("Name of cif not in cif list.\n")

# Set the 3-vector of integer seeds needed by the subroutine arand:
iseed <- if(is.null(start$iseed)) sample(1:1000000,3) else start$iseed
iseed.save <- iseed

# The R in-house random number/sampling system gets used below.
# Therefore we set an argument for set.seed() --- from iseed --- so
# that if iseed was supplied, then it determines all the randomness,
# including ``proposal points'' and possibly the starting state.
# Thus supplying the same ``iseed'' in a repeat simulation will
# give ***exactly*** the same result.)

	rrr <- .Fortran(
		"arand",
		ix=as.integer(iseed[1]),
		iy=as.integer(iseed[2]),
		iz=as.integer(iseed[3]),
		rand=double(1),
                PACKAGE="spatstat"
	)
	build.seed <- round(rrr$rand*1e6)
	iseed <- unlist(rrr[c("ix","iy","iz")])
	set.seed(build.seed)

# Make sure that the control arguments are adequately specified.
if(is.null(control)) {
	control <- list(
			p=0.9,
			q=0.5,
			nrep=6e5,
			fixall=FALSE,
			periodic=FALSE,
			nverb=0
		   )
}

# Check that precisely one method of specifying the starting
# configuration is provided.  If x.start is given, coerce it into
# a point pattern.  If x.start is specified, model$w may be used to
# specify the simulation window (if this is absent from x.start)
# or a window to which the pattern will be clipped at the finish.
# Dig out these (possibly different) windows.

if(is.null(start$n.start)) {
	if(is.null(start$x.start))
		stop("No starting method provided.\n")
	else {
		whinge <- "Window model$w is not a subwindow of x.start$window.\n"
		use.n <- FALSE
		x.start <- start$x.start
		if(is.null(x.start$window)) {
			if(is.null(model$w))
				stop("No window specified in which to simulate.\n")
			w.sim <- w.clip <- model$w
			x.start <- as.ppp(x.start,w.sim)
		} else {
			x.start <- as.ppp(x.start)
			w.sim   <- x.start$window
			w.clip  <- if(is.null(model$w)) w.sim else model$w
			if(is.null(model$w))
				w.clip <- w.sim
			else {
				if(is.subset.owin(model$w,w.sim)) w.clip <- model$w
				else stop(whinge)
			}
		}
	}
} else {
	if(is.null(start$x.start)) {
		if(is.null(model$w))
			stop("No window specified in which to simulate.\n")
		use.n <- TRUE
		n.start <- start$n.start
		w.clip  <- w.sim <- model$w
	} else stop("Both n.start and x.start were specified.\n")
}

w.sim  <- as.owin(w.sim)
w.clip <- as.owin(w.clip)

# Now (possibly) expand the window; to do this we need to deal
# the expand argument.  Dealing with expand requires that we
# check on several other things.
expand <- control$expand

# Expand must be 1 if there is a trend given by an image.
trendy <- !is.null(model$trend)
if(trendy) {
	trim <- is.im(model$trend) | any(unlist(lapply(model$trend,is.im)))
	if(trim) {
		if(is.null(expand)) expand <- 1
		if(expand > 1)
			stop(paste("When there is trend given as an image,",
                                   "expand must be 1.\n"))
	}
}

# Expand must be 1 if we are conditioning on the number of points.
# cond = 1 <--> no conditioning
# cond = 2 <--> conditioning on n = number of points
# cond = 3 <--> conditioning on the number of points of each type.
p <- control[[match("p",names(control))]]
if(is.null(p)) p <- 0.9
fixall  <- if(is.null(control$fixall)) FALSE else control$fixall
cond    <- 2 - (p<1) + fixall - fixall*(p<1)
bwhinge <- "When conditioning on the number of points,"
if(cond > 1) {
        if(is.null(expand)) expand <- 1
        if(expand > 1)
                stop(paste(bwhinge,"expand must be 1.\n"))
}

# Also the expand argument must be 1 if we are using x.start.
# In a similar vein, if we are using x.start and we are conditioning
# on the number of points, no clipping of the final result
# should be done.  (Nothing to do with expand, as such, but
# we might as well check on this here.)
if(!use.n) {
	if(is.null(expand)) expand <- 1
	else if(expand > 1)
		stop("When using x.start, expand must be 1.\n")
	if(cond > 1 & !identical(all.equal(w.clip,w.sim),TRUE))
		stop(paste(bwhinge,"we cannot clip the result to another window.\n"))
}

# If periodic is TRUE, expand must be 1.  While we're at it,
# if periodic is TRUE check that the window is rectangular and set
# the period.
periodic <- if(is.null(control$periodic)) FALSE else control$periodic
if(periodic) {
	if(is.null(expand)) expand <- 1
        else if(expand > 1)
		stop("Must have expand=1 for periodic simulation.\n")
	if(w.sim$type != "rectangle")
		stop("Need rectangular window for periodic simulation.\n")
	period <- c(w.sim$xrange[2] - w.sim$xrange[1],
                    w.sim$yrange[2] - w.sim$yrange[1])
} else period <- c(-1,-1)

# At this stage we have no reason not to expand the window, and
# if expand has not been specified we let it default to 2.
if(is.null(expand)) expand <- 2

# Now build the expanded window within which to suspend the actual
# window of interest (in order to approximate the simulation of a
# windowed process, rather than a process existing only in the given
# window.  If expand == 1, then we are simulating the latter.  The
# larger ``expand'' is, the better we approximate the former.  Note
# that any value of ``expand'' smaller than 1 is treated as if it
# were 1.
if(expand>1) { # Note that if expand > 1, then use.n is TRUE!
       	rw <- c(w.sim$xrange,w.sim$yrange) # Enclosing box.
	xdim <- rw[2]-rw[1]
	ydim <- rw[4]-rw[3]
	fff  <- (sqrt(expand)-1)*0.5
	ew   <- as.owin(c(rw[1] - fff*xdim,rw[2] + fff*xdim,
                          rw[3] - fff*ydim,rw[4] + fff*ydim))
	n.start <- ceiling(n.start*area.owin(ew)/area.owin(w.sim))
		# The foregoing is incorrect if there is a trend/are trends,
		# but in that case it's just too bloody complicated for it
		# to be worthwhile to try to do the correct thing.
}
else ew <- w.sim

# Determine if the model is multitype.  If so, set up the number
# of types and the types themselves.
if(use.n) {
	mtype <- (!is.null(model$types)) | (length(model$par$beta) > 1)
	npts <- sum(n.start) # Redundant if n.start is scalar; no harm, but.
} else {
	mtype <- is.marked(x.start)
	npts  <- x.start$n
}

if(mtype) {
	if(is.na(match(model$cif, mt.list)))
		stop(paste("Conditional intensity function", cif,
                           "is not multitype.\n"))
	ptypes <- control$ptypes
	if(use.n) {
		types <- model$types
		if (is.null(types)) {
			ntypes <- length(model$par$beta)
			types <- 1:ntypes
		} else {
			ntypes <- length(types)
			if (ntypes != length(model$par$beta))
				stop(paste("Mismatch in lengths of model$types",
                                           "and model$par$beta.\n"))
		}

# If we are conditioning on the number of points of each type, make
# sure that the length of the vector of these numbers is the same as
# ntypes.
		if(cond == 3 & length(n.start) != ntypes)
			stop("Length of n.start not equal to number of types.\n")
# Build ptypes and marks
		if(is.null(ptypes)) ptypes <- rep(1/ntypes,ntypes)
		marks <- if(fixall) rep(1:ntypes,n.start)
			 else sample(1:ntypes,npts,TRUE,ptypes)
	} else {
		marks  <- x.start$marks
                types  <- levels(marks)
                ntypes <- length(types)
                marks  <- match(marks,levels(marks)) # Makes marks into an integer
                                                     # vector for passing to
                                                     # subroutine methas.
		if(is.null(ptypes)) ptypes <- table(marks)/npts
	}

# Check for compatibility of ntypes and length of ptypes.
	if(length(ptypes) != ntypes | sum(ptypes) != 1)
		stop("Argument ptypes is mis-specified.\n")
} else {
	ntypes <- 1
	ptypes <- 1
	marks  <- 0
}

# Warn about a silly value of fixall:
if(fixall & (ntypes==1 | p < 1))
	warning("Setting fixall = TRUE is silly when ntypes = 1 or p < 1.\n")

# Integral of trend over the expanded window (or area of window):
# Iota == Integral Of Trend (or) Area.
if(trendy) {
	if(is.function(model$trend) | is.im(model$trend)) {
		tmp  <- as.im(model$trend,ew)[ew, drop=FALSE]
                sump <- summary(tmp)
		iota <- sump$integral
		tmax <- sump$max
	} else {
		if(is.list(model$trend)) {
			if(length(model$trend) != ntypes)
				stop(paste("Mismatch of ntypes and",
                                           "length of trend list.\n"))
			iota <- numeric(ntypes)
			tmax <- numeric(ntypes)
			for(i in 1:ntypes) {
				tmp <- as.im(model$trend[[i]],ew)[ew, drop=FALSE]
                                sump <- summary(tmp)
				iota[i] <- sump$integral
				tmax[i] <- sump$max
			}
		}
	}
} else {
	iota <- area.owin(ew)
	tmax <- NULL
}

# Build starting state consisting of x, y and possibly marks.
if(use.n) {
	xy   <- if(trendy) rpoint.multi(npts,model$trend,tmax,factor(marks),ew,...)
			else runifpoint(npts,ew,...)
	x <- xy$x
	y <- xy$y
} else {
	x <- x.start$x
	y <- x.start$y
}

# Do some rudimentary pre-processing of the par arguments. Save
# the supplied values of par first.

par.save <- par <- model$par

# 1. Strauss.
if(cif=="strauss") {
	nms <- c("beta","gamma","r")
	if(sum(!is.na(match(names(par),nms))) != 3) {
		cat("For the strauss cif, par must be a named vector\n")
		cat("with components beta, gamma, and r.\n")
		stop("Bailing out.\n")
	}
	if(any(par<0))
		stop("Negative parameters for strauss cif.\n")
	if(par["gamma"] > 1)
		stop("For Strauss processes, gamma must be <= 1.\n")
	par <- par[nms]
}

# 2. Strauss with hardcore.
if(cif=="straush") {
	nms <- c("beta","gamma","r","hc")
	if(sum(!is.na(match(names(par),nms))) != 4) {
		cat("For the straush cif, par must be a named vector\n")
		cat("with components beta, gamma, r, and hc.\n")
		stop("Bailing out.\n")
	}
	if(any(par<0))
		stop("Negative parameters for straush cif.\n")
	par <- par[nms]
}

# 3. Softcore.
if(cif=="sftcr") {
	nms <- c("beta","sigma","kappa")
	if(sum(!is.na(match(names(par),nms))) != 3) {
		cat("For the sftcr cif, par must be a named vector\n")
		cat("with components beta, sigma, and kappa.\n")
		stop("Bailing out.\n")
	}
	if(any(par<0))
		stop("Negative  parameters for sftcr cif.\n")
	if(par["kappa"] > 1)
		stop("For Softcore processes, kappa must be <= 1.\n")
	par <- par[nms]
}

# 4. Marked Strauss.
if(cif=="straussm") {
	nms <- c("beta","gamma","radii")
	if(!is.list(par) || sum(!is.na(match(names(par),nms))) != 3) {
		cat("For the straussm cif, par must be a named list with\n")
		cat("components beta, gamma, and radii.\n")
		stop("Bailing out.\n")
	}
	beta <- par$beta
	if(length(beta) != ntypes)
		stop("Length of beta does not match ntypes.\n")
	gamma <- par$gamma
	if(!is.matrix(gamma) || sum(dim(gamma) == ntypes) != 2)
		stop("Component gamma of par is of wrong shape.\n")
	r <- par$radii
	if(!is.matrix(r) || sum(dim(r) == ntypes) != 2)
		stop("Component r of par is of wrong shape.\n")
	gamma <- t(gamma)[row(gamma)>=col(gamma)]
	r <- t(r)[row(r)>=col(r)]
	par <- c(beta,gamma,r)
	if(any(par[!is.na(par)]<0))
		stop("Negative  parameters for straussm cif.\n")
}

# 5. Marked Strauss with hardcore.
if(cif=="straushm") {
	nms <- c("beta","gamma","iradii","hradii")
	if(!is.list(par) || sum(!is.na(match(names(par),nms))) != 4) {
		cat("For the straushm cif, par must be a named list with\n")
		cat("components beta, gamma, iradii, and hradii.\n")
		stop("Bailing out.\n")
	}
	beta <- par$beta
	if(length(beta) != ntypes)
		stop("Length of beta does not match ntypes.\n")

	gamma <- par$gamma
	if(!is.matrix(gamma) || sum(dim(gamma) == ntypes) != 2)
		stop("Component gamma of par is of wrong shape.\n")
	gamma[is.na(gamma)] <- 1

	iradii <- par$iradii
	if(!is.matrix(iradii) || sum(dim(iradii) == ntypes) != 2)
		stop("Component iradii of par is of wrong shape.\n")
	iradii[is.na(iradii)] <- 0

	hradii <- par$hradii
	if(!is.matrix(hradii) || sum(dim(hradii) == ntypes) != 2)
		stop("Component hradii of par is of wrong shape.\n")
	hradii[is.na(hradii)] <- 0

	gamma <- t(gamma)[row(gamma)>=col(gamma)]
	iradii <- t(iradii)[row(iradii)>=col(iradii)]
	hradii <- t(hradii)[row(hradii)>=col(hradii)]

	par <- c(beta,gamma,iradii,hradii)
	if(any(par[!is.na(par)]<0))
	if(any(is.na(par)) || any(par<0))
		stop("Some parameters negative or illegally set to NA.\n")
}

# 6. Using the interaction function number 1 from Diggle, Gates, and Stibbard).
if(cif=="dgs") {
	nms <- c("beta","rho")
	if(sum(!is.na(match(names(par),nms))) != 2) {
		cat("For the dgs cif, par must be a named vector\n")
		cat("with components beta and rho.\n")
		stop("Bailing out.\n")
	}
	if(any(par<0))
		stop("Negative parameters for dgs cif.\n")
	par <- par[nms]
}

# 7. Using Diggle-Gratton interaction function (function number 2
#    from Diggle, Gates, and Stibbard).
if(cif=="diggra") {
	nms <- c("beta","kappa","delta","rho")
	if(sum(!is.na(match(names(par),nms))) != 4) {
		cat("For the diggra cif, par must be a named vector\n")
		cat("with components beta, kappa, delta, and rho.\n")
		stop("Bailing out.\n")
        }
	if(any(par<0))
		stop("Negative parameters for diggra cif.\n")
	if(par["delta"] >= par["rho"])
		stop("Radius delta must be less than radius rho.\n")
	par <- par[nms]
}

# 8. The Geyer conditional intensity function.
if(cif=="geyer") {
	nms <- c("beta","gamma","r","sat")
	if(sum(!is.na(match(names(par),nms))) != 4) {
		cat("For the geyer cif, par must be a named vector\n")
		cat("with components beta, gamma, r, and sat.\n")
		stop("Bailing out.\n")
	}
	if(any(par<0))
		stop("Negative parameters for geyer cif.\n")
	if(par["sat"] > .Machine$integer.max-100)
		par["sat"] <- .Machine$integer.max-100
	par <- par[nms]
}

# 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 Fortran code.

if(cif=="lookup") {
	nms <- c("beta","h")
	if(!is.list(par) || sum(!is.na(match(names(par),nms))) != 2) {
                cat("For the lookup cif, par must be a named list\n")
                cat("with components beta and h (and optionally r).\n")
                stop("Bailing out.\n")
        }
	beta <- par[["beta"]]
	if(beta < 0)
		stop("Negative value of beta for lookup cif.\n")
	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.\n"))
		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 \"f\" and \"right\" arguments for stepfun.\n"))
		r     <- knots(h.init)
		h0    <- get("yleft",envir=environment(h.init))
		h     <- h.init(r)
		nlook <- length(r)
		if(!identical(all.equal(h[nlook],1),TRUE))
			stop(paste("The lookup interaction step function",
                                   "must be equal to 1 for \"large\"",
                                   "distances.\n"))
		if(r[1] <= 0)
			stop(paste("The first jump point (knot) of the lookup",
				   "interaction step function must be",
                                   "strictly positive.\n"))
		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.\n")
		if(any(is.na(r)))
			stop("Missing values not allowed in r lookup vector.\n")
		if(is.unsorted(r))
			stop("The r lookup vector must be in increasing order.\n")
		if(r[1] <= 0)
			stop(paste("The first entry of the lookup vector r",
                                   "should be strictly positive.\n"))
		h <- c(h,1)
	}
	if(any(h < 0))
		stop(paste("Negative values in the lookup",
                           "pairwise interaction function.\n"))
	if(h[1] > 0 & any(h > 1))
		stop("Lookup pairwise interaction function does not define a valid point process.\n")
	rmax   <- r[nlook]
	r <- c(0,r)
	nlook <- nlook+1
	deltar <- mean(diff(r))
	if(identical(all.equal(diff(r),rep(deltar,nlook-1)),TRUE)) {
		equisp <- 1
		par <- c(beta,nlook,equisp,deltar,rmax,h)
	} else {
		equisp <- 0
		par <- c(beta,nlook,equisp,deltar,rmax,h,r)
	}
}

# If we are simulating a Geyer saturation process we need some
# ``auxilliary information''.
if(nmbr==8) {
	aux <- .Fortran(
		"initaux",
		nmbr=as.integer(nmbr),
		par=as.double(par),
		period=as.double(period),
		x=as.double(x),
		y=as.double(y),
		npts=as.integer(npts),
		aux=integer(npts),
                PACKAGE="spatstat"
	)$aux
	need.aux <- TRUE
} else {
	aux <- 0
	need.aux <- FALSE
}

# The vectors x and y (and perhaps marks) which hold the generated
# process may grow.  We need to allow storage space for them to grow
# in.  Unless we are conditioning on the number of points, we have no
# real idea how big they will grow.  Hence we start off with storage
# space which has twice the length of the ``initial state'', and
# structure things so that the storage space may be incremented
# without losing the ``state'' which has already been generated.

if(cond == 1) {
	x <- c(x,numeric(npts))
	y <- c(y,numeric(npts))
	if(ntypes>1) marks <- c(marks,numeric(npts))
	if(need.aux) aux <- c(aux,numeric(npts))
	nincr <- 2*npts
} else {
	nincr <- npts
}
npmax <- 0
mrep  <- 1

# Set up remaining control parameters:
q     <- if(is.null(control$q)) 0.5 else control$q
nrep  <- if(is.null(control$nrep)) 0.6e5 else control$nrep
nverb <- if(is.null(control$nverb)) 0 else control$nverb

# If the pattern is multitype, generate the mark proposals.
mprop <- if(ntypes>1)
	sample(1:ntypes,nrep,TRUE,prob=ptypes) else 0
		
# Generate the ``proposal points'' in the expanded window.
xy <- if(trendy) rpoint.multi(nrep,model$trend,tmax,factor(mprop),ew,...) else
			runifpoint(nrep,ew)
xprop <- xy$x
yprop <- xy$y

# The repetition is to allow the storage space to be incremented if
# necessary.
repeat {
	npmax <- npmax + nincr
# Call the Metropolis-Hastings simulator:
	rslt <- .Fortran(
			"methas",
			nmbr=as.integer(nmbr),
			iota=as.double(iota),
			par=as.double(par),
			period=as.double(period),
			xprop=as.double(xprop),
			yprop=as.double(yprop),
			mprop=as.integer(mprop),
			ntypes=as.integer(ntypes),
			ptypes=as.double(ptypes),
			iseed=as.integer(iseed),
			nrep=as.integer(nrep),
			mrep=as.integer(mrep),
			p=as.double(p),
			q=as.double(q),
			npmax=as.integer(npmax),
			nverb=as.integer(nverb),
			x=as.double(x),
			y=as.double(y),
			marks=as.integer(marks),
			aux=as.integer(aux),
			npts=as.integer(npts),
			fixall=as.logical(fixall),
                        PACKAGE="spatstat"
		)

# If npts > npmax we've run out of storage space.  Tack some space
# onto the end of the ``state'' already generated, increase npmax
# correspondingly, and re-call the methas subroutine.  Note that
# mrep is the number of the repetition on which things stopped due
# to lack of storage; so we start again at the ***beginning*** of
# the mrep repetition.
	npts <- rslt$npts
	if(npts <= npmax) break
	if(verbose) {
		cat('Number of points greater than ',npmax,';\n',sep='')
		cat('increasing storage space and continuing.\n')
	}
	x     <- c(rslt$x,numeric(nincr))
	y     <- c(rslt$y,numeric(nincr))
	marks <- if(ntypes>1) c(rslt$marks,numeric(nincr)) else 0
	aux   <- if(need.aux) c(rslt$aux,numeric(nincr)) else 0
	mrep  <- rslt$mrep
	iseed <- rslt$iseed
	npts  <- npts-1
}

x <- rslt$x[1:npts]
y <- rslt$y[1:npts]
if(mtype) {
	marks <- factor(rslt$marks[1:npts],labels=types)
	xxx <- ppp(x=x, y=y, window=as.owin(ew), marks=marks)
} else xxx <- ppp(x=x, y=y, window=as.owin(ew))

# Now clip the pattern to the ``clipping'' window:
xxx <- xxx[,w.clip]

# Append to the result information about how it was generated.
start <- if(use.n) list(n.start=n.start,iseed=iseed.save)
		else list(x.start=x.start,iseed=iseed.save)
attr(xxx, "info") <- list(model=list(cif=cif,par=par.save,trend=model$trend),
                          start=start,
                          control=list(p=p,q=q,nrep=nrep,expand,periodic,
                                       ptypes=ptypes,fixall=fixall))
return(xxx)
}
#
# simulation of FITTED model
#
#  $Revision: 1.9 $ $Date: 2004/09/02 03:50:58 $
#
#
rmh.ppm <- function(model, start = NULL, control = NULL, ...,
                    verbose=TRUE, project=TRUE) {
  verifyclass(model, "ppm")

  # convert fitted model object to list of parameters for rmh.default
  X <- rmhmodel.ppm(model, verbose=verbose, project=project)

  # call appropriate simulation routine

  if(X$cif != "poisson") {
    if(is.null(start)) {
      datapattern <- summary(model, quick="no prediction")$data
      start <- list(n.start=datapattern$n)
    }
    if(is.null(control)) 
      control <- list(nrep=1e6)
    return(rmh.default(X, start=start, control=control, ..., verbose=verbose))
  }
  
  # Poisson process
  intensity <- if(is.null(X$trend)) X$par$beta else X$trend
  if(is.null(X$types))
    return(rpoispp(intensity, win=X$w, ...))
  else
    return(rmpoispp(intensity, win=X$w, types=X$types))
}

#
#  rmhmodel.ppm.R
#
#   convert ppm object into format palatable to rmh.default
#
#  $Revision: 2.7 $   $Date: 2004/08/20 10:32:00 $
#
#   .Spatstat.rmhinfo
#   rmhmodel.ppm()
#

.Spatstat.Rmhinfo <-
list(
     "Diggle-Gratton process" =
     function(coeffs, inte) {
       kappa <- inte$interpret(coeffs,inte)$param$kappa
       delta <- inte$par$delta
       rho   <- inte$par$rho
       return(list(cif='diggra',
                   par=c(kappa=kappa,delta=delta,rho=rho)))
     },
     "Geyer saturation process" =
     function(coeffs, inte) {
       gamma <- inte$interpret(coeffs,inte)$param$gamma
       r <- inte$par$r
       sat <- inte$par$saturate
       return(list(cif='geyer',
                   par=c(gamma=gamma,r=r,sat=sat)))
     },
     "Soft core process" =
     function(coeffs, inte) {
       kappa <- inte$par$kappa
       sigma <- inte$interpret(coeffs,inte)$param$sigma
       return(list(cif="sftcr",
                   par=c(sigma=sigma,kappa=kappa)))
     },
     "Strauss process" =
     function(coeffs, inte) {
       gamma <- inte$interpret(coeffs,inte)$param$gamma
       r <- inte$par$r
       return(list(cif = "strauss",
                   par = list(gamma = gamma, r = r)))
     },
     "Strauss - hard core process" =
     function(coeffs, inte) {
       gamma <- inte$interpret(coeffs,inte)$param$gamma
       r <- inte$par$r
       hc <- inte$par$hc
       return(list(cif='straush',
                   par=c(gamma=gamma,r=r,hc=hc)))
     },
     "Multitype Strauss process" =
     function(coeffs, inte) {
       # interaction radii r[i,j]
       radii <- inte$par$radii
       # interaction parameters gamma[i,j]
       gamma <- (inte$interpret)(coeffs, inte)$param$gammas
       return(list(cif='straussm',
                   par=list(gamma=gamma,radii=radii)))
     },
     "Multitype Strauss Hardcore process" =
     function(coeffs, inte) {
       # interaction radii r[i,j]
       iradii <- inte$par$iradii
       # hard core radii r[i,j]
       hradii <- inte$par$hradii
       # interaction parameters gamma[i,j]
       gamma <- (inte$interpret)(coeffs, inte)$param$gammas
       return(list(cif='straushm',
                   par=list(gamma=gamma,iradii=iradii,hradii=hradii)))
     },
     "Piecewise constant pairwise interaction process" =
     function(coeffs, inte) {
       r <- inte$par$r
       gamma <- (inte$interpret)(coeffs, inte)$param$gammas
       h <- stepfun(r, c(gamma, 1))
       return(list(cif='lookup', par=list(h=h)))
     }
)


# OTHER MODELS not yet implemented:
#
#
#      interaction object           rmh.default 
#      ------------------           -----------
#
#           <none>                   dgs
#
#           LennardJones             <none>
#
#           OrdThresh                <none>
#
#  'dgs' has no canonical parameters (it's determined by its irregular
#  parameter rho) so there can't be an interaction object for it.
#
#  Implementing rmh.default for the others is probably too hard.


rmhmodel.ppm <- function(model, win, ..., verbose=TRUE, project=TRUE) {
  # convert ppm object `model' into format palatable to rmh.default
  
    verifyclass(model, "ppm")
    X <- model

    # Extract essential information
    Y <- summary(X)

    if(Y$marked && !Y$multitype)
      stop("Not implemented for marked point processes other than multitype")

    ########  Interpoint interaction
    if(Y$poisson) {
      Z <- list(cif="poisson",
                par=list())  # par is filled in later
    } else {
      # First check version number of ppm object
      ver <- model$version
      if(is.null(ver)
         || is.character(ver)   # old style, version <= 1.3-4
         || is.null(major <- ver$major)
         || is.null(minor <- ver$minor)
         || (major == 1 && minor < 4)) {
        whinge <- paste(
        "This model was fitted by an earlier version of spatstat;\n",
        "simulation is not possible.\n",
        "Re-fit the model using the current version of the package")
        stop(whinge)
      }
      
      # Extract the interpoint interaction object
      inte <- Y$entries$interaction
      # Determine whether the model can be simulated using rmh
      siminfo <- .Spatstat.Rmhinfo[[inte$name]]
      if(is.null(siminfo))
        stop(paste("Simulation of a fitted \'", inte$name,
                   "\' has not yet been implemented"))
      
      # Get fitted model's canonical coefficients
      coeffs <- Y$entries$theta
      # Ensure the fitted model is valid
      # (i.e. exists mathematically as a point process)
      valid <- inte$valid(coeffs, inte)
      # if not, 
      if(!valid) {
        if(project) {
          if(verbose)
            cat("Model is invalid - projecting it\n")
          coeffs <- inte$project(coeffs, inte)
        }
        else
          stop("The fitted model is not a valid point process")
      }
      # Translate the model to the format required by rmh.default
      Z <- siminfo(coeffs, inte)
      if(is.null(Z))
        stop("The model cannot be simulated")
      else if(is.null(Z$cif))
        stop(paste("Internal error: no cif returned from .Spatstat.Rmhinfo"))
    }

    # Don't forget the types
    if(Y$multitype && is.null(Z$types))
      Z$types <- levels(Y$entries$marks)
       
    ######## Simulation window 
    
    if(missing(win))
      win <- Y$entries$data$window

    Z$w <- win

    ###### Trend or Intensity ############

    if(Y$stationary) {
      # first order terms (beta or beta[i]) are carried in Z$par$beta
      Z$par[["beta"]] <- Y$trend$value
      Z$trend <- NULL
    } else {
      # all first order effects are subsumed in Z$trend
      Z$par[["beta"]] <- if(!Y$marked) 1 else rep(1, length(Z$types))
      Z$trend <- predict(X, window=as.mask(win), type="trend")
    }
    # Note the construction m[["name"]] <-
    # ensures that m does not need to be coerced from vector to list
    return(Z)
}

#
#	rotate.S
#
#	$Revision: 1.2 $	$Date: 2003/03/11 01:21:59 $
#

rotxy <- function(X, angle=pi/2) {
  co <- cos(angle)
  si <- sin(angle)
  list(x = co * X$x - si * X$y,
       y = si * X$x + co * X$y)
}

"rotate.owin" <- function(X, angle=pi/2, ...) {
  verifyclass(X, "owin")
  switch(X$type,
         rectangle={
           # convert rectangle to polygon
           P <- owin(X$xrange, X$yrange, poly=
                     list(x=X$xrange[c(1,2,2,1)],
                          y=X$yrange[c(1,1,2,2)]))
           # call polygonal case
           return(rotate.owin(P, angle))
         },
         polygonal={
           # First rotate the polygonal boundaries
           bdry <- lapply(X$bdry, rotxy, angle=angle)
           # Compute bounding box of new polygons
           xr <- range(unlist(lapply(bdry, function(a) a$x)))
           yr <- range(unlist(lapply(bdry, function(a) a$y)))
           # wrap up
           return(owin(xr, yr, poly=bdry))
         },
         mask={
           stop("Sorry, \'rotate.owin\' is not yet implemented for masks")
         },
         stop("Unrecognised window type")
         )
}

"rotate.ppp" <- function(X, angle=pi/2, ...) {
  verifyclass(X, "ppp")
  r <- rotxy(X, angle)
  w <- rotate.owin(X$window, angle)
  return(ppp(r$x, r$y, window=w, marks=X$marks))
}


"rotate" <- function(X, ...) {
  UseMethod("rotate")
}

  
#
#
#    saturated.S
#
#    $Revision: 1.2 $	$Date: 2001/08/07 11:52:17 $
#
#    Saturated pairwise process with user-supplied potential
#
#    Saturated()  create a saturated pairwise process
#                 [an object of class 'interact']
#                 with user-supplied potential
#	
#
# -------------------------------------------------------------------
#	

Saturated <- function(pot, name) {
  if(missing(name))
    name <- "Saturated process with user-defined potential"
  
  out <- 
  list(
         name     = name,
         family    = pairsat.family,
         pot      = pot,
         par      = NULL,
         parnames = NULL,
         init     = NULL,
         update   = NULL, 
         print = function(self) {
           cat(paste(self$name, "\n"))
           cat("Potential function:\n")
           print(self$pot)
           invisible()
         }
  )
  class(out) <- "interact"
  return(out)
}
#
#
#     setcov.R
#
#     $Revision: 1.2 $ $Date: 2002/07/18 10:54:34 $
#
#    Compute the set covariance function of a window
#
#

setcov <- function(W) {
  W <- as.owin(W)
  # pixel approximation
  mW <- as.mask(W)
  M <- mW$m
  # pad with zeroes
  nr <- nrow(M)
  nc <- ncol(M)
  Mpad <- matrix(0, ncol=2*nc, nrow=2*nr)
  Mpad[1:nr, 1:nc] <- M
  lengthMpad <- 4 * nc * nr
  # compute set covariance by fft
  fM <- fft(Mpad)
  G <- fft(Mod(fM)^2, inverse=TRUE)/lengthMpad
#  cat(paste("maximum imaginary part=", max(Im(G)), "\n"))
  G <- Mod(G) * mW$xstep * mW$ystep
  # Currently G[i,j] corresponds to a vector shift of
  #     dy = (i-1) mod nr, dx = (j-1) mod nc.
  # Rearrange this periodic function so that 
  # the origin of translations (0,0) is at matrix position (nr,nc)
  G <- G[ ((-nr):nr) %% (2 * nr) + 1, (-nc):nc %% (2*nc) + 1]
  # Now set up a raster image 
  xstep <- mW$xstep
  ystep <- mW$ystep
  out <- im(G, xcol=xstep * ((-nc):nc), yrow=ystep * ((-nr):nr))
  return(out)
}

#
#
#    softcore.S
#
#    $Revision: 2.1 $   $Date: 2004/01/27 08:06:38 $
#
#    Soft core processes.
#
#    Softcore()    create an instance of a soft core process
#                 [an object of class 'interact']
#
#
# -------------------------------------------------------------------
#

Softcore <- function(kappa) {
  out <- 
  list(
         name     = "Soft core process",
         family   = pairwise.family,
         pot      = function(d, par) {
                        -d^(-2/par$kappa)
                    },
         par      = list(kappa = kappa),
         parnames = "Exponent kappa",
         init     = function(self) {
                      kappa <- self$par$kappa
                      if(!is.numeric(kappa) || length(kappa) != 1 ||
                         kappa <= 0 || kappa >= 1)
                       stop("Exponent kappa must be a positive \
number less than 1")
                    },
         update = NULL,  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           theta <- coeffs[["Interaction"]]
           sigma <- theta^(self$par$kappa/2)
           return(list(param=list(sigma=sigma),
                       inames="interaction parameter sigma",
                       printable=sigma))
         },
         valid = function(coeffs, self) {
           theta <- coeffs[["Interaction"]]
           return(is.finite(theta) && (theta >= 0))
         },
         project = function(coeffs, self) {
           theta <- coeffs[["Interaction"]]
           if(is.na(theta))
             theta <- 0
           coeffs[["Interaction"]] <- max(0, theta)
           return(coeffs)
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}

#
# split.R
#
# $Revision: 1.1 $ $Date: 2004/08/26 05:12:58 $
#
# split.ppp and "split<-.ppp"
#
#########################################

split.ppp <- function(x, f = x$marks) {
  verifyclass(x, "ppp")
  if(!missing(f)) {
    if(!is.factor(f))
      stop("f must be a factor")
    if(length(f) != x$n)
      stop("length(f) must equal the number of points in x")
  } else {
    if(is.marked(x) && is.factor(x$marks)) 
      f <- x$marks
    else
      stop("f is missing and there is no sensible default")
  }
  out <- list()
  for(l in levels(f)) 
    out[[paste(l)]] <- x[f == l]
  
  class(out) <- c("splitppp", class(out))
  return(out)
}

"split<-.ppp" <- function(x, f=x$marks, value) {
  verifyclass(x, "ppp")
  if(!missing(f)) {
    if(!is.factor(f))
      stop("f must be a factor")
    if(length(f) != x$n)
      stop("length(f) must equal the number of points in x")
  } else {
    if(is.marked(x) && is.factor(x$marks))
      f <- x$marks
    else
      stop("f is missing and there is no sensible default")
  }
  if(!is.list(value) || length(value) != length(levels(f)))
    stop("value must be a list, with an entry for each level of f")
  if(!all(unlist(lapply(value, is.ppp))))
    stop("Each entry of \`value\' must be a point pattern")

  if(is.null(names(value)))
    names(value) <- paste(levels(f))
  
  out <- x
  for(l in levels(f))
    out[f == l] <- value[[paste(l)]]

  return(out)
}
#
#
#    strauss.S
#
#    $Revision: 2.1 $	$Date: 2004/01/27 08:06:38 $
#
#    The Strauss process
#
#    Strauss()    create an instance of the Strauss process
#                 [an object of class 'interact']
#	
#
# -------------------------------------------------------------------
#	

Strauss <- function(r) {
  out <- 
  list(
         name     = "Strauss process",
         family    = pairwise.family,
         pot      = function(d, par) {
                         d <= par$r
                    },
         par      = list(r = r),
         parnames = "interaction distance",
         init     = function(self) {
                      r <- self$par$r
                      if(!is.numeric(r) || length(r) != 1 || r <= 0)
                       stop("interaction distance r must be a positive number")
                    },
         update = NULL,  # default OK
         print = NULL,    # default OK
         interpret =  function(coeffs, self) {
           loggamma <- coeffs[["Interaction"]]
           gamma <- exp(loggamma)
           return(list(param=list(gamma=gamma),
                       inames="interaction parameter gamma",
                       printable=round(gamma,4)))
         },
         valid = function(coeffs, self) {
           gamma <- ((self$interpret)(coeffs, self))$param$gamma
           return(is.finite(gamma) && (gamma <= 1))
         },
         project = function(coeffs, self) {
           loggamma <- coeffs[["Interaction"]]
           coeffs[["Interaction"]] <-
             if(is.na(loggamma)) 0 else min(0, loggamma)
           return(coeffs)
         }
  )
  class(out) <- "interact"
  out$init(out)
  return(out)
}
#
#
#    strausshard.S
#
#    $Revision: 2.1 $	$Date: 2004/01/27 08:06:38 $
#
#    The Strauss/hard core process
#
#    StraussHard()     create an instance of the Strauss-hardcore process
#                      [an object of class 'interact']
#	
#
# -------------------------------------------------------------------
#	

StraussHard <- function(r, hc) {
  out <- 
  list(
         name   = "Strauss - hard core process",
         family  = pairwise.family,
         pot    = function(d, par) {
           v <- ifelse(d <= par$r, 1, 0)
           v[ d <= par$hc ] <-  (-Inf)
           v
         },
         par    = list(r = r, hc = hc),
         parnames = c("interaction distance",
                      "hard core distance"), 
         init   = function(self) {
           r <- self$par$r
           hc <- self$par$hc
           if(!is.numeric(hc) || length(hc) != 1 || hc <= 0)
             stop("hard core distance hc must be a positive number")
           if(!is.numeric(r) || length(r) != 1 || r <= hc)
             stop("interaction distance r must be a number greater than hc")
         },
         update = NULL,       # default OK
         print = NULL,         # default OK
         interpret =  function(coeffs, self) {
           loggamma <- coeffs[["Interaction"]]
           gamma <- exp(loggamma)
           return(list(param=list(gamma=gamma),
                       inames="interaction parameter gamma",
                       printable=round(gamma,4)))
         },
         valid = function(coeffs, self) {
           gamma <- (self$interpret)(coeffs, self)$param$gamma
           return(is.finite(gamma))
         },
         project = function(coeffs, self) {
           gamma <- (self$interpret)(coeffs, self)$param$gamma
           if(is.na(gamma)) 
             coeffs[["Interaction"]] <- 0
           else if(!is.finite(gamma)) 
             coeffs[["Interaction"]] <-
               log(.Machine$double.xmax)
           return(coeffs)
         }
  )
  class(out) <- "interact"
  (out$init)(out)
  return(out)
}
"[<-.ppp" <-
  function(x, subset, window, value) {
    verifyclass(x, "ppp")
    verifyclass(value, "ppp")
    
    thin <- !missing(subset)
    trim <- !missing(window)
    if(trim)
      verifyclass(window, "owin")

    if(!thin && !trim)
      return(value)

    # determine index subset
    SUB <- seq(x$n)
    
    if(thin) 
      SUB <- SUB[subset]
    if(trim) {
      xsub <- x[SUB]
      xsubok <- inside.owin(xsub$x, xsub$y, window)
      SUB <- SUB[xsubok]
    }
    
    # anything to replace?
    if(length(SUB) == 0)
      return(x)
    
    if(!is.marked.ppp(x) && is.marked.ppp(value))
      warning("The replacement points have marks -- ignored them")
    
    # exact replacement?
    if(value$n == length(SUB)) {
      x$x[SUB] <- value$x
      x$y[SUB] <- value$y
      if(is.marked.ppp(x) && is.marked.ppp(value))
          x$marks[SUB] <- value$marks
    } else {
      if(is.marked.ppp(x) && !is.marked.ppp(value))
        stop("Replacement point pattern must be marked")
      x <- superimpose(x[-SUB], value)
    }
    
    return(x)
}
#
#    summary.im.R
#
#    summary() method for class "im"
#
#    $Revision: 1.1 $   $Date: 2004/01/06 10:13:58 $
#
#    summary.im()
#    print.summary.im()
#    print.im()
#
summary.im <- function(object, ...) {
  verifyclass(object, "im")

  x <- object

  y <- unclass(x)[c("dim", "xstep", "ystep")]
  pixelarea <- y$xstep * y$ystep

  # extract image values
  v <- x$v
  inside <- !is.na(v)
  v <- v[inside]

  # summarise image values
  y$integral <- sum(v) * pixelarea
  y$mean <- mean(v)
  y$range <- range(v)
  y$min <- y$range[1]  
  y$max <- y$range[2]  
  
  # summarise pixel raster
  win <- as.owin(x)
  y$window <- summary.owin(win)

  y$fullgrid <- all(inside & win$m)

  class(y) <- "summary.im"
  return(y)
}

print.summary.im <- function(x, ...) {
  verifyclass(x, "summary.im")
  cat("Pixel image\n")
  di <- x$dim
  win <- x$window
  cat(paste(di[1], "x", di[2], "pixel array\n"))
  cat("enclosing rectangle: ")
  cat(paste("[",
            paste(win$xrange, collapse=", "),
            "] x [",
            paste(win$yrange, collapse=", "),
            "]\n"))
  cat(paste("dimensions of each pixel:", x$xstep, "x", x$ystep, "\n"))
  if(x$fullgrid) {
    cat("Image is defined on the full rectangular grid\n")
    cat(paste("Frame area = ", win$area, "\n"))
  } else {
    cat("Image is defined on a subset of the rectangular grid\n")
    cat(paste("Subset area = ", win$area, "\n"))
  }
  cat(paste("Pixel values ",
            if(x$fullgrid) "" else "(inside window)",
            ":\n", sep=""))
  cat(paste(
      "\trange = [",
      paste(x$range, collapse=","),
      "]\n",
      "\tintegral = ",
      x$integral,
      "\n",
      "\tmean = ",
      x$mean,
      "\n",
      sep=""))

  
  return(invisible(NULL))
}



print.im <- function(x, ...) {
  cat("Pixel image\n")
  di <- x$dim
  cat(paste(di[1], "x", di[2], "pixel array\n"))
  cat("enclosing rectangle: ")
  cat(paste("[",
            paste(x$xrange, collapse=", "),
            "] x [",
            paste(x$yrange, collapse=", "),
            "]\n"))
  return(invisible(NULL))
}
#
#    summary.ppm.R
#
#    summary() method for class "ppm"
#
#    $Revision: 1.9 $   $Date: 2004/06/09 09:59:17 $
#
#    summary.ppm()
#    print.summary.ppm()
#
summary.ppm <- function(object, ..., quick=FALSE) {
  verifyclass(object, "ppm")

  x <- object
  y <- list()

  #######  Check version #########################
  
  ver <- object$version 
  antiquated <- is.null(ver) || !is.list(ver) ||
                      (ver$major == 1 && ver$minor < 5)
  y$antiquated <- antiquated
  
  #######  Extract main data components #########################

  QUAD <- object$Q
  DATA <- QUAD$data
  TREND <- x$trend

  INTERACT <- x$interaction
  if(is.null(INTERACT)) INTERACT <- Poisson()

  ####### Determine type of model ############################
  
  y$no.trend <- identical.formulae(TREND, NULL) || identical.formulae(TREND, ~1)

  y$stationary <- y$no.trend || identical.formulae(TREND, ~marks)

  y$poisson <- is.null(INTERACT$family)

  y$marked <- is.marked.ppp(DATA)
  y$multitype <- y$marked && is.factor(DATA$marks)
  if(y$marked) y$entries <- list(marks = DATA$marks)

  y$name <- paste(
          if(y$stationary) "Stationary " else "Nonstationary ",
          if(y$poisson) {
            if(y$multitype) "multitype "
            else if(y$marked) "marked "
            else ""
          },
          INTERACT$name,
          sep="")

  if(is.logical(quick) && quick) {
    class(y) <- "summary.ppm"
    return(y)
  }
  
  ######  Does it have external covariates?  ####################

  if(!antiquated) {
    hc <- !is.null(x$covariates)
  } else {
    # Antiquated format
    # Interpret the function call instead
    callexpr <- parse(text=x$call)
    callargs <- names(as.list(callexpr[[1]]))
    # Data frame of covariates was called 'data' in versions up to 1.4-x
    hc <- !is.null(callargs) && !is.na(pmatch("data", callargs))
  }
  y$has.covars <- hc
    
  ######  Arguments in call ####################################
  
  y$args <- x[c("call", "correction", "rbord")]
  
  #######  Main data components #########################

  y$entries <- append(list(quad=QUAD,
                           data=DATA,
                           interaction=INTERACT),
                      y$entries)

  ####### Summarise data ############################

  y$data <- summary.ppp(DATA)
  y$quad <- summary.quad(QUAD)

  if(is.character(quick) && (quick == "no prediction"))
    return(y)
  
  ######  Extract fitted model coefficients #########################

  if(exists("is.R") && is.R()) 
    theta <- x$coef # result of coef(glm(...))
  else
    theta <- x$theta # result of dummy.coef(glm(....))

  y$entries$theta <- theta

  # corresponding internal names of regressor variables 
  Vnames <- x$internal$Vnames

  ######  Trend component #########################

  y$trend <- list()

  y$trend$name <- if(y$poisson) "Intensity" else "Trend"

  y$trend$formula <- if(y$no.trend) NULL else TREND

  if(y$poisson && y$no.trend) {
    lambda <- exp(theta[[1]])
    if(!y$marked) { 
      y$trend$label <- "Uniform intensity"
      y$trend$value <- lambda
    } else {
      y$trend$label <- "Uniform intensity for each mark level"
      y$trend$value <- lambda
    }
  } else # process is at least one of: marked, nonstationary, non-poisson
  if(y$stationary) {
    if(!y$marked) {
      # stationary non-poisson non-marked
      y$trend$label <- "First order term"
      y$trend$value <- c(beta=exp(theta[[1]]))
    } else {
      # stationary, marked
      mrk <- DATA$marks
      y$trend$label <-
        if(y$poisson) "Fitted intensities" else "Fitted first order terms"
      # Use predict.ppm to evaluate the fitted intensities
      lev <- factor(levels(mrk), levels=levels(mrk))
      nlev <- length(lev)
      marx <- list(x=rep(0, nlev), y=rep(0, nlev), marks=lev)
      betas <- predict(x, locations=marx, type="trend")
      names(betas) <- paste("beta_", as.character(lev), sep="")
      y$trend$value <- betas
    }
  } else {
    # not stationary 
    y$trend$label <- "Fitted coefficients for trend formula"
    # extract trend terms without trying to understand them much
    if(is.null(Vnames)) 
      trendbits <- theta
    else {
      agree <- outer(names(theta), Vnames, "==")
      whichbits <- apply(!agree, 1, all)
      trendbits <- theta[whichbits]
    }
    # decide whether there are 'labels within labels'
    unlabelled <- unlist(lapply(trendbits,
                                function(x) { is.null(names(x)) } ))
    if(all(unlabelled))
      y$trend$value <- unlist(trendbits)
    else {
      y$trend$value <- list()
      for(i in seq(trendbits))
          y$trend$value[[i]] <-
            if(unlabelled[i])
              unlist(trendbits[i])
            else
              trendbits[[i]]
    }
  }
  
  ######  Interaction component #########################

  if(!y$poisson) {
    if(!is.null(INTERACT$interpret)) {
      # invoke auto-interpretation feature 
      sensible <- (INTERACT$interpret)(x$coef, INTERACT)
      header <- paste("Fitted", sensible$inames)
      printable <- sensible$printable
    } else {
      # fallback
      sensible <- NULL
      header <- "Fitted interaction terms"
      printable <-  exp(unlist(theta[Vnames]))
    }
    y$interaction <- list(sensible=sensible,
                          header=header,
                          printable=printable)
  }

  class(y) <- "summary.ppm"
  return(y)
}

print.summary.ppm <- function(x, ...) {

  if(is.null(x$args)) {
    # this is the quick version
    cat(paste(x$name, "\n"))
    return(invisible(NULL))
  }

  # otherwise - full details
  cat("Point process model\n")
  cat("fitted by maximum pseudolikelihood\n")

  cat(paste("Call:\n", x$args$call, "\n"))

  cat(paste("Edge correction: \'", x$args$correction, "\'\n", sep=""))
  if(x$args$rbord > 0)
    cat(paste("border correction distance r =", x$args$rbord,"\n"))

  cat("\n----------------------------------------------------\n")

  # print summary of quadrature scheme
  print(x$quad)
  
  cat("\n----------------------------------------------------\n")
  cat("FITTED MODEL:\n\n")

  # This bit is currently identical to print.ppm()
  # except for a bit more fanfare
  # and the inclusion of the 'gory details' bit
  
  notrend <-    x$no.trend
  stationary <- x$stationary
  poisson <-    x$poisson
  markeddata <- x$marked
  multitype  <- x$multitype
        
  markedpoisson <- poisson && markeddata

  # names of interaction variables if any
  Vnames <- x$Vnames
  # their fitted coefficients
  theta <- x$theta

  # ----------- Print model type -------------------
        
  cat(x$name)
  cat("\n")

  if(markeddata) mrk <- x$entries$marks
  if(multitype) {
    cat("Possible marks: \n")
    cat(paste(levels(mrk)))
  }

  # ----- trend --------------------------

  cat(paste("\n\n ---- ", x$trend$name, ": ----\n\n", sep=""))

  if(!notrend) {
    cat("Trend formula: ")
    print(x$trend$formula)
    if(x$has.covars)
      cat("Model involves external covariates\n")
  }
        
  cat(paste("\n", x$trend$label, ":\n", sep=""))
  
  tv <- x$trend$value
  if(!is.list(tv))
    print(tv)
  else 
    for(i in seq(tv))
      print(tv[[i]])
        
  # ---- Interaction ----------------------------

  if(!poisson) {
    cat("\n\n ---- Interaction: -----\n\n")
    print(x$entries$interaction)
    
    cat(paste(x$interaction$header, ":\n", sep=""))
    print(x$interaction$printable)
  }

  ####### Gory details ###################################
  cat("\n\n----------- gory details -----\n")
  theta <- x$entries$theta
      
  cat("\nFitted regular parameters (theta): \n")
  print(theta)

  cat("\nFitted exp(theta): \n")
  print(exp(unlist(theta)))

  return(invisible(NULL))
}

no.trend.ppm <- function(x) {
  summary.ppm(x, quick=TRUE)$no.trend
}

is.stationary.ppm <- function(x) {
  summary.ppm(x, quick=TRUE)$stationary
}

is.poisson.ppm <- function(x) {
  summary.ppm(x, quick=TRUE)$poisson
}

is.marked.ppm <- function(X, ...) {
  summary.ppm(X, quick=TRUE)$marked
}

#
# summary.quad.R
#
#  summary() method for class "quad"
#
#  $Revision: 1.3 $ $Date: 2004/01/27 07:06:14 $
#
summary.quad <- function(object, ...) {
  verifyclass(object, "quad")
  s <- list(
       data  = summary.ppp(object$data),
       dummy = summary.ppp(object$dummy),
       param = object$param)
  doit <- function(ww) {
    return(list(range=range(ww), sum=sum(ww)))
  }
  w <- object$w
  Z <- is.data(object)
  s$w <- list(all=doit(w), data=doit(w[Z]), dummy=doit(w[!Z]))
  class(s) <- "summary.quad"
  return(s)
}

print.summary.quad <- function(x, ..., dp=3) {
  cat("Quadrature scheme = data + dummy + weights\n")
  pa <- x$param
  if(is.null(pa))
    cat("created by an unknown function.\n")
  cat("Data pattern:\n")
  print(x$data, dp=dp)

  cat("\n\nDummy quadrature points:\n")
  # How they were computed
  if(!is.null(pa)) {
    dumpar <- pa$dummy
    if(is.null(dumpar))
      cat("(provided manually)\n")
    else if(!is.null(dumpar$nd)) 
      cat(paste("(", dumpar$nd[1], "x", dumpar$nd[2],
                "grid, plus 4 corner points)\n"))
    else
      cat("(rule for creating dummy points not understood)")
  }
  # Description of them
  print(x$dummy, dp=dp)

  cat("\n\nQuadrature weights:\n")
  # How they were computed
  if(!is.null(pa)) {
    wpar <- pa$weight
    if(is.null(wpar))
      cat("(values provided manually)\n")
    else if(!is.null(wpar$method)) {
      if(wpar$method=="grid") {
        cat(paste("(counting weights based on",
                  wpar$ntile[1], "x", wpar$ntile[2],
                  "array of rectangular tiles)\n"))
      } else if(wpar$method=="dirichlet") {
        cat(paste("(Dirichlet tile areas, computed",
                  if(wpar$exact) "exactly" else "by pixel approximation",
                  ")\n"))
      } else
      cat("(rule for creating dummy points not understood)\n")
    }
  }
  # Description of them
  doit <- function(ww) {
    cat(paste("range: ",
              "[",
              paste(signif(ww$range, digits=dp), collapse=", "),
              "]\t",
              "total: ",
              signif(ww$sum, digits=dp),
              "\n", sep=""))
  }
  cat("All weights:\n\t")
  doit(x$w$all)
  cat("Weights on data points:\n\t")
  doit(x$w$data)
  cat("Weights on dummy points:\n\t")
  doit(x$w$dummy)

  return(invisible(NULL))
}

    
print.quad <- function(x, ...) {
  cat("Quadrature scheme\n")
  cat(paste(x$data$n, "data points, ", x$dummy$n, "dummy points\n"))
  cat(paste("Total weight ", sum(x$w), "\n"))
  return(invisible(NULL))
}
# superimpose.R
#
# $Revision: 1.4 $ $Date: 2004/08/26 08:36:55 $
#
# This has been taken out of ppp.S
#
############################# 

"superimpose" <-
  function(...)
{
  # superimpose any number of point patterns
  # ASSUMED TO BE IN THE SAME WINDOW
  
  arglist <- list(...)

  if(length(arglist) == 1 && inherits(arglist[[1]], "list"))
    arglist <- arglist[[1]]
  
  # concatenate lists of (x,y) coordinates
  XY <- do.call("concatxy", arglist)

  # determine window
  P <- arglist[[1]]
  if(!verifyclass(P, "ppp", fatal=FALSE))
    stop("The first argument is not a point pattern object")
  OUT <- ppp(XY$x, XY$y, window=P$window)
  
  # find out whether the arguments are marked patterns
  Mlist <- lapply(arglist, function(x) {x$marks})
  ismarked <- !unlist(lapply(Mlist, is.null))
  isfactor <- unlist(lapply(Mlist, is.factor))

  if(any(ismarked) && !all(ismarked))
    warning("Some, but not all, patterns contain marks -- ignored.")
  if(any(isfactor) && !all(isfactor))
    stop("Patterns have incompatible marks - some are factors, some are not")

  if(!all(ismarked)) {
    # Assume all patterns unmarked.
    # If patterns are not named, return the superimposed point pattern.
    nama <- names(arglist)
    if(is.null(nama) || any(nama == ""))
      return(OUT)
    # Patterns are named. Make marks from names.
    len <- unlist(lapply(arglist, function(x) { x$n }))
    M <- factor(rep(nama, len), levels=nama)
    OUT <- OUT %mark% M
    return(OUT)
  }

  # All patterns are marked.
  # Concatenate vectors of marks
  if(!all(isfactor))
    # continuous marks
    M <- unlist(Mlist)
  else {
    # multitype
    Llist <- lapply(Mlist, levels)
    lev <- unique(unlist(Llist))
    codesof <- function(x, lev) { as.integer(factor(x, levels=lev)) }
    Mlist <- lapply(Mlist, codesof, lev=lev)
    M <- factor(unlist(Mlist), levels=codesof(lev,lev), labels=lev)
  }
  OUT <- OUT %mark% M
  return(OUT)
}

#
#	tryFGJKest.S
#
#	Test the F, G, J and K estimation routines
#
#	$Revision: 4.3 $ $Date: 2002/05/13 12:41:10 $
#
#   Note: this is not the most efficient way to calculate F, G, J and K
#         if all four are required. See the source for 'allstats'
#
################################################################
#
"try.FGJKest"<-
function(niter = 20, lambda = 25, r = seq(0, sqrt(2), 0.02), eps=0.01, slow=FALSE)
{
	Frs <- 
	Fkm <- 
	Grs <- 
	Gkm <- 
	Jrs <- 
	Jkm <- 
	Kbord <- matrix(0, nrow = niter, ncol = length(r))

	cat("computing realisation ")
	for(i in 1:niter) {
		cat(paste(i))

		pp <- rpoispp(lambda)
                cat("(")
                cat("F")
                FF <- Fest(pp, eps, r)
		Fkm[i,  ] <- FF$km
		Frs[i,  ] <- FF$rs
                cat("G")
                G <- Gest(pp, r)
		Gkm[i,  ] <- G$km
		Grs[i,  ] <- G$rs
                cat("J")
                J <- Jest(pp, eps, r)
		Jkm[i,  ] <- J$km
		Jrs[i,  ] <- J$rs
                cat("K") ;
                K <- Kest(pp, r, slow=slow)
		Kbord[i,  ] <- K$border
                cat("), ")
	}
	cat("Done.\n")

        oldpar <- par(ask=TRUE)
	plotteststuff <- function(r, mat, correction, symb, trueval) {
          	rrange <- range(r)
                mrange <- range(c(mat, trueval), na.rm=TRUE)
                plot(rrange, mrange, xlab="r", ylab=symb, sub=correction,
                     main=paste("estimated", symb), type="n")
                niter <- nrow(mat)
                for(i in 1:niter) {
                  lines(r, mat[i,  ])
                }
                lines(r, trueval, lty=2)
                dev <- mat - t(matrix(trueval, ncol=nrow(mat), nrow=ncol(mat)))
                derange <- range(c(dev,0), na.rm=TRUE)
                plot(rrange, derange, xlab="r", ylab="Deviation",
                     sub=correction,
                     main=paste("deviation of estimated", symb), type="n")
                for(i in 1:niter) {
                  lines(r, dev[i,  ])
                }
                abline(0,0,lty=2)
                bias <- apply(mat, 2, mean, na.rm=TRUE) - trueval
                brange <- range(c(bias, 0), na.rm=TRUE)
                plot(r, bias, xlab="r", ylab="Bias",
                     sub=correction, ylim=brange,
                     main=paste("Bias of estimated", symb), type="l")
                abline(0,0,lty=2)
                
                varnaok <- function(x) {
                  nbg <- is.na(x)
                  if(all(nbg))
                    NA
                  else
                    var(x[!nbg])   # should work in all dialects
                }
                sd <- sqrt(apply(mat, 2, varnaok))
# Splus 5.1:    sd <- sqrt(apply(mat, 2, var, na.method="available"))
# R:            sd <- sqrt(apply(mat, 2, var, na.rm=TRUE))
                
                plot(r, sd, xlab="r", ylab="SD",
                     sub=correction,
                     main=paste("Standard deviation of estimated", symb),
                     type="l")
                invisible(NULL)
              }

        trueK  <- pi * r^2
        trueFG <- 1 - exp( - lambda * pi * r^2)
        trueJ <- rep(1, length(r))

        plotteststuff(r, Fkm, "Kaplan-Meier", "F", trueFG)
        plotteststuff(r, Frs, "reduced sample", "F", trueFG)
        plotteststuff(r, Gkm, "Kaplan-Meier", "G", trueFG)
        plotteststuff(r, Grs, "reduced sample", "G", trueFG)
        plotteststuff(r, Jkm, "Kaplan-Meier", "J", trueJ)
        plotteststuff(r, Jrs, "reduced sample", "J", trueJ)
        plotteststuff(r, Kbord, "border method", "K", trueK)

        par(oldpar)
	invisible(NULL)
}
#
#	tryKcross.S
#
#	Test the routine Kcross()
#
#	$Revision: 4.3 $ $Date: 2002/05/13 12:41:10 $
#
################################################################
#
"try.Kcross"<-
function(niter = 20, lambda1 = 25, lambda2 = 25, r = seq(0, 1, 0.02), R=0.2)
{
	lambda <- lambda1 + lambda2
	probs <- c(lambda1,lambda2)/lambda
	
	k <- matrix(0, nrow = niter, ncol = length(r))
	k2 <- k
	cat("computing realisation ")
	for(i in 1:niter) {
		cat(paste(i,", ", sep=""))

                X <- rpoispp(lambda)
		X$marks <- factor(sample(1:2, X$n, prob=probs, replace=TRUE))
		out <- Kcross(X, "1", "2", r)
		k[i,  ] <- out$border
		k2[i,  ] <- out$bord.modif
	}
	cat("\n")

        # restrict to r in [0,R]
        ok <- (r <= R)
        r <- r[ok]
        k <- k[, ok]
        k2 <- k2[, ok]
        
	truek <- pi * r^2
	rrange <- range(r)
	krange <- range(c(k, k2, truek), na.rm=TRUE)
	
	plot(rrange, krange, xlab = "r", ylab = "Kcross", 
				main = "border method", type = "n")
	for(i in 1:niter) {
		lines(r, k[i,  ])
	}
	plot(krange, krange, xlab = "true Kcross", ylab = "estimated Kcross", 
				main = "border method", type = "n")
	for(i in 1:niter) {
		lines(truek, k[i,  ])
	}
	plot(rrange, krange, xlab = "r", ylab = "Kcross", 
				main = "border (modified)", type = "n")
	for(i in 1:niter) {
		lines(r, k2[i,  ])
	}
	plot(krange, krange, xlab = "true Kcross", ylab = "estimated Kcross", 
				main = "border (modified)", type = "n")
	for(i in 1:niter) {
		lines(truek, k2[i,  ])
	}
	invisible(NULL)
}
#
#  update.ppm.R
#
#
#  $Revision: 1.3 $    $Date: 2004/06/09 06:03:17 $
#
#
#

update.ppm <- function(object, ...,
                       Q, trend, interaction, covariates,
                       correction, rbord, use.gam) {
  verifyclass(object, "ppm")

  aargh <- list(...)

  # Default values for some formal arguments
  defaults <- list(Q=quad.ppm(object),
                   trend=object$trend,
                   interaction=object$interaction,
                   correction=object$correction,
                   rbord=object$rbord)

  matchedargs <- defaults

  # Match named arguments
  # (note: if argument is present and equals NULL, this deletes it from list)
  if(!missing(Q)) matchedargs$Q <- Q
  if(!missing(trend)) matchedargs$trend <- trend
  if(!missing(interaction)) matchedargs$interaction <- interaction
  if(!missing(covariates)) matchedargs$covariates <- covariates
  if(!missing(correction)) matchedargs$correction <- correction
  if(!missing(rbord)) matchedargs$rbord <- rbord
  if(!missing(use.gam)) matchedargs$rbord <- use.gam
  
  # Some formal arguments may be recognised implicitly by their class
  foundclass <- function(cname, inlist, formalname, absent) {
    ok <- unlist(lapply(inlist, inherits, what=cname))
    nok <- sum(ok)
    if(nok > 1)
      stop(paste("I\'m confused: there are two unnamed arguments ",
                 "of class \"", cname, "\"", sep=""))
    if(nok == 0) return(0)
    if(!absent)
      stop(paste("I\'m confused: there is an unnamed argument ",
                 "of class \"", cname, "\" which conflicts with the",
                 "named argument \"", formalname, "\"", sep=""))
    theposition <- seq(ok)[ok]
    return(theposition)
  }
  foundclasses <- function(cnames, inlist, formalname, absent) {
    pozzie <- logical(length(cnames))
    for(i in seq(cnames))
      pozzie[i] <- foundclass(cnames[i],  inlist, formalname, absent)
    found <- (pozzie > 0)
    nfound <- sum(found)
    if(nfound == 0)
      return(0)
    else if(nfound == 1)
      return(pozzie[found])
    else
      stop(paste("I\'m confused: there are ", nfound,
                 " unnamed arguments of different classes (\`",
                 paste(cnames(pozzie[found]), collapse="\', \`"),
                 "\') which could be interpreted as \"",
                 formalname, "\"", sep=""))
  }

  if(length(aargh) > 0) {
    if(n <- foundclasses(c("ppp", "quad"), aargh, "Q", missing(Q)))
       matchedargs$Q <- aargh[[n]]
    if(n<- foundclass("interact", aargh, "interaction", missing(interaction)))
       matchedargs$interaction <- aargh[[n]]
    if(n<- foundclass("formula", aargh, "trend", missing(trend)))
       matchedargs$trend <- aargh[[n]]
    if(n<- foundclass("data.frame", aargh, "covariates", missing(covariates)))
       matchedargs$covariates <- aargh[[n]]
  }
  
  # *************************************************************
  # ****** Special action when Q is a point pattern *************
  # *************************************************************
  if(!is.null(X <- matchedargs$Q) && inherits(X, "ppp")) {
    # Instead of allowing default.dummy(X) to occur,
    # explicitly create a quadrature scheme from X,
    # using the same dummy points and weight parameters
    # as were used in the fitted model 
    Qold <- quad.ppm(object)
    Dum <- Qold$dummy
    wpar <- Qold$param$weight
    Qnew <- do.call("quadscheme", append(list(X, Dum), wpar))
    # replace X by new Q
    matchedargs$Q <- Qnew
  }

  # finally call ppm
  result <- do.call("ppm", matchedargs)
  return(result)
}
#
#    util.S    miscellaneous utilities
#
#    $Revision: 1.4 $    $Date: 2002/04/07 11:11:54 $
#
#  (a) for matrices only:
#
#    matrowany(X) is equivalent to apply(X, 1, any)
#    matrowall(X) "   "  " "  "  " apply(X, 1, all)
#    matcolany(X) "   "  " "  "  " apply(X, 2, any)
#    matcolall(X) "   "  " "  "  " apply(X, 2, all)
#
#  (b) for 3D arrays only:
#    apply23sum(X)  "  "   "  " apply(X, c(2,3), sum)
#
#  (c) weighted histogram
#    whist()
#
matrowsum <- function(x) {
  x %*% rep(1, ncol(x))
}

matcolsum <- function(x) {
  rep(1, nrow(x)) %*% x
}
  
matrowany <- function(x) {
  (matrowsum(x) > 0)
}

matrowall <- function(x) {
  (matrowsum(x) == ncol(x))
}

matcolany <- function(x) {
  (matcolsum(x) > 0)
}

matcolall <- function(x) {
  (matcolsum(x) == nrow(x))
}

########
    # hm, this is SLOWER

apply23sum <- function(x) {
  dimx <- dim(x)
  if(length(dimx) != 3)
    stop("x is not a 3D array")
  result <- array(0, dimx[-1])

  nz <- dimx[3]
  for(k in 1:nz) {
    result[,k] <- matcolsum(x[,,k])
  }
  result
}
    
#######################
#
#    whist      weighted histogram
#

whist <-
  function(x, breaks, weights) {
    if(missing(weights)) 
      h <- hist(x, breaks=breaks, plot=FALSE,probability=FALSE)$counts
    else {
      # Thanks to Peter Dalgaard
      cell <- cut(x, breaks, include.lowest=TRUE)
      h <- tapply(weights, cell, sum)
      h[is.na(h)] <- 0
    }
    return(h)
}
#
#	weights.S
#
#	Utilities for computing quadrature weights
#
#	$Revision: 4.9 $	$Date: 2004/06/22 02:35:47 $
#
#
# Main functions:
		
#	gridweights()	    Divide the window frame into a regular nx * ny
#			    grid of rectangular tiles. Given an arbitrary
#			    pattern of (data + dummy) points derive the
#			    'counting weights'.
#
#	dirichlet.weights() Compute the areas of the tiles of the
#			    Dirichlet tessellation generated by the 
#			    given pattern of (data+dummy) points,
#			    restricted to the window.
#	
# Auxiliary functions:	
#			
#       countingweights()   compute the counting weights
#                           for a GENERIC tiling scheme and an arbitrary
#			    pattern of (data + dummy) points,
#			    given the tile areas and the information
#			    that point number k belongs to tile number id[k]. 
#
#
#	gridindex()	    Divide the window frame into a regular nx * ny
#			    grid of rectangular tiles. 
#			    Compute tile membership for arbitrary x,y.
#				    
#       discretise()        1-dimensional analogue of gridindex()
#
#
#-------------------------------------------------------------------
	
countingweights <- function(id, areas, check=TRUE) {
	#
	# id:        cell indices of n points
	#                     (length n, values in 1:k)
	#
	# areas:     areas of k cells 
	#                     (length k)
	#
    id <- factor(id, levels=seq(areas))
    counts <- table(id)
    w <- areas[id] / counts[id]     # ensures denominator > 0
    w <- as.vector(w)
#	
# that's it; but check for funny business
#
    zerocount <- (counts == 0)
    zeroarea <- (areas == 0)
    if(any(!zeroarea & zerocount))
	warning("some tiles with positive area do not contain any points")
    if(any(!zerocount & zeroarea)) {
	warning("Some tiles with zero area contain points")
	warning("Some weights are zero")
	attr(w, "zeroes") <- zeroarea[id]
    }
#
    names(w) <- NULL
    w
}

gridindex <- function(x, y, xrange, yrange, nx, ny) {
	#
	# The box with dimensions xrange, yrange is divided
	# into nx * ny cells.
	#
	# For each point (x[i], y[i]) compute the index (ix, iy)
	# of the cell containing the point.
	# 
	ix <- discretise(x, xrange, nx)
	iy <- discretise(y, yrange, ny)
	#
	return(list(ix=ix, iy=iy, index=(iy-1) * nx + ix))
}

discretise <- function(x, xrange, nx) {
	i <- ceiling( nx * (x - xrange[1])/diff(xrange))
	i <- pmax(1, i)
	i <- pmin(i, nx)
	i
}

gridweights <- function(X, ntile=NULL, ..., window=NULL, verbose=FALSE) {
	#
	# Compute counting weights based on a regular tessellation of the
	# window frame into ntile[1] * ntile[2] rectangular tiles.
	#
	# Arguments X and (optionally) 'window' are interpreted as a
	# point pattern.
	#
	# The window frame is divided into a regular ntile[1] * ntile[2] grid
	# of rectangular tiles. The counting weights based on this tessellation
	# are computed for the points (x, y) of the pattern.
	#
	
	X <- as.ppp(X, window)
	x <- X$x
	y <- X$y
	win <- X$window

        # determine number of tiles
        if(is.null(ntile))
          ntile <- default.ntile(X)
        if(length(ntile) == 1)
          ntile <- rep(ntile, 2)
        nx <- ntile[1]
        ny <- ntile[2]

        if(verbose)
          cat(paste("grid weights for a", nx, "x", ny, "grid of tiles\n"))
        
	# classify each point according	to its tile
	
	id <- gridindex(x, y, win$xrange, win$yrange, nx, ny)$index

	# compute tile areas
	if(win$type == "rectangle") {

		tilearea <- area.owin(win)/(nx * ny)
		areas <- rep(tilearea, nx * ny)

	} else {
                # convert to mask
                win <- as.mask(win)

                # extract pixel coordinates inside window
		xx <- as.vector(raster.x(win)[win$m])
		yy <- as.vector(raster.y(win)[win$m])
                                
		# classify all pixels into tiles
		pixelid <- gridindex(xx, yy, 
				win$xrange, win$yrange, nx, nx)$index
                pixelid <- factor(pixelid, levels=seq(nx * ny))
                                
		# compute digital areas of tiles
		tilepixels <- as.vector(table(pixelid))
		pixelarea <- win$xstep * win$ystep
		areas <- tilepixels * pixelarea
	} 

	# compute counting weights 
	w <- countingweights(id, areas)

        # attach information about weight construction parameters
        attr(w, "weight.parameters") <- list(method="grid", ntile=ntile)
        
	return(w)
}


dirichlet.weights <- function(X, window = NULL, exact=TRUE, ...) {
	#
	# Compute weights based on Dirichlet tessellation of the window 
	# induced by the point pattern X. 
	# The weights are just the tile areas.
	#
	# NOTE:	X should contain both data and dummy points,
	# if you need these weights for the B-T-B method.
	#
	# Arguments X and (optionally) 'window' are interpreted as a
	# point pattern.
	#
	# If the window is a rectangle, we invoke Rolf Turner's "deldir"
	# package to compute the areas of the tiles of the Dirichlet
	# tessellation of the window frame induced by the points.
	# [NOTE: the functionality of deldir to create dummy points
	# is NOT used. ]
	#	if exact=TRUE	compute the exact areas, using "deldir"
	#	if exact=FALSE      compute the digital areas using exactdt()
	# 
	# If the window is a mask, we compute the digital area of
	# each tile of the Dirichlet tessellation by counting pixels.
	#
	#
	# 
	#
	
	X <- as.ppp(X, window)
	x <- X$x
	y <- X$y
	win <- X$window

        if (exact) {
          # check that deldir is available
          old.op <- options(warn=-1)
          on.exit(options(old.op))
          delthere <- require(deldir,quietly=TRUE)
          options(old.op)
          if(!delthere) {
            warning("\'deldir\' package not found; using discrete approximation\n")
            exact <- FALSE
          }
        }

	if(exact && (win$type == "rectangle")) {
		rw <- c(win$xrange, win$yrange)
	        # invoke deldir() with NO DUMMY POINTS
		tessellation <- deldir(x, y, dpl=NULL, rw=rw)
	        # extract tile areas
	        w <- tessellation$summary[, 'dir.area']
	} else {
		# Compute digital areas of Dirichlet tiles.
                win <- as.mask(win)
                X$window <- win
		#
                # Nearest data point to each pixel:
                tileid <- exactdt(X)$i
                # 
		if(win$type == "mask") 
			# Restrict to window (result is a vector - OK)
			tileid <- tileid[win$m]
		# Count pixels in each tile
		id <- factor(tileid, levels=seq(X$n))
		counts <- table(id)
                # turn off the christmas lights
                class(counts) <- NULL
                names(counts) <- NULL
                dimnames(counts) <- NULL
		# Convert to digital area
		pixelarea <- win$xstep * win$ystep
		w <- pixelarea * counts
		# Check for zero pixel counts
		zeroes <- (counts == 0)
		if(any(zeroes)) {
			warning("some Dirichlet tiles have zero digital area")
			attr(w, "zeroes") <- zeroes
		}
	} 
        # attach information about weight construction parameters
        attr(w, "weight.parameters") <- list(method="dirichlet", exact=exact)

        return(w)
}

default.ntile <- function(X) { 
	# default number of tiles (n x n) for tile weights
        # when data and dummy points are X
  X <- as.ppp(X)
  guess.ngrid <- 10 * floor(sqrt(X$n)/10)
  max(5, guess.ngrid/2)
}

#
#	window.S
#
#	A class 'owin' to define the "observation window"
#
#	$Revision: 4.25 $	$Date: 2004/07/26 05:30:46 $
#
#
#	A window may be either
#
#		- rectangular:
#                       a rectangle in R^2
#                       (with sides parallel to the coordinate axes)
#
#		- polygonal:
#			delineated by one or more non-self-intersecting
#                       polygons, possibly including polygonal holes.
#	
#		- digital mask:
#			defined by a binary image
#			whose pixel values are TRUE wherever the pixel
#                       is inside the window
#
#	Any window is an object of class 'owin', 
#       containing at least the following entries:	
#
#		$type:	a string ("rectangle", "polygonal" or  "mask")
#
#		$xrange   
#		$yrange
#			vectors of length 2 giving the real dimensions 
#			of the enclosing box.
#
#	The 'rectangle' type has only these entries.
#
#       The 'polygonal' type has an additional entry
#
#               $bdry
#                       a list of polygons.
#                       Each entry bdry[[i]] determines a closed polygon.
#
#                       bdry[[i]] has components $x and $y which are
#                       the cartesian coordinates of the vertices of
#                       the i-th boundary polygon (without repetition of
#                       the first vertex, i.e. same convention as in the
#                       plotting function polygon().)
#
#
#	The 'mask' type has entries
#
#		$m		logical matrix
#		$dim		its dimension array
#		$xstep,ystep	x and y dimensions of a pixel
#		$xcol	        vector of x values for each column
#               $yrow           vector of y values for each row
#	
#	(the row index corresponds to increasing y coordinate; 
#	 the column index "   "     "   "  "  "  x "   "    ".)
#
#
#-----------------------------------------------------------------------------
#
owin <- function(xrange=c(0,1), yrange=c(0,1), poly=NULL, mask=NULL) {

  ## Exterminate ambiguities
  if(!missing(poly) && !is.null(poly) && !missing(mask) && !is.null(mask))
     stop("Ambiguous -- both polygonal boundary and digital mask supplied")
     
  if(missing(xrange) != missing(yrange))
    stop("If one of xrange, yrange is specified then both must be.")

  if(missing(poly) && missing(mask)) {
    ######### rectangle #################
    if(!is.vector(xrange) || length(xrange) != 2 || xrange[2] <= xrange[1])
      stop("xrange should be a vector of length 2 giving (xmin, xmax)")
    if(!is.vector(yrange) || length(yrange) != 2 || yrange[2] <= yrange[1])
      stop("yrange should be a vector of length 2 giving (ymin, ymax)")
    w <- list(type="rectangle", xrange=xrange, yrange=yrange)
    class(w) <- "owin"
    return(w)
  } else if(!missing(poly)) {
    ######### polygonal boundary ########
    #
    # test whether it's a single polygon or multiple polygons
    if(verify.xypolygon(poly, fatal=FALSE))
      psingle <- TRUE
    else if(all(unlist(lapply(poly, verify.xypolygon, fatal=FALSE))))
      psingle <- FALSE
    else
      stop("poly must be either a list(x,y) or a list of list(x,y)")
                  
    if(psingle) {
      # single boundary polygon
      if(area.xypolygon(poly) < 0)
        stop("Area of polygon is negative - maybe traversed in wrong direction?")
      bdry <- list(poly)
    } else {
      # multiple boundary polygons
      bdry <- poly
      if(sum(unlist(lapply(poly, area.xypolygon))) < 0)
        stop(paste("Area of window is negative;\n",
             "check that all polygons were traversed in the right direction"))
    }

    actual.xrange <- range(unlist(lapply(bdry, function(a) a$x)))
    if(missing(xrange))
      xrange <- actual.xrange
    else {
      if(!is.vector(xrange) || length(xrange) != 2 || xrange[2] <= xrange[1])
        stop("xrange should be a vector of length 2 giving (xmin, xmax)")
      if(!all(xrange == range(c(xrange, actual.xrange))))
        stop("polygon's x coordinates outside xrange")
    }
    
    actual.yrange <- range(unlist(lapply(bdry, function(a) a$y)))
    if(missing(yrange))
      yrange <- actual.yrange
    else {
      if(!is.vector(yrange) || length(yrange) != 2 || yrange[2] <= yrange[1])
        stop("yrange should be a vector of length 2 giving (ymin, ymax)")
      if(!all(yrange == range(c(yrange, actual.yrange))))
      stop("polygon's y coordinates outside yrange")
    }

    w <- list(type="polygonal", xrange=xrange, yrange=yrange, bdry=bdry)
    class(w) <- "owin"
    return(w)
    
  } else if(!missing(mask)) {
    ######### digital mask #####################
    
    if(!is.matrix(mask))
      stop("\`mask\' must be a matrix")
    if(!is.logical(mask))
      stop("The entries of \`mask\' must be logical")
    
    nc <- ncol(mask)
    nr <- nrow(mask)

    if(missing(xrange) && missing(yrange)) {
      # take pixels to be 1 x 1 unit
      xrange <- c(0,nc)
      yrange <- c(0,nr)
    } else {
      if(!is.vector(xrange) || length(xrange) != 2 || xrange[2] <= xrange[1])
        stop("xrange should be a vector of length 2 giving (xmin, xmax)")
      if(!is.vector(yrange) || length(yrange) != 2 || yrange[2] <= yrange[1])
        stop("yrange should be a vector of length 2 giving (ymin, ymax)")
    }

    xstep <- diff(xrange)/nc
    ystep <- diff(yrange)/nr
  
    out <- list(type     = "mask",
                xrange   = xrange,
                yrange   = yrange,
                dim      = c(nr, nc),
                xstep    = xstep,
                ystep    = ystep,
                warnings = c(
"Row index corresponds to increasing y coordinate; column to increasing x",
"Transpose matrices to get the standard presentation in S",
"Example: image(result$xcol,result$yrow,t(result$d))"
                ),
                xcol    = seq(xrange[1]+xstep/2, xrange[2]-xstep/2, length=nc),
                yrow    = seq(yrange[1]+ystep/2, yrange[2]-ystep/2, length=nr),
                m       = mask)
    class(out) <- "owin"
    return(out)
  }
  # never reached
  NULL
}

#
#-----------------------------------------------------------------------------
#

is.owin <- function(x) { inherits(x, "owin") }

as.owin <- function(W) {
	# Tries to interpret data as an object of class 'window'
	# W may be
	#	an object of class 'window'
	#	a structure with entries xrange, yrange
	#	a four-element vector (interpreted xmin, xmax, ymin, ymax)
	#	a structure with entries xl, xu, yl, yu
	#	an object of class 'ppp'
	#	an object of class 'im'

	if(verifyclass(W, "owin", fatal=FALSE))
		return(W)
        else if(verifyclass(W, "ppp", fatal=FALSE))
		return(W$window)
        else if(verifyclass(W, "im", fatal=FALSE)) 
                return(owin(W$xrange, W$yrange, mask=!is.na(W$v)))
        else if(checkfields(W, c("xrange", "yrange"))) {
		Z <- owin(W$xrange, W$yrange)
		return(Z)
	} else if(is.vector(W) && is.numeric(W) && length(W) == 4) {
		Z <- owin(W[1:2], W[3:4])
		return(Z)
	} else if(checkfields(W, c("xl", "xu", "yl", "yu"))) {
                W <- as.list(W)
		Z <- owin(c(W$xl, W$xu),c(W$yl, W$yu))
		return(Z)
        } else if(checkfields(W, c("x", "y", "area"))
                  && checkfields(W$area, c("xl", "xu", "yl", "yu"))) {
                V <- as.list(W$area)
                Z <- owin(c(V$xl, V$xu),c(V$yl, V$yu))
                return(Z)
	} else
		stop("Can't interpret W as a window")
}		

#
#-----------------------------------------------------------------------------
#
#
as.rectangle <- function(...) {
        w <- as.owin(...)
        return(owin(w$xrange, w$yrange))
}

#
#-----------------------------------------------------------------------------
#
as.mask <- function(w, eps=NULL, dimyx=NULL, xy=NULL) {
#	eps:		   grid mesh (pixel) size
#	dimyx:		   dimensions of pixel raster
#       xy:                coordinates of pixel raster  
#
#  NOTE: rows <=> y coordinate

  if(!missing(w)) {
    verifyclass(w, "owin")
  } else if(is.null(xy))
    stop("If w is missing, xy is required")

  # If it's already a mask, and no other arguments specified,
  # just return it.
  if(!missing(w) && w$type == "mask" &&
     is.null(eps) && is.null(dimyx) && is.null(xy))
    return(w)
  
#
#  First create pixel array
#  
  if(is.null(xy)) {
#
# Pixel coordinates to be computed from other dimensions
#
    # determine row & column dimensions of output raster
    if(!is.null(dimyx)) {
      nr <- dimyx[1]
      nc <- dimyx[2]
    } else {
    # use pixel size 'eps'
      if(!is.null(eps)) {
        nr <- ceiling(diff(w$yrange)/eps)
        nc <- ceiling(diff(w$xrange)/eps)
      } else {
    # use spatstat defaults
        np <- spatstat.options("npixel")[[1]]
        if(!is.numeric(np) || length(np) > 2)
          stop("Illegal value for spatstat.options(\"npixel\")")
        if(length(np) == 1)
          nr <- nc <- np[1]
        else {
          nr <- np[2]  
          nc <- np[1]
        }
      }
    }
    # Initial mask with all entries True
    out <- owin(w$xrange, w$yrange,
                mask=matrix(TRUE, nrow=nr, ncol=nc))
  } else {
#
# Pixel coordinates given explicitly:
#
    if(!checkfields(xy, c("x", "y")))
      stop("\`xy\' should be a list containing two vectors x and y")
    x <- sort(unique(xy$x))
    y <- sort(unique(xy$y))
    # derive other parameters
    nr <- length(y)
    nc <- length(x)
    # x and y pixel sizes
    dx <- diff(x)
    if(diff(range(dx)) > 0.01 * mean(dx))
      stop("x coordinates must be evenly spaced")
    xstep <- mean(dx)
    dy <- diff(y)
    if(diff(range(dy)) > 0.01 * mean(dy))
      stop("y coordinates must be evenly spaced")
    ystep <- mean(dy)
    # coordinate ranges
    xrange <- range(x) + xstep * c(-1,1)/2
    yrange <- range(y) + ystep * c(-1,1)/2
    # Initial mask with all entries TRUE
    m <- matrix(TRUE, nrow=nr, ncol=nc)
    out <- list(type     = "mask",
                xrange   = xrange,
                yrange   = yrange,
                dim      = c(nr, nc),
                xstep    = xstep,
                ystep    = ystep,
                warnings = c(
"Row index corresponds to increasing y coordinate; column to increasing x",
"Transpose matrices to get the standard presentation in S",
"Example: image(result$xcol,result$yrow,t(result$d))"
                  ),
                xcol    = x, 
                yrow    = y,
                m       = m)
    class(out) <- "owin"
    # window may be implicit in this case.
    if(missing(w))
      w <- owin(xrange, yrange)
  }

  # Second, intersect pixel raster with existing window
  if(w$type != "rectangle") {
    # test every pixel
    x <- as.vector(raster.x(out))
    y <- as.vector(raster.y(out))
    value <- inside.owin(x, y, w)
    out$m <- matrix(value, nrow=nr, ncol=nc)
  }
  
  return(out)
}

#
#-----------------------------------------------------------------------------
#
as.polygonal <- function(W) {
  # the only sensible use of this function is to
  # convert a rectangle to a polygon
  verifyclass(W, "owin")
  switch(W$type,
         rectangle = {
           xr <- W$xrange
           yr <- W$yrange
           return(owin(xr, yr, poly=list(x=xr[c(1,2,2,1)],y=yr[c(1,1,2,2)])))
         },
         polygonal = {
           return(W)
         },
         mask = {
           stop("A mask cannot be converted to a polygon")
         }
         )
}

#
# ----------------------------------------------------------------------

validate.mask <- function(w, fatal=TRUE) {
  verifyclass(w, "owin", fatal=fatal)
  if(w$type == "mask")
    return(TRUE)
  if(fatal)
      stop(deparse(substitute(w)), "is not a binary mask")
  else {
      warning(deparse(substitute(w)), "is not a binary mask")
      return(FALSE)
  }
}
             
raster.x <- function(w) {
	validate.mask(w)
        di <- w$dim
        nr <- di[1]
        nc <- di[2]
	m <- matrix(0, nrow=nr, ncol=nc)
	matrix(w$xcol[col(m)], nrow=nr, ncol=nc)
}

raster.y <- function(w) {
	validate.mask(w)
        di <- w$dim
        nr <- di[1]
        nc <- di[2]
	m <- matrix(0, nrow=nr, ncol=nc)
	matrix(w$yrow[row(m)], nrow=nr, ncol=nc)
}

nearest.raster.point <- function(x,y,w) {
	validate.mask(w)
	nr <- w$dim[1]
	nc <- w$dim[2]
	cc <- round(0.5 + (x - w$xrange[1])/w$xstep)
	rr <- round(0.5 + (y - w$yrange[1])/w$ystep)
	cc <- pmax(1,pmin(cc, nc))
	rr <- pmax(1,pmin(rr, nr))
	return(list(row=rr, col=cc))
}

#------------------------------------------------------------------
		
bounding.box <- function(...) {
        wins <- list(...)

        if(length(wins) == 0)
          stop("No arguments supplied")

        if(length(wins) > 1) {
          # multiple arguments -- compute bounding box for each
          boxes <- lapply(wins, bounding.box)
          # take bounding box of these boxes
          xrange <- range(unlist(lapply(boxes, function(b){b$xrange})))
          yrange <- range(unlist(lapply(boxes, function(b){b$yrange})))
          return(owin(xrange, yrange))
        }

        w <- wins[[1]]
          
        # determine a tight bounding box for the window w
        verifyclass(w, "owin")

        switch(w$type,
               rectangle = {
                 return(w)
               },
               polygonal = {
                 bdry <- w$bdry
                 xr <- range(unlist(lapply(bdry, function(a) a$x)))
                 yr <- range(unlist(lapply(bdry, function(a) a$y)))
                 return(owin(xr, yr))
               },
               mask = {
                 m <- w$m
                 x <- raster.x(w)
                 y <- raster.y(w)
                 xr <- range(x[m])
                 yr <- range(y[m])
                 return(owin(xr, yr))
               },
               stop("unrecognised window type", w$type)
               )
}
  
complement.owin <- function(w) {
	verifyclass(w, "owin")
        switch(w$type,
               mask = {
                 w$m <- !(w$m)
               },
               polygonal = {

                 bdry <- w$bdry
                 
                 # bounding box, in anticlockwise order
                 box <- list(x=w$xrange[c(1,2,2,1)],
                             y=w$yrange[c(1,1,2,2)])
                 boxarea <- area.xypolygon(box)
                 
                 # first check whether one of the current boundary polygons
                 # is the bounding box itself (with + sign)
                 nvert <- unlist(lapply(bdry, function(a) { length(a$x) }))
                 area <- unlist(lapply(bdry, area.xypolygon))
                 boxarea.mineps <- boxarea * (1 - .Machine$single.eps)
                 is.box <- (nvert == 4 & area >= boxarea.mineps)
                 if(sum(is.box) > 1)
                   stop("Internal error: multiple copies of bounding box")
                 
                 # if box is present (with + sign), remove it
                 if(any(is.box))
                   bdry <- bdry[!is.box]
                 
                 # reverse the direction of each polygon
                 bdry <- lapply(bdry, reverse.xypolygon)
                 
                 # if box was absent, add it
                 if(!any(is.box))
                   bdry <- c(bdry, list(box))   # sic
                 
                 # put back into w
                 w$bdry <- bdry
               },
               rectangle = {
                 stop("window is a rectangle - its complement is empty")
               },
               stop("unrecognised window type", w$type)
               )
	return(w)
}

#-----------------------------------------------------------

inside.owin <- function(x, y, w) {
  # test whether (x,y) is inside window w
  # x, y may be vectors 
  
  verifyclass(w, "owin")

  # test whether inside bounding rectangle
  xr <- w$xrange
  yr <- w$yrange
  frameok <- (xr[1] <= x) & (x <= xr[2]) & (yr[1] <= y) & (y <= yr[2])

  if(all(!frameok))  # all points OUTSIDE window - no further work needed
    return(frameok)

  ok <- frameok
  switch(w$type,
         rectangle = {
           return(ok)
         },
         polygonal = {
           xy <- list(x=x,y=y)
           bdry <- w$bdry
           total <- rep(0, length(x))
           on.bdry <- rep(FALSE, length(x))
           for(i in seq(bdry)) {
             score <- inside.xypolygon(xy, bdry[[i]], test01=FALSE)
             total <- total + score
             on.bdry <- on.bdry | attr(score, "on.boundary")
           }
           # any points identified as belonging to the boundary get score 1
           total[on.bdry] <- 1
           # check for sanity now..
           if(any(total * (1-total) != 0)) 
             stop("internal error: some total scores are neither 0 nor 1")
           return(ok & (total != 0))
         },
         mask = {
           # consider only those points which are inside the frame
           xf <- x[frameok]
           yf <- y[frameok]
           # map locations to raster (row,col) coordinates
           loc <- nearest.raster.point(xf,yf,w)
           # look up mask values
           mas <- w$m
           nf <- sum(frameok)
           okf <- logical(nf)
           for(i in 1:nf) 
             okf[i] <- mas[loc$row[i],loc$col[i]]
           # insert into 'ok' vector
           ok[frameok] <- okf
           return(ok)
         },
         stop("unrecognised window type", w$type)
         )
}

#-------------------------------------------------------------------------
  
print.owin <- function(x, ...) {
  verifyclass(x, "owin")
  cat("window: ")
  switch(x$type,
         rectangle={
           cat("rectangle = ")
         },
         polygonal={
           cat("polygonal boundary\n")
           cat("enclosing rectangle: ")
         },
         mask={
           cat("binary image mask\n")
           cat("enclosing rectangle: ")
         }
         )
    cat(paste("[",
              x$xrange[1],
              ",",
              x$xrange[2],
              "] x [",
              x$yrange[1],
              ",",
              x$yrange[2],
              "]\n"))
}

summary.owin <- function(object, ...) {
  verifyclass(object, "owin")
  result <- list(xrange=object$xrange,
                 yrange=object$yrange,
                 type=object$type,
                 area=area.owin(object))
  switch(object$type,
         rectangle={
         },
         polygonal={
           poly <- object$bdry
           result$npoly <- npoly <- length(poly)
           if(npoly == 1) {
             result$areas <- area.xypolygon(poly[[1]])
             result$nvertices <- length(poly[[1]]$x)
           } else {
             result$areas <- unlist(lapply(poly, area.xypolygon))
             result$nvertices <- unlist(lapply(poly,
                                               function(a) {length(a$x)}))
           }
           result$nhole <- sum(result$areas < 0)
         },
         mask={
           result$npixels <- object$dim
         }
         )
  class(result) <- "summary.owin"
  result
}

print.summary.owin <- function(x, ...) {
  verifyclass(x, "summary.owin")
  cat("Window: ")
  switch(x$type,
         rectangle={
           cat("rectangle = ")
         },
         polygonal={
           cat("polygonal boundary\n")
           if(x$npoly == 1) {
             cat(paste("single connected closed polygon with",
                       x$nvertices, 
                       "vertices\n"))
           } else {
             cat(paste(x$npoly, "separate polygons ("))
             if(x$nhole == 0) cat("no holes)\n")
             else if(x$nhole == 1) cat("1 hole)\n")
             else cat(paste(x$nhole, "holes)\n"))
             print(data.frame(vertices=x$nvertices,
                              area=x$areas,
                              relative.area=signif(x$areas/x$area,3),
                              row.names=paste("polygon",
                                1:(x$npoly),
                                ifelse(x$areas < 0, "(hole)", "")
                                )))
           }
           cat("enclosing rectangle: ")
         },
         mask={
           cat("binary image mask\n")
           di <- x$npixels
           cat(paste(di[1], "x", di[2], "pixel array\n"))
           cat("enclosing rectangle: ")
         }
         )
  cat(paste("[",
            x$xrange[1],
            ",",
            x$xrange[2],
            "] x [",
            x$yrange[1],
            ",",
            x$yrange[2],
            "]\n"))
  cat(paste("Window area = ", x$area, "\n"))
  return(invisible(x))
}

  
#
#	wingeom.S	Various geometrical computations in windows
#
#
#	$Revision: 4.11 $	$Date: 2004/01/08 13:00:03 $
#
#
#
#
#-------------------------------------
area.owin <- function(w) {
	verifyclass(w, "owin")
        switch(w$type,
               rectangle = {
		width <- abs(diff(w$xrange))
		height <- abs(diff(w$yrange))
		area <- width * height
               },
               polygonal = {
                 area <- sum(unlist(lapply(w$bdry, area.xypolygon)))
               },
               mask = {
                 pixelarea <- abs(w$xstep * w$ystep)
                 npixels <- sum(w$m)
                 area <- pixelarea * npixels
               },
               stop("Unrecognised window type")
        )
        return(area)
}

eroded.areas <- function(w, r) {
	verifyclass(w, "owin")
	
	switch(w$type,
               rectangle = {
                 width <- abs(diff(w$xrange))
                 height <- abs(diff(w$yrange))
                 areas <- pmax(width - 2 * r, 0) * pmax(height - 2 * r, 0)
               },
               polygonal = {
                 # warning("Approximating polygonal window by digital image")
                 w <- as.mask(w)
                 areas <- eroded.areas(w, r)
               },
               mask = {
                 # distances from each pixel to window boundary
                 b <- bdist.pixels(w, coords=FALSE)
                 # histogram breaks to satisfy hist()
                 Bmax <- max(b, r)
                 breaks <- c(-1,r,Bmax+1)
                 # histogram of boundary distances
                 h <- hist(b, breaks=breaks, plot=FALSE, probability=FALSE)$counts
                 # reverse cumulative histogram
                 H <- rev(cumsum(rev(h)))
                 # drop first entry corresponding to r=-1
                 H <- H[-1]
                 # convert count to area
                 pixarea <- w$xstep * w$ystep
                 areas <- pixarea * H
               },
 	       stop("unrecognised window type")
               )
	areas
}	

diameter <- function(w) {
	verifyclass(w, "owin")
	
        width <- abs(diff(w$xrange))
        height <- abs(diff(w$yrange))
        
        sqrt(width^2 + height^2)
}

even.breaks.owin <- function(w) {
	verifyclass(w, "owin")
        Rmax <- diameter(w)
        make.even.breaks(Rmax, Rmax/(100 * sqrt(2)))
}

unit.square <- function() { owin(c(0,1),c(0,1)) }

square <- function(r=1) {
  if(length(r) != 1 || !is.numeric(r))
    stop("argument r must be a single number")
  if(is.na(r) || !is.finite(r))
    stop("argument r is NA or infinite")
  if(r <= 0)
    stop("side of square must be positive")
  owin(c(0,r),c(0,r))
}

overlap.owin <- function(A, B) {
  # compute the area of overlap between two windows
  At <- A$type
  Bt <- B$type
  if(At=="rectangle" && Bt=="rectangle") {
    xmin <- max(A$xrange[1],B$xrange[1])
    xmax <- min(A$xrange[2],B$xrange[2])
    if(xmax <= xmin) return(0)
    ymin <- max(A$yrange[1],B$yrange[1])
    ymax <- min(A$yrange[2],B$yrange[2])
    if(ymax <= ymin) return(0)
    return((xmax-xmin) * (ymax-ymin))
  }
  if((At=="rectangle" && Bt=="polygonal")
     || (At=="polygonal" && Bt=="rectangle")
     || (At=="polygonal" && Bt=="polygonal"))
  {
    AA <- as.polygonal(A)$bdry
    BB <- as.polygonal(B)$bdry
    area <- 0
    for(i in seq(AA))
      for(j in seq(BB))
        area <- area + overlap.xypolygon(AA[[i]], BB[[j]])
    return(area)
  }
  if(At=="mask") {
    # count pixels in A that belong to B
    pixelarea <- abs(A$xstep * A$ystep)
    x <- as.vector(raster.x(A)[A$m])
    y <- as.vector(raster.y(A)[A$m])
    ok <- inside.owin(x, y, B) 
    return(pixelarea * sum(ok))
  }
  if(Bt== "mask") {
    # count pixels in B that belong to A
    pixelarea <- abs(B$xstep * B$ystep)
    x <- as.vector(raster.x(B)[B$m])
    y <- as.vector(raster.y(B)[B$m])
    ok <- inside.owin(x, y, A)
    return(pixelarea * sum(ok))
  }
  stop("Internal error")
}

#
#
#  Intersection and union of windows
#
#
intersect.owin <- function(A, B) {
  verifyclass(A, "owin")
  verifyclass(B, "owin")

  # chicken out 
  if(A$type == "polygonal")
    A <- as.mask(A)
  if(B$type == "polygonal")
    B <- as.mask(B)
  
  # determine intersection of x and y ranges
  intersect.ranges <- function(a, b) {
    lo <- max(a[1],b[1])
    hi <- min(a[2],b[2])
    if(lo >= hi) stop("Intersection is empty")
    return(c(lo, hi))
  }
  xr <- intersect.ranges(A$xrange, B$xrange)
  yr <- intersect.ranges(A$yrange, B$yrange)
  C <- owin(xr, yr)
  
  Arect <- (A$type == "rectangle")
  Brect <- (B$type == "rectangle")

  if(Arect && Brect)
    return(owin(xr, yr))

  # Otherwise, we'll need this
  trim.mask <- function(M, R) {
    # M is a mask,
    # R is a rectangle inside bounding.box(M)
    # Extract subset of image grid
    within.range <- function(u, v) { (u >= v[1]) & (u <= v[2]) }
    yrowok <- within.range(M$yrow, R$yrange)
    xcolok <- within.range(M$xcol, R$xrange)
    if(sum(yrowok) == 0 || sum(xcolok) == 0)
      stop("result is empty")
    Z <- M
    Z$xrange <- R$xrange
    Z$yrange <- R$yrange
    Z$yrow <- M$yrow[yrowok]
    Z$xcol <- M$xcol[xcolok]
    Z$m <- M$m[yrowok, xcolok]
    Z$dim <- dim(Z$m)
    return(Z)
  }

  if(!Arect && Brect)
    return(trim.mask(A, C))
  else if(Arect && !Brect) 
    return(trim.mask(B, C))
  else {
    # both are masks
    # First trim A 
    D <- trim.mask(A, C)
    # Then determine which pixels of D are inside B
    x <- raster.x(D)
    y <- raster.y(D)
    ok <- inside.owin(x, y, B)
    # 'and'
    if(!all(ok))
      D$m[!ok] <- FALSE
    return(D)
  }
          
  stop("Internal error")
}


union.owin <- function(A, B) {
  verifyclass(A, "owin")
  verifyclass(B, "owin")

  if(A$type == "rectangle" && B$type == "rectangle") {
    if(is.subset.owin(A, B))
      return(B)
    else if (is.subset.owin(B,A))
      return(A)
  }

  C <- owin(range(A$xrange, B$xrange),
            range(A$yrange, B$yrange))
  
  C <- as.mask(C)
  x <- raster.x(C)
  y <- raster.y(C)
  ok <- inside.owin(x, y, A) | inside.owin(x, y, B)

  if(!any(ok))
    stop("Internal error: union is empty")

  if(!all(ok))
    C$m[!ok] <- FALSE

  return(C)
}
#
#    xypolygon.S
#
#    $Revision: 1.5 $    $Date: 2002/05/13 12:41:10 $
#
#    low-level functions defined for polygons in list(x,y) format
#
verify.xypolygon <- function(p, fatal=TRUE) {
  whinge <- NULL
  if(!is.list(p) || length(p) != 2 ||
     length(names(p)) != 2 || any(sort(names(p)) != c("x","y")))
    whinge <- "polygon must be a list with two components x and y"
  else if(is.null(p$x) || is.null(p$y) || !is.numeric(p$x) || !is.numeric(p$y))
    whinge <- "components x and y must be numeric vectors"
  else if(length(p$x) != length(p$y))
    whinge <- "lengths of x and y vectors unequal"
  ok <- is.null(whinge)
  if(!ok && fatal)
    stop(whinge)
  return(ok)
}

inside.xypolygon <- function(pts, polly, test01=TRUE) {
  # pts:  list(x,y) points to be tested
  # polly: list(x,y) vertices of a single polygon (n joins to 1)
  # test01: logical - if TRUE, test whether all values in output are 0 or 1
  verify.xypolygon(pts)
  verify.xypolygon(polly)
  
  x <- pts$x
  y <- pts$y
  xp <- polly$x
  yp <- polly$y

  npts <- length(x)
  nedges <- length(xp)   # sic

  score <- rep(0, npts)
  on.boundary <- rep(FALSE, npts)

  for(i in 1:nedges) {
    x0 <- xp[i]
    y0 <- yp[i]
    x1 <- if(i == nedges) xp[1] else xp[i+1]
    y1 <- if(i == nedges) yp[1] else yp[i+1]
    dx <- x1 - x0
    dy <- y1 - y0
    if(dx < 0) {
      # upper edge
      xcriterion <- (x - x0) * (x - x1)
      consider <- (xcriterion <= 0)
      if(any(consider)) {
        ycriterion <- y[consider] * dx - x[consider] * dy + (x0 * dy - y0 * dx)
        # closed inequality
        contrib <- (ycriterion >= 0) * ifelse(xcriterion[consider] == 0, 1/2, 1)
        # positive edge sign
        score[consider] <- score[consider] + contrib
        # detect whether any point lies on this segment
        on.boundary[consider] <- on.boundary[consider] | (ycriterion == 0)
      }
    } else if(dx > 0) {
      # lower edge
      xcriterion <- (x - x0) * (x - x1)
      consider <- (xcriterion <= 0)
      if(any(consider)) {
        ycriterion <- y[consider] * dx - x[consider] * dy + (x0 * dy - y0 * dx)
        # open inequality
        contrib <- (ycriterion < 0) * ifelse(xcriterion[consider] == 0, 1/2, 1)
        # negative edge sign
        score[consider] <- score[consider] - contrib
        # detect whether any point lies on this segment
        on.boundary[consider] <- on.boundary[consider] | (ycriterion == 0)
      }
    } else {
      # vertical edge
      consider <- (x == x0)
      if(any(consider)) {
        # zero score
        # detect whether any point lies on this segment
        yconsider <- y[consider]
        ycriterion <- (yconsider - y0) * (yconsider - y1)
        on.boundary[consider] <- on.boundary[consider] | (ycriterion <= 0)
      }
    }
  }
  
  # any point recognised as lying on the boundary gets score 1.
  score[on.boundary] <- 1

  if(test01) {
    # check sanity
    if(!all((score == 0) | (score == 1)))
      warning("internal error: some scores are not equal to 0 or 1")
  }

  attr(score, "on.boundary") <- on.boundary
  
  return(score)
}

area.xypolygon <- function(polly) {
  #
  # polly: list(x,y) vertices of a single polygon (n joins to 1)
  #
  verify.xypolygon(polly)
  
  xp <- polly$x
  yp <- polly$y
  
  nedges <- length(xp)   # sic
  
  # place x axis below polygon
  yp <- yp - min(yp) 

  # join vertex n to vertex 1
  nxt <- c(2:nedges, 1)

  # x step, WITH sign
  dx <- xp[nxt] - xp

  # average height 
  ym <- (yp + yp[nxt])/2
  
  -sum(dx * ym)
}

bdrylength.xypolygon <- function(polly) {
  verify.xypolygon(polly)
  xp <- polly$x
  yp <- polly$y
  nedges <- length(xp)
  nxt <- c(2:nedges, 1)
  dx <- xp[nxt] - xp
  dy <- yp[nxt] - yp
  sum(sqrt(dx^2 + dy^2))
}

reverse.xypolygon <- function(p) {
  # reverse the order of vertices
  # (=> change sign of polygon)

  verify.xypolygon(p)
  
  return(lapply(p, rev))
}

overlap.xypolygon <- function(P, Q) {
  # compute area of overlap of two simple closed polygons 
  verify.xypolygon(P)
  verify.xypolygon(Q)
  
  xp <- P$x
  yp <- P$y
  np <- length(xp)
  nextp <- c(2:np, 1)

  xq <- Q$x
  yq <- Q$y
  nq <- length(xq)
  nextq <- c(2:nq, 1)

  # adjust y coordinates so all are nonnegative
  ylow <- min(c(yp,yq))
  yp <- yp - ylow
  yq <- yq - ylow

  area <- 0
  for(i in 1:np) {
    ii <- c(i, nextp[i])
    xpii <- xp[ii]
    ypii <- yp[ii]
    for(j in 1:nq) {
      jj <- c(j, nextq[j])
      area <- area +
        overlap.trapezium(xpii, ypii, xq[jj], yq[jj])
    }
  }
  return(area)
}

overlap.trapezium <- function(xa, ya, xb, yb, verb=FALSE) {
  # compute area of overlap of two trapezia
  # which have same baseline y = 0
  #
  # first trapezium has vertices
  # (xa[1], 0), (xa[1], ya[1]), (xa[2], ya[2]), (xa[2], 0).
  # Similarly for second trapezium
  
  # Test for vertical edges
  dxa <- diff(xa)
  dxb <- diff(xb)
  if(dxa == 0 || dxb == 0)
    return(0)

  # Order x coordinates, x0 < x1
  if(dxa > 0) {
    signa <- 1
    lefta <- 1
    righta <- 2
    if(verb) cat("A is positive\n")
  } else {
    signa <- -1
    lefta <- 2
    righta <- 1
    if(verb) cat("A is negative\n")
  }
  if(dxb > 0) {
    signb <- 1
    leftb <- 1
    rightb <- 2
    if(verb) cat("B is positive\n")
  } else {
    signb <- -1
    leftb <- 2
    rightb <- 1
    if(verb) cat("B is negative\n")
  }
  signfactor <- signa * signb # actually (-signa) * (-signb)
  if(verb) cat(paste("sign factor =", signfactor, "\n"))

  # Intersect x ranges
  x0 <- max(xa[lefta], xb[leftb])
  x1 <- min(xa[righta], xb[rightb])
  if(x0 >= x1)
    return(0)
  if(verb) {
    cat(paste("Intersection of x ranges: [", x0, ",", x1, "]\n"))
    abline(v=x0, lty=3)
    abline(v=x1, lty=3)
  }

  # Compute associated y coordinates
  slopea <- diff(ya)/diff(xa)
  y0a <- ya[lefta] + slopea * (x0-xa[lefta])
  y1a <- ya[lefta] + slopea * (x1-xa[lefta])
  slopeb <- diff(yb)/diff(xb)
  y0b <- yb[leftb] + slopeb * (x0-xb[leftb])
  y1b <- yb[leftb] + slopeb * (x1-xb[leftb])
  
  # Determine whether upper edges intersect
  # if not, intersection is a single trapezium
  # if so, intersection is a union of two trapezia

  yd0 <- y0b - y0a
  yd1 <- y1b - y1a
  if(yd0 * yd1 >= 0) {
    # edges do not intersect
    areaT <- (x1 - x0) * (min(y1a,y1b) + min(y0a,y0b))/2
    if(verb) cat(paste("Edges do not intersect\n"))
  } else {
    # edges do intersect
    # find intersection
    xint <- x0 + (x1-x0) * abs(yd0/(yd1 - yd0))
    yint <- y0a + slopea * (xint - x0)
    if(verb) {
      cat(paste("Edges intersect at (", xint, ",", yint, ")\n"))
      points(xint, yint, cex=2, pch="O")
    }
    # evaluate left trapezium
    left <- (xint - x0) * (min(y0a, y0b) + yint)/2
    # evaluate right trapezium
    right <- (x1 - xint) * (min(y1a, y1b) + yint)/2
    areaT <- left + right
    if(verb)
      cat(paste("Left area = ", left, ", right=", right, "\n"))    
  }

  # return area of intersection multiplied by signs 
  return(signfactor * areaT)
}

#
#      xysegment.S
#
#     $Revision: 1.5 $    $Date: 2002/07/25 10:45:35 $
#
# Low level utilities for analytic geometry for line segments
#
# author: Adrian Baddeley 2001
#         from an original by Rob Foxall 1997
#
# distpl(p, l) 
#       distance from a single point p  = (xp, yp)
#       to a single line segment l = (x1, y1, x2, y2)
#
# distppl(p, l) 
#       distances from each of a list of points p[i,]
#       to a single line segment l = (x1, y1, x2, y2)
#       [uses only vector parallel ops]
#
# distppll(p, l) 
#       distances from each of a list of points p[i,]
#       to each of a list of line segments l[i,] 
#       [uses large matrices and 'outer()']
#

distpl <- function(p, l) {
  xp <- p[1]
  yp <- p[2]
  dx <- l[3]-l[1]
  dy <- l[4]-l[2]
  leng <- sqrt(dx^2 + dy^2)
  # vector from 1st endpoint to p
  xpl <- xp - l[1]
  ypl <- yp - l[2]
  # distance from p to 1st & 2nd endpoints
  d1 <- sqrt(xpl^2 + ypl^2)
  d2 <- sqrt((xp-l[3])^2 + (yp-l[4])^2)
  dmin <- min(d1,d2)
  # test for zero length
  if(leng < .Machine$double.eps)
    return(dmin)
  # rotation sine & cosine
  co <- dx/leng
  si <- dy/leng
  # back-rotated coords of p
  xpr <- co * xpl + si * ypl
  ypr <-  - si * xpl + co * ypl
  # test
  if(xpr >= 0 && xpr <= leng)
    dmin <- min(dmin, abs(ypr))
  return(dmin)
}

distppl <- function(p, l) {
  xp <- p[,1]
  yp <- p[,2]
  dx <- l[3]-l[1]
  dy <- l[4]-l[2]
  leng <- sqrt(dx^2 + dy^2)
  # vector from 1st endpoint to p
  xpl <- xp - l[1]
  ypl <- yp - l[2]
  # distance from p to 1st & 2nd endpoints
  d1 <- sqrt(xpl^2 + ypl^2)
  d2 <- sqrt((xp-l[3])^2 + (yp-l[4])^2)
  dmin <- pmin(d1,d2)
  # test for zero length
  if(leng < .Machine$double.eps)
    return(dmin)
  # rotation sine & cosine
  co <- dx/leng
  si <- dy/leng
  # back-rotated coords of p
  xpr <- co * xpl + si * ypl
  ypr <-  - si * xpl + co * ypl
  # ypr is perpendicular distance to infinite line
  # Applies only when xp, yp in the middle
  middle <- (xpr >= 0 & xpr <= leng)
  if(any(middle))
    dmin[middle] <- pmin(dmin[middle], abs(ypr[middle]))
  
  return(dmin)
}

distppll <- function(p, l) {
  np <- nrow(p)
  nl <- nrow(l)
  xp <- p[,1]
  yp <- p[,2]
  dx <- l[,3]-l[,1]
  dy <- l[,4]-l[,2]
  # segment lengths
  leng <- sqrt(dx^2 + dy^2)
  # rotation sines & cosines
  co <- dx/leng
  si <- dy/leng
  co <- matrix(co, nrow=np, ncol=nl, byrow=TRUE)
  si <- matrix(si, nrow=np, ncol=nl, byrow=TRUE)
  # matrix of squared distances from p[i] to 1st endpoint of segment j
  xp.x1 <- outer(xp, l[,1], "-")
  yp.y1 <- outer(yp, l[,2], "-")
  d1 <- xp.x1^2 + yp.y1^2
  # ditto for 2nd endpoint
  xp.x2 <- outer(xp, l[,3], "-")
  yp.y2 <- outer(yp, l[,4], "-")
  d2 <- xp.x2^2 + yp.y2^2
  # for each (i,j) rotate p[i] around 1st endpoint of segment j
  # so that line segment coincides with x axis
  xpr <- xp.x1 * co + yp.y1 * si
  ypr <-  - xp.x1 * si + yp.y1 * co
  d3 <- ypr^2
  # test
  lenf <- matrix(leng, nrow=np, ncol=nl, byrow=TRUE)
  zero <- (lenf < .Machine$double.eps) 
  outside <- (zero | xpr < 0 | xpr > lenf) 
  if(any(outside))
    d3[outside] <- Inf

  dmin <- matrix(pmin(d1, d2, d3),nrow=np, ncol=nl)
  return(sqrt(dmin))
}



