.packageName <- "DCluster"
achisq.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]
	return( achisq.stat(data, ...)$T )
}
achisq.pboot<-function(...)
{
	return( achisq.stat(...)$T )
}
achisq.stat<-function(data, lambda=NULL)
{
	attach(data)

	df<-length(Observed)


	#If internal standardization was  used then lambda=1 and df=n-1
	if(sum(data$Observed)==sum(data$Expected))
	{
		lambda<-1
		df<-df-1
	}
	else 
	{
		#If lambda is unknown then we must slightly modify E_i
		if(is.null(lambda))
		{
			lambda<-sum(Observed)/sum(Expected)
			df<-df-1
		}
	}
		
	Elambda<-Expected*lambda

	T<-sum((Observed-Elambda)^2/Elambda)
	pvalue<-pchisq(T, df, lower.tail=FALSE)

	detach(data)
	
	return( list(T=T, df=df, pvalue=pvalue) )
}
besagnewell.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]
	return( besagnewell.stat(data, ...) )
}
besagnewell.pboot<-function(...)
{
        besagnewell.stat(...)
}
	
bn.iscluster<-function(data, idx, idxorder, alpha, k, model="poisson", R=999, mle)
{
        #Indexes of regions in the balls ordered by distance to the centre
	localidx<-idxorder[idx[idxorder]]

		
	bnboot<-switch(model,
	permutation = boot(data[localidx,], statistic=besagnewell.boot, R=R, k=k),
	multinomial = besagnewell.stat(data[localidx,], k ),
	poisson = besagnewell.stat(data[localidx,], k ),
	negbin = boot(data[localidx, ], statistic=besagnewell.pboot, R=R, sim="parametric",ran.gen=negbin.sim,  mle=list(n=sum(idx),size=mle$size,prob=mle$prob[localidx]), k=k)
	)

	stat<-ifelse(model=="permutation" | model=="negbin", bnboot$t0[1], bnboot[1])
	
	if(is.null(stat))
		return(c(NA,NA,NA,NA))

	pvalue<-switch(model,
	permutation=sum(bnboot$t[,1]<=stat)/(R+1),
	multinomial=1-pbinom(k-1, size=mle$n, p=sum(mle$p[localidx[1:stat]]) ),
	poisson=1 - ppois(k-1, sum(mle$lambda[localidx[1:stat]])),
	negbin=sum(bnboot$t[,1]<=stat)/(R+1)
	)
		
	return(c(stat, (alpha>pvalue), pvalue, stat))
}


#Data are supposed to be ordered according to distance to the putative 
#pollution source
besagnewell.stat<-function(data, k)
{
	csum<-cumsum(data$Observed)-1

	#Number of regions needed to sum k cases
	l<-sum(csum<k)+1
	if(l>length(data[[1]]) ) l<-l-1

	return(c(value=l, size=l))
}
calculate.mle<-function(d, model="poisson")
{
	mle<-switch(model,
	multinomial=list(n=sum(d$Observed), p=scale(d$Expected, center=FALSE, scale=sum(d$Expected))),
	poisson=list(n=length(d$Observed), lambda=d$Expected)
	)
	
	if(model=="negbin")
	{
		smth<-empbaysmooth(d$Observed, d$Expected)
		mle<-list(n=length(d$Observed), nu=smth$nu, alpha=smth$alpha,
		size=smth$nu,  prob=smth$alpha/(smth$alpha+d$Expected) ) 
	}

	return(mle)
}
# Copyright 2004 Virgilio Gmez Rubio and Roger Bivand

test.nb.pois <- function(x.nb, x.glm){
	if (!(inherits(x.nb, "negbin"))) stop("not a negbin object")
	if (!(inherits(x.glm, "glm"))) stop("not a glm object")
	zscore <- -log(x.nb$theta)*x.nb$theta/x.nb$SE.theta
	u <- pnorm(zscore)
	pz <- 2*min(u, 1-u)
	probs <- x.nb$theta/(x.nb$theta+x.nb$fitted.values)
	lrt <- 2*(sum(dnbinom(x.nb$y, x.nb$theta, probs, log=TRUE))-
		sum(dpois(x.nb$y, x.glm$fitted.values, log=TRUE)))
	names(lrt) <- "LR"
	pchi <- pchisq(lrt, df=1, lower.tail=FALSE)
	vec <- c(zscore, pz)
	names(vec) <- c("zscore", "p.mayor.modZ")
	res <- list(estimate=vec, statistic=lrt, p.value=pchi, parameter=1, 
		method="Likelihood ratio test for overdispersion",
		data.name=paste(deparse(substitute(x.nb)), ":", 
		deparse(substitute(x.glm))))
	class(res) <- "htest"
	res
}

DeanB <- function(x.glm, alternative="greater") {
	alternative <- match.arg(alternative, c("less", "greater", "two.sided"))
	if (!(inherits(x.glm, "glm"))) stop("not a glm object")
	y <- model.response(model.frame(x.glm))
	mu <- fitted(x.glm)
	Pb <- sum((y-mu)^2-y)/sqrt(2*sum(mu^2))
	names(Pb) <- "P_B"
	Pv <- NA
	if (is.finite(Pb)) {
			if (alternative == "two.sided") 
				Pv <- 2 * pnorm(abs(Pb), lower.tail=FALSE)
			else if (alternative == "greater")
				Pv <- pnorm(Pb, lower.tail=FALSE)
			else Pv <- pnorm(Pb)
	}
	res <- list(statistic=Pb, p.value=Pv, alternative=alternative, 
		method="Dean's P_B test for overdispersion",
		data.name=deparse(substitute(x.glm)))
	class(res) <- "htest"
	res
}

DeanB2 <- function(x.glm, alternative="greater"){
	
	y <- model.response(model.frame(x.glm))
	mu <- fitted(x.glm)
	h <- hatvalues(x.glm)
	Pb2 <- sum((y-mu)^2-y+h*mu)/sqrt(2*sum(mu^2))
	names(Pb2) <- "P'_B"
	Pv <- NA
	if (is.finite(Pb2)) {
			if (alternative == "two.sided") 
				Pv <- 2 * pnorm(abs(Pb2), lower.tail=FALSE)
			else if (alternative == "greater")
				Pv <- pnorm(Pb2, lower.tail=FALSE)
			else Pv <- pnorm(Pb2)
	}
	res <- list(statistic=Pb2, p.value=Pv, alternative=alternative, 
		method="Dean's P'_B test for overdispersion",
		data.name=deparse(substitute(x.glm)))
	class(res) <- "htest"
	res
}
empbaysmooth<-function(Observed, Expected, maxiter=20, tol=1e-5)
{
	if(length(Observed)!=length(Expected))
	{
		print("Lengths of the two vectors differs")
		return(NULL)
	}
	
	n<-length(Observed)
	idx<-Expected>0
	n1<-length(Expected[idx])#Number of non-zero values
	
	#Starting point: the smoothed R.R. are Observed/Expected
	smthrr<-rep(0,n)
	smthrr[idx]<-Observed[idx]/Expected[idx]
	
	m0<-mean(smthrr[idx])
	v0<-var(smthrr[idx])

	if(v0==0)#No variability, i.e., Observed = K
	{
		print("Observed cases are equal to a constant.")
		return( list(nu=NA, alpha=NA, smthrr=rep(NA,n), niter=0) )
	}

	#Initial values for the gamma parameters
	nu<-m0*m0/v0
	alpha<-m0/v0

	smthrr[idx]<-(nu+Observed[idx])/(alpha+Expected[idx])

	m<-mean(smthrr[idx])
	v<- sum( (1+alpha/Expected[idx]) * ((smthrr[idx]-m)^2) )/(n1-1)

	iter<-1
	while(  (  ( abs(m-m0) >tol*(m+m0) ) || ( abs(v-v0) >tol*(v+v0) ) )   && ( iter<=maxiter) )
	{
		#Updated values for the gamma parameters
		nu<-m*m/v
		alpha<-m/v

		smthrr[idx]<-(Observed[idx]+nu)/(Expected[idx]+alpha)
		
		#Previous mean and variance
		m0<-m
		v0<-v

		m<-mean(smthrr[idx])
		v<- sum( (1+alpha/Expected[idx]) * ((smthrr[idx]-m)^2) )/(n1-1)

		iter<-iter+1
	}


	return( list(n=length(Observed), nu=nu, alpha=alpha, smthrr=smthrr, niter=iter) )

}
gearyc.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]
	return( gearyc.stat(data, ...) )

}
gearyc.pboot<-function(...)
{
	return( gearyc.stat(...) )
}
gearyc.stat<-function(data, applyto="residuals", ...)
{
	n<-length(data$Observed)

	if(applyto == "residuals")
	{
		Z<- data$Observed - data$Expected
	}
	else
	{
		Z<- data$Observed/data$Expected 
		Z[!is.finite(Z)]<-0
	}

	return(spdep::geary(x=Z, ...)$C)
}
kullnagar.boot<-function(data, i, ...)
{
         data$Observed<-data$Observed[i]

         kullnagar.stat(data, ...)

}
kullnagar.pboot<-function(...)
{
	kullnagar.stat(...)
}
kn.iscluster<-function(data, idx, idxorder, alpha, fractpop, use.poisson=TRUE, 
	model="poisson", R, mle)
{
        #Indexes of regions in the balls ordered by distance to the centre
        localidx<-idxorder[idx[idxorder]]


	knboot<-switch(model,
	permutation = boot(data[idxorder,], statistic=kullnagar.boot, R=R, fractpop=fractpop, use.poisson=use.poisson),
	multinomial=boot(data[localidx,], statistic=kullnagar.pboot, sim="parametric", ran.gen=multinom.sim,  R=R, fractpop=fractpop, use.poisson=use.poisson, mle=list(n=mle$n, p=mle$p[localidx]) ),
	poisson = boot(data[localidx,], statistic=kullnagar.pboot, sim="parametric", ran.gen=poisson.sim,  R=R, fractpop=fractpop, use.poisson=use.poisson, mle=list(n=mle$n, lambda=mle$lambda[localidx]) ),
	negbin = boot(data[localidx,], statistic=kullnagar.pboot, sim="parametric", ran.gen=negbin.sim,  R=R, fractpop=fractpop, use.poisson=use.poisson, mle=list(n=mle$n, size=mle$size,prob=mle$prob[localidx]) )
	)

	if(is.null(knboot$t0))
		return(c(NA, NA, NA, NA))

	pvalue<-(sum(knboot$t[,1]>knboot$t0[1])+1)/(R+1)
	return(c( knboot$t0[1], alpha>pvalue, pvalue, knboot$t0[2]) )
}


#Compute the statistic around the first location(row) in the dataframe
#Data must be order according to distance to the center of the circle
kullnagar.stat<-function(data, fractpop, use.poisson=TRUE, log.v=FALSE)
{

	n<-length(data[[1]])

	if(use.poisson)
	{
	#	r<-kullnagar.stat.poisson(data, fractpop, log.v=FALSE)
		r<-.Call("Rkn_poisson", data$Observed, data$Expected, 
		fractpop, PACKAGE="DCluster")

		if(!log.v)
			r[1]<-exp(r[1])

		r<-c(value=r[1], size=r[2])
	}
	else
		r<-kullnagar.stat.bern(data, fractpop, log.v)

	return(r)
}


#Bernouilli version
kullnagar.stat.bern<-function(data, fractpop, log.v=FALSE)
{
	n<-length(data[[1]])


	csumpop<-cumsum(data$Population)
	P<-csumpop[n]

	p<-sum(csumpop<(fractpop*P))+1
	if(p>=n) p<-n-1 #The ratio is 1 when all regions are considered

	L<-0
	O<-sum(data$Observed)
	csumobs<-cumsum(data$Observed[1:p])

	#log(L_0)
	l0<-O*log(O)+(P-O)*log(P-O)-P*log(P)

	#Size of the cluster, number of regions from the centre
	size<-1
	for(i in 1:p)
	{
		if( (csumobs[i]*(P-csumpop[i])) > (csumpop[i]*(O-csumobs[i])) )
		{
			#Likelihood inside ball Z
			l<-csumobs[i]*log(csumobs[i])
			
			aux<-csumpop[i]-csumobs[i]
			l<-l+ aux*log(aux) 
			
			l<-l- csumpop[i]*log(csumpop[i])
				
			
			#Likelihood outside ball Z
			aux<-O-csumobs[i]
			l<-l+aux*log(aux)
			
			aux<-P-csumpop[i]-O+csumobs[i]
			l<-l+aux*log(aux)
			
			aux<-P-csumpop[i]
			l<-l-aux*log(aux)

			#L_0
			l<-l-l0

		}
		else
		{
			l<-0
		}

		if(l>L)
		{
			L<-l
			size<-i
		}
	}

	if(!log.v) L<-exp(L)

	return(c(value=L, size=size))
}

#Poisson version
kullnagar.stat.poisson<-function(data, fractpop, log.v=FALSE)
{
	n<-length(data[[1]])

	csumexp<-cumsum(data$Expected)
	E<-csumexp[n]

	p<-sum(csumexp<(fractpop*E))+1
	if(p>=n) p<-n-1 #The ratio is 1 when all regions are considered

	L<-0
	O<-sum(data$Observed)
	csumobs<-cumsum(data$Observed[1:p])


	#log(L_0)
	l0<-O*log(O/E)

	#Size of the cluster, number of regions from the centre
	size<-1
	for(i in 1:p)
	{
		difobs<-O-csumobs[i]
		difexp<-E-csumexp[i]

		if( (csumobs[i]*difexp) > (csumexp[i]*difobs) )
		{
			#Likelihood inside ball Z
			l<-csumobs[i]*log(csumobs[i]/csumexp[i])
			
			#Likelihood outside ball Z
			l<-l+difobs*log(difobs/difexp)

			#Divide by L_0
			l<-l-l0
		}
		else
		{
			l<-0
		}

		if(l>L)
		{
			L<-l
			size<-i
		}
	}

	if(!log.v) L<-exp(L)

	return(c(value=L, size=size))
}
lognormalEB<-function(Observed, Expected, maxiter = 20, tol = 1e-05)
{
	n<-length(Observed)

	#Initial values
	b<-log((Observed+.5)/Expected)
	m0<-mean(b)
	v0<-var(b)

	m1<-m0
	v1<-(v0*sum( 1/(1+v0*(Observed+.5)) ) +sum( (b-m1)*(b-m1) ) )/n

	b<-m1+(Observed+.5)*v1*log((Observed+.5)/Expected)-v1/2
	b<-b/(1+(Observed+.5)*v1)

	iter<-1
	while( ((abs((m0-m1)/(m0+m1))>tol) || (abs((v0-v1)/(v0+v1))>tol)) &&(iter<=maxiter))
	{
		m0<-m1
		v0<-v1

		m1<-mean(b)
		v1<-(v0*sum(1/(1+v0*(Observed+.5))) +sum((b-m1)*(b-m1)))/n

		b<-m1+(Observed+.5)*v1*log((Observed+.5)/Expected)-v1/2
		b<-b/(1+(Observed+.5)*v1)

		iter<-iter+1
	}

	print(iter)
	b

	return(list(n = length(Observed), phi = m1, sigma2=v1,
        smthrr = b))
}
moranI.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]
	return( moranI.stat(data, ...) )

}
moranI.pboot<-function(...)
{
	return( moranI.stat(...) )
}
moranI.stat<-function(data, applyto="residuals", ...)
{
	if(applyto == "residuals")
	{
		Z<- data$Observed - data$Expected
	}
	else
	{
		Z<- data$Observed/data$Expected 
		Z[!is.finite(Z)]<-0
	}

	return(spdep::moran(x=Z,...)$I)
}
multinom.sim<-function(data, mle=NULL)
{
	if(is.null(mle))
		data$Observed<-rmultin(sum(data$Observed), data$Expected/sum(data$Expected))
	else
		data$Observed<-rmultin(mle$n, mle$p)
	return(data)
}
negbin.sim<-function(data, mle=NULL)
{
	if(is.null(mle))
	{
		mle<-empbaysmooth(data$Observed, data$Expected)
		mle<-list(n=mle$n, size=mle$nu, 
			prob=mle$alpha/(mle$alpha+data$Expected) )
	}
	
	data$Observed<-rnbinom(n=mle$n, size=mle$size, prob=mle$prob)
	return(data)
}

opgam.iscluster.default<-function(data, idx, idxorder, alpha, ...)
{
	#Indexes of regions in the balls ordered by distance to the centre
	localidx<-idxorder[idx[idxorder]]

	localO<-sum(data$Observed[localidx])
	localE<-sum(data$Expected[localidx])
	if(localE ==0) return(c(localO, NA, NA, NA)) 

	

	localP<-sum(data$Population[localidx])

	pvalue<-ppois(localO, localE, lower.tail=FALSE)

	return (c(localO, alpha>pvalue, pvalue, sum(idx)))
}

opgam.iscluster.negbin<-function(data, idx, idxorder, alpha, mle, R=999, ...)
{
	#Indexes of regions in the balls ordered by distance to the centre
        localidx<-idxorder[idx[idxorder]]
	

	localO<-sum(data$Observed[localidx])
	localE<-sum(data$Expected[localidx])
	if(localE ==0) return(c(localO, NA, NA, NA)) 

#	bt<-boot(data[localidx, ], statistic=function(x){sum(x$Observed)},
#		R=R, sim="parametric",ran.gen=negbin.sim,
#		mle=list(n=sum(idx),size=mle$size,prob=mle$prob[localidx]))
#	pvalue<-sum(bt$t>localO)/(R+1)

	pvalue<-.Call("Ropgam_iscluster_negbin",data$Observed[localidx], data$Expected[localidx], mle$size, mle$prob[localidx], R, PACKAGE="DCluster")

	return (c(localO, alpha>pvalue, pvalue, sum(idx)))
}

opgam<-function(data, thegrid=NULL, radius=Inf, step=NULL, alpha, iscluster=opgam.iscluster.default, set.idxorder=TRUE, ...)
{
	#If the Grid is null, then create a new grid
	if(is.null(thegrid))
	{
		if(is.null(step))
			step<-.2*radius

		xgrid<-seq(min(data$x), max(data$x), by=step)
		ygrid<-seq(min(data$y), max(data$y), by=step) 

		xlen<-length(xgrid)
		ylen<-length(ygrid)
		npoints<-xlen*ylen

		thegrid<-matrix(rep(NA, 2*npoints) , ncol=2)
		
		thegrid[,1]<-rep(xgrid, times=ylen)
		thegrid[,2]<-rep(ygrid, each=xlen)
	}


	rr<-radius*radius

	GAM<-apply(thegrid, 1, opgam.intern, data, rr, set.idxorder, iscluster, alpha, ...)

	#Take only those balls which were significant
	GAM<-GAM[,!is.na(GAM[4,])]
	GAM<-as.data.frame(t(GAM[, as.logical(GAM[4,])==TRUE ]))
	#Just the first five names are set because it is possible
	#to get more than five columns if user-defined functions
	#are used
	names(GAM)<-c("x", "y", "statistic", "cluster", "pvalue", "size")

	return(GAM)
}


opgam.intern<-function(point, data, rr, set.idxorder, iscluster, alpha, ...)
{
	xd<-(data$x-point[1])
	yd<-(data$y-point[2])
	dist<-xd*xd+yd*yd

	idx<-(dist<=rr)
	if(set.idxorder) idxorder<-order(dist)

	cl<-iscluster(data=data, idx=idx, idxorder=idxorder, alpha=alpha, ...)

	return(c(point, cl))
}
poisson.sim<-function(data, mle=NULL)
{
	if(is.null(mle))
		data$Observed<-rpois(length(data$Observed), lambda=data$Expected)
	else
		data$Observed<-rpois(n=mle$n, lambda=mle$lambda)
	return(data)
}
pottwhitt.boot<-function(data, i)
{
	data$Observed<-data$Observed[i]

	return( pottwhitt.stat(data)$T )

}
pottwhitt.pboot<-function(...)
{
	return( pottwhitt.stat(...)$T )
}
pottwhitt.stat <-function(data)
{
	T<-sum(data$Expected)*sum(data$Observed*(data$Observed-1)/data$Expected)

	allO<-sum(data$Observed)
	
	asintmean<-allO*(allO-1)
	asintvar<-2*(length(data$Observed)-1)*asintmean
	pvalue<-pnorm(T, asintmean, sqrt(asintvar))
	pvalue<-min(pvalue, 1-pvalue)
	
	return(list(T=T, asintmean=asintmean, asintvat=asintvar, pvalue=pvalue))
}
#Simulate samples from a multinomial distribution
#The algorithm is to treat each variable as if it
#were binomial at a time

rmultin<-function(n, p)
{
	l<-length(p)
	x<-rep(0,l)
	
	pdenom<-1
	m<-n

	for(i in 1:(l-1) )
	{
		pr<-p[i]/pdenom
		x[i]<-rbinom(1, m, pr)

		m<-m-x[i]
		pdenom<-pdenom-p[i]
	}
	x[l]<-m

	return(x)
}
stone.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]

	return( stone.stat(data, ...)[1] )
}
stone.pboot<-function(...)
{
	return( stone.stat(...)[1] )
}
stone.stat<-function(data, region, sorted=FALSE, lambda=NULL)
{
	if(is.null(lambda))
		lambda<-sum(data$Observed)/sum(data$Expected)

	if(!sorted)
	{
		xd<-data$x-data$x[region]
		yd<-data$y-data$y[region]
		dist<-xd*xd+yd*yd

		idx<-order(dist)
	}
	else
	{
		idx<-1:length(data$Observed)
	}
	
	ccoc<-cumsum(data$Observed[idx])/(lambda*cumsum(data$Expected[idx]))
	
	t<-max(ccoc)

	return( c(t, region=which(ccoc==t)) )
}
tango.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]

	tango.stat(data, ...)
}
tango.pboot<-function(...)
{
	return( tango.stat(...) )
}
tango.stat<-function(data, listw, zero.policy=FALSE)
{
	p<-scale(data$Expected, center=FALSE, scale=sum(data$Expected))
	r<-scale(data$Observed, center=FALSE, scale=sum(data$Observed))

	rp<-r-p
	T<-lag.listw(listw, rp, zero.policy = zero.policy)
	T<-t(rp)%*%T
	return(T)
}
whittermore.boot<-function(data, i, ...)
{
	data$Observed<-data$Observed[i]

	return( whittermore.stat(data, ...) ) 
}
whittermore.pboot<-function(...)
{
	return( whittermore.stat(...) )
}
whittermore.stat<-function(data, listw, zero.policy=FALSE)
{
	n<-length(data$Observed)
	r<-scale(data$Observed, center=FALSE, scale=sum(data$Observed) )

	T<-lag.listw(listw, r, zero.policy = zero.policy)
	T<-(n/(n-1))*(t(r)%*%T)

	return(T)
}
library(spdep)
library(boot)

.First.lib <- function(lib, pkg) {
        library.dynam("DCluster", pkg, lib)
}
