# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

Fhat <- function(pts1,pts2,s)
{
	Fdists <- nndistF(pts1,pts2)
	plt(Fdists,s)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

.First.lib <- function(lib,pkg)
{
	cat("\nSpatial Point Pattern Analysis Code in S-Plus\n")
	cat("\n Version 2 - Spatial and Space-Time analysis\n")
	library.dynam("splancs", pkg, lib)
	invisible(0)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

Fzero <- function(density,s)
{
	1-exp(-pi*density*s^2)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

Ghat <- function(pts,s)
{
	Gdists <- nndistG(pts)$dists
	plt(Gdists,s)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

Kenv.csr <- function(nptg,poly,nsim,s,quiet=F)
{
	kmax <- rep(0,length=length(s))
	kmin <- rep(1.0E34,length=length(s))
	
	for(isim in (1:nsim)){
		if(!quiet)cat('Doing simulation ',isim,'\n')
		khsim <- khat(csr(poly,nptg),poly,s)
		kmax <- pmax(kmax,khsim)
		kmin <- pmin(kmin,khsim)
	}
	list(lower=kmin,upper=kmax)
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

Kenv.label <- function(pts1,pts2,poly,nsim,s,quiet=F)
{
	kmax <- rep(0,length=length(s))
	kmin <- rep(1.0E34,length=length(s))
	
	for(isim in (1:nsim)){
		if(!quiet)cat('Doing labelling ',isim,'/',nsim,'\n')
		labpts <- rlabel(pts1,pts2)
		k1sim <- khat(labpts[[1]],poly,s)
		k2sim <- khat(labpts[[2]],poly,s)
		diffk <- k1sim-k2sim
		kmax <- pmax(kmax,diffk)
		kmin <- pmin(kmin,diffk)
	}
	list(lower=kmin,upper=kmax)
}

# Copyright Giovanni Petris <GPetris@uark.edu> 2001
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
###
### Calculate simulation envelope for a Poisson Cluster Process
###
Kenv.pcp <- function(rho, m, s2, region.poly, larger.region=NULL, nsim, r) {
  ## rho: intensity of the parent process
  ## m: average number of offsprings per parent
  ## s2: variance of location of offsprings relative to
  ##   their parent
  ## region.poly: a polygon defining the region in which
  ##   the process is to be generated
  ## larger.region: a rectangle containing the region of interest
  ##   given in the form (xl,xu,yl,yu)
  ## nsim: number of simulations required
  ## r: vector of distances at which the K function has to be estimated
  if (is.null(larger.region))
    larger.region <- as.vector(apply(sbox(region.poly), 2, range))
  Kenv <- list(lower=rep(99999,length(r)), ave=numeric(length(r)),
               upper=rep(-99999,length(r)))
  for(i in 1:nsim) {
    Khat <- khat(pcp.sim(rho, m, s2, region.poly, larger.region),
                 region.poly, r)
    Kenv$ave <- Kenv$ave + Khat
    Kenv$lower <- pmin(Kenv$lower, Khat)
    Kenv$upper <- pmax(Kenv$upper, Khat)
  }
  Kenv$ave <- Kenv$ave/nsim
  Kenv
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

Kenv.tor <- function(pts1,pts2,poly,nsim,s,quiet=F)
{
	rect <- bbox(poly)
	kmax <- rep(0, length = length(s))
	kmin <- rep(9.999999999999999e+33, length = length(s))
	for(isim in 1:nsim){
		if(!quiet)cat("Doing shift ", isim, "/", nsim, "\n")
		pts2 <- rtor.shift(pts2,rect)
		k12sim <- k12hat(pts1,pts2,poly,s)
		kmax <- pmax(kmax,k12sim)
		kmin <- pmin(kmin,k12sim)
	}
	list(lower=kmin,upper=kmax)
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

addpoints <- function(pts,plot=F,quiet=F)
{
	if(!plot & !missing(pts)){
		pointmap(pts)
	}

	if(missing(pts))pts <- NULL

	if(!quiet)cat("Use button 1 to enter new points - button 2 when finished.\n")
	newpts <- locator(type="p")
	pts <- rbind(pts,cbind(newpts$x,newpts$y))
	pts
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

#area <- function(poly)
areapl <- function(poly)
{
#	library.dynam("splancs","areapl.o")

	np <- length(poly[,1])

	polyx <- c(poly[,1],poly[1,1])
	polyy <- c(poly[,2],poly[1,2])
	
	answer <- 0

	alist <- .Fortran(	"areapl",
			as.double(polyx),
			as.double(polyy),
			as.integer(np),
			as.double(answer)
			)
	alist[[4]]	
	
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

as.points <- function(...)
{
	nv <- nargs()
	fargs <- list(...)
	if(nv==2){
		l1 <- length(fargs[[1]])
		l2 <- length(fargs[[2]])
		if(l1==l2){
			pts <- cbind(fargs[[1]],fargs[[2]])
		}
		else{
			stop("Cannot make points from different length vectors")
		}
		
	}
	else{
		if(nv==1){
			if(is.list(fargs[[1]])){
				fargs <- fargs[[1]]
				if(any(names(fargs)=="x") & any(names(fargs)=="y")){
					arx <- fargs$x
					ary <- fargs$y
					if(length(arx)!=length(ary)){
						stop("Cannot make points from different length x and y list components!")
					}
					else{
						pts <- cbind(arx,ary)
					}
				}
				else{
					stop("Cannot make points from list without x and y components.")
				}
			}
			else{
				if(is.points(fargs[[1]]))pts <- fargs[[1]]
				else stop("Cannot make points from this object")
			}
		
		}
		else{
			stop("Cannot make object into points!")
		}
	}

	pts
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

bbox <- function(pts)
{
	if(!is.points(pts))stop('Points argument not valid point data')
	
	xr <- range(pts[,1],na.rm=T)
	yr <- range(pts[,2],na.rm=T)
	
	cbind(c(xr[1],xr[2],xr[2],xr[1]),c(yr[1],yr[1],yr[2],yr[2]))
}

 
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

csr <- function(poly,npoints)
{
	ranpts(NULL,poly,npoints)[1:npoints,]
}

ranpts <- function(pts,poly,nprq)
{
# recursively keep generating points until we have more than enough...
#	cat("generating ",nprq," points\n")
	genpts <- gen(poly,nprq)
	npgen <- length(genpts)/2
#	cat("generated ",npgen," points\n")
	if(npgen != 0)pts <- rbind(pts,genpts)
	if (npgen < nprq)
	{
		pts <- ranpts(pts,poly,nprq-npgen)
	}
	pts
}

gen <- function(poly,npoints)
{
	areap <- areapl(poly)
	areab <- areapl(bbox(poly))

	xmin <- min(poly[,1],na.rm=T)
	xmax <- max(poly[,1],na.rm=T)
	ymin <- min(poly[,2],na.rm=T)
	ymax <- max(poly[,2],na.rm=T)

	aratio <- areab/areap
	ngen <- npoints*aratio
	
	xc <- xmin+runif(ngen)*(xmax-xmin)
	yc <- ymin+runif(ngen)*(ymax-ymin)
	
	xy <- cbind(xc,yc)
	pip(xy,poly)
	
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

delpoints <- function(pts,add=F,...)
{
	if(!add)pointmap(pts)
	cat("Use button 1 to delete points - button 2 when finished.\n")
	deld <- identify(pts[,1],pts[,2],atpen=F,offset=0,labels=rep("X",length(pts[,1])))
	if(length(deld)!=0){
		pts <- pts[-deld,]
		}
	pts
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

dsquare <- 
function(pts, srcs, namepref="d")
{
  ptsxy <- as.points(pts)
  nameso <- names(pts)
	d <- NULL
	nsrcs <- npts(srcs)
	for(i in 1:nsrcs) {
		d <- cbind(d, (srcs[i, 1] - ptsxy[,1])^2 + (srcs[i, 2] - 
			ptsxy[,2])^2)
		nameso <- c(nameso,paste(namepref,i,sep=''))
	}
	res <- d
        colnames(res) <- nameso
        res
}

# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

getpoly <- function(quiet=F)
{
	if(!quiet){
		cat("Enter points with button 1\n")
		cat("Finish with button 2\n")
		cat("Don't try to join the polygon up - it is done for you.\n")
	}
	raw <- locator(type = "l")
	resloc <- cbind(raw$x, raw$y)
	lines(c(raw$x[1], raw$x[length(raw$x)]),
	      c(raw$y[1], raw$y[length(raw$y)]))
	resloc
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

gridpts <- function(poly,npts,xs,ys)
{
	bb <- bbox(poly)
	
	if(!missing(npts))
	{
		areap <- areapl(poly)
		areab <- areapl(bb)
		ratio <- areab/areap
		ngen <- npts*ratio
		nx <- sqrt(ngen)
		ny <- sqrt(ngen)
		xs <- (diff(range(bb[,1])))/nx
		ys <- (diff(range(bb[,2])))/ny
	}
	xc <- seq(from=min(bb[,1])-(xs/2),to=max(bb[,1])+(xs/2),by=xs)
	yc <- seq(from=min(bb[,2])-(ys/2),to=max(bb[,2])+(ys/2),by=ys)
		
	nx <- length(xc)
	ny <- length(yc)
	npts <- nx*ny
	
	xy <- matrix(c(xc[(0:(npts-1))%%nx+1],yc[(0:(npts-1))%/%nx+1]),ncol=2)
	pip(xy,poly)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2001 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

inout <- function (pts, poly, bound = NULL, quiet=TRUE) 
{
    xp <- c(poly[, 1], poly[1, 1])
    yp <- c(poly[, 2], poly[1, 2])
    np <- length(xp)
    nptsi <- npts(pts)
    ind <- logical(length = nptsi)
    if (!is.null(bound)) {
#
# sets in-polygon criterion for points equal to polygon
# boundaries (suggestion by Rainer Hurling <rhurlin@gwdg.de>)
#
	   if (!is.logical(bound)) 
		   stop("bound must be NULL, TRUE, or FALSE")
	   result <- integer(length=nptsi)
	   bb <- as.vector(apply(sbox(as.points(xp, yp)), 2, range))
	   za <- .C("ptinpoly1", as.integer(result), as.double(pts[, 1]),
		as.double(pts[, 2]), as.double(xp), as.double(yp),
		as.integer(np), as.double(bb), as.integer(nptsi))

	   z <- ind
	   if (!quiet) {
	       bpts <- which(za[[1]] == 0)
	       if (length(bpts > 0)) {
	           cat("Points on boundary:\n")
	           print(bpts)
	       }
	       else cat("No points on boundary\n")
	   }
	   if(bound) z[which(za[[1]] <= 0)] <- TRUE
	   else z[which(za[[1]] < 0)] <- TRUE
    } else {
        piplist <- .Fortran("inpip", as.double(pts[, 1]), as.double(pts[,2]), 
            as.integer(nptsi), as.double(xp), as.double(yp), 
            as.integer(np), as.logical(ind))
        z <- piplist[[7]]
    }
    z
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2001 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

inpip <- function (pts, poly, bound=NULL, quiet=TRUE)
{
	seq(1:npts(pts))[inout(pts, poly, bound, quiet)]
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

is.points <- function(p)
{
	is <- F
	if(is.array(p))
		if(length(dim(p))==2)
			if(dim(p)[2]>=2) is <- T
	is
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

k12hat <- function(pts1,pts2,poly, s)
{
#	mathlib.dynam("splancs","k12hat.o")
	ptsx1 <- pts1[,1]
	ptsy1 <- pts1[,2]
	npt1 <- npts(pts1)
	ptsx2 <- pts2[,1]
	ptsy2 <- pts2[,2]
	npt2 <- npts(pts2)

	ns <- length(s)
	s <- sort(s)

	np <- length(poly[,1])
	polyx <- c(poly[,1],poly[1,1])
	polyy <- c(poly[,2],poly[1,2])

	h12 <- rep(0,times=ns)
	h21 <- h12

	klist <- .Fortran("k12hat",
		as.double(ptsx1),
		as.double(ptsy1),
		as.integer(npt1),
		as.double(ptsx2),
		as.double(ptsy2),
		as.integer(npt2),
		as.double(polyx),
		as.double(polyy),
		as.integer(np),
		as.double(s),
		as.integer(ns),
		as.double(h12),
		as.double(h21))
	klist[[12]]
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

kernel2d <- function(pts,poly,h0,nx=20,ny=20,kernel='quartic')
{
	if(!is.points(pts))stop('Invalid points argument')
	
	if(!is.points(poly))stop('Invalid poly argument')
	
	nptsk <- npts(pts)
	npoly <- length(poly[,1])
	poly <- rbind(poly,c(poly[1,1],poly[1,2]))
	
	
	xrang <- range(poly[,1],na.rm=T)
	yrang <- range(poly[,2],na.rm=T)
	
	bb <- bbox(poly)
	a1 <- xrang[1]
	a2 <- xrang[2]
	b1 <- yrang[1]
	b2 <- yrang[2]
	cat("Xrange is ",a1,a2,"\n")
	cat("Yrange is ",b1,b2,"\n")
	xgrid <- rep(0,nx)
	ygrid <- rep(0,ny)
	zgrid <- matrix(0,nx,ny)
	if(kernel=='quartic')
	{
		cat('Doing quartic kernel\n')
#		library.dynam('splancs','krnqrt.o')
		storage.mode(zgrid) <- "double"
		klist <- .Fortran("krnqrt",
			as.double(pts[,1]),
			as.double(pts[,2]),
			as.integer(nptsk),
			as.double(poly[,1]),
			as.double(poly[,2]),
			as.integer(npoly),
			as.double(h0),
			as.double(a1),
			as.double(a2),
			as.double(b1),
			as.double(b2),
			as.integer(nx),
			as.integer(ny),
			xgrid=as.double(xgrid),
			ygrid=as.double(ygrid),
			zgrid=(zgrid)
			)
		klist$zgrid[klist$zgrid<0] <- NA
		res <- list(x=klist$xgrid,y=klist$ygrid,z=klist$zgrid,
			 h0=h0,kernel=kernel)
	}
	else
	{
		stop('Invalid kernel function specification')
	}
res
}

	
	
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

"kernel3d"<-
function(pts,times, xgr, ygr, zgr, hxy, hz)
{

#        library.dynam('splancs','kernel3d.o')
        pts3 <- cbind(pts,times)
	nx <- length(xgr)
	ny <- length(ygr)
	nz <- length(zgr)
	mat3 <- array(data = 0, dim = c(nx, ny, nz))
	storage.mode(mat3) <- "double"
	ans <- .Fortran("kern3d",
		as.double(pts3[, 1]),
		as.double(pts3[, 2]),
		as.double(pts3[, 3]),
		as.integer(length(pts3[, 3])),
		as.double(xgr),
		as.integer(length(xgr)),
		as.double(ygr),
		as.integer(length(ygr)),
		as.double(zgr),
		as.integer(length(zgr)),
		as.double(hxy),
		as.double(hz),
		kernarr = mat3)
	list(xgr = xgr, ygr = ygr, zgr = zgr, hxy = hxy, hz = hz, v = ans$
		kernarr)
}


# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

kernrat <- function(pts1,pts2,poly,h1,h2,nx=20,ny=20,kernel='quartic')
{
	kern1 <- kernel2d(pts1,poly,h1,nx,ny,kernel)
	kern2 <- kernel2d(pts2,poly,h2,nx,ny,kernel)
	
	list(x=kern1$x,y=kern1$y,z=kern1$z/kern2$z,h=c(h1,h2),kernel=kernel)
}


	
	
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

"kerview"<-
function(pts,times, k3, map = T,addimg=T,ncol=1)
{
        pts3 <- cbind(pts,times)
        zgr <- k3$zgr
	old.par <- par()
	im.dev <- dev.cur()
	par(mfrow=c(ncol,ncol))
	if(ncol!=1)addimg <- F
	brks <- quantile(k3$v, seq(0,1,0.05))
	cols <- heat.colors(length(brks)-1)
	image(k3$xgr, k3$ygr, k3$v[,  , 1], breaks=brks, col=cols, asp=1)
	map.dev <- -999
	if(map) {
		pbox <- bbox(pts3)
		dstring <- paste(names(dev.cur()), 
			"(\"-geometry 500x500-5+5\")", sep = "")
		eval(parse(text = dstring))	
	#  dev.copy(eval(parse(text=names(dev.cur()))),'-geometry=500x500-5+5')
		map.dev <- dev.cur()
		on.exit(if(map.dev != -999) dev.off(map.dev))
		par(pty = "s")
		par(mfrow=c(ncol,ncol))
#		par(mai=c(0,0,0,0))
		pointmap(pts3, asp=1)
		tmin <- min(pts3[, 3])
		tmax <- max(pts3[, 3])
		tbins <- (zgr[1:(length(zgr) - 1)] + zgr[2:length(zgr)])/2
	#  if(tbins[1] < tmin)tbins <- c(tmin,tbins)
#  if(tbins[length(tbins)] > tmax)tbins <- c(tbins,tmax)
		pbins <- cut(pts3[, 3], tbins)
	}
#dev.copy(eval(parse(text=names(dev.cur()))),'-geometry=500x250')
	dstring <- paste(names(dev.cur()), "(\"-geometry 700x300+0-5\")", sep
		 = "")
	eval(parse(text = dstring))
	hi.dev <- dev.cur()
	on.exit({
		dev.off(hi.dev)
		if(map.dev != -999)
			dev.off(map.dev)
	}
	)
	hist(pts3[, 3])
	repeat {
		tsl <- locator(1)
		if(length(tsl) == 0)
			break
		tsl <- tsl$x
		bdist <- abs(tsl - k3$zgr)
		bin <- (1:length(k3$zgr))[bdist == min(bdist)]
		bin <- bin[1]
		dev.set(im.dev)
		image(k3$xgr, k3$ygr, k3$v[,  , bin], add = addimg,
		      breaks=brks, col=cols, asp=1)
		if(map) {
			dev.set(map.dev)
#			ptsin <- pts3[pbins == bin,]
		       ptsin <- pts3[abs(pts3[,3]-k3$zgr[bin]) < k3$hz,]
			if(length(ptsin != 0)) {
				pointmap(pbox, type = "n", asp=1)
				pointmap(ptsin, add = T)
				title(paste("time = ", format(k3$zgr[bin])))
			}
		}
		dev.set(hi.dev)
	}
#dev.off(hi.dev)
	dev.set(im.dev)
}


# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

khat <- function(pts,poly, s)
{
#	mathlib.dynam("splancs","dokhat.o")
	ptsx <- pts[,1]
	ptsy <- pts[,2]
	npt <- npts(pts)

	ns <- length(s)
	s <- sort(s)

	np <- length(poly[,1])
	polyx <- c(poly[,1],poly[1,1])
	polyy <- c(poly[,2],poly[1,2])

	hkhat <- rep(0,times=ns)

	klist <- .Fortran("dokhat",
		as.double(ptsx),
		as.double(ptsy),
		as.integer(npt),
		as.double(polyx),
		as.double(polyy),
		as.integer(np),
		as.double(s),
		as.integer(ns),
		as.double(hkhat))
	klist[[9]]
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

khvc <- function(pts1,pts2,poly,s)
{
#	mathlib.dynam('splancs','khvc.o')
	anslist <- list(0,0,0,0)
        names(anslist) <- c('varmat','k11','k12','k22')
	ns <- length(s)

	np <- npts(poly)
        xp <- c(poly[, 1],poly[1,1])
        yp <- c(poly[, 2],poly[1,2])

	n1 <- npts(pts1);n2 <- npts(pts2);n <- n1+n2
	
	x <- c(pts1[, 1], pts2[, 1])
	y <- c(pts1[, 2], pts2[, 2])

        bvec <- vector(mode="numeric", length=ns)
	table <- matrix(0,ncol=ns,nrow=n)
        cmat <- matrix(0,ncol=ns,nrow=ns)
        v11 <- vector(mode='numeric',length=ns)
        v12 <- vector(mode='numeric',length=ns)
	v22 <- vector(mode='numeric',length=ns)

slist <- .Fortran("khvc",
                as.double(x),
                as.double(y),
                as.integer(n),
                as.integer(n1),
                as.integer(n2),
                as.double(xp),
                as.double(yp),
                as.integer(np),
                as.double(s),
                as.integer(ns),
		as.double(table),
		as.double(bvec),
		vark1=as.double(v11),
		vark12=as.double(v12),
		vark2=as.double(v22),
		covmat=as.double(cmat)
		)

 ans <- matrix(slist$covmat,nrow=ns,byrow=T)
anslist$varmat <-  ans
anslist$k11 <- slist$vark1
anslist$k12 <- slist$vark12
anslist$k22 <- slist$vark2
anslist
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

khvmat <- function(pts1,pts2,poly,s)
{
#	mathlib.dynam("splancs","khvmat.o")
	ns <- length(s)

	np <- npts(poly)
        xp <- c(poly[, 1],poly[1,1])
        yp <- c(poly[, 2],poly[1,2])

	n1 <- npts(pts1);n2 <- npts(pts2);n <- n1+n2
	

	smax <- max(s)
	x <- c(pts1[, 1], pts2[, 1])
	y <- c(pts1[, 2], pts2[, 2])
        bvec <- vector(mode="numeric", length=ns)
	table <- matrix(0,ncol=ns,nrow=n)
        cmat <- matrix(0,ncol=ns,nrow=ns)

slist <- .Fortran("khvmat",
                as.double(x),
                as.double(y),
                as.integer(n),
                as.integer(n1),
                as.integer(n2),
                as.double(xp),
                as.double(yp),
                as.integer(np),
                as.double(s),
                as.integer(ns),
		as.double(table),
		as.double(bvec),
		varmat=as.double(cmat)
		)

ans <- matrix(slist$varmat,nrow=ns,byrow=T)
ans <- ans+t(ans)
diag(ans) <- diag(ans)/2

ans

}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

mpoint <- function(...,cpch,add=F,type="p")
{
	arglist <- list(...)

	nptsets <- length(arglist)
	if(missing(cpch)){
		alphanum <- c(as.character(1:9),LETTERS)
		cpch <- alphanum[1:nptsets]
		}
	cpch <- rep(cpch,length=nptsets)
	ipch <- 1
	xmax <- NA;ymax <- NA;xmin <- NA;ymin <- NA
	if(add==F){
		
		for(ia in 1:nptsets){
			if(is.points(arglist[[ia]]))
			{
				ptsc <- arglist[[ia]]
				ymax <- max(ymax,ptsc[,2],na.rm=T)
				ymin <- min(ymin,ptsc[,2],na.rm=T)
				xmax <- max(xmax,ptsc[,1],na.rm=T)
				xmin <- min(xmin,ptsc[,1],na.rm=T)
			}
		}
		pointmap(cbind(c(xmin,xmax,xmin,xmax),c(ymin,ymax,ymax,ymin)),type="n")
	}	
	for(ia in 1:nptsets){
		ptsc <- arglist[[ia]]
		pointmap(ptsc,add=T,pch=cpch[ipch],type=type)
		ipch <- ipch+1
	}
	invisible(0)
}	
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

mse2d <- function(pts,poly,nsmse,range)
{
#	library.dynam("splancs","twodimmse.o")
	ptsx <- pts[,1]
	ptsy <- pts[,2]
	nptsm <- npts(pts)
	
	a1 <- min(poly[,1],na.rm=T)
	a2 <- max(poly[,1],na.rm=T)
	b1 <- min(poly[,2],na.rm=T)
	b2 <- max(poly[,2],na.rm=T)
	
	hsmse <- range/nsmse
	amse <- rep(0,nsmse)
	t <- rep(0,nsmse)
	
	mselist <- .Fortran("mse2d",
		as.double(ptsx),
		as.double(ptsy),
		as.integer(nptsm),
		as.double(a1),
		as.double(a2),
		as.double(b1),
		as.double(b2),
		as.integer(nsmse),
		as.double(hsmse),
		as.double(amse),
		as.double(t)
		)
		
	list(mse=mselist[[10]],h=mselist[[11]])
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

n2dist <- function(pts1,pts2)
{
#	library.dynam("splancs","nndist.o")
	npts1 <- npts(pts1)
	npts2 <- npts(pts2)

# reserve arrays for the result
	dists <- rep(0,npts2)
	neighs <- rep(0,npts2)

	nnlist <- .Fortran("n2dist",as.double(pts1[,1]),
				 as.double(pts1[,2]),
	                         as.integer(npts1),
	                         as.double(pts2[,1]),
	                         as.double(pts2[,2]),
	                         as.integer(npts2),
	                         as.double(dists),
				as.integer(neighs))
	list(dists=nnlist[[7]],neighs=nnlist[[8]])
}


# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

nndistF <- function(pts1,pts2)
{
#	library.dynam("splancs","nndist.o")
	npts1 <- npts(pts1)
	npts2 <- npts(pts2)

# reserve an array for the result
	dists <- rep(0,npts2)

	nnlist <- .Fortran("nndisf",as.double(pts1[,1]),
				 as.double(pts1[,2]),
	                         as.integer(npts1),
	                         as.double(pts2[,1]),
	                         as.double(pts2[,2]),
	                         as.integer(npts2),
	                         as.double(dists))
	nnlist[[7]]
}


# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

nndistG <- function(pts)
{
#	library.dynam("splancs","nndist.o")
	nptsg <- npts(pts)
	neighs <- rep(0,nptsg)
	dists <- rep(0,nptsg)
	nnlist <- .Fortran("nndisg",as.double(t(pts[,1:2])),
	                         as.integer(nptsg),
	                         as.double(dists),
				 as.integer(neighs))
	list(dists=nnlist[[3]],neighs=nnlist[[4]])
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

npts <- function(pts)
{
	dim(pts)[1]
}
# Copyright Giovanni Petris <GPetris@uark.edu> 2001
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
###
### Fit a Poisson Cluster Process
###
pcp <- function(point.data, poly.data, h0=NULL, expo=0.25, n.int=20) {
  ## point.data: a points object
  ## poly.data: a polygon enclosing the study region
  ## h0: upper bound of integration in the criterion function
  ## expo: exponent in the criterion function
  ## n.int: number of intervals used to approximate the integral
  ##   in the criterion function with a sum 
  if (is.null(h0)) {
    dsq <- dsquare(point.data, point.data)
    h0 <- sqrt(max(dsq)/3)
  }
  h <- h0 / 20 * 1:20
  ## Compute K hat
  K.hat <- khat(point.data, poly.data, h)
  ## Define a function that computes K(h;theta)
  ## theta[1] = log(sigma^2),
  ## theta[2] = log(rho)
  K <- function(h, theta) {
    theta <- exp(theta)
    pi*h^2 + (1 - exp(-h^2/(4*theta[1])))/theta[2]
  }
  ## Define a function that evaluates the criterion
  D <- function(theta) {
    K.values <- K(h, theta)
    sum((K.hat^expo - K.values^expo)^2)
  }
  ## Minimize the criterion
  fit <- optim(c(0,0), D)
  fit$par <- exp(fit$par)
  names(fit$par) <- c("s2","rho")
  fit
}

# Copyright Giovanni Petris <GPetris@uark.edu> 2001
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
###
### Generate a Poisson Cluster Process
###
pcp.sim <- function(rho, m, s2, region.poly, larger.region=NULL) {
  ## rho: intensity of the parent process
  ## m: average number of offsprings per parent
  ## s2: variance of location of offsprings relative to
  ##   their parent
  ## region.poly: a polygon defining the region in which
  ##   the process is to be generated
  ## larger.region: a rectangle containing the region of interest
  ##   given in the form (xl,xu,yl,yu)
  if (is.null(larger.region))
    larger.region <- as.vector(apply(sbox(region.poly), 2, range))
  sim.events <- c(0,0)
  ## 1. Generate the parents on [xl,xu]x[yl,yu]
  n <- rpois(1,lambda=rho*(larger.region[2]-larger.region[1])*
             (larger.region[4]-larger.region[3]))
  parents <- cbind(runif(n,larger.region[1],larger.region[2]),
                   runif(n,larger.region[3],larger.region[4]))
  ## 2. Generate the children
  sd <- sqrt(s2)
  for (j in 1:n) {
    num.child <- rpois(1,lambda=m)
    for (k in 1:num.child) {
      new.child <- parents[j,]+rnorm(2,0,sd=sd)
      sim.events <- rbind(sim.events,new.child)
    }
  }
  sim.events <- sim.events[-1,]  
  ## return only the events within the region of interest
  pip(as.points(sim.events),region.poly)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

pdense <- function(pts,poly)
{
	length(pts[,1])/areapl(poly)
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2001 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

pip <- function(pts,poly,out=F,bound=NULL, quiet=TRUE)
{
	inoutv <- inout(pts,poly,bound,quiet)
	if(!out){
		res <- pts[inoutv==T,,drop=F]
	}
	else{
		res <- pts[inoutv==F,,drop=F]
	}
	res
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

plt <- function(data, value)
{
	data <- sort(data)
	nv <- length(value)
	nd <- length(data)
	res <- NULL
	for(iv in 1:nv) {
		nlt <- length(data[data < value[iv]])
		res <- c(res, nlt/nd)
	}
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

pointmap <- function(pts,add=F,axes=T,xlab="",ylab="",...)
{
	if(add) 
		{
		points(pts[,1:2,drop=F],...)
		}
	else	
		{
		plot(pts[,1:2,drop=F],
		axes=axes,xlab=xlab,ylab=ylab,asp=1,...)
	}
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

polymap <- function(poly,add=F,xlab="",ylab="",axes=T,...)
{
	if(!add){
		plot(poly,type="n",axes=axes,xlab=xlab,
		ylab=ylab,asp=1)
	}
	polygon(poly,...)
}



# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

print.ribfit <- function(x,...){
	if(!is.null(cl <- x$call)) {
		cat("Call:\n")
		dput(cl)
	}
	if(!is.null(x$kcode))cat(paste("Kcode = ",x$kcode,'\n',sep=''))

	if(!is.null(x$alpha)){
	  cat("\nDistance decay parameters:\n")
	  pmat <- cbind(x$alpha,x$beta)
	  dimnames(pmat) <- list(NULL,c('Alpha','Beta'))
	  print(pmat,...)
	}
	if(!is.null(x$theta)){
	  cat("\nCovariate parameters:\n")
	  print(x$theta,...)
	}
	cat(paste("\nrho parameter : ",x$rho,'\n\n',sep=''))

	cat(paste("     log-likelihood : ",x$logl,'\n',sep=''))
	cat(paste("null log-likelihood : ",x$null,'\n',sep=''))
	cat(paste("\n"))
	cat(paste("        D = 2(L-Lo) : ",2*(x$logl-x$null),'\n',sep=''))


}

# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

rlabel <- function(...){
	arglist <- list(...)
	nptsets <- length(arglist)
	ntotpts <- 0
	allpts <- NULL
	newperm <- NULL
	for(ia in 1:nptsets){
		nptsia <- npts(arglist[[ia]])
		ntotpts <- ntotpts+nptsia
		allpts <- rbind(allpts,arglist[[ia]])
		newperm <- c(newperm,rep(ia,times=nptsia))
	}
	newperm <- sample(newperm)
	outlist <- list()
	for(ia in 1:nptsets){
		outlist[[ia]] <- allpts[newperm==ia,]
	}
	outlist
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

rtor.shift <- function(pts,rect)
{
	if(missing(rect))rect <- bbox(pts)
	xsc <- max(rect[,1])-min(rect[,1])
	ysc <- max(rect[,2])-min(rect[,2])
	xsh <- runif(1)*xsc
	ysh <- runif(1)*ysc
	tor.shift(pts,xsh,ysh,rect)
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

sbox <- function(pts,xfrac=.1,yfrac=.1)
{
	if(!is.points(pts))stop('Points argument not valid point data')
	
	xr <- range(pts[,1],na.rm=T)
	yr <- range(pts[,2],na.rm=T)
	
	xw <- xr[2]-xr[1]
	xr[1] <- xr[1]-xfrac*xw
	xr[2] <- xr[2]+xfrac*xw

	yw <- yr[2]-yr[1]
	yr[1] <- yr[1]-yfrac*yw
	yr[2] <- yr[2]+yfrac*yw
	
	cbind(c(xr[1], xr[2], xr[2], xr[1]), c(yr[1], yr[1], yr[2], yr[2]))
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

secal <- function(pts1, pts2, poly, s)
{
	sqrt(diag(khvmat(pts1, pts2, poly, s)))
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

shift <- function(pts,xsh=0.0,ysh=0.0)
{
	pts[,1] <- pts[,1]+xsh
	pts[,2] <- pts[,2]+ysh
	pts
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

splancs <- function()
{
#	cat('Splancs version 2.00     Date 23/11/93\n')
#	cat('\n(c) BSR and PJD 1991      Lancaster University\n')
#	cat('                          Lancaster, U.K.\n')
#	cat('\n This version of Splancs is not public domain and\n')
#	cat('must not be copied or redistributed without prior\n')
#	cat('permission of the authors\n')
	'2.01'
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

spoints <- function(data,npoints)
{
	ldat <- length(data)
	if(missing(npoints)){
		if(ldat%%2 != 0){
			warning("Odd number of data items")
			warning("last one will be ignored")
			ldat <- ldat-1
			data <- data[1:ldat]
		}
		npoints <- ldat/2
	}
	else{
		if(ldat < npoints*2){
			data <- rep(data,length.out=npoints*2)
		}
		else{
			data <- data[1:(npoints*2)]
		}
	}
	matrix(data,ncol=2,byrow=T)	
}

	
	
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

stdiagn <- function(pts,stkh,stse,stmc=0,Dzero=F)
{
# set up the 2x2 layout
oldpar <- par(mfrow=c(2,2))

# map the points
#par(pty='s')
pointmap(as.points(pts))
title('Data map')

# plot the D surface
# 2/9/94  added Dzero option
oprod <- outer(stkh$ks,stkh$kt)
st.D <- stkh$kst-oprod
st.R <- st.D/(stse)

#par(pty='m')
if(!Dzero){
persp(stkh$s, stkh$t, st.D,xlab='Distance',ylab='Time',zlab='D', expand=0.5, ticktype="detailed", theta=-30, shade=0.4, cex=0.7)
title('D plot')
} else {
persp(stkh$s, stkh$t, st.D/oprod,xlab='Distance',ylab='Time',zlab='Dzero', expand=0.5, ticktype="detailed", theta=-30, shade=0.4, cex=0.7)
title('Dzero plot')
}


plot(outer(stkh$ks, stkh$kt), st.R,xlab='K(s)K(t)',ylab='R')
abline(h=0)
title('Residual Plot')
if(length(stmc)>1){
 hist(stmc,nclass=50,include.lowest=T,xlab='Test statistic',main="")
 y.75 <- par()$usr[4]*.75
 y.8 <- par()$usr[4]*.8
 lines(rep(stmc[1],2),c(0,y.75),lwd=2)
 text(stmc[1],y.8,'Data Statistic')
 title('MC results')
}else{
 plot(c(0,1),c(0,1),type='n',axes=F,xlab='',ylab='')
 ad <- par()$adj
 par(adj=.5)
 text(0.5,.5,'No MC available')
 par(adj=ad)
}
par(oldpar)
#invisible(0)

}
# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

stkhat <- function(pts, times, poly, tlimits, s, tm)
{
#	mathlib.dynam('splancs','stkhat.o')
# space-time khat function
	tlow <- min(tlimits)
	thigh <- max(tlimits)
	s <- sort(s)
	ns <- length(s)
	tm <- sort(tm)
	nt <- length(tm)
	x1 <- pts[, 1]
	y1 <- pts[, 2]
	t1 <- times
	n1 <- length(x1)
	nc <- npts(poly)
	xc <- c(poly[, 1], poly[1, 1])
	yc <- c(poly[, 2], poly[1, 2])
	hs <- rep(0, ns)
	ht <- rep(0, nt)
	hst <- matrix(0, ns, nt)
	storage.mode(hst) <- "double"
	ktlist <- .Fortran("stkhat",
		as.double(x1),
		as.double(y1),
		as.double(t1),
		as.integer(n1),
		as.double(xc),
		as.double(yc),
		as.integer(nc),
		as.double(s),
		as.integer(ns),
		as.double(tm),
		as.integer(nt),
		as.double(tlow),
		as.double(thigh),
		hs = as.double(hs),
		ht = as.double(ht),
		hst = (hst))

	list(s=s,t=tm,ks = ktlist$hs, kt = ktlist$ht, kst = ktlist$hst)
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#


stmctest <- function(pts,times,poly,tlimits,s,tt,nsim,quiet=F)
{
	stats <- NULL
	ntpts <- npts(pts)
	
	for(isim in (1:nsim))
	{
		if(!quiet)cat("Doing simulation ", isim, "\n")
		kstsim <- stkhat(pts,times,poly,tlimits,s,tt)
		resids <- kstsim$kst-outer(kstsim$ks,kstsim$kt)
		stats <- c(stats,sum(resids))
		rdat <- rank(stats)[1]
		if(!quiet)cat("Data ranks ",rdat," of ",isim,"\n")
		times <- sample(times)
	}
	stats
}


# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

stsecal <- function(pts,times,poly,tlim,s,tm)
{
bigmat <- matrix(stvmat(pts,times,poly,tlim,s,tm),nrow=length(s)*length(tm))
diagon <- diag(bigmat)
semat <- sqrt(t(matrix(diagon,ncol=length(s))))
semat
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

stvmat <- function(pts,times,poly,tlim,s,tm)
{
#	mathlib.dynam('splancs','stsecal.o')
# full spacetime variance/covariance matrix
	tlow <- min(tlim)
        tupp <- max(tlim)

	ns <- length(s)
        nt <- length(tm)
        tm <- sort(tm)

	np <- npts(poly)
        xp <- c(poly[, 1],poly[1,1])
        yp <- c(poly[, 2],poly[1,2])

	n <- npts(pts)
	

	x <- pts[, 1]
	y <- pts[, 2]
        z <- times

        svec <- vector(mode="numeric", length=ns)
        tvec <- vector(mode="numeric", length=nt)

	smat <- matrix(0,ncol=ns,nrow=n)
        tmat <- matrix(0,ncol=nt,nrow=n)

        long <- ns*nt
        cmat <- matrix(0,ncol=long,nrow=long)

slist <- .Fortran("stsecal",
                as.double(x),
                as.double(y),
                as.integer(n),
                as.double(xp),
                as.double(yp),
                as.integer(np),
                as.double(s),
                as.integer(ns),
		as.double(smat),
		as.double(svec),
		as.double(z),
		as.double(tlow),
		as.double(tupp),
		as.double(tm),
		as.integer(nt),
		as.double(tmat),
		as.double(tvec),
		as.integer(long),
		varmat=as.double(cmat)
		)

 ans <- matrix(slist$varmat,nrow=long,byrow=T)
 ans <- array(ans,dim=c(nt,ns,nt,ns))
ans
}

# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

thin <- function(pts,n)
{
	pts <- as.points(pts)
	nptsi <- npts(pts)
	if(nptsi<n)
	{
		warning(paste("Requested ",n," points from data with ",nptsi,".\n"))
		n <- nptsi
	}
	if(nptsi==0 | n==0)
	{
		pts <- NULL
	}
	else
	{
		pts[sample(1:nptsi)[1:n],]
	}
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

tor.shift <- function(pts,xsh,ysh,rect)
{
	if(missing(rect))rect <- bbox(pts)
	
	xoff <- min(rect[,1])
	yoff <- min(rect[,2])
	
	xsc <- (max(rect[,1])-xoff)
	ysc <- (max(rect[,2])-yoff)
	
	pts[,1] <- pts[,1]-xoff
	pts[,2] <- pts[,2]-yoff
	pts <- shift(pts,xsh,ysh)
	pts[,1] <- (pts[,1] %% xsc )+xoff
	pts[,2] <- (pts[,2] %% ysc )+yoff
	pts
}
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

tribble <- function(ccflag,vars=NULL,alphas=NULL,betas=NULL,rho
  ,which=1:length(alphas),covars=NULL,thetas=NULL,steps=NULL
  ,reqmin=0.001,icount=50,hessian=NULL)
{
#        library.dynam('splancs','tribble.o')
	vars <- cbind(vars)  # make sure its a matrix
	nalphas <- length(alphas)
	nbetas <- length(betas)
	if(nalphas!=nbetas){
		stop("alphas and betas must be same length")
	}
	else
	{
		ndpars <- nalphas
	}
	npt <- length(ccflag)
	if(is.null(vars)){
		ndvars <- 0
		if(is.null(covars))stop("No variates found!!")
	}
	else
	{
		ndvars <- dim(vars)[2]
		if(dim(vars)[1] != npt)stop('Number of variates inconsistent with number of cases/controls')
		if(ndvars < ndpars)stop('More source parameters than variables!')
		if(length(which) != ndvars) stop(' The "which" parameter is not the same length as the number of source parameters')
		wsu <- sort(unique(which))
		if(length(wsu) != ndpars)stop('Not enough distinct  values in "which"')
		if(!any(wsu == 1:ndpars))stop('Invalid values in "which"')
# scale distances
		disscale <- apply(vars,2,max)
		vars <- vars/matrix(disscale,ncol=ndvars,nrow=npt,byrow=T)
	}
	if(is.null(covars) | is.null(thetas)){
		ncovars <- 0
	} else {
		covars <- as.matrix(covars)
		ncovars <- dim(covars)[2]
		if(ncovars != length(thetas))stop('Number of parameters inconsistent with covariate array')
		if(dim(covars)[1] != npt)stop('Number of covariates inconsistent with number of cases/controls')
# scale covariates
		covscale <- abs(apply(covars,2,max))
		covars <- covars/matrix(covscale,ncol=ncovars,nrow=npt,byrow=T)
		
	}

	allvars <- ifelse(ncovars != 0, cbind(vars,covars),
             matrix(vars, ncol=ndvars, nrow=npt))

	nallpars <- ndvars*2+ncovars + 1
	
        print(nallpars)
        storage.mode(allvars) <- "double"
	
	pstart <- c(alphas,betas,thetas,rho)
# initial steps - .5 for a,b,t, .1 for rho
	if(is.null(steps))steps <- c(rep(0.5,length=ndvars*2+ncovars),.1)

	l <- .Fortran('tribble',
		as.integer(ccflag),
		(allvars),
		as.integer(npt),
		as.integer(ndvars),
		as.integer(ndpars),
		as.integer(ncovars),
		as.integer(which),
		as.double(pstart),
		parfin=as.double(pstart),
		as.double(steps),
		as.double(reqmin),
		icode=as.integer(icount),
		kcode=as.integer(1),
		dlogl=as.double(1.00))
	alphas <- betas <- thetas <- NULL
	if(ndpars!=0){
		alphas <- l$parfin[1:ndpars]
		betas <- (l$parfin[(ndpars+1):(ndpars*2)])/disscale
	}
	if(l$icode < 0)stop(paste("Error in minimisation algorithm code ",icode))
	rho <- l$parfin[length(l$parfin)]
	if(ncovars != 0){
	  thetas <- l$parfin[(1+ndpars*2):(ncovars+ndpars*2)]
	  thetas <- thetas/covscale
	}

	ncase <- sum(ccflag)
        ncont <- sum(1-ccflag)
        p <- ncase/(ncase+ncont)
        null.logl <- log(p)*ncase+log(1-p)*ncont

res <- list(alphas=alphas,betas=betas,thetas=thetas,rho=rho,logl=l$dlogl,
null.logl=null.logl,kcode=l$kcode,
call=match.call())
	class(res) <- "ribfit"

	if(!is.null(hessian)){

	  hess1 <- hessian.ribfit(res,ccflag=ccflag,vars=vars,covars=covars,which=which)
	  hess2 <- hessian2.ribfit(res,ccflag=ccflag,vars=vars,covars=covars,which=which)
	  res$hessian.1 <- hess1
	  res$hessian.2 <- hess2
	}

	res
}
	


# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

triblik <- function(ccflag,vars=NULL,alphas=NULL,betas=NULL
,rho,which=1:length(alphas),covars=NULL,thetas=NULL)
{

	vars <- cbind(vars)  # make sure its a matrix
	nalphas <- length(alphas)
	nbetas <- length(betas)
	if(nalphas!=nbetas){
		stop("alphas and betas must be same length")
	}
	else
	{
		ndpars <- nalphas
	}
	npt <- length(ccflag)
	if(is.null(vars)){
		ndvars <- 0
		if(is.null(covars))stop("No variates found!!")
	}
	else
	{
		ndvars <- dim(vars)[2]
		if(dim(vars)[1] != npt)stop('Number of variates inconsistent with number of cases/controls')
		if(ndvars < ndpars)stop('More source parameters than variables!')
		if(length(which) != ndvars) stop(' The "which" parameter is not the same length as the number of source parameters')
		wsu <- sort(unique(which))
		if(length(wsu) != ndpars)stop('Not enough distinct  values in "which"')
		if(!any(wsu == 1:ndpars))stop('Invalid values in "which"')
	}
	if(is.null(covars) | is.null(thetas)){
		ncovars <- 0
	} else {
		covars <- as.matrix(covars)
		ncovars <- dim(covars)[2]
		if(ncovars != length(thetas))stop('Number of parameters inconsistent with covariate array')
		if(dim(covars)[1] != npt)stop('Number of covariates inconsistent with number of cases/controls')
	}

	allvars <- cbind(vars,covars)
	nallpars <- ndvars*2+ncovars + 1
	
        storage.mode(allvars) <- "double"
	
	pars <- c(alphas,betas,thetas,rho)

	l <- .Fortran('trblik',
		as.integer(ccflag),
		(allvars),
		as.integer(npt),
		as.integer(nallpars),
		as.integer(ndvars),
		as.integer(which),
		as.integer(ndpars),
		as.double(pars),
		dlogl=as.double(1.00))
	l$dlogl
}
	


# Local Variables:
# mode:S
# S-temp-buffer-p:t
# End:
# Copyright Barry Rowlingson <b.rowlingson@lancaster.ac.uk> and 
# Peter Diggle (c) 1991-3; http://www.maths.lancs.ac.uk/~rowlings/Splancs/
# R port: copyright 1998-2000 by Roger S. Bivand
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#

zoom <- function(quiet=F,out=F,...)
{
	if(!out){
		if(!quiet){
			cat("Enter 2 points as corners of zoom area\n")
		}
		pointmap(bbox(as.points(locator(2,type="l"))),type="n",...)
	}
	if(out){
		usr <- par()$usr
		xwidth <- usr[2]-usr[1]
		ywidth <- usr[4]-usr[3]
		xmin <- usr[1]-xwidth
		xmax <- usr[2]+xwidth
		ymin <- usr[3]-ywidth
		ymax <- usr[4]+ywidth
		pointmap(cbind(c(xmin,xmax),c(ymin,ymax)),type='n')
	}
	invisible(0)
}

