#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     binnnest(response, totals=NULL, nest=NULL, ccov=NULL, tvcov=NULL,
#	mu=~1, re1=~1, re2=~1, preg=NULL, pre1=NULL, pre2=NULL,
#	binom.mix=c(10,10), binom.prob=c(0.5,0.5), fcalls=900,
#	eps=0.01, print.level=0)
#
#  DESCRIPTION
#
#    A function to fit binary random effects models with two levels
#  of nesting.
#
binnest <- function(response, totals=NULL, nest=NULL, ccov=NULL, tvcov=NULL,
	mu=~1, re1=~1, re2=~1, preg=NULL, pre1=NULL, pre2=NULL,
	binom.mix=c(10,10), binom.prob=c(0.5,0.5), fcalls=900,
	eps=0.01, print.level=0){
# Fortran constants
maxt1 <- maxt2 <- maxt3 <- 10

call <- sys.call()
if(length(binom.prob)==1)binom.prob <- c(binom.prob,binom.prob)
if(any(binom.prob<=0)||any(binom.prob>=1))stop("binom.prob parameters must be between zero and one")
if(length(binom.mix)==1)binom.mix <- c(binom.mix,binom.mix)
total1 <- length(preg)
total2 <- length(pre1)
total3 <- length(pre2)
total <- total1+total2+total3
dimw <- total*(total+7)/2
if(!inherits(response,"repeated")){
	if(!inherits(response,"response")){
		if(is.matrix(response)||is.data.frame(response))response <- restovec(response,totals=totals,nest=nest,times=F)
		else if(is.list(response))response <- restovec(response,times=F)
		else stop("response must be a matrix, data.frame, list, or object of type repeated or response")}
	resp <- response$y
	if(is.null(response$n)){
		if(any(response$y!=0&response$y!=1))stop("if binomial totals are not supplied, all responses must be 0 or 1")
		else resp <- cbind(resp,rep(1,length(response$y)))}
	else resp <- cbind(resp,response$n)
	if(!is.null(ccov)){
		if(!inherits(ccov,"tccov"))ccov <- tcctomat(ccov)
		resp <- cbind(resp,ccov$ccov[covind(response),,drop=F])}
	if(!is.null(tvcov)){
		if(!inherits(tvcov,"tvcov"))tvcov <- tvctomat(tvcov)
		resp <- cbind(resp,tvcov$tvcov)}
	nind <- length(response$nobs)
	numsubj <- length(response$y)
	nest <- response$nest
	regname <- if(ncol(resp)>2)c("(Intercept)",colnames(resp[,3:ncol(resp)]))
	else "(Intercept)"
	if(total2==1)re1name <- "(Intercept)"
	else if(!is.null(total2))stop("pre1 should supply 1 initial estimate")
	if(total3==1)re2name <- "(Intercept)"
	else if(!is.null(total3))stop("pre2 should supply 1 initial estimate")
	if(!is.null(ccov))rm(ccov)
	if(!is.null(tvcov))rm(tvcov)}
else {
	envname <- paste(deparse(substitute(response)))
	resp <- response$response$y
	if(is.null(response$response$n)){
		if(any(response$response$y!=0&response$response$y!=1))stop("if binomial totals are not supplied, all responses must be 0 or 1")
		else resp <- cbind(resp,rep(1,length(response$response$y)))}
	else resp <- cbind(resp,response$response$n)
	if(inherits(mu,"formula")){
		if(as.character(mu)[2]!="1"){
			tmp <- attr(finterp(mu,envir=response,name=envname),"model")
			if(!is.matrix(tmp))stop("mu must be a W&R formula")
			if(ncol(tmp)!=total1)stop(paste("preg should contain",ncol(tmp),"initial estimates"))
			resp <- cbind(resp,tmp[,-1,drop=F])
			regname <- gsub("\\[.i]","",colnames(tmp))}
		else {
			regname <- "(Intercept)"
			if(total1!=1)stop("preg should contain 1 initial estimate")}}
	else stop("mu must be a W&R formula")
	if(inherits(re1,"formula")&&!is.null(pre1)){
		if(as.character(re1)[2]!="1"){
			tmp <- attr(finterp(re1,envir=response,name=envname),"model")
			if(!is.matrix(tmp))stop("re1 must be a W&R formula")
			if(ncol(tmp)!=total2)stop(paste("pre1 should contain",ncol(tmp),"initial estimates"))
			resp <- cbind(resp,tmp[,-1,drop=F])
			re1name <- gsub("\\[.i]","",colnames(tmp))}
		else {
			re1name <- "(Intercept)"
			if(total2!=1)stop("pre1 should contain 1 initial estimate")}}
	else pre1 <- re1name <- NULL
	if(inherits(re2,"formula")&&!is.null(pre2)){
		if(as.character(re2)[2]!="1"){
			tmp <- attr(finterp(re2,envir=response,name=envname),"model")
			if(!is.matrix(tmp))stop("re2 must be a W&R formula")
			if(ncol(tmp)!=total3)stop(paste("pre2 should contain",ncol(tmp),"initial estimates"))
			resp <- cbind(resp,tmp[,-1,drop=F])
			re2name <- gsub("\\[.i]","",colnames(tmp))}
		else {
			re2name <- "(Intercept)"
			if(total3!=1)stop("pre2 should contain 1 initial estimate")}}
	else pre2 <- re2name <- NULL
	nind <- length(response$response$nobs)
	numsubj <- length(response$response$y)
	nest <- response$response$nest}
nobs1 <- nobs2 <- NULL
if(!is.null(nest))for(i in 1:nind){
	nobs1 <- c(nobs1,length(unique(nest[covind(response)==i])))
	nobs2 <- c(nobs2,as.vector(table(nest[covind(response)==i])))}
else nobs1 <- nobs2 <- rep(1,nind)
rm(response)
maxmother <- max(nobs1)
maxkid <- max(nobs2)
p <- c(preg,pre1,pre2)
z0 <- .Fortran("binnest",
        Fvalue=double(1),
        res=integer(3),  #  Iter_N,Fun_N,flag
        x=double(total),
        g=double(total),
        hess=double(total*total),
        p=as.double(p),
        numcase1=as.integer(nind),
	numcase2=as.integer(length(nobs2)),
	numsubj=as.integer(numsubj),
	maxkid=as.integer(maxkid),
	maxmother=as.integer(maxmother),
        totcol=as.integer(ncol(resp)),
        total1=as.integer(total1),
	total2=as.integer(total2),
	total3=as.integer(total3),
	uph1in=as.integer(binom.mix[1]),
	uph2in=as.integer(binom.mix[2]),
	fcalls=as.integer(fcalls),
	dimw=as.integer(dimw),
        par=as.double(c(eps,binom.prob[1:2])),
	case1=as.integer(nobs1),
        case2=as.integer(nobs2),
        subject=as.double(resp),  # numsubj*(total+2)
	iout=as.integer(print.level),
        hab=double(maxmother*total1),
        hac=double(maxmother*total2),
        had=double(maxmother*total3),
        ha=double(maxmother),
        v1=double(binom.mix[1]),
        v2=double(binom.mix[2]),
        h1choo=double(binom.mix[1]),
        h2choo=double(binom.mix[2]),
        hn=double(binom.mix[2]),
        h1=double(binom.mix[1]),
        h2=double(binom.mix[2]),
        betakk=double(maxmother*maxkid),
        sig1kk=double(maxmother*maxkid),
        sig2kk=double(maxmother*maxkid),
        mother=integer(maxmother),
        rr=double(nind*maxmother*maxkid),
        r=double(nind*maxmother*maxkid),
        sn=double(nind*maxmother*maxkid),
        z=double(nind*maxmother*maxkid*total1),
        uu1=double(nind*maxmother*maxkid*total2),
        uu2=double(nind*maxmother*maxkid*total3),
        w=double(dimw),
        habb=double(maxmother*total1*total1),
        habs1=double(maxmother*total1*total2),
        habs2=double(maxmother*total1*total3),
        has1s1=double(maxmother*total2*total2),
        has1s2=double(maxmother*total2*total3),
        has2s2=double(maxmother*total3*total3),
        ebb=double(maxmother*total1*total1),
        ebs1=double(maxmother*total1*total2),
        ebs2=double(maxmother*total1*total3),
        fs1s1=double(maxmother*total2*total2),
        fs1s2=double(maxmother*total2*total3),
        gs2s2=double(maxmother*total3*total3),
        e2bb=double(maxmother*maxmother*total1*total1),
        e2bs1=double(maxmother*maxmother*total1*total2),
        e2bs2=double(maxmother*maxmother*total1*total3),
        f2s1s1=double(maxmother*maxmother*total2*total2),
        f2s1s2=double(maxmother*maxmother*total2*total3),
        g2s2s2=double(maxmother*maxmother*total3*total3),
	dup=F)
if(z0$res[3]>0)switch(as.character(z0$res[3]),
		"1"=warning("Maximum number of function evaluations has been used"),
		"2"=stop("Linear search failed to improve the function value. Either the function or the gradient is incorrectly coded"),
		"3"=stop("Search vector was not a descent direction. The convergence criterion may be too strict"))
z0$hess <- matrix(-z0$hess,ncol=total)
if(any(is.na(z0$hess)))a <- 0
else a <- qr(z0$hess)$rank
if(a==total)cov <- solve(z0$hess)
else cov <- matrix(NA,ncol=total,nrow=total)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
z <- list(
        call=call,
	mu=mu,
	re1=re1,
	re2=re2,
        maxlike=z0$Fvalue,
        aic=z0$Fvalue+total,
        df=nrow(resp)-total,
	total1=total1,
	total2=total2,
	total3=total3,
        coefficients=z0$x,
	regname=regname,
	re1name=re1name,
	re2name=re2name,
        se=se,
        cov=cov,
        corr=corr,
        grad=z0$g,
        iterations=z0$res[1],
	ifun=z0$res[2],
        code=z0$res[3])
class(z) <- "binnest"
return(z)}

print.binnest <- function(z){
	np <- z$total1+z$total2+z$total3
	cat("\nNested binomial model\n")
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n-Log likelihood     ",z$maxlike,"\n")
	cat("Degrees of freedom  ",z$df,"\n")
	cat("AIC                 ",z$aic,"\n")
	cat("Iterations          ",z$iter,"\n")
	cat("Function evaluations",z$ifun,"\n")
	cat("\nFixed effect parameters\n")
	coef.table <- cbind(z$coef[1:z$total1],z$se[1:z$total1])
	dimnames(coef.table) <- list(z$regname, c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	if(z$total2>0){
		cat("\nFirst level random effects parameters\n")
		num <- (z$total1+1):(z$total1+z$total2)
		coef.table <- cbind(z$coef[num],z$se[num])
		dimnames(coef.table) <- list(z$re1name,c("estimate", "se"))
		print.default(coef.table, digits=4, print.gap=2)}
	if(z$total3>0){
		cat("\nSecond level random effects parameters\n")
		num <- (z$total1+z$total2+1):np
		coef.table <- cbind(z$coef[num],z$se[num])
		dimnames(coef.table) <- list(z$re2name,c("estimate", "se"))
		print.default(coef.table, digits=4, print.gap=2)}
	cat("\nCorrelations\n")
	dimnames(z$corr) <- list(seq(1,np),seq(1,np))
	print.default(z$corr, digits=4)
}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     biv.betab(freq, x=NULL, p, depend=T, print.level=0,
#	typsiz=abs(p), ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p),
#	steptol=0.00001, iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit a bivariate beta-binomial regression

biv.betab <- function(freq, x=NULL, p, depend=T, print.level=0,
	typsiz=abs(p), ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p),
	steptol=0.00001, iterlim=100, fscale=1){
like <- function(p){
	dll <- 0
	for(kk in 1:n){
		tt1 <- p[1]*(y[kk,2]+y[kk,3]+2*y[kk,4])
		if(depend)tt1 <- tt1+p[2]*y[kk,4]
		if(full)for(i in 1:np)
			tt1 <- tt1+p[i+pn]*(x[kk,i]*(y[kk,2]+y[kk,4])+x[kk,i+np]*(y[kk,3]+y[kk,4]))
		dll <- dll+tt1
		tt2 <- 1
		t1 <- t2 <- p[1]
		if(full)for(i in 1:np){
			t1 <- t1+p[i+pn]*x[kk,i]
			t2 <- t2+p[i+pn]*x[kk,i+np]}
		tt2 <- tt2+exp(t1)+exp(t2)
		t1 <- 2*p[1]
		if(depend)t1 <- t1+p[2]
		if(full)for(i in 1:np)t1 <- t1+p[i+pn]*(x[kk,i]+x[kk,i+np])
		tt2 <- tt2+exp(t1)
		dll <- dll-(y[kk,1]+y[kk,2]+y[kk,3]+y[kk,4])*log(tt2)}
	-dll}
call <- sys.call()
if(!is.matrix(y))stop("y must be a matrix")
else n <- dim(y)[1]
if(missing(x))np <- 0
else if(!is.matrix(x))stop("x must be a matrix")
else  {
	np <- dim(x)[2]/2
	if(trunc(dim(x)[2]/2)!=np)stop("x must contain an even number of columns")}
if(!dim(y)[2]==4)stop("y must have four columns")
if(!missing(x)&&!dim(y)[1]==dim(x)[1])stop("x and y must have the same number of rows")
full <- np>0
if(length(p)!=np+1+depend)stop(paste(np+1+depend,"parameter estimates must be supplied"))
pn <- depend+1
z0 <- nlm(like, p=p, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
np <- length(p)
a <- qr(z0$hessian)
if(a$rank==np)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
z1 <- list(
	call=call,
	maxlike=z0$minimum,
	aic=z0$minimum+length(p),
	coefficients=z0$estimate,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "bevbetab"
return(z1)}

print.bevbetab <- function(z) {
	np <- length(z$coef)
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("-Log likelihood   ",z$maxlike,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	cat("Parameter estimates:\n")
	coef.table <- cbind(z$coef,z$se)
	dimnames(coef.table) <- list(seq(1,np), c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	if(np>1){
		cat("\nCorrelations:\n")
		dimnames(z$corr) <- list(seq(1,np),seq(1,np))
		print.default(z$corr, digits=4)}
	invisible(z)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     biv.binom(freq, marg1=~1, marg2=~1, interaction=~1, pmarg1=1,
#	pmarg2=1,pinteraction=1, print.level=0, typsiz=abs(p),
#	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p),
#	steptol=0.00001, iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit a marginal bivariate binomial regression

biv.binom <- function(freq, marg1=~1, marg2=~1, interaction=~1, pmarg1=1,
	pmarg2=1,pinteraction=1, print.level=0, typsiz=abs(p),
	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p),
	steptol=0.00001, iterlim=100, fscale=1){
like1 <- function(p){
	pia <- 1/(1+exp(dm1 %*% p[1:npt1]))
	pib <- 1/(1+exp(dm2 %*% p[(npt1+1):(npt1+npt2)]))
	psi <- exp(dm3 %*% p[(npt1+npt2+1):(npt1+npt2+npt3)])
	k1 <- 0.5/(psi-1)
	k2 <- 1+(pia+pib)*(psi-1)
	k3 <- 4*psi*(1-psi)*pia*pib
	k4 <- k1*(k2-sqrt(k2*k2+k3))
	s11 <- (psi!=1)*k4+(psi==1)*pia*pib
	s12 <- pia-s11
	s21 <- pib-s11
	s22 <- 1-s11-s12-s21
	ss[seq(1,n-3,by=4)] <- s11
	ss[seq(2,n-2,by=4)] <- s12
	ss[seq(3,n-1,by=4)] <- s21
	ss[seq(4,n,by=4)] <- s22
	list(like=-sum(freq*log(ss*(ss>0)+0.0001)),fitted=tot*ss,ss=ss)}
call <- sys.call()
if(!is.matrix(freq))stop("freq must be a matrix")
if(!dim(freq)[2]==4)stop("freq must have 4 columns")
freq <- as.vector(t(freq))
n <- length(freq)
nn <- n/4
tot <- rep(collapse(freq,as.integer(gl(nn,4,n))),rep(4,nn))
ss <- rep(0,n)
p <- c(pmarg1,pmarg2,pinteraction)
if(inherits(marg1,"formula")){
	mt <- terms(marg1)
	if(is.numeric(mt[[2]])){
		dm1 <- matrix(rep(1,nn),ncol=1)
		colnames(dm1) <- "(Intercept)"
		npt1 <- 1}
	else {
		mf <- model.frame(mt,sys.frame(sys.parent()),na.action=na.fail)
		dm1 <- model.matrix(mt, mf)
		npt1 <- dim(dm1)[2]}
	np <- npt1
	nam1 <- colnames(dm1)}
else stop("marg1 must be a model formula")
if(npt1!=length(pmarg1))
	stop(paste(npt1,"parameter estimates must be supplied for marg1"))
if(inherits(marg2,"formula")){
	mt <- terms(marg2)
	if(is.numeric(mt[[2]])){
		dm2 <- matrix(rep(1,nn),ncol=1)
		colnames(dm2) <- "(Intercept)"
		npt2 <- 1}
	else {
		mf <- model.frame(mt,sys.frame(sys.parent()),na.action=na.fail)
		dm2 <- model.matrix(mt, mf)
		npt2 <- dim(dm2)[2]}
	np <- np+npt2
	nam2 <- colnames(dm2)}
else stop("marg2 must be a model formula")
if(npt2!=length(pmarg2))
	stop(paste(npt2,"parameter estimates must be supplied for marg2"))
if(inherits(interaction,"formula")){
	mt <- terms(interaction)
	if(is.numeric(mt[[2]])){
		dm3 <- matrix(rep(1,nn),ncol=1)
		colnames(dm3) <- "(Intercept)"
		npt3 <- 1}
	else {
		mf <- model.frame(mt,sys.frame(sys.parent()),na.action=na.fail)
		dm3 <- model.matrix(mt, mf)
		npt3 <- dim(dm3)[2]}
	np <- np+npt3
	nam3 <- colnames(dm3)}
else stop("interaction must be a model formula")
if(npt3!=length(pinteraction))
	stop(paste(npt3,"parameter estimates must be supplied for interaction"))
like1a <- function(p) like1(p)$like
z1 <- nlm(like1a, p=p, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
fit <- like1(z1$estimate)$fitted
maxlike <- sum(fit-freq*log(fit)+lgamma(freq+1))
aic <- maxlike+length(p)+nn
cov <- solve(z1$hessian)
se <- sqrt(diag(cov))
z <- list(call=call,
	maxlike=maxlike,
	aic=aic,
	df=n-length(p)+nn,
	fitted.values=fit,
	coefficients=z1$estimate,
	npt=list(npt1,npt2,npt3),
	vnames=list(nam1,nam2,nam3),
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z1$gradient,
	iterations=z1$iterations,
	code=z1$code)
class(z) <- "bivbinom"
return(z)}

print.bivbinom <- function(z){
	npt1 <- z$npt[[1]]
	npt2 <- z$npt[[2]]
	npt3 <- z$npt[[3]]
	np <- npt1+npt2+npt3
	cat("Bivariate binomial marginal regression\n")
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("-Log likelihood   ",z$maxlike,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	cat("Margin one parameters:\n")
	coef.table <- cbind(z$coefficients[1:npt1], z$se[1:npt1])
	dimnames(coef.table) <- list(z$vnames[[1]], c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	cat("\nMargin two parameters:\n")
	coef.table <- cbind(z$coefficients[(npt1+1):(npt1+npt2)], z$se[(npt1+1):(npt1+npt2)])
	dimnames(coef.table) <- list(z$vnames[[2]], c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	cat("\nInteraction parameters:\n")
	coef.table <- cbind(z$coefficients[(npt1+npt2+1):(npt1+npt2+npt3)], z$se[(npt1+npt2+1):(npt1+npt2+npt3)])
	dimnames(coef.table) <- list(z$vnames[[3]], c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	cat("\nCorrelations:\n")
	dimnames(z$corr) <- list(seq(1,np),seq(1,np))
	print.default(z$corr, digits=4)}
capture <- function(z,n){
	aft <- bef <- rep(1,2^n-1)
	aa <- bb <- m <- rep(1,n)
	for(i in (1-n):-1){
		m[n+i] <- z$fit[1]+z$fit[2^(n+i-1)+1]
		aft <- aft*(2-rep(rep(1:2,rep(2^(n+i-1),2)),2^(-i))[1:(2^n-1)])
		aa[n+i] <- sum(aft*z$fit[1:(2^n-1)])
		bef <- bef*(2-rep(rep(1:2,rep(2^(-i),2)),2^(n+i-1))[1:(2^n-1)])
		bb[1-i] <- sum(bef*z$fit[1:(2^n-1)])}
	aa[n] <- bb[1] <- z$fit[1]
	cc <- aa[c(n,1:(n-1))]
	m[n] <- cc[n]
	ph <- z$fit[1]/m
	nest <- aa*m*bb/z$fit[1]^2
	phih <- aa*m/(cc*z$fit[1])
	if(max(ph[2:(n-1)])-min(ph[2:(n-1)])<=10^(-4)){
		nest <- nest*ph/ph[2]
		ph[1] <- ph[2]
		ph[n] <- ph[2]
		phih[n] <- z$fit[1]/(m[n]*ph[n])}
	phih[1] <- 1
	phih[n] <- phih[n]+(m[n-1]/m[n]-1)*10^(-4)*(phih[n-1]<=1-10^(-4))
	bh <- nest-phih*nest[c(n,1:(n-1))]
	bh[1] <- nest[1]
	zz <- cbind(1:n,nest,phih,ph,bh)
	colnames(zz) <- c("i","N(i)","Phi(i-1)","P(i)","B(i-1)")
	zz}

setup <- expression({
	p1 <- as.numeric(gl(2,1,2^n))-1
	pbd <- p2 <- as.numeric(gl(2,2,2^n))-1
	p3 <- as.numeric(gl(2,4,2^n))-1
	b2 <- i1 <- p1*p2
	d1 <- i2 <- p2*p3
	pb <- pbd+p3
	if(n>=4){
		p4 <- as.numeric(gl(2,8,2^n))-1
		d2 <- i3 <- p3*p4
		b3 <- b2*p3
		d1 <- d2*p2
		pbd <- pbd+p3
		pb <- pbd+p4}
	if(n>=5){
		p5 <- as.numeric(gl(2,16,2^n))-1
		d3 <- i4 <- p4*p5
		b4 <- b3*p4
		d2 <- d3*p3
		d1 <- d2*p2
		pbd <- pbd+p4
		pb <- pbd+p5}
	if(n>=6){
		p6 <- as.numeric(gl(2,32,2^n))-1
		d4 <- i5 <- p5*p6
		b5 <- b4*p5
		d3 <- d4*p4
		d2 <- d3*p3
		d1 <- d2*p2
		pbd <- pbd+p5
		pb <- pbd+p6}
	if(n>=7){
		p7 <- as.numeric(gl(2,64,2^n))-1
		d5 <- i6 <- p6*p7
		b6 <- b5*p6
		d4 <- d5*p5
		d3 <- d4*p4
		d2 <- d3*p3
		d1 <- d2*p2
		pbd <- pbd+p6
		pb <- pbd+p7}
	pw <- rep(1,2^n)
	pw[2^n] <- 0
	pd <- pbd+p1
	pc <- pb+p1})

#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     catmiss(response, frequency, ccov=NULL)
#
#  DESCRIPTION
#
#    A function to calculate marginal probabilities from the fitted
#  values of a log linear model

# Woolson and Clarke (1984) calculation of marginal probabilities

catmiss <- function(response, frequency, ccov=NULL){
	if(!is.matrix(response))stop("response must be a matrix")
	if(!is.vector(frequency,mode="numeric"))stop("frequency must be a vector")
	if(!is.null(ccov)){
		if(is.vector(ccov,mode="numeric")||is.vector(ccov,mode="character"))ccov <- matrix(ccov,ncol=1)
		else if(!is.matrix(ccov))stop("ccov must be a vector or matrix")}
	nr <- nrow(response)
	lf <- length(frequency)
	ncr <- ncol(response)
	response <- matrix(as.numeric(response),ncol=ncr)
	res <- sort(unique(response),na.last=T)
	nc <- length(res)-any(is.na(response))
	kron <- lf/nr
	if(trunc(kron)!=kron)stop("length of frequency must be a multiple of number of rows of response")
	if(!is.null(ccov)&&(nrow(ccov)*nr)!=lf)stop("ccov has incorrect number of rows")
# complete
	pc <- resp <- NULL
	for(i in 1:nrow(response))resp <-
		rbind(resp,if(any(is.na(response[i,])))rep(NA,ncr)
		else response[i,])
	for(i in 1:ncr){
	      tt <- as.matrix(tapply(frequency,list(rep(resp[,i],kron),gl(kron,nr,lf)),sum))
	      if(i==1)tot <- matrix(rep(rep(1,nc)%*%tt,nc),ncol=kron,byrow=T)
	      pc <- c(pc,as.vector(t(tt/tot)))}
	pc <- as.vector(matrix(pc,ncol=kron,byrow=T))
	coef.table <- cbind(pc,sqrt(pc*(1-pc)/rep(tot,rep(ncr,kron*nc))))
	cnames <- c("complete","se")
# all
if(any(is.na(response))){
	total <- rep(collapse(frequency,as.integer(gl(kron,nr,lf))),rep(nr,kron))
	prmat <- NULL
	b <- matrix(0,nrow=ncr*nc,ncol=ncr*(nc+1))
	for(i in 1:ncr){
	      jj <- 0
	      for(j in res[1:nc]){
		    jj <- jj+1
		    prmat <- rbind(prmat,as.numeric(!is.na(response[,i])&response[,i]==j))
		    b[jj+(i-1)*nc,jj+(i-1)*(nc+1)] <- 1
		    b[jj+(i-1)*nc,i*(nc+1)] <- -1}
	      prmat <- rbind(prmat,as.numeric(!is.na(response[,i])))}
	p1 <- diag(kron)%x%b
	p2 <- diag(kron)%x%prmat
	p3 <- frequency/total
	p4 <- as.vector(p2%*%p3)
	p <- as.vector(exp(p1%*%log(p4)))
	se <- diag(p)%*%p1%*%diag(1/p4)%*%p2
	coef.table <- cbind(coef.table,p,sqrt(diag(se%*%diag(p3*(1-p3)/total)%*%t(se))))
	cnames <- c(cnames,"all","se")}
#
	if(is.null(ccov))rnames <- paste(rep(1:nc,kron*ncr),rep(rep(1:ncr,rep(nc,ncr)),kron))
	else {
	     rnames <- NULL
	     for(i in 1:nrow(ccov)){
		tmp <- NULL   
		for(j in 1:ncol(ccov))tmp <- paste(tmp,ccov[i,j])
		rnames <- c(rnames,tmp)}
	     rnames <- paste(rep(1:nc,kron*ncr),rep(1:ncr,rep(nc,ncr)),rep(rnames,rep(ncr*nc,length(rnames))))}
	dimnames(coef.table) <- list(rnames,cnames)
	coef.table
}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     chidden(response, totals=NULL, times=NULL, distribution="Bernoulli",
#       pgamma, cmu=NULL, tvmu=NULL, pcmu=NULL, ptvmu=NULL, pshape=NULL,
#       pfamily=NULL, delta=1, print.level=0, ndigit=10, gradtol=0.00001,
#       steptol=0.00001, fscale=1, iterlim=100, typsiz=abs(p),
#	stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit hidden Markov chain models in continuous time

chidden <- function(response, totals=NULL, times=NULL,
	distribution="Bernoulli", pgamma, cmu=NULL,
	tvmu=NULL, pcmu=NULL, ptvmu=NULL, pshape=NULL,
	pfamily=NULL, delta=1, print.level=0, ndigit=10, gradtol=0.00001,
	steptol=0.00001, fscale=1, iterlim=100, typsiz=abs(p),
	stepmax=10*sqrt(p%*%p)){
likel <- function(p){
	if(is.function(cmu))pmu1 <- cmu(p[nm1:ncmu])
	if(is.function(tvmu))pmu2 <- tvmu(p[ncmu1:np1])
	if(np>np1){
		if(np3-np1==1)pshape <- rep(p[np3],states)
		else pshape <- p[np2:np3]}
	z <- .Fortran("chidden",
		x=as.double(p),
		as.integer(states),
		iq=as.integer(nosubj),
		nobs=as.integer(response$response$nobs),
		mobs=as.integer(mobs),
		s=as.double(response$response$y),
		n=as.integer(response$response$n),
		times=as.double(response$response$times),
		l=as.integer(l),
		pgamma=as.double(pgamma),
		gamma=double(states*states),
		val=double(states),
		vec=double(states*states),
		invec=double(states*states),
		model=as.integer(mdl),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np]),
		delta=double(states),
		nn=as.integer(nob),
		filter=double(states*nob),
		cf=as.logical(0),
		a=double(states),
		b=double(states*states),
		c=double(states),
		gmod=double(states*states),
		rhs=double(states),
		pivot=integer(states),
		qraux=double(states),
		work=double(2*states),
		like=double(1),
		DUP=F)
z$like}
like <- function(p){
	if(is.function(cmu))pmu1 <- cmu(p[nm1:ncmu])
	if(is.function(tvmu))pmu2 <- tvmu(p[ncmu1:np1])
	if(np>np1){
		if(np3-np1==1)pshape <- rep(p[np3],states)
		else pshape <- p[np2:np3]}
	z <- .Fortran("chidden",
		x=as.double(p),
		as.integer(states),
		iq=as.integer(nosubj),
		t=as.integer(response$response$nobs),
		mobs=as.integer(mobs),
		s=as.double(response$response$y),
		n=as.integer(response$response$n),
		times=as.double(response$response$times),
		l=as.integer(l),
		pgamma=as.double(pgamma),
		gamma=double(states*states),
		val=double(states),
		vec=double(states*states),
		invec=double(states*states),
		model=as.integer(mdl),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np]),
		delta=double(states),
		nn=as.integer(nob),
		filter=double(states*nob),
		cf=as.logical(1),
		a=double(states),
		b=double(states*states),
		c=double(states),
		gmod=double(states*states),
		rhs=double(states),
		pivot=integer(states),
		qraux=double(states),
		work=double(2*states),
		like=double(1),
		DUP=F)
	z$gamma <- matrix(0,ncol=states,nrow=states)
	z$gamma[ipos] <- p[1:nm]
	diag(z$gamma) <- -z$gamma%*%rep(1,states)
z}
call <- sys.call()
tmp <- c("Bernoulli","Poisson","multinomial","binomial","exponential",
	"beta binomial","negative binomial","normal","inverse Gauss",
	"logistic","Cauchy","Laplace","Levy","Pareto","gamma","Weibull",
	"gen gamma","gen logistic","Hjorth","Burr","gen Weibull",
	"gen extreme value","gen inverse Gauss","power exponential")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
if(!is.matrix(pgamma)||ncol(pgamma)!=nrow(pgamma)){
	if(length(pgamma)==1&pgamma==1)pgamma <- as.matrix(pgamma)
	else stop("pgamma must be a square transition matrix")}
states <- nrow(pgamma)
if(mdl>5){
	if(is.null(pshape))stop("pshape estimate must be supplied")
	else if(length(pshape)!=1&&length(pshape)!=states)
	     stop(paste("pshape must have 1 or",states,"estimates"))}
if(mdl>16){
	if(is.null(pfamily))stop("pfamily estimate must be supplied")
	else if(length(pshape)!=1)
	     stop(paste("pshape must have one estimate"))}
ipos <- pg <- NULL
if(states>1)for(i in 1:states){
	if(pgamma[i,i]!=0&sum(pgamma[i,])!=0)stop(paste("row",i,"of pgamma does not sum to 0"))
	for(j in 1:states)if(i!=j&&pgamma[i,j]!=0)
		ipos <- c(ipos,states*(j-1)+i)
	pg <- c(pg,pgamma[i,(1:states)!=i&pgamma[i,]!=0])}
if(!inherits(response,"repeated")){
	if(!inherits(response,"response")){
		if(is.vector(response,mode="numeric"))response <- matrix(response,nrow=1)
		response <- restovec(response,totals=totals,times=times,delta=delta)}
	if(!is.null(response$delta))delta <- response$delta
	response <- rmna(response=response)}
if((distribution=="binomial"||distribution=="beta binomial")&&is.null(response$response$n))stop("totals must be supplied")
if(mdl<6){
	if(any(response$response$y<0))stop("all responses must be non-negative")}
else if((mdl!=8)&&(mdl!=10)&&(mdl!=11)&&(mdl!=12)&&(mdl!=13)&&(mdl!=18)&&(mdl!=24)&&(any(response$response$y<=0)))
	stop("all responses must be positive")
nosubj <- length(response$response$nobs)
mobs <- max(response$response$nobs)
nob <- length(response$response$y)
if(distribution=="multinomial"){
	if(min(response$response$y)<1)stop("multinomial categories must be numbered from 1")
	l <- max(response$response$y)-1
	if(l<1)stop("multinomial response must have at least 2 categories")}
else l <- 1
if(is.function(cmu)){
	if(is.null(pcmu))stop("Initial values of pcmu must be supplied")
	d <- dim(cmu(pcmu))
	if(length(d)<2)stop("cmu must return an array")
	if(d[2]!=states)stop(paste("cmu must return a",states,"column array"))
	if(d[1]!=nosubj)
		stop("cmu must return an array with one row per individual")
	if(distribution=="multinomial"){
		if(length(d)!=3)stop("cmu must return a 3 dimensional array")
		if(d[3]!=l)stop(paste("cmu must return an array with",l,"layers"))}}
else pmu1 <- array(0,c(states,nosubj,l))
if(is.function(tvmu)){
	if(is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	d <- dim(tvmu(ptvmu))
	if(length(d)<2)stop("tvmu must return an array")
	if(d[2]!=states)stop("tvmu must return a",states,"column array")
	else if(d[1]!=mobs)
	     stop("tvmu must return an array with one row per time point")
	if(distribution=="multinomial"){
		if(length(d)!=3)stop("tvmu must return a 3 dimensional array")
		if(d[3]!=l)stop(paste("tvmu must return an array with",l,"layers"))}}
else pmu2 <- array(0,c(states,mobs,l))
if(!is.function(cmu)&&!is.function(tvmu))
	stop("Either cmu or tvmu must be a function")
nm <- length(pg)
nm1 <-  nm+1
ncmu <- length(pg)+length(pcmu)
ncmu1 <- ncmu+1
ntvmu <- length(ptvmu)
p <- c(pg,pcmu,ptvmu,pshape,pfamily)
np1 <- length(p)-length(pshape)-length(pfamily)
np2 <- np1+1
np3 <- length(p)-length(pfamily)
np <- length(p)
pshape <- rep(0,states)
z <- nlm(likel,p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
coef <- z$estimate[nm1:np]
pshape <- if(np3>np1)z$estimate[np2:np3] else NULL
pfamily <- if(np>np3)z$estimate[np] else NULL
maxlike <- z$minimum
delta <- if(!is.null(response$response$delta)) sum(log(response$response$delta)) else 0
maxlike <- z$minimum - if(mdl>7) delta else 0
z0 <- like(z$estimate)
if(any(is.na(z$hessian)))a <- 0
else a <- qr(z$hessian)$rank
if(a==np)cov <- solve(z$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
z1 <- list(
   call=call,
   distribution=distribution,
   response=response$response,
   maxlike=maxlike,
   aic=maxlike+np,
   states=states,
   cmu=cmu,
   tvmu=tvmu,
   coef=coef,
   pshape=pshape,
   pfamily=pfamily,
   ncmu=length(pcmu),
   ntvmu=length(ptvmu),
   gamma=matrix(z0$gamma,ncol=states),
   delta=z0$delta,
   cov=cov,
   corr=corr,
   se=se,
   filter=matrix(z0$filter,nrow=states),
   iterations=z$iter,
   code=z$code)
class(z1) <- "hidden"
z1}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gar(response, distribution="normal", times=NULL, totals=NULL,
#	censor=NULL, delta=NULL, mu=NULL, shape=NULL, shfn=F,
#	common=F, preg=NULL, pshape=NULL, pdepend=NULL,
#	transform="identity", link="identity", autocorr="exponential",
#	order=1, envir=sys.frame(sys.parent()), print.level=0, ndigit=10,
#	gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
#	typsiz=abs(p), stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit generalized nonlinear autoregression models with
#  various distributions

gar <- function(response, distribution="normal", times=NULL, totals=NULL,
	censor=NULL, delta=NULL, mu=NULL, shape=NULL, shfn=F, common=F,
	preg=NULL, pshape=NULL, pdepend=NULL, transform="identity",
	link="identity", autocorr="exponential", order=1,
	envir=sys.frame(sys.parent()),print.level=0, ndigit=10,
	gradtol=0.00001, steptol=0.00001,fscale=1, iterlim=100,
	typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
likekal <- function(p){
	eta <- mu1(p)
	if(sh){
		shr <- sh1(p)
		theta <- c(p[npr1:nprd],exp(p[np]))}
	else theta <- p[npr1:np]
	z <- .C("gar",
		y=y,
		total=response$response$n,
		my=as.integer(3*max(y)),
		nobs=as.integer(response$response$nobs),
		nind=as.integer(nind),
		times=as.double(response$response$times),
		censor=as.integer(censor),
		cens=as.integer(!is.null(response$response$censor)),
		eta=eta,
		theta=theta,
		model=as.integer(mdl),
		thp=as.integer(thp),
		shape=shr,
		sh=as.integer(sh),
		link=as.integer(lnk),
		ar=as.integer(ar),
		order=as.integer(order),
		pred=double(n),
		rpred=double(n),
		like=double(1),
		DUP=F)
	z$like+jacob}
call <- sys.call()
tmp <- c("binomial","Poisson","exponential","negative binomial",
	"mult Poisson","double Poisson","beta binomial","mult binomial",
	"double binomial","normal","logistic","Cauchy", "Weibull","gamma",
	"Laplace","inverse Gauss","Pareto","Levy","gen gamma",
	"gen logistic","Hjorth","Burr","gen Weibull","gen extreme value",
	"gen inverse Gauss","power exponential")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
tmp <- c("exponential","gaussian","cauchy","spherical","IOU")
ar <- match(autocorr <- match.arg(autocorr,tmp),tmp)
transform <- match.arg(transform,c("identity","exp","square","sqrt","log"))
tmp <- c("identity","exp","square","sqrt","log","logit","cloglog")
lnk <- match(link <- match.arg(link,tmp),tmp)
if((link=="logit"||link=="cloglog")&&(mdl!=1&&mdl!=7&&mdl!=8&&mdl!=9))stop("logit and cloglog links can only be used with binary data")
if(is.null(times)&&is.matrix(response))times <- matrix(1,nrow=nrow(response),ncol=ncol(response))
respenv <- inherits(response,"repeated")
envname <- if(respenv)paste(deparse(substitute(response)))
	else NULL
if(!respenv){
	if(!inherits(response,"response")){
		response <- if(mdl==1||mdl==7||mdl==8||mdl==9)restovec(response, times=times, censor=censor, delta=delta, totals=totals)
		else restovec(response, times=times, censor=censor, delta=delta)}
	response <- rmna(response=response)}
if((inherits(envir,"repeated")&&
	(length(response$response$nobs)!=length(envir$response$nobs)||
	any(response$response$nobs!=envir$response$nobs)))||
	(inherits(envir,"tvcov")&&
	(length(response$response$nobs)!=length(envir$tvcov$nobs)||
	any(response$response$nobs!=envir$tvcov$nobs))))
	stop("response and envir objects are incompatible")
if(mdl==1||mdl==7||mdl==8||mdl==9){
	if(is.null(response$response$n)){
		if(any(response$response$y!=0&&response$response$y!=1))stop("responses must be binary if totals are not supplied")
		else response$response$n <- rep(1,length(response$response$y))}}
y <- response$response$y
n <- length(y)
mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else if(inherits(envir,"tccov"))"tccov"
		else "tvcov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,envir=response,name=envname)
			else finterp(mu,envir=envir,name=envname)
		class(mu) <- c(class(mu),type)}
	else if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=response,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu3 <- mu
		if(respenv)attr(mu3,"model") <- tmp}
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,envir=response,name=envname)
			else finterp(shape,envir=envir,name=envname)
		class(shape) <- c(class(shape),type)}
	else if(is.function(shape)){
		tmp <- parse(text=paste(deparse(shape))[-1])
		class(shape) <- type
		shape <- if(respenv)fnenvir(shape,envir=response,name=envname)
			else fnenvir(shape,envir=envir,name=envname)
		sh3 <- shape
		if(respenv)attr(sh3,"model") <- tmp}}
npr <- length(preg)
npr1 <- npr+1
nprd <- npr+length(pdepend)
nprd1 <- if(common) 1 else nprd+1
if(inherits(mu,"formula")){
	mu2 <- if(respenv)finterp(mu,envir=response,name=envname)
		else finterp(mu,envir=envir,name=envname)
	npt1 <- length(attr(mu2,"parameters"))
	if(is.matrix(attr(mu2,"model"))){
		if(all(dim(attr(mu2,"model"))==1)){
			mu1 <- function(p) p[1]*rep(1,n)
			attributes(mu1) <- attributes(mu2)
			mu2 <- NULL}}
	else {
		if(npr!=npt1){
			cat("\nParameters are ")
			cat(attr(mu2,"parameters"),"\n")
			stop(paste("preg should have",npt1,"estimates"))}
		if(is.list(preg)){
			if(!is.null(names(preg))){
				o <- match(attr(mu2,"parameters"),names(preg))
				preg <- unlist(preg)[o]
				if(sum(!is.na(o))!=length(preg))stop("invalid estimates for mu - probably wrong names")}
			else preg <- unlist(preg)}}
	if(!is.null(mu2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			mu1 <- function(p) mu2(p)[cv]
			attributes(mu1) <- attributes(mu2)}
		else {
			mu1 <- mu2
			rm(mu2)}}}
else if(is.null(mu)){
	mu1 <- function(p) p[1]*rep(1,n)
	npt1 <- 1}
else mu1 <- mu
if(!is.null(mu1)&&is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=response))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=response))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu1))length(attr(mu1,"parameters"))
	else if(is.null(mu1))NULL
	else npt1
if(!is.null(nlp)&&!common&&nlp!=npr)
	stop(paste("preg should have",nlp,"initial estimates"))
nps <- length(pshape)
if(inherits(shape,"formula")){
	sh2 <- if(respenv)finterp(shape,envir=response,start=nprd1,name=envname)
		else finterp(shape,envir=envir,start=nprd1,name=envname)
	npt2 <- length(attr(sh2,"parameters"))
	if(is.matrix(attr(sh2,"model"))){
		if(all(dim(attr(sh2,"model"))==1)){
			sh1 <- function(p) p[nprd1]*rep(1,n)
			attributes(sh1) <- attributes(sh2)
			sh2 <- NULL}}
	else {
		if(nps!=npt2){
			cat("\nParameters are ")
			cat(attr(sh2,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh2,"parameters"),names(pshape))
				pshape <- unlist(pshape)[o]
				if(sum(!is.na(o))!=length(pshape))stop("invalid estimates for shape - probably wrong names")}
			else pshape <- unlist(pshape)}}
	if(!is.null(sh2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			sh1 <- function(p) sh2(p)[cv]
			attributes(sh1) <- attributes(sh2)}
		else {
			sh1 <- sh2
			rm(sh2)}}}
else if(!is.function(shape)&&distribution!="binomial"&&
	distribution!="Poisson"&&distribution!="exponential"&&
	distribution!="geometric"&&distribution!="logarithmic"){
	sh1 <- function(p) p[nprd1]*rep(1,n)
	if(length(pshape)!=1)stop("pshape must provide an estimate")}
else sh1 <- if(shfn)function(p) shape(p[nprd1:np], mu1(p))
	else function(p) shape(p[nprd1:np])
if(!is.null(sh1)&&is.null(attributes(sh1)))
	attributes(sh1) <- if(is.function(shape)){
		if(!inherits(shape,"formulafn")){
			if(respenv)attributes(fnenvir(shape,envir=response))
			else attributes(fnenvir(shape,envir=envir))}
		else attributes(shape)}
		else {
			if(respenv)attributes(fnenvir(sh1,envir=response))
			else attributes(fnenvir(sh1,envir=envir))}
nlp <- if(is.function(shape))length(attr(sh1,"parameters"))-shfn
	else if(is.null(shape))NULL
	else npt2
if(!is.null(nlp)&&!common&&nlp!=nps)
	stop(paste("pshape should have",nlp,"initial estimates"))
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(sh1,"parameters"))))
	if(nlp!=npr)stop(paste("with a common parameter model, preg should contain",nlp,"estimates"))}
if(mdl<10){
	if(any(y<0))stop("all responses must be non-negative")}
else if((mdl!=10)&&(mdl!=11)&&(mdl!=12)&&(mdl!=15)&&(mdl!=18)&&(mdl!=20)&&(mdl!=26)&&(any(y<=0)))
	stop("all responses must be positive")
else if(distribution=="Levy"&&any(response$response$y<=mu1(preg)))
	stop("location function must be strictly less than corresponding observation")
if(distribution=="Pareto"&&pshape<=1)stop("shape parameter must be > 1")
censor <- response$response$censor
if(is.null(censor))censor <- rep(1,n)
else if(mdl==1||mdl==2||mdl==4||mdl==5||mdl==6||mdl==7||mdl==8||mdl==9)stop(paste("Censored data not allowed for",distribution,"distribution"))
nind <- length(response$response$nobs)
if(transform=="identity")jacob <- 0
else if(transform=="exp"){
	jacob <- -sum(y[censor==1])
	y <- exp(y)}
else {
	if(any(y<0))stop("Nonpositive response values: invalid transformation")
	else if(transform=="square"){
		jacob <- -sum(log(y[y>0&censor==1]))
		y  <- y^2}
	else if(transform=="sqrt"){
		jacob <- sum(log(y[y>0&censor==1]))/2
		y <- sqrt(y)}
	else if(any(y==0))stop("Zero response values: invalid transformation")
	else if(transform=="log"){
		jacob <- sum(log(y[censor==1]))
		y <- log(y)}}
if(!is.null(response$response$delta)){
	if(length(response$response$delta)==1)
		jacob <- jacob-length(y[censor==1])*log(response$response$delta)
	else jacob <- jacob-sum(log(response$response$delta[censor==1]))}
if(order!=1&&order!=2)stop("Autoregression must have order 1 or 2")
if(is.null(pdepend))
	stop("Initial estimates of the dependence parameters must be supplied")
if(order==2&&length(pdepend)!=2)stop("2 estimates of dependence parameters must be given")
else if(length(pdepend)!=1&&length(pdepend)!=2)
     stop("One or two estimates of dependence parameters must be given")
thp <- length(pdepend)==2&&order==1
sh <- is.function(shape)||inherits(shape,"formula")
if(length(mu1(preg))!=length(response$response$y))
	stop("The mu function must provide an estimate for each observation")
else if(any(is.na(mu1(preg))))
	stop("Non-numerical mu: probably invalid initial values")
if(any(pdepend<=0))stop("All dependence parameters must be positive")
p <- c(preg,-log(pdepend))
if(mdl>3){
	if(!sh)p <- c(p,log(pshape))
	else {
	     if(mdl>=19)p <- if(common)c(p,log(pshape[nps]))
			else c(p,pshape[1:(nps-1)],log(pshape[nps]))
	     else p <- c(p,pshape)}}
np <- length(p)
if(!sh){
	if((mdl<=3&&nps!=0)||(mdl>3&&mdl<19&&nps!=1)||(mdl>=19&&nps!=2))
		stop("Incorrect number of shape parameter estimates")
	else if(nps>0&&any(pshape<=0))
		stop("All shape parameters must be positive")
	shr <- rep(0,length(response$response$y))}
else {
	if(any(is.na(sh1(p))))stop("The shape model returns NAs: probably invalid initial values")
	if(length(sh1(p))!=length(response$response$y))stop("The shape function must provide an estimate for each observation")}
if(fscale==1)fscale <- likekal(p)
if(is.na(likekal(p)))stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(likekal, p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
like <- z0$minimum
if(any(is.na(z0$hessian)))a <- 0
else a <- qr(z0$hessian)$rank
if(a==np)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
eta <- mu1(z0$estimate)
if(sh){
	shr <- sh1(z0$estimate)
	theta <- c(z0$estimate[npr1:nprd],exp(z0$estimate[np]))}
else theta <- z0$estimate[npr1:np]
z <- .C("gar",
	y=y,
	total=response$response$n,
	my=as.integer(3*max(y)),
	nobs=as.integer(response$response$nobs),
	nind=as.integer(nind),
	times=as.double(response$response$times),
	censor=as.integer(censor),
	cens=as.integer(!is.null(response$response$censor)),
	eta=eta,
	theta=theta,
	model=as.integer(mdl),
	thp=as.integer(thp),
	shape=shr,
	sh=as.integer(sh),
	link=as.integer(lnk),
	ar=as.integer(ar),
	order=as.integer(order),
	pred=double(n),
	rpred=double(n),
	like=double(1),
	DUP=F)
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
z <- list(
	call=call,
	distribution=distribution,
	mu=mu1,
	formula=mu,
	shape=shape,
	sh1=sh1,
	shfn=shfn,
	common=common,
	response=response$response,
	link=link,
	order=order,
	autocorr=autocorr,
	transform=transform,
	maxlike=like,
	aic=like+np,
	df=length(response$response$y)-np,
	np=np,
	npr=npr,
	nps=nps,
	thp=thp,
	coefficients=z0$estimate,
	se=se,
	cov=cov,
	corr=corr,
	pred=z$pred,
	rpred=z$rpred,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z) <- c("gar","recursive")
return(z)}

coefficients.gar <- function(z) z$coefficients
deviance.gar <- function(z) 2*z$maxlike
fitted.gar <- function(z, recursive=TRUE)
	if(recursive) z$rpred else z$pred
residuals.gar <- function(z, recursive=TRUE){
	if(z$transform=="exp")z$response$y <- exp(z$response$y)
	else if(z$transform=="square")z$response$y  <- z$response$y^2
	else if(z$transform=="sqrt")z$response$y <- sqrt(z$response$y)
	else if(z$transform=="log")z$response$y <- log(z$response$y)
	if(recursive) z$response$y-z$rpred else z$response$y-z$pred}

print.gar <- function(z, digits = max(3, .Options$digits - 3)) {
	np1 <- if(z$distribution=="binomial"||z$distribution=="exponential"
			||z$distribution=="Poisson") 0
		else if(z$distribution=="gen gamma"
			||z$distribution=="gen logistic"
			||z$distribution=="Hjorth"||z$distribution=="Burr"
			||z$distribution=="gen Weibull"
			||z$distribution=="gen extreme value"
			||z$distribution=="gen inverse Gauss"
			||z$distribution=="power exponential") 2
		else 1
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("Number of subjects    ",length(z$response$nobs),"\n")
	cat("Number of observations",length(z$response$y),"\n")
	cat("Transformation        ",z$trans,"\n")
	cat("Link function         ",z$link,"\n\n")
	cat(z$distribution,"distribution\n")
	if(z$order==1)cat("First order ")
	else cat("Second order ")
	cat(z$autocorr,"dependence\n")
	cat("\n-Log likelihood   ",z$maxlike,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	if(z$common)cat("Location model\n")
	else cat("Location parameters\n")
	if(!is.null(attr(z$mu,"formula")))
		cat(deparse(attr(z$mu,"formula")),sep="\n")
	else if(!is.null(attr(z$mu,"model"))){
		t <- deparse(attr(z$mu,"model"))
		t[1] <- sub("expression\\(","",t[1])
		t[length(t)] <- sub("\\)$","",t[length(t)])
		cat(t,sep="\n")}
	cname <- if(is.matrix(attr(z$mu,"model")))
		colnames(attr(z$mu,"model"))
		else attr(z$mu,"parameters")
	coef.table <- cbind(z$coef[1:z$npr],z$se[1:z$npr])
	colname <- c("estimate","se")
	if(!z$common){
		dimnames(coef.table) <- list(cname,colname)
		print.default(coef.table, digits=digits, print.gap=2)}
	else {
		cat("\nShape model\n")
	        if(!is.null(attr(z$sh1,"formula")))
	        	cat(deparse(attr(z$sh1,"formula")),sep="\n")
	        else if(!is.null(attr(z$sh1,"model"))){
	        	t <- deparse(attr(z$sh1,"model"))
	        	t[1] <- sub("expression\\(","",t[1])
	        	t[length(t)] <- sub("\\)$","",t[length(t)])
	        	cat(t,sep="\n")}
	        cname <- c(cname,if(is.matrix(attr(z$sh1,"model")))
				colnames(attr(z$sh1,"model"))
			else attr(z$sh1,"parameters")[1:(length(attr(z$sh1,"parameters"))-z$shfn)])
		cname <- unique(cname)
		cat("\nCommon parameters\n")
		dimnames(coef.table) <- list(cname,colname)
		print.default(coef.table, digits=digits, print.gap=2)}
	if(z$thp||z$order==2){
		cat("\nDependence parameters\n")
		if(z$thp)cname <- c("phi","rho")
		else cname <- c("rho1","rho2")
		coef.table <- cbind(z$coef[(z$npr+1):(z$npr+2)],
			z$se[(z$npr+1):(z$npr+2)],
			exp(-z$coef[(z$npr+1):(z$npr+2)]))}
	else {
		cat("\nDependence parameter\n")
		cname <- "rho"
		coef.table <- cbind(z$coef[z$npr+1],
			z$se[z$npr+1],exp(-z$coef[z$npr+1]))}
	dimnames(coef.table) <- list(cname, c("estimate","se","parameter"))
	print.default(coef.table, digits=digits, print.gap=2)
	if(np1>0&&!z$common){
		cat("\nShape parameters\n")
		if(is.null(z$shape)){
			cname <- "shape"
			if(np1==2)cname <- c(cname,"psi")
			coef.table <- cbind(z$coef[(z$np-np1+1):z$np],
				z$se[(z$np-np1+1):z$np],
				exp(z$coef[(z$np-np1+1):z$np]))
				dimnames(coef.table) <- list(cname, c("estimate","se","parameter"))}
		else {
	                if(!is.null(attr(z$sh1,"formula")))
	                	cat(deparse(attr(z$sh1,"formula")),sep="\n")
	                else if(!is.null(attr(z$sh1,"model"))){
	                	t <- deparse(attr(z$sh1,"model"))
	                	t[1] <- sub("expression\\(","",t[1])
	                	t[length(t)] <- sub("\\)$","",t[length(t)])
	                	cat(t,sep="\n")}
	                cname <- if(is.matrix(attr(z$sh1,"model")))
					colnames(attr(z$sh1,"model"))
				else attr(z$sh1,"parameters")[1:(length(attr(z$sh1,"parameters"))-z$shfn)]
			np2 <- length(cname)
			coef.table <- cbind(z$coef[(z$np-np2+1):z$np],
				z$se[(z$np-np2+1):z$np])
			dimnames(coef.table) <- list(cname, c("estimate","se"))
	                if(np1==2){
	                	cname[length(cname)] <- "psi"
	                	coef.table <- cbind(coef.table,c(rep(NA,nrow(coef.table)-1),exp(z$coef[z$np])))
	                	colname <- c(colname,"parameter")}}
		print.default(coef.table,digits=digits,print.gap=2)}
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     glmm(formula, family=gaussian, data=list(), weights=NULL,
#	offset=NULL, nest, delta=1, maxiter=20, points=10, print.level=0,
#	control=glm.control(epsilon=0.0001,maxit=10,trace=FALSE))
#
#  DESCRIPTION
#
#    A function to fit generalized linear mixed models with normal
#  random effect

# does not work: na.omit
glmm <- function(formula, family=gaussian, data=list(), weights=NULL,
	offset=NULL, nest, delta=1, maxiter=20, points=10, print.level=0,
	control=glm.control(epsilon=0.0001,maxit=10,trace=FALSE)){
	call <- sys.call()
	md <- missing(data)
	if(missing(data))data <- sys.frame(sys.parent())
	mf <- model.frame(terms(formula,data=data),data,na.action=na.fail)
	slen <- nrow(mf)
	if(is.character(family))family <- get(family)
	if(is.function(family))family <- family()
	if(is.vector(mf[,1])){
		y <- as.vector(mf[,1])
		if(family$family=="binomial")y2 <- rep(1,length(y))-y}
	else {
		y <- as.vector(mf[,1][,1])
		y2 <- as.vector(mf[,1][,2])}
	slen <- length(y)
	if(length(nest)!=slen)stop("the nesting variable is not the same length as the other variables")
	if(is.factor(nest))nest <- codes(nest)
	nind <- length(unique(nest))
	if(length(nest)==nind&&family$family!="binomial"&&family$family!="poisson")stop("Some individuals must have more than one observation")
	i <- rep(1:slen,points)
	ii <- rep(1:nind,points)
	k <- NULL
	for(j in 1:points)k <- c(k,nest+(j-1)*max(nest))
	k <- as.integer(k)
	quad <- gauss.hermite(points)
	sd <- quad[rep(1:points,rep(slen,points)),1]
	qw <- quad[rep(1:points,rep(nind,points)),2]
	nmodel <- update.formula(formula,.~.+sd)
	nnmf <- if(md)mf[i,,drop=F] else data[i,,drop=F]
	if(is.null(weights))lwt <- rep(1,slen)
	else lwt <- as.vector(weights)
	nobs <- sum(lwt)
	if(is.null(offset))offset <- rep(0,slen)
	else if(!is.data.frame(data))stop("offset can only be used when a data.frame is specified")
	if(is.data.frame(data)){
		if(is.null(weights))weights <- rep(1,slen)
		data <- cbind(data,weights,offset)
		zz <- glm(formula,family=family,data=data,control=control,weights=weights)}
	else {
		if(!is.null(weights))stop("weights can only be used when a data.frame is specified")
		zz <- glm(formula,family=family,data=data,control=control)}
	offset <- offset[i]
	ndev <- zz$deviance
	rdf <- zz$df.res-1
	ndf <- zz$df.null
	fv <- family$linkinv(zz$linear[i]+sd)
	sc <- ndev/nobs
	fpw <- switch(family$family,
		binomial= function()
			y*log(fv+0.0001)+(y2)*log(1-fv+0.0001),
		poisson= function() -fv+y*log(fv),
		Gamma= function() (log(y/fv)-y/fv)/sc,
		gaussian= function() -(y-fv)^2/sc/2,
		inverse.gaussian= function() -(y-fv)^2/(y*fv^2)/(2*sc))
	for(j in 1:maxiter){
		under  <- 0
		odev <- ndev
		ppr <- NULL
		for(ij in split(lwt*fpw(),k))ppr <- c(ppr,sum(ij))
		if(any(is.na(ppr)))stop("NAs - try another link function")
		if(max(ppr)-min(ppr)>1410){
			if(print.level==2)cat("Log probabilities:\n",ppr,"\n\n")
			stop("Product of probabilities is too small to calculate.\n Try fewer points.")}
		if(any(ppr > 705))under <- 705-max(ppr)
		else if(any(ppr < -705))under <- -705-min(ppr)
		pw <- qw*exp(ppr+under)
		pr <- NULL
		for(ij in split(pw,ii))pr <- c(pr,sum(ij))
		pw <- lwt*(pw/pr[ii])[k]
		nmf <- data.frame(nnmf,sd,pw,offset)
		z <- glm(nmodel,family=family,data=nmf,weights=pw,
			offset=offset,control=control)
		fv <- family$linkinv(z$linear)
		ndev <- -sum(log(pr)-under)
		sc <- z$dev/nobs
		if((odev-ndev)^2<0.00001)break}
	z$deviance <- -2*sum(log(pr)-under)
	formula <- update.formula(formula,.~1)
	class(formula) <- "formula"
	if(is.data.frame(data))
		zz <- glm(formula,family=family,data=data,control=control,weights=weights)
	else zz <- glm(formula,family=family,data=data,control=control)
	switch(family$family,
		binomial={
			sc <- NULL
			z$aic <- z$deviance-2*sum(lwt*lchoose(y+y2,y))
			z$deviance <- z$deviance+2*sum(lwt*(y*
				log(ifelse(y,y,1))+y2*log(ifelse(y2,y2,1))
				-(y+y2)*log(ifelse(y+y2,y+y2,1))))},
		poisson={
			sc <- NULL
			z$aic <- z$deviance+2*sum(lwt*lgamma(y+1))
			z$deviance <- z$deviance+2*sum(lwt*(-y+
				y*log(ifelse(y,y,1))))},
		Gamma={
			sc1 <- zz$dev/sum(lwt)
			z$null.deviance <- 2*sum(lwt*(log(sc1)/sc1-(log(y/zz$fit)-y/zz$fit)/sc1+log(y)+lgamma(1/sc1)-log(delta)))
			z$deviance <- z$deviance+2*sum(lwt*(log(sc)/sc+log(y)+lgamma(1/sc)-log(delta)))
			z$aic <- z$deviance+2},
		gaussian={
			z$null.deviance <- sum(lwt)*(log(2*pi*zz$dev/sum(lwt))+1)-2*sum(lwt*log(delta))
			z$deviance <- z$deviance+sum(lwt)*log(2*pi*sc)-2*sum(lwt*log(delta))
			z$aic <- z$deviance+2},
		inverse.gaussian={
			z$null.deviance <- sum(lwt*(log(2*pi*zz$dev/sum(lwt)*y^3))+1-2*log(delta))
			z$deviance <- z$deviance+sum(lwt*(log(2*pi*sc*y^3)-2*log(delta)))
			z$aic <- z$deviance+2})
	z$call <- call
	z$aic <- z$aic+2*z$qr$rank
	z$df.null <- ndf-!is.null(sc)
	z$df.residual <- rdf-!is.null(sc)
	z$iter <- j
	z$scale <- sc
	class(z) <- c("glmm",class(z))
	z}

print.glmm <- function(z,...){
	print.glm(z,...)
	if(!is.null(z$scale)){
		cat("\nModel deviances are -2 log likelihood\n")
		cat("Model dispersion:      ",z$scale,"\n")}
	cat("Normal mixing variance:",z$coef[names(z$coef)=="sd"]^2,"\n")}

print.summary.glmm <- function(z,...){
	print.summary.glm(z,...)
	if(!is.null(z$scale)){
		cat("Model deviances are -2 log likelihood\n")
		cat("Model dispersion:      ",z$scale,"\n")}
	cat("Normal mixing variance:",z$coef[rownames(z$coef)=="sd",1]^2,"\n")}

summary.glmm <- function(z,...){
	zz <- summary.glm(z,...)
	class(zz) <- c("summary.glmm",class(zz))
	if(!is.null(z$scale))zz$scale <- z$scale
	zz}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gnlmm(y, distribution="normal", mu=NULL, shape=NULL, linear=NULL,
#	nest=NULL, pmu=NULL, pshape=NULL, psd=NULL, exact=F, wt=1,
#	delta=1, shfn=F, scale=NULL, points=10, common=F,
#	envir=sys.frame(sys.parent()), print.level=0, typsiz=abs(p),
#	ndigit=10, gradtol=0.00001, stepmax=sqrt(p%*%p)/10,
#	steptol=0.00001, iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit generalized nonlinear mixed models with normal
#  random effect

gnlmm <- function(y, distribution="normal", mu=NULL, shape=NULL, linear=NULL,
	nest=NULL, pmu=NULL, pshape=NULL, psd=NULL, exact=F, wt=1, delta=1,
	shfn=F, scale=NULL, points=10, common=F, envir=sys.frame(sys.parent()),
	print.level=0, typsiz=abs(p), ndigit=10, gradtol=0.00001,
	stepmax=sqrt(p%*%p)/10, steptol=0.00001, iterlim=100, fscale=1){

pinvgauss <- function(y,m,s){
	t <- y/m
	v <- sqrt(y*s)
	pnorm((t-1)/v)+exp(2/(m*s))*pnorm(-(t+1)/v)}
plaplace <- function(y,m,s){
	u <- (y-m)/s
	t <- exp(-abs(u))/2
	ifelse(u<0,t,1-t)}
plevy <- function(y, m, s)
	.C("plevy",
		as.double(y),
		as.double(m),
		as.double(s),
		as.double(1),
		len=as.integer(n),
		eps=as.double(1.0e-6),
		pts=as.integer(5),
		max=as.integer(16),
		err=integer(1),
		res=double(n),
		DUP=F)$res

call <- sys.call()
if(!missing(distribution)&&!is.function(distribution)){
	distribution <- match.arg(distribution,c("binomial","beta binomial",
	"double binomial","mult binomial","Poisson","negative binomial",
	"double Poisson","mult Poisson","gamma count","Consul","logarithmic",
	"geometric","normal","inverse Gauss","logistic","exponential","gamma",
	"Weibull","extreme value","Pareto","Cauchy","Laplace","Levy"))}
shp <- distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"
if(common){
	if(!is.function(mu))stop("with common parameters, mu must be a function")
	if(!is.function(shape))stop("with common parameters, shape must be a function")
	if(!is.null(linear))stop("linear cannot be used with common parameters")}
if(!missing(scale))scale <- match.arg(scale,c("identity","log","logit",
	"reciprocal","exp"))
if(!missing(pmu))npl <- length(pmu)
else npl <- 0
if(!missing(pshape))nps <- length(pshape)
else nps <- 0
if(missing(psd))stop("An initial value of psd must be supplied")
np <- npl+nps+1
if(np<1)stop("At least one parameter must be estimated")
if(is.function(distribution)){
	fcn <- distribution
	distribution <- "own"}
respenv <- inherits(y,"repeated")
envname <- if(respenv)paste(deparse(substitute(y)))
	else NULL
lin1 <- lin2 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]}
else lin1 <- linear
if(inherits(mu,"formula"))lin1 <- mu
if(inherits(shape,"formula"))lin2 <- shape
lin1a <- lin2a <- mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else if(inherits(envir,"tccov"))"tccov"
		else "tvcov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(lin1,"formula")){
		if(is.function(mu)){
			lin1a <- if(respenv)finterp(lin1,envir=y,name=envname)
			else finterp(lin1,envir=envir,name=envname)}
		class(lin1) <- c(class(lin1),type)}
	if(inherits(lin2,"formula")){
		if(is.function(shape)){
			lin2a <- if(respenv)finterp(lin2,envir=y,name=envname)
			else finterp(lin2,envir=envir,name=envname)}
		class(lin2) <- c(class(lin2),type)}
	if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=y,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu3 <- mu
		if(respenv)attr(mu3,"model") <- tmp}
	if(is.function(shape)){
		tmp <- parse(text=paste(deparse(shape))[-1])
		class(shape) <- type
		shape <- if(respenv)fnenvir(shape,envir=y,name=envname)
			else fnenvir(shape,envir=envir,name=envname)
		sh3 <- shape
		if(respenv)attr(sh3,"model") <- tmp}}
if(inherits(lin1,"formula")){
	mu2 <- if(respenv)finterp(lin1,envir=y,name=envname)
		else finterp(lin1,envir=envir,name=envname)
	npt1 <- length(attr(mu2,"parameters"))
	if(is.matrix(attr(mu2,"model"))){
		if(all(dim(attr(mu2,"model"))==1)){
			if(is.function(mu)){
				lin1 <- mu2
				mu1 <- function(p) mu(p,p[npl-1]*rep(1,n))}
			else {
				mu1 <- function(p) p[1]*rep(1,n)
				attributes(mu1) <- attributes(mu2)}
			mu2 <- NULL}
		else {
			if(is.function(mu)){
				lf <- if(inherits(mu,"formulafn"))length(attr(mu,"parameters"))
					else length(if(respenv)attr(fnenvir(mu,envir=y),"parameters")
						else attr(fnenvir(mu,envir=envir),"parameters"))
				dm1 <- attr(mu2,"model")
				lin1 <- mu2
				mu2 <- function(p) mu(p,dm1%*%p[lf:(lf+npt1-1)])}}}
	else {
		if(is.function(mu)){
			warning("ignoring mu function\n")
			mu <- mu2 <- NULL}
		if(npl!=npt1){
			cat("\nParameters are ")
			cat(attr(mu2,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu2,"parameters"),names(pmu))
				pmu <- unlist(pmu)[o]
				if(sum(!is.na(o))!=length(pmu))stop("invalid estimates for mu - probably wrong names")}
			else pmu <- unlist(pmu)}}
	if(!is.null(mu2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			mu1 <- function(p) mu2(p)[cv]
			attributes(mu1) <- attributes(mu2)}
		else {
			mu1 <- mu2
			rm(mu2)}}}
else if(!is.function(mu)){
	mu1 <- function(p) p[1]*rep(1,n)
	npt1 <- 1}
else {
	mu1 <- mu
	if(length(mu1(pmu))==1)mu1 <- function(p) mu(p)*rep(1,n)}
if(is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=y))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=y))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu)){
		if(is.null(lin1))length(attr(mu1,"parameters"))
		else length(attr(mu1,"parameters"))-1+npt1}
       else npt1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl <- if(common) 1 else npl+1
npl1 <- npl+1
if(inherits(lin2,"formula")){
	sh2 <- if(respenv)finterp(lin2,envir=y,start=npl1,name=envname)
		else finterp(lin2,envir=envir,start=npl1,name=envname)
	npt2 <- length(attr(sh2,"parameters"))
	if(is.matrix(attr(sh2,"model"))){
		if(all(dim(attr(sh2,"model"))==1)){
			if(is.function(shape)){
				lin2 <- sh2
				sh1 <- function(p) shape(p[npl1:np],p[np]*rep(1,n))}
			else {
				sh1 <- function(p) p[npl1]*rep(1,n)
				sh3 <- fnenvir(function(p) p[1]*rep(1,n))
				attributes(sh1) <- attributes(sh2)}
			sh2 <- NULL}
		else {
			if(is.function(shape)){
				lfs <- if(inherits(shape,"formulafn"))length(attr(shape,"parameters"))
					else length(if(respenv)attr(fnenvir(shape,envir=y),"parameters")
						else attr(fnenvir(shape,envir=envir),"parameters"))
				dm2 <- attr(sh2,"model")
				sh1 <- if(shfn)function(p) shape(p[npl1:np],dm2%*%p[(npl+lfs):np], mu1(p))
				else function(p) shape(p[npl1:np],dm2%*%p[(npl+lfs):np])}}}
	else {
		if(is.function(shape)){
			warning("ignoring shape function\n")
			shape <- sh2 <- NULL}
		if(nps!=npt2){
			cat("\nParameters are ")
			cat(attr(sh2,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh2,"parameters"),names(pshape))
				pshape <- unlist(pshape)[o]
				if(sum(!is.na(o))!=length(pshape))stop("invalid estimates for shape - probably wrong names")}
			else pshape <- unlist(pshape)}}
	if(!is.null(sh2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			sh1 <- function(p) sh2(p)[cv]
			attributes(sh1) <- attributes(sh2)}
		else {
			sh1 <- sh2
			rm(sh2)}}}
else if(!is.function(shape)&&shp){
	sh1 <- function(p) p[npl1]*rep(1,n)
	sh3 <- fnenvir(function(p) p[1]*rep(1,n))
	npt2 <- 1}
else if(shp){
	sh1 <- if(shfn)function(p) shape(p[npl1:np], mu1(p))
		else function(p) shape(p[npl1:np])}
else sh1 <- NULL
if(shp){
	if(is.null(attributes(sh1))){
		attributes(sh1) <- if(is.function(shape)){
			if(!inherits(shape,"formulafn")){
				if(respenv)attributes(fnenvir(shape,envir=y))
				else attributes(fnenvir(shape,envir=envir))}
			else attributes(shape)}
			else {
				if(respenv)attributes(fnenvir(sh1,envir=y))
				else attributes(fnenvir(sh1,envir=envir))}}
	nlp <- if(is.function(shape)){
			if(is.null(lin2))length(attr(sh1,"parameters"))-shfn
			else length(attr(sh1,"parameters"))-1+npt2-shfn}
		else npt2
	if(!common&&nlp!=nps)stop(paste("pshape should have",nlp,"initial estimates"))}
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(sh1,"parameters"))))-shfn
	if(nlp!=npl)stop(paste("with a common parameter model, pmu should contain",nlp,"estimates"))}
pmu <- c(pmu,psd)
p <- c(pmu,pshape)
if(respenv){
	if(inherits(envir,"repeated")&&(length(y$response$nobs)!=length(envir$response$nobs)||any(y$response$nobs!=envir$response$nobs)))stop("y and envir objects are incompatible")
	if(!is.null(y$response$wt)&&!is.na(y$response$wt))wt <- y$response$wt
	if(!is.null(y$response$delta))delta <- y$response$delta
	if(length(y$response$nobs)==1&&y$response$nobs==1)
		nest <- 1:length(y$response$y)
	else nest <- covind(y)
	y <- response(y)}
else if(inherits(y,"response")){
	if(inherits(envir,"repeated")&&(length(y$nobs)!=length(envir$response$nobs)||any(y$nobs!=envir$response$nobs)))stop("y and envir objects are incompatible")
	if(!is.null(y$wt)&&!is.na(y$wt))wt <- y$wt
	if(!is.null(y$delta))delta <- y$delta
	if(length(y$nobs)==1&&y$nobs==1)nest <- 1:length(y$y)
	else nest <- covind(y)
	y <- response(y)}
if(any(is.na(y)))stop("NAs in y - use rmna")
if(distribution=="binomial"||distribution=="double binomial"||
	distribution=="beta binomial"||distribution=="mult binomial"){
	if(length(dim(y))!=2||ncol(y)!=2)
		stop(paste("Two column matrix required for response: successes and failures"))
	if(any(y<0))stop("All response values must be positive")
	n <- nrow(y)
	nn <- y[,1]+y[,2]
	censor <- F}
else {
	censor <- length(dim(y))==2&&ncol(y)==2
	if(censor&&all(y[,2]==1)){
		y <- y[,1]
		censor <- F}
	if(!censor){
		if(!is.vector(y,mode="numeric"))stop("y must be a vector")
		n <- length(y)
		if(distribution=="double Poisson"||distribution=="mult Poisson")
			my <- 3*max(y)}}
if((distribution=="inverse Gauss"||distribution=="exponential"||
	distribution=="gamma"||distribution=="Weibull"||
	distribution=="extreme value")&&((censor&&any(y[,1]<=0))||
	(!censor&&any(y<=0))))stop("All response values must be > 0")
if((distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="gamma count"||distribution=="double Poisson"||
	distribution=="mult Poisson")&&(any(y<0)))
	stop("All response values must be >= 0")
if(distribution=="logarithmic"&&any(y[wt>0]<1))
	stop("All response values must be integers > 0")
if(censor){
	n <- nrow(y)
	y[,2] <- as.integer(y[,2])
	if(any(y[,2]!=-1&y[,2]!=0&y[,2]!=1))
		stop("Censor indicator must be -1s, 0s, and 1s")
	cc <- ifelse(y[,2]==1,1,0)
	rc <- ifelse(y[,2]==0,1,ifelse(y[,2]==-1,-1,0))
	lc <- ifelse(y[,2]==-1,0,1)
	if(any(delta<=0&y[,2]==1))
		stop("All deltas for uncensored data must be positive")
	else {
		delta <- ifelse(delta<=0,0.000001,delta)
		delta <- ifelse(y[,1]-delta/2<=0,delta-0.00001,delta)}}
else {
	if(min(delta)<=0)stop("All deltas for must be positive")}
if(length(wt)==1)wt <- rep(wt,n)
else if(length(wt)!=n)stop("wt must be the same length as the other variables")
if(min(wt)<0)stop("All weights must be non-negative")
if(length(delta)==1)delta <- rep(delta,n)
else if(length(delta)!=n)stop("delta must be the same length as the other variables")
if(is.null(nest))stop("A nest vector must be supplied")
else if(length(nest)!=n)stop("nest must be the same length as the other variables")
if(is.factor(nest))nest <- codes(nest)
nind <- length(unique(nest))
od <- length(nest)==nind
i <- rep(1:n,points)
ii <- rep(1:nind,points)
k <- NULL
for(j in 1:points)k <- c(k,nest+(j-1)*max(nest))
k <- as.integer(k)
quad <- gauss.hermite(points)
sd <- quad[rep(1:points,rep(n,points)),1]
qw <- quad[rep(1:points,rep(nind,points)),2]
if(missing(scale)){
	if(distribution=="binomial"||distribution=="beta binomial"||
		distribution=="double binomial"||distribution=="mult binomial")
		scale <- "logit"
	else if(distribution=="normal"||distribution=="logistic"||
		distribution=="Cauchy"||distribution=="Laplace")
		scale <- "identity"
	else scale <- "log"}
mu2 <- if(scale=="logit") function(p){
		pp <- exp(log(mu1(p)/(1-mu1(p)))[i]+p[npl]*sd)
		pp/(1+pp)}
	else if(scale=="identity") function(p) mu1(p)[i]+p[npl]*sd
	else if(scale=="log") function(p) exp(log(mu1(p))[i]+p[npl]*sd)
	else if(scale=="reciprocal") function(p) 1/(1/mu1(p)[i]+p[npl]*sd)
	else if(scale=="exp") function(p) log(exp(mu1(p))[i]+p[npl]*sd)
if(any(is.na(mu2(pmu))))stop("The location model returns NAs")
if(distribution=="Levy"&&((!censor&&any(y<=mu1(pmu)))||(censor&&any(y[,1]<=mu1(pmu)))))
	stop("location parameter must be strictly less than corresponding observation")
if(distribution=="Pareto"&&exp(sh1(p))<=1)stop("shape parameters must be > 0")
if(distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"){
	if(any(is.na(sh1(p))))stop("The shape model returns NAs")
	if(od)stop("Some individuals must have more than one observation")}
if (!censor){
	ret <- switch(distribution,
	binomial={
		fcn <- function(p) {
			m <- mu2(p)
			-wt*(y[,1]*log(m)+y[,2]*log(1-m))}
		const <- -wt*lchoose(nn,y[,1])},
	"beta binomial"={
		fcn <- function(p) {
			m <- mu2(p)
			s <- exp(sh1(p))
			t <- s*m
			u <- s*(1-m)
			-wt*(lbeta(y[,1]+t,y[,2]+u)-lbeta(t,u))}
		const <- -wt*lchoose(nn,y[,1])},
	"double binomial"={
		fcn <- function(p) {
			-.C("ddb",as.integer(y[,1]),as.integer(nn),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(n),as.double(wt),res=double(n),
				DUP=F)$res}
		const <- 0},
	"mult binomial"={
		fcn <- function(p) {
			-.C("dmb",as.integer(y[,1]),as.integer(nn),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(n),as.double(wt),res=double(n),
				DUP=F)$res}
		const <- 0},
	Poisson={
		fcn <- function(p) {
			m <- mu2(p)
			-wt*(-m+y*log(m))}
		const <- wt*lgamma(y+1)},
	"negative binomial"={
		fcn <- function(p) {
			m <- mu2(p)
			t <- sh1(p)
			s <- exp(t)
			-wt*(lgamma(y+s)-lgamma(s)+s*t+y*log(m)
				-(y+s)*log(s+m))}
		const <- wt*lgamma(y+1)},
	"double Poisson"={
		fcn <- function(p) {
			-.C("ddp",as.integer(y),as.integer(my),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(length(y)),as.double(wt),
				res=double(length(y)),DUP=F)$res}
		const <- 0},
	"mult Poisson"={
		fcn <- function(p) {
			-.C("dmp",as.integer(y),as.integer(my),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(length(y)),as.double(wt),
				res=double(length(y)),DUP=F)$res}
		const <- 0},
	"gamma count"={
		fcn <- function(p) {
			m <- mu1(p)
			s <- exp(sh1(p))
			u <- m*s
			-wt*log(ifelse(y==0,1-pgamma(u,(y+1)*s,1),
				pgamma(u,y*s+(y==0),1)-
				pgamma(u,(y+1)*s,1)))}
		const <- 0},
	Consul={
		fcn <- function(p) {
			m <- mu2(p)
			t <- sh1(p)
			s <- exp(t)
			-wt*(log(m)-(m+y*(s-1))/s+(y-1)*log(m+y*(s-1))-y*t)}
		const <- wt*lgamma(y+1)},
	logarithmic={
		fcn <- function(p) {
			m <- exp(mu2(p))
			m <- m/(1+m)
			-wt*(y*log(m)-log(y)-log(-log(1-m)))}
		const <- 0},
	geometric={
		fcn <- function(p) {
			m <- mu2(p)
			-wt*(y*log(m)-(y+1)*log(1+m))}
		const <- 0},
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p)/2)
				-wt*log(pnorm(y+delta/2,m,s)
					-pnorm(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				t <- sh1(p)
				wt*(t+(y-mu2(p))^2/exp(t))/2}
			const <- wt*(log(2*pi)/2-log(delta))}},
        "inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				-wt*log(pinvgauss(y+delta/2,m,s)-
					pinvgauss(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				wt*(t+(y-m)^2/(y*exp(t)*m^2))/2}
			const <- wt*(log(2*pi*y^3)/2-log(delta))}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				-wt*log(plogis(y+delta/2,m,s)
					-plogis(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)*sqrt(3)/pi
				wt*((y-m)/s+t+2*log(1+exp(-(y-m)/s)))}
			const <- -wt*(log(pi/sqrt(3))+log(delta))}},
	Cauchy={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p)/2)
				-wt*log(pcauchy(y+delta/2,m,s)
					-pcauchy(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p)/2)
				wt*log(s*(1+(y-m)^2/s^2))}
			const <- -wt*log(delta/pi)}},
        Laplace={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				-wt*log(plaplace((y+delta/2-m)/s)
					-plaplace((y-delta/2-m)/s))}
			const <- 0}
		else {
			fcn <- function(p) {
				t <- sh1(p)
				wt*(abs(y-mu2(p))/exp(t)+t)}
			const <- -wt*log(delta/2)}},
        Levy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*log(plevy(y+delta/2,m,s)
					-plevy(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(0.5*log(s/(2*pi))-1.5*log(y-m)-
					s/(2*(y-m)))}
			const <- -wt*log(delta/2)}},
        Pareto={
		if(exact){
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*log((1+(y-delta/2)*t)^-s
					-(1+(y+delta/2)*t)^-s)}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*(log(s*t)-(s+1)*log(1+y*t))}
			const <- -wt*log(delta)}},
        exponential={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				-wt*log(-exp(-(y+delta/2)/m)
					+exp(-(y-delta/2)/m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				wt*(log(m)+y/m)}
			const <- -wt*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				u <- m/s
				-wt*log(pgamma(y+delta/2,s,u)
					-pgamma(y-delta/2,s,u))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(s*(t-log(m)-y/m)+(s-1)*log(y)-lgamma(s))}
			const <- -wt*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				-wt*log(pweibull(y+delta/2,s,m)
					-pweibull(y-delta/2,s,m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(t+(s-1)*log(y)-s*log(m)-(y/m)^s)}
			const <- -wt*log(delta)}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				ey <- exp(y[,1])
				-wt*log(pweibull(ey+ey*delta/2,s,m)
					-pweibull(ey-ey*delta/2,s,m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(t+s*y-s*log(m)-(exp(y)/m)^s)}
			const <- -wt*log(delta)}},
	own={ const <- 0})}
else {
	ret <- switch(distribution,
	Poisson={
		fcn <- function(p) {
			m <- mu2(p)
			-wt*(cc*(-m+y[,1]*log(m))+
				log(lc-rc*ppois(y[,1],m)))}
		const <- wt*cc*lgamma(y[,1]+1)},
	"negative binomial"={
		fcn <- function(p) {
			m <- mu2(p)
			t <- sh1(p)
			s <- exp(t)
			-wt*(cc*(lgamma(y[,1]+s)-lgamma(s)
				+s*t+y[,1]*log(m)-(y[,1]+s)*log(s+m))+
				log(lc-rc*pnbinom(y[,1],s,1/(1+m/s))))}
		const <- wt*cc*lgamma(y[,1]+1)},
	geometric={
		fcn <- function(p) {
			m <- mu2(p)
			-wt*(cc*(y[,1]*log(m)-(y[,1]+1)*log(1+m))+
				log(lc-rc*pgeom(y[,1],1/(1+m))))}
		const <- 0},
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p)/2)
				-wt*(cc*log(pnorm(y[,1]+delta/2,m,s)-
					pnorm(y[,1]-delta/2,m,s))
					+log(lc-rc*pnorm(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(-(t+(y[,1]-m)^2/s)/2)+log(lc-rc
					*pnorm(y[,1],m,sqrt(s))))}
			const <- wt*cc*(log(2*pi)/2-log(delta))}},
        "inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				-wt*(cc*log(pinvgauss(y[,1]+delta/2,m,s)-
					pinvgauss(y[,1]-delta/2,m,s))
					+log(lc-rc*pinvgauss(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(-(t+(y[,1]-m)^2/(y[,1]*s*m^2))/2)+
					log(lc-rc*pinvgauss(y[,1],m,s)))}
			const <- wt*cc*(log(2*pi*y[,1]^3)/2-log(delta))}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				-wt*(cc*log(plogis(y[,1]+delta/2,m,s)-
					plogis(y[,1]-delta/2,m,s))
					+log(lc-rc*plogis(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				y1 <- (y[,1]-m)/s
				-wt*(cc*(-y1-log(s)-2*log(1+exp(-y1)))
					+log(lc-rc*plogis(y[,1],m,s)))}
			const <- -wt*cc*log(delta)}},
	Cauchy={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p)/2)
				-wt*(cc*log(pcauchy(y[,1]+delta/2,m,s)-
					pcauchy(y[,1]-delta/2,m,s))
					+log(lc-rc*pcauchy(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p)/2)
				-wt*(-cc*log(s*(1+(y[,1]-m)^2/s^2))
					+log(lc-rc*pcauchy(y[,1],m,s)))}
			const <- -wt*cc*log(delta/pi)}},
        Laplace={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				-wt*(cc*log(plaplace((y[,1]+delta/2-m)/s)-
					plaplace((y[,1]-delta/2-m)/s))
					+log(lc-rc*plaplace((y[,1]-m)/s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(-abs(y[,1]-m)/s-t)+log(lc-rc
					*plaplace((y[,1]-m)/s)))}
			const <- -wt*cc*log(delta/2)}},
        Levy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(cc*log(plevy(y[,1]+delta/2,m,s)-
					plevy(y[,1]-delta/2,m,s))
					+log(lc-rc*plevy(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(0.5*log(s/(2*pi))-1.5*log(y[,1]-m)-
					s/(2*(y[,1]-m)))+log(lc-rc
					*plevy(y[,1],m,s)))}
			const <- -wt*cc*log(delta/2)}},
        Pareto={
		if(exact){
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*(cc*log((1+(y[,1]-delta/2)*t)^-s-
					(1+(y[,1]+delta/2)*t)^-s)
					+log(lc-rc*(-(1+(y[,1])*t)^-s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*(cc*(log(s*t)-(s+1)*log(1+y[,1]*t))
					+log(lc-rc*(1-(1+y[,1]*t)^-s)))}
			const <- -wt*cc*log(delta)}},
	exponential={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				-wt*(cc*log(-exp(-(y[,1]+delta/2)/m)
					+exp(-(y[,1]-delta/2)/m))+
					log(lc-rc*(1-exp(-y[,1]/m))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				-wt*(cc*(-log(m)-y[,1]/m)+log(lc-rc*
					(1-exp(-y[,1]/m))))}
			const <- -wt*cc*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				u <- m/s
				-wt*(cc*log(pgamma(y[,1]+delta/2,s,u)-
					pgamma(y[,1]-delta/2,s,u))
					+log(lc-rc*pgamma(y[,1],s,u)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(s*(t-log(m)-y[,1]/m)+(s-1)*log(y[,1])
					-lgamma(s))+log(lc-rc
					*pgamma(y[,1],s,m/s)))}
			const <- -wt*cc*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				-wt*(cc*log(pweibull(y[,1]+delta/2,s,m)-
					pweibull(y[,1]-delta/2,s,m))
					+log(lc-rc*pweibull(y[,1],s,m)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(t+(s-1)*log(y[,1])-s*log(m)
					-(y[,1]/m)^s)+log(lc-rc*
					pweibull(y[,1],s,m)))}
			const <- -wt*cc*log(delta)}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu2(p)
				s <- exp(sh1(p))
				ey <- exp(y[,1])
				-wt*(cc*log(pweibull(ey+ey*delta/2,s,m)-
					pweibull(ey-ey*delta/2,s,m))
					+log(lc-rc*pweibull(ey,s,m)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu2(p)
				t <- sh1(p)
				s <- exp(t)
				ey <- exp(y[,1])
				-wt*(cc*(t+s*y[,1]-s*log(m)-(ey/m)^s)+log(lc-
					rc*pweibull(ey,s,m)))}
			const <- -wt*cc*log(delta)}},
	own={const <- 0})}
fn <- function(p) {
	under  <- 0
	if(od)pr <- -fcn(p)
	else {
		pr <- NULL
		for(i in split(fcn(p),k))pr <- c(pr,-sum(i))}
	if(any(is.na(pr)))stop("NAs - unable to calculate probabilities.\n Try other initial values.")
	if(max(pr)-min(pr)>1400){
		if(print.level==2)cat("Log probabilities:\n",pr,"\n\n")
		stop("Product of probabilities is too small to calculate.\n Try fewer points.")}
	if(any(pr > 700))under <- 700-max(pr)
	else if(any(pr < -700))under <- -700-min(pr)
	tmp <- NULL
	for(i in split(qw*exp(pr+under),ii))tmp <- c(tmp,sum(i))
	-sum(log(tmp)-under)}
if(fscale==1)fscale <- fn(p)
if(is.na(fn(p)))
	stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(fn, p=p, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
z0$minimum <- z0$minimum+sum(const)
if(inherits(mu1,"formulafn")&&!is.matrix(attr(mu1,"model")))
	cname <- attr(mu1,"parameters")
else if(inherits(lin1,"formula")){
	cname <- if(inherits(mu1,"formulafn"))colnames(attr(mu1,"model"))
		else colnames(dm1)
	if(is.null(cname)&&npl==2)cname <- "(Intercept)"
	if(is.function(mu)&&length(cname)<npl-1)
		cname <- c(cname,paste("p",(length(cname)+1):npl,sep=""))}
else cname <- paste("p",1:(npl-1),sep="")
if(inherits(sh1,"formulafn")&&!is.matrix(attr(sh1,"model")))
	sname <- attr(sh1,"parameters")
else if(inherits(lin2,"formula")){
	sname <- if(inherits(sh1,"formulafn"))colnames(attr(sh1,"model"))
		else colnames(dm2)
	if(is.null(sname)&&nps==1)sname <- "(Intercept)"
	if(is.function(shape)&&length(sname)<nps)
		sname <- c(sname,paste("p",(length(sname)+1):nps,sep=""))}
else sname <- paste("p",1:nps,sep="")
fitted.values <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial")
		as.vector((y[,1]+y[,2])*mu2(z0$estimate))
	else as.vector(mu2(z0$estimate))
residuals <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial"||censor)
		y[,1]-fitted.values
	else y-fitted.values
if(npl+nps==1){
	cov <- 1/z0$hessian
	se <- sqrt(cov)}
else {
	if(any(is.na(z0$hessian)))a <- 0
	else a <- qr(z0$hessian)$rank
	if(a==npl+nps)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=npl+nps,nrow=npl+nps)
	se <- sqrt(diag(cov))}
like.comp <- as.vector(fcn(z0$estimate)+const)
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
if(!is.null(lin1a))lin1 <- lin1a
if(!is.null(lin2a))lin2 <- lin2a
z1 <- list(
	call=call,
	delta=delta,
	distribution=distribution,
	likefn=fcn,
	mu=mu1,
	shape=sh1,
	linear=list(lin1,lin2),
	common=common,
	scale=scale,
	points=points,
	prior.weights=wt,
	censor=censor,
	maxlike=z0$minimum,
	fitted.values=fitted.values,
	residuals=residuals,
	like.comp=like.comp,
	aic=z0$minimum+np,
	df=sum(wt)-np,
	coefficients=z0$estimate,
	cname=cname,
	sname=sname,
	npl=npl,
	npm=0,
	nps=nps,
	npf=0,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "gnlr"
return(z1)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     hidden(response, totals=NULL, distribution="Bernoulli", pgamma, cmu=NULL,
#       tvmu=NULL, pcmu=NULL, ptvmu=NULL, pshape=NULL, pfamily=NULL,
#       delta=1, print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001,
#       fscale=1, iterlim=100, typsiz=abs(p), stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit hidden Markov chain models in discrete time

hidden <- function(response, totals=NULL, distribution="Bernoulli", pgamma,
	cmu=NULL, tvmu=NULL, pcmu=NULL, ptvmu=NULL, pshape=NULL, pfamily=NULL,
	delta=1, print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001,
	fscale=1, iterlim=100, typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
likel <- function(p){
	if(is.function(cmu))pmu1 <- cmu(p[nm1:ncmu])
	if(is.function(tvmu))pmu2 <- tvmu(p[ncmu1:np1])
	if(np>np1){
		if(np3-np1==1)pshape <- rep(p[np3],states)
		else pshape <- p[np2:np3]}
	z <- .Fortran("hidden",
		x=as.double(p),
		as.integer(states),
		iq=as.integer(nosubj),
		nobs=as.integer(response$response$nobs),
		mobs=as.integer(mobs),
		s=as.double(response$response$y),
		n=as.integer(response$response$n),
		l=as.integer(l),
		pgamma=as.double(pgamma),
		pos=as.integer(pos),
		gamma=double(states*states),
		model=as.integer(mdl),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np]),
		delta=double(states),
		nn=as.integer(nob),
		filter=double(states*nob),
		cf=as.logical(0),
		a=double(states),
		b=double(states*states),
		c=double(states),
		gmod=double(states*states),
		rhs=double(states),
		pivot=integer(states),
		qraux=double(states),
		work=double(2*states),
		like=double(1),
		DUP=F)
z$like}
like <- function(p){
	if(is.function(cmu))pmu1 <- cmu(p[nm1:ncmu])
	if(is.function(tvmu))pmu2 <- tvmu(p[ncmu1:np1])
	if(np>np1){
		if(np3-np1==1)pshape <- rep(p[np3],states)
		else pshape <- p[np2:np3]}
	z <- .Fortran("hidden",
		x=as.double(p),
		as.integer(states),
		iq=as.integer(nosubj),
		t=as.integer(response$response$nobs),
		mobs=as.integer(mobs),
		s=as.double(response$response$y),
		n=as.integer(response$response$n),
		l=as.integer(l),
		pgamma=as.double(pgamma),
		pos=as.integer(pos),
		gamma=double(states*states),
		model=as.integer(mdl),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np]),
		delta=double(states),
		nn=as.integer(nob),
		filter=double(states*nob),
		cf=as.logical(1),
		a=double(states),
		b=double(states*states),
		c=double(states),
		gmod=double(states*states),
		rhs=double(states),
		pivot=integer(states),
		qraux=double(states),
		work=double(2*states),
		like=double(1),
		DUP=F)
z}
call <- sys.call()
tmp <- c("Bernoulli","Poisson","multinomial","binomial","exponential",
	"beta binomial","negative binomial","normal","inverse Gauss",
	"logistic","Cauchy","Laplace","Levy","Pareto","gamma","Weibull",
	"gen gamma","gen logistic","Hjorth","Burr","gen Weibull",
	"gen extreme value","gen inverse Gauss","power exponential")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
if(!is.matrix(pgamma)||ncol(pgamma)!=nrow(pgamma)){
	if(length(pgamma)==1&pgamma==1)pgamma <- as.matrix(pgamma)
	else stop("pgamma must be a square transition matrix")}
if(any(pgamma<0|pgamma>1))
     stop("All pgamma estimates must be between zero and one")
states <- nrow(pgamma)
if(mdl>5){
	if(is.null(pshape))stop("pshape estimate must be supplied")
	else if(length(pshape)!=1&&length(pshape)!=states)
	     stop(paste("pshape must have 1 or",states,"estimates"))}
if(mdl>16){
	if(is.null(pfamily))stop("pfamily estimate must be supplied")
	else if(length(pshape)!=1)
	     stop(paste("pshape must have one estimate"))}
if(states>1&any(diag(pgamma)==1))stop("Diagonal of pgamma cannot be 1")
pgamma <- ifelse(pgamma==0,1e-31,pgamma)
pg <- NULL
pos <- rep(1,states)
if(states>1)for(i in 1:states){
	if(sum(pgamma[i,])!=1)stop(paste("row",i,"of pgamma does not sum to 1"))
	for(j in 1:states){
		if(pgamma[i,j]>1e-30){
			pos[i] <- j
			pdg <- pgamma[i,j]
			break}}
	if(any(pgamma[i,]>=1e-30&pgamma[i,]!=1))
		pg <- c(pg,log(pgamma[i,(1:states)!=pos[i]&pgamma[i,]>=1e-30&pgamma[i,]!=1]/pdg))}
if(!inherits(response,"repeated")){
	if(!inherits(response,"response")){
		if(is.vector(response,mode="numeric"))response <- matrix(response,nrow=1)
		response <- restovec(response,totals=totals,delta=delta)}
	if(!is.null(response$delta))delta <- response$delta
	response <- rmna(response=response)}
if((distribution=="binomial"||distribution=="beta binomial")&&is.null(response$response$n))stop("totals must be supplied")
if(mdl<6){
	if(any(response$response$y<0))stop("all responses must be non-negative")}
else if((mdl!=8)&&(mdl!=10)&&(mdl!=11)&&(mdl!=12)&&(mdl!=13)&&(mdl!=18)&&(mdl!=24)&&(any(response$response$y<=0)))
	stop("all responses must be positive")
nosubj <- length(response$response$nobs)
mobs <- max(response$response$nobs)
nob <- length(response$response$y)
if(distribution=="multinomial"){
	if(min(response$response$y)<1)stop("multinomial categories must be numbered from 1")
	l <- max(response$response$y)-1
	if(l<1)stop("multinomial response must have at least 2 categories")}
else l <- 1
if(is.function(cmu)){
	if(is.null(pcmu))stop("Initial values of pcmu must be supplied")
	d <- dim(cmu(pcmu))
	if(length(d)<2)stop("cmu must return an array")
	if(d[2]!=states)stop(paste("cmu must return a",states,"column array"))
	if(d[1]!=nosubj)
		stop("cmu must return an array with one row per individual")
	if(distribution=="multinomial"){
		if(length(d)!=3)stop("cmu must return a 3 dimensional array")
		if(d[3]!=l)stop(paste("cmu must return an array with",l,"layers"))}}
else pmu1 <- array(0,c(states,nosubj,l))
if(is.function(tvmu)){
	if(is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	d <- dim(tvmu(ptvmu))
	if(length(d)<2)stop("tvmu must return an array")
	if(d[2]!=states)stop("tvmu must return a",states,"column array")
	else if(d[1]!=mobs)
	     stop("tvmu must return an array with one row per time point")
	if(distribution=="multinomial"){
		if(length(d)!=3)stop("tvmu must return a 3 dimensional array")
		if(d[3]!=l)stop(paste("tvmu must return an array with",l,"layers"))}}
else pmu2 <- array(0,c(states,mobs,l))
if(!is.function(cmu)&&!is.function(tvmu))
	stop("Either cmu or tvmu must be a function")
nm1 <- length(pg)+1
ncmu <- length(pg)+length(pcmu)
ncmu1 <- ncmu+1
ntvmu <- length(ptvmu)
p <- c(pg,pcmu,ptvmu,pshape,pfamily)
np1 <- length(p)-length(pshape)-length(pfamily)
np2 <- np1+1
np3 <- length(p)-length(pfamily)
np <- length(p)
pshape <- rep(0,states)
z <- nlm(likel,p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
coef <- z$estimate[nm1:np1]
pshape <- if(np3>np1)z$estimate[np2:np3] else NULL
pfamily <- if(np>np3)z$estimate[np] else NULL
if(length(delta)==1)delta <- rep(delta,nob)
maxlike <- z$minimum - if(mdl>7) sum(log(delta)) else 0
z0 <- like(z$estimate)
if(any(is.na(z$hessian)))a <- 0
else a <- qr(z$hessian)$rank
if(a==np)cov <- solve(z$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
z1 <- list(
   call=call,
   distribution=distribution,
   response=response$response,
   maxlike=maxlike,
   aic=maxlike+np,
   states=states,
   cmu=cmu,
   tvmu=tvmu,
   coef=coef,
   pshape=pshape,
   pfamily=pfamily,
   ncmu=length(pcmu),
   ntvmu=length(ptvmu),
   gamma=matrix(z0$gamma,ncol=states),
   delta=z0$delta,
   cov=cov,
   corr=corr,
   se=se,
   filter=matrix(z0$filter,nrow=states),
   iterations=z$iter,
   code=z$code)
class(z1) <- "hidden"
z1}

print.hidden <- function(z, digits = max(3, .Options$digits - 3)){
	m <- z$states
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	cat(z$distribution)
	if(z$states>1)cat(" hidden Markov chain with",m,"states\n\n")
	else cat(" independence model\n\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("Number of subjects    ",length(z$response$nobs),"\n")
	cat("Number of observations",length(z$response$y),"\n")
	cat("\n-Log likelihood   ",z$maxlike,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n")
	if(z$ncmu>0){
		cat("\nTime-constant coefficients\n")
		t <- deparse(z$cmu)
		cat(t[2:length(t)],sep="\n")
		coef <- matrix(z$coef[1:z$ncmu],nrow=1)
		dimnames(coef) <- list(paste(1),paste(1:z$ncmu))
		print.default(coef, digits=digits, print.gap=2)}
	if(z$ntvmu>0){
		cat("\nTime-varying coefficients\n")
		t <- deparse(z$tvmu)
		cat(t[2:length(t)],sep="\n")
		coef <- matrix(z$coef[(z$ncmu+1):(z$ncmu+z$ntvmu)],nrow=1)
		dimnames(coef) <- list(paste(1),paste(1:z$ntvmu))
		print.default(coef, digits=digits, print.gap=2)}
	if(!is.null(z$pshape)){
		cat("\nDispersion parameters\n")
		coef <- matrix(z$pshape,nrow=1)
		dimnames(coef) <- list(paste(1),paste(1:length(z$pshape)))
		print.default(coef, digits=digits, print.gap=2)}
	if(!is.null(z$pfamily)){
		cat("\nFamily parameter\n")
		coef <- matrix(z$pfamily,nrow=1)
		dimnames(coef) <- list(paste(1),paste(1))
		print.default(coef, digits=digits, print.gap=2)}
	if(z$states>1){
		cat("\nTransition matrix\n")
		dimnames(z$gamma) <- list(paste(1:m),paste(1:m))
		print.default(z$gamma, digits=digits, print.gap=2)
		cat("\nStationary distribution\n")
		z$delta <- matrix(z$delta,nrow=1)
		dimnames(z$delta) <- list(paste(1),paste(1:m))
		print.default(z$delta, digits=digits, print.gap=2)}
}

plot.hidden <- function(z, nind=1, smooth=F, main=NULL, ylab=NULL,
	xlab="Time", xlim=NULL, ...){
	if(max(nind)>length(z$response$nobs))stop("no such individual")
	ns <- length(nind)
	ii <- covind(z$response)
	if(is.null(main)){
		main <- NULL
		for(i in nind)main <- c(main,paste("Individual ",i))}
	else if(length(main)!=ns){
		if(length(main==1))main <- rep(main,ns)
		else stop("main must have a name for each individual")}
	if(is.null(xlim))xlim <- c(0,max(z$resp$times))
	oldpar <- par(mfcol=c(z$states,ns))
	k <- 0
	for(i in nind){
		k <- k+1
		lenf <- sum(ii==i)
		for(j in 1:z$states){
			xl <- if(j==z$states)xlab else ""
			mn <- if(j==1)main[k] else ""
			yl <- if(k==1){
				if(is.null(ylab))paste("State ",j) else ylab}
			else ""
			if(smooth){
				y <- (z$filter[j,ii==i][1:(lenf-2)]+
					z$filter[j,ii==i][3:lenf])*0.25+
					z$filter[j,ii==i][2:(lenf-1)]*0.5
				y <- c(z$filter[j,ii==i][1],y,
					z$filter[j,ii==i][lenf])}
			else y <- z$filter[j,ii==i]
			plot(z$resp$times[ii==i],y,type="l", ylab=yl, xlab=xl,
				main=mn, ylim=c(0,1), xlim=xlim, ...)}}
	par(oldpar)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     kalcount(response, times=NULL, origin=0, intensity="exponential",
#	depend="independence", update="Markov", mu=NULL, shape=NULL,
#	density=F, ccov=NULL, tvcov=NULL, preg=NULL, ptvc=NULL,
#	pbirth=NULL, pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL,
#	envir=sys.frame(sys.parent()), print.level=0, ndigit=10,
#	gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
#	typsiz=abs(p), stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit various distributions inserted into a Pareto
#  distribution with serial dependence or gamma frailties using
#  Kalman-type update for longitudinal count data.

kalcount <- function(response, times=NULL, origin=0, intensity="exponential",
	depend="independence", update="Markov", mu=NULL, shape=NULL,
	density=F, ccov=NULL, tvcov=NULL, preg=NULL, ptvc=NULL,
	pbirth=NULL, pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL,
	envir=sys.frame(sys.parent()), 	print.level=0, ndigit=10,
	gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
	typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
kcountb <- function(p){
	if(rf)b <- mu1(p)
	if(sf)v <- sh1(p[nps1:np])
	z <- .C("kcountb",
		p=as.double(p),
		y=as.double(resp$response$times),
		origin=as.double(origin),
		c=as.integer(resp$response$y),
		x=as.double(resp$ccov$ccov),
		nind=as.integer(nind),
		nobs=as.integer(resp$response$nobs),
		nbs=as.integer(length(resp$response$y)),
		nccov=as.integer(nccov),
		model=as.integer(mdl),
		density=as.integer(density),
		dep=as.integer(dep),
		birth=as.integer(birth),
		tvc=as.integer(tvc),
		tvcov=as.double(resp$tvcov$tvcov),
		fit=as.integer(0),
		pred=double(length(resp$response$y)),
		rpred=double(length(resp$response$y)),
		rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=F)
	z$like}
countfb <- function(p){
	if(rf)b <- mu1(p)
	if(sf)v <- sh1(p[nps1:np])
	z <- .C("countfb",
		p=as.double(p),
		y=as.double(resp$response$times),
		c=as.integer(resp$response$y),
		x=as.double(resp$ccov$ccov),
		nind=as.integer(nind),
		nobs=as.integer(resp$response$nobs),
		nbs=as.integer(length(resp$response$y)),
		nccov=as.integer(nccov),
		model=as.integer(mdl),
		density=as.integer(density),
		tvc=as.integer(tvc),
		tvcov=as.double(resp$tvcov$tvcov),
		fit=as.integer(0),
		pred=double(length(resp$response$y)),
		rpred=double(length(resp$response$y)),
		rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=F)
	z$like}
call <- sys.call()
tmp <- c("exponential", "Weibull","gamma","gen logistic","log normal",
	"log logistic","log Cauchy","log Laplace")
mdl <- match(intensity <- match.arg(intensity,tmp),tmp)
depend <- match.arg(depend,c("independence","serial","frailty"))
tmp <- c("Markov","serial","event","cumulated","count","kalman","time")
dep <- match(update <- match.arg(update,tmp),tmp)
rf <- !is.null(mu)
sf <- !is.null(shape)
respenv <- inherits(response,"repeated")
envname <- if(respenv)paste(deparse(substitute(response)))
	else NULL
if(!respenv){
	if(!inherits(response,"response"))resp <- restovec(response,times)
	else resp <- response
	if(is.null(ccov))nccov <- 0
	else {
		if(!inherits(ccov,"tccov")){
			ccname <- paste(deparse(substitute(ccov)))
			if((is.matrix(ccov)&&is.null(colnames(ccov)))){
				ccname <- paste(deparse(substitute(ccov)))
				if(ncol(ccov)>1){
					tmp <- NULL
					for(i in 1:ncol(ccov))tmp <- c(tmp,paste(ccname,i,sep=""))
					ccname <- tmp}}
			ccov <- tcctomat(ccov,names=ccname)}
		nccov <- if(rf) 0 else ncol(ccov$ccov)}
	if(is.null(tvcov))ttvc <- 0
	else {
		if(!inherits(tvcov,"tvcov")){
			tvcname <- paste(deparse(substitute(tvcov)))
			if(is.list(tvcov)&&ncol(tvcov[[1]])>1){
				if(is.null(colnames(tvcov[[1]]))){
					tvcname <- paste(deparse(substitute(tvcov)))
					tmp <- NULL
					for(i in 1:ncol(tvcov[[1]]))tmp <- c(tmp,paste(tvcname,i,sep=""))
					tvcname <- tmp}
				else tvcname <- colnames(tvcov[[1]])}
			tvcov <- tvctomat(tvcov, names=tvcname)}
		ttvc <- if(rf) 0 else ncol(tvcov$tvcov)}
	resp <- rmna(response=resp, tvcov=tvcov, ccov=ccov)
	if(!is.null(ccov))rm(ccov)
	if(!is.null(tvcov))rm(tvcov)}
else {
	if(!rf){
		resp <- response
		if(is.null(ccov))resp$ccov <- NULL
		else if(inherits(ccov,"formula"))
			resp$ccov$ccov <- attr(finterp(ccov,envir=response,expand=F,name=paste(deparse(substitute(response)))),"model")[,-1,drop=F]
		else stop("ccov must be a W&R formula")
		if(is.null(tvcov))resp$tvcov <- NULL
		else if(inherits(tvcov,"formula"))
			resp$tvcov$tvcov <- attr(finterp(tvcov,envir=response,name=paste(deparse(substitute(response)))),"model")[,-1,drop=F]
		else stop("tvcov must be a W&R formula")}
	else resp <- rmna(response$response)
	nccov <- if(rf||is.null(resp$ccov$ccov)) 0
		 else  ncol(resp$ccov$ccov)
	ttvc <- if(rf||is.null(resp$tvcov$tvcov)) 0
		 else  ncol(resp$tvcov$tvcov)}
if((inherits(envir,"repeated")&&
	(length(resp$response$nobs)!=length(envir$response$nobs)||
	any(resp$response$nobs!=envir$response$nobs)))||
	(inherits(envir,"tvcov")&&
	(length(resp$response$nobs)!=length(envir$tvcov$nobs)||
	any(resp$response$nobs!=envir$tvcov$nobs))))
	stop("response and envir objects are incompatible")
if(is.null(resp$response$times))stop("These models cannot be fitted without times.")
mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else if(inherits(envir,"tccov"))"tccov"
		else "tvcov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,envir=response,name=envname)
			else finterp(mu,envir=envir,name=envname)
		class(mu) <- c(class(mu),type)}
	else if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=response,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu3 <- mu
		if(respenv)attr(mu3,"model") <- tmp}
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,envir=response,name=envname)
			else finterp(shape,envir=envir,name=envname)
		class(shape) <- c(class(shape),type)}
	else if(is.function(shape)){
		tmp <- parse(text=paste(deparse(shape))[-1])
		class(shape) <- type
		shape <- if(respenv)fnenvir(shape,envir=response,name=envname)
			else fnenvir(shape,envir=envir,name=envname)
		sh3 <- shape
		if(respenv)attr(sh3,"model") <- tmp}}
npreg <- length(preg)
mu1 <- sh1 <- v <- b <- NULL
if(inherits(mu,"formula")){
	pr <- if(npreg>0)preg else ptvc
	npr <- length(pr)
	mu2 <- if(respenv)finterp(mu,envir=response,name=envname,expand=is.null(preg))
		else finterp(mu,envir=envir,name=envname,expand=is.null(preg))
	npt1 <- length(attr(mu2,"parameters"))
	if(is.matrix(attr(mu2,"model"))){
		if(all(dim(attr(mu2,"model"))==1)){
			mu1 <- function(p) exp(p[1]*rep(1,n))
			attributes(mu1) <- attributes(mu2)
			mu2 <- NULL}
		else {
			mu1 <- function(p) exp(mu2(p))
			attributes(mu1) <- attributes(mu2)}}
	else {
		if(npr!=npt1&&length(ptvc)!=npt1){
			cat("\nParameters are ")
			cat(attr(mu2,"parameters"),"\n")
			stop(paste("preg or ptvc should have",npt1,"estimates"))}
		if(is.list(pr)){
			if(!is.null(names(pr))){
				o <- match(attr(mu2,"parameters"),names(pr))
				pr <- unlist(pr)[o]
				if(sum(!is.na(o))!=length(pr))stop("invalid estimates for mu - probably wrong names")}
			else pr <- unlist(pr)
			if(npreg>0)preg <- pr else ptvc <- pr}}
	if(!is.null(mu2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			mu1 <- function(p) mu2(p)[cv]
			attributes(mu1) <- attributes(mu2)}
		else if(!is.matrix(attr(mu2,"model"))){
			mu1 <- mu2
			rm(mu2)}}}
else if(is.function(mu))mu1 <- mu
if(!is.null(mu1)&&is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=response))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=response))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu1))length(attr(mu1,"parameters"))
	else if(is.null(mu1))NULL
	else npt1
if(!is.null(nlp)){
	if(is.null(ptvc)&&nlp!=npreg)
		stop(paste("preg should have",nlp,"initial estimates"))
	else if(!is.null(ptvc)&&length(ptvc)!=nlp)
		stop(paste("ptvc should have",nlp,"initial estimates"))}
nps <- length(pshape)
if(inherits(shape,"formula")){
	sh2 <- if(respenv)finterp(shape,envir=response,name=envname)
		else finterp(shape,envir=envir,name=envname)
	npt2 <- length(attr(sh2,"parameters"))
	if(is.matrix(attr(sh2,"model"))){
		if(all(dim(attr(sh2,"model"))==1)){
			sh1 <- function(p) p[npl1]*rep(1,n)
			attributes(sh1) <- attributes(sh2)
			sh2 <- NULL}}
	else {
		if(nps!=npt2){
			cat("\nParameters are ")
			cat(attr(sh2,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh2,"parameters"),names(pshape))
				pshape <- unlist(pshape)[o]
				if(sum(!is.na(o))!=length(pshape))stop("invalid estimates for shape - probably wrong names")}
			else pshape <- unlist(pshape)}}
	if(!is.null(sh2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			sh1 <- function(p) sh2(p)[cv]
			attributes(sh1) <- attributes(sh2)}
		else {
			sh1 <- sh2
			rm(sh2)}}}
else if(is.function(shape))sh1 <- shape
if(!is.null(sh1)&&is.null(attributes(sh1)))
	attributes(sh1) <- if(is.function(shape)){
		if(!inherits(shape,"formulafn")){
			if(respenv)attributes(fnenvir(shape,envir=response))
			else attributes(fnenvir(shape,envir=envir))}
		else attributes(shape)}
		else {
			if(respenv)attributes(fnenvir(sh1,envir=response))
			else attributes(fnenvir(sh1,envir=envir))}
nlp <- if(is.function(shape))length(attr(sh1,"parameters"))
	else if(is.null(shape))NULL
	else npt2
if(!is.null(nlp)&&nlp!=nps)
	stop(paste("pshape should have",nlp,"initial estimates"))
if(rf&&!is.function(mu1))stop("mu must be a formula or function")
if(sf&&!is.function(sh1))stop("shape must be a formula or function")
if(origin<0)stop("Origin must be positive")
birth <- !is.null(pbirth)
tvc <- length(ptvc)
if(rf&&birth)stop("Birth models cannot be fitted with a mean function")
if(intensity=="exponential"){
	sf <- F
	pshape <- NULL}
else {
	if(is.null(pshape))
		stop("Initial value of the shape parameter must be supplied")
	if(!sf){
		if(pshape<=0)stop("shape must be positive")
		pshape <- log(pshape)}}
if(intensity=="gen logistic"){
	if(is.null(pintercept))stop("Initial value of the intercept parameter must be supplied")}
else pintercept <- NULL
if(pinitial<=0)stop("Estimate of initial parameter must greater than 0")
else pinitial <- log(pinitial)
if(depend=="independence"){
	pdepend <- NULL
	dep <- 0}
else if(depend=="serial"){
	if(update=="time")stop("time update can only be used with frailty")
	if(is.null(pdepend))
		stop("An estimate of the dependence parameter must be supplied")
	else if(pdepend<=0|pdepend>=1)
		stop("Dependence parameter must be between 0 and 1")
	else pdepend <- log(pdepend/(1-pdepend))}
else if(depend=="frailty"){
	if(update=="time")dep <- 1
	else {
		dep <- 0
		update <- "no"}
	if(!is.null(pdepend))pdepend <- NULL}
if(rf&&npreg>0)nccov <- npreg-1
if(!rf&&1+nccov!=npreg)
	stop(paste(1+nccov,"regression estimates must be supplied"))
nind <- length(resp$response$nobs)
if(!rf&&(ttvc>0&&tvc!=ttvc||ttvc==0&&tvc>0))stop(paste(ttvc,"initial estimates of coefficients for time-varying covariates must be supplied"))
if(rf){
	if(tvc>0&&nccov>0)stop("With a mean function, initial estimates must be supplied either in preg or in ptvc")
	if(tvc>0){
		if(length(mu1(ptvc))!=length(resp$response$y))stop("The mu function or formula must provide an estimate for each observation")
		tvc <- tvc-1}
	else if(length(mu1(preg))==1){
		if(nccov==0)mu1 <- function(p) rep(p[1],length(resp$response$y))
		else stop("Number of estimates does not correspond to mu function")}
	else if(length(mu1(preg))!=nind)stop("The mu function or formula must provide an estimate for each individual")}
if(sf&&length(sh1(pshape))!=length(resp$response$y))stop("The shape function must provide an estimate for each observation")
np <- 1+nccov+tvc+1+(depend=="serial")+birth+nps+(!is.null(pintercept))
nps1 <- np-nps-(!is.null(pintercept))+1
p <- c(preg,pbirth,ptvc,pinitial,pdepend,pshape,pintercept)
if(depend=="frailty")count <- countfb
else count <- kcountb
if(fscale==1)fscale <- count(p)
if(is.na(count(p)))
	stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(count, p=p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
if(any(is.na(z0$hessian)))a <- 0
else a <- qr(z0$hessian)$rank
if(a==np)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
z <- if(depend=="frailty"){
	if(rf)b <- mu1(z0$estimate)
	if(sf)v <- sh1(z0$estimate[nps1:np])
	.C("countfb",
        	p=as.double(z0$estimate),
        	y=as.double(resp$response$times),
        	c=as.integer(resp$response$y),
        	x=as.double(resp$ccov$ccov),
        	nind=as.integer(nind),
        	nobs=as.integer(resp$response$nobs),
        	nbs=as.integer(length(resp$response$y)),
        	nccov=as.integer(nccov),
        	model=as.integer(mdl),
        	density=as.integer(density),
        	tvc=as.integer(tvc),
        	tvcov=resp$tvcov$tvcov,
        	fit=as.integer(1),
        	pred=double(length(resp$response$y)),
		rpred=double(length(resp$response$y)),
        	rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
        	like=double(1),
		DUP=F)}
else {
	if(rf)b <- mu1(z0$estimate)
	if(sf)v <- sh1(z0$estimate[nps1:np])
	.C("kcountb",
        	p=as.double(z0$estimate),
        	y=as.double(resp$response$times),
        	origin=as.double(origin),
        	c=as.integer(resp$response$y),
        	x=as.double(resp$ccov$ccov),
        	nind=as.integer(nind),
        	nobs=as.integer(resp$response$nobs),
        	nbs=as.integer(length(resp$response$y)),
        	nccov=as.integer(nccov),
        	model=as.integer(mdl),
        	density=as.integer(density),
        	dep=as.integer(dep),
        	birth=as.integer(birth),
        	tvc=as.integer(tvc),
        	tvcov=resp$tvcov$tvcov,
        	fit=as.integer(1),
        	pred=double(length(resp$response$y)),
		rpred=double(length(resp$response$y)),
		rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=F)}
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
z <- list(
	call=call,
	intensity=intensity,
	mdl=mdl,
	mu=mu1,
	npr=1+nccov+tvc+birth,
	shape=sh1,
	nps=np-nps,
	density=density,
	depend=depend,
	update=update,
	birth=birth,
	response=resp$response,
	pred=z$pred,
	rpred=z$rpred,
	ccov=resp$ccov,
	tvcov=resp$tvcov,
	maxlike=z0$minimum,
	aic=z0$minimum+np,
	df=length(resp$response$y)-np,
	npt=np,
	coefficients=z0$estimate,
	se=se,
	cov=cov,
	corr=corr,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z) <- c("kalcount","recursive")
return(z)}

coefficients.kalcount <- function(z) z$coefficients
deviance.kalcount <- function(z) 2*z$maxlike
fitted.kalcount <- function(z, recursive=TRUE)
	if(recursive) z$rpred else z$pred
residuals.kalcount <- function(z, type = "response", recursive=TRUE){
	if(type=="response") z$response$y-z$rpred
	else (z$response$y-z$rpred)/sqrt(z$rpred)}

print.kalcount <- function(z, digits = max(3, .Options$digits - 3)) {
	if(!is.null(z$ccov))nccov <- ncol(z$ccov$ccov)
	else nccov <- 0
	expm <- z$intensity!="exponential"&&!is.function(z$shape)
	glm <- z$intensity=="gen logistic"
	nps <- if(is.function(z$shape)) z$nps else z$npt
	deppar <- (z$depend=="serial"||z$depend=="Markov")
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("Number of subjects    ",length(z$response$nobs),"\n")
	cat("Number of observations",length(z$response$y),"\n")
	if(z$density)cat(z$intensity," density",sep="")
	else cat(z$intensity," intensity",sep="")
	if(z$depend=="independence")cat(" with independence\n")
	else if(z$depend=="frailty")
		cat(" with",z$depend,"dependence and",z$update,"weight\n")
	else cat(" with ",z$update," update\n",sep="")
	cat("\n-Log likelihood   ",z$maxlike,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	cat("Location parameters\n")
	if(!is.null(attr(z$mu,"formula")))
		cat(deparse(attr(z$mu,"formula")),sep="\n")
	else if(!is.null(attr(z$mu,"model"))){
		t <- deparse(attr(z$mu,"model"))
		t[1] <- sub("expression\\(","",t[1])
		t[length(t)] <- sub("\\)$","",t[length(t)])
		cat(t,sep="\n")}
	coef.table <- cbind(z$coef[1:z$npr],z$se[1:z$npr])
	if(inherits(z$mu,"formulafn"))
		cname <- if(is.matrix(attr(z$mu,"model")))
				colnames(attr(z$mu,"model"))
			else attr(z$mu,"parameters")
	else {
		cname <- "(Intercept)"
		if(nccov)cname <- c(cname,colnames(z$ccov$ccov))
		if(z$birth)cname <- c(cname,"birth")
		if(!is.null(z$tvcov))cname <- c(cname,colnames(z$tvcov$tvcov))}
	dimnames(coef.table) <- list(cname, c("estimate","se"))
	print.default(coef.table, digits=digits, print.gap=2)
	if(is.function(z$shape))cat("\nDependence parameters\n")
	else cat("\nNonlinear parameters\n")
	coef <- exp(z$coef[(nps-deppar-expm-glm):nps])
	cname <- "initial"
	if(deppar){
		coef[2] <- coef[2]/(1+coef[2])
		cname <- c(cname,"depend")}
	if(glm){
		cname <- c(cname,"asymptote","intercept")
		coef[length(coef)-1] <- 1/coef[length(coef)-1]
		coef[length(coef)] <- NA}
	else if(expm)cname <- c(cname,"shape")
	coef.table <- cbind(z$coef[(nps-deppar-expm-glm):nps],z$se[(nps-deppar-expm-glm):nps],coef)
	dimnames(coef.table) <- list(cname, c("estimate","se","parameter"))
	print.default(coef.table, digits=digits, print.gap=2)
	if(inherits(z$shape,"formulafn")){
		cat("\nShape parameters\n")
		if(!is.null(attr(z$sh1,"formula")))
			cat(deparse(attr(z$sh1,"formula")),sep="\n")
		else if(!is.null(attr(z$sh1,"model"))){
			t <- deparse(attr(z$sh1,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		cname <- if(is.matrix(attr(z$sh1,"model")))
				colnames(attr(z$sh1,"model"))
			else attr(z$sh1,"parameters")
		coef.table <- cbind(z$coef[(z$nps+1):z$npt],
			z$se[(z$nps+1):z$npt])
		dimnames(coef.table) <- list(cname, c("estimate","se"))
		print.default(coef.table, digits=digits, print.gap=2)}
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     kalseries(response, times=NULL, intensity="exponential",
#	depend="independence", mu=NULL, shape=NULL, density=F, ccov=NULL,
#	tvcov=NULL, torder=0, interaction=NULL, preg=NULL, ptvc=NULL,
#	pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL, delta=NULL,
#	transform="identity", link="identity", envir=sys.frame(sys.parent()),
#	print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001, fscale=1,
#	iterlim=100, typsiz=abs(p), stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit various distributions inserted into a Pareto
#  distribution with serial dependence or gamma frailties using
#  Kalman-type update for continuous longitudinal data.

.First.lib <- function(lib, pkg) {
	library.dynam("repeated", pkg, lib)
	provide(repeated)
}
require(rmutil)

kalseries <- function(response, times=NULL, intensity="exponential",
	depend="independence", mu=NULL, shape=NULL, density=F, ccov=NULL,
	tvcov=NULL, torder=0, interaction=NULL, preg=NULL, ptvc=NULL,
	pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL, delta=NULL,
	transform="identity", link="identity", envir=sys.frame(sys.parent()),
	print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001, fscale=1,
	iterlim=100, typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
series <- function(p){
	if(rf)b <- mu1(p)
	if(sf)v <- sh1(p[nps1:np])
	z <- .C("kserie",
		p=as.double(p),
		y=as.double(y),
		t=as.double(times),
		x=as.double(resp$ccov$ccov),
		nind=as.integer(nind),
		nobs=as.integer(resp$response$nobs),
		nbs=as.integer(length(y)),
		nccov=as.integer(nccov),
		npv=as.integer(npv),
		model=as.integer(mdl),
		link=as.integer(lnk),
		density=as.integer(density),
		dep=as.integer(dep),
		torder=as.integer(torder),
		inter=as.integer(interaction),
		tvc=as.integer(tvc),
		tvcov=resp$tvcov$tvcov,
		fit=as.integer(0),
		pred=double(length(resp$response$y)),
		rpred=double(length(resp$response$y)),
		rf=as.integer(rf),
		bbb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=F)
	z$like}
serief <- function(p){
	if(rf)b <- mu1(p)
	if(sf)v <- sh1(p[nps1:np])
	z <- .C("krand",
		p=as.double(p),
		y=as.double(y),
		t=as.double(times),
		x=as.double(resp$ccov$ccov),
		nind=as.integer(nind),
		nobs=as.integer(resp$response$nobs),
		nbs=as.integer(length(y)),
		nccov=as.integer(nccov),
		npv=as.integer(npv),
		model=as.integer(mdl),
		link=as.integer(lnk),
		density=as.integer(density),
		torder=as.integer(torder),
		inter=as.integer(interaction),
		tvc=as.integer(tvc),
		tvcov=resp$tvcov$tvcov,
		fit=as.integer(0),
		pred=double(length(resp$response$y)),
		rpred=double(length(resp$response$y)),
		rf=as.integer(rf),
		bbb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=F)
	z$like}
call <- sys.call()
tmp <- c("exponential","Weibull","gamma","gen logistic","normal",
	"logistic","Cauchy","Laplace","log normal","log logistic",
	"log Cauchy","log Laplace")
mdl <- match(intensity <- match.arg(intensity,tmp),tmp)
tmp <- c("independence","Markov","serial","frailty")
dep <- match(depend <- match.arg(depend,tmp),tmp)-1
transform <- match.arg(transform,c("identity","exp","square","sqrt","log"))
tmp <- c("identity","exp","square","sqrt","log")
lnk <- match(link <- match.arg(link,tmp),tmp)
rf <- !is.null(mu)
sf <- !is.null(shape)
respenv <- inherits(response,"repeated")
envname <- if(respenv)paste(deparse(substitute(response)))
	else NULL
if(!respenv){
	if(!inherits(response,"response"))resp <- restovec(response,times,delta=delta)
	else resp <- response
	if(is.null(ccov))nccov <- 0
	else {
		if(!inherits(ccov,"tccov")){
			ccname <- paste(deparse(substitute(ccov)))
			if((is.matrix(ccov)&&is.null(colnames(ccov)))){
				ccname <- paste(deparse(substitute(ccov)))
				if(ncol(ccov)>1){
					tmp <- NULL
					for(i in 1:ncol(ccov))tmp <- c(tmp,paste(ccname,i,sep=""))
					ccname <- tmp}}
			ccov <- tcctomat(ccov,names=ccname)}
		nccov <- if(rf) 0 else ncol(ccov$ccov)}
	if(is.null(tvcov))ttvc <- 0
	else {
		if(!inherits(tvcov,"tvcov")){
			tvcname <- paste(deparse(substitute(tvcov)))
			if(is.list(tvcov)&&ncol(tvcov[[1]])>1){
				if(is.null(colnames(tvcov[[1]]))){
					tvcname <- paste(deparse(substitute(tvcov)))
					tmp <- NULL
					for(i in 1:ncol(tvcov[[1]]))tmp <- c(tmp,paste(tvcname,i,sep=""))
					tvcname <- tmp}
				else tvcname <- colnames(tvcov[[1]])}
			tvcov <- tvctomat(tvcov,names=tvcname)}
		ttvc <- if(rf) 0 else ncol(tvcov$tvcov)}
	resp <- rmna(response=resp, tvcov=tvcov, ccov=ccov)
	if(!is.null(ccov))rm(ccov)
	if(!is.null(tvcov))rm(tvcov)}
else{
	if(!rf){
		resp <- response
		if(is.null(ccov))resp$ccov <- NULL
		else if(inherits(ccov,"formula"))
			resp$ccov$ccov <- attr(finterp(ccov,envir=response,expand=F,name=paste(deparse(substitute(response)))),"model")[,-1,drop=F]
		else stop("ccov must be a W&R formula")
		if(is.null(tvcov))resp$tvcov <- NULL
		else if(inherits(tvcov,"formula"))
			resp$tvcov$tvcov <- attr(finterp(tvcov,envir=response,name=paste(deparse(substitute(response)))),"model")[,-1,drop=F]
		else stop("tvcov must be a W&R formula")}
	else resp <- rmna(response$response)
	nccov <- if(rf||is.null(resp$ccov$ccov)) 0
		 else  ncol(resp$ccov$ccov)
	ttvc <- if(rf||is.null(resp$tvcov$tvcov)) 0
		 else  ncol(resp$tvcov$tvcov)}
if((inherits(envir,"repeated")&&
	(length(resp$response$nobs)!=length(envir$response$nobs)||
	any(resp$response$nobs!=envir$response$nobs)))||
	(inherits(envir,"tvcov")&&
	(length(resp$response$nobs)!=length(envir$tvcov$nobs)||
	any(resp$response$nobs!=envir$tvcov$nobs))))
	stop("response and envir objects are incompatible")
mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else if(inherits(envir,"tccov"))"tccov"
		else "tvcov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,envir=response,name=envname)
			else finterp(mu,envir=envir,name=envname)
		class(mu) <- c(class(mu),type)}
	else if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=response,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu3 <- mu
		if(respenv)attr(mu3,"model") <- tmp}
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,envir=response,name=envname)
			else finterp(shape,envir=envir,name=envname)
		class(shape) <- c(class(shape),type)}
	else if(is.function(shape)){
		tmp <- parse(text=paste(deparse(shape))[-1])
		class(shape) <- type
		shape <- if(respenv)fnenvir(shape,envir=response,name=envname)
			else fnenvir(shape,envir=envir,name=envname)
		sh3 <- shape
		if(respenv)attr(sh3,"model") <- tmp}}
npreg <- length(preg)
mu1 <- sh1 <- v <- b <- NULL
if(inherits(mu,"formula")){
	pr <- if(npreg>0)preg else ptvc
	npr <- length(pr)
	mu2 <- if(respenv)
		finterp(mu,envir=response,name=envname,expand=is.null(preg))
		else finterp(mu,envir=envir,name=envname,expand=is.null(preg))
	npt1 <- length(attr(mu2,"parameters"))
	if(is.matrix(attr(mu2,"model"))){
		if(all(dim(attr(mu2,"model"))==1)){
			mu1 <- function(p) p[1]*rep(1,n)
			attributes(mu1) <- attributes(mu2)
			mu2 <- NULL}}
	else {
		if(npr!=npt1){
			cat("\nParameters are ")
			cat(attr(mu2,"parameters"),"\n")
			stop(paste("preg or ptvc should have",npt1,"estimates"))}
		if(is.list(pr)){
			if(!is.null(names(pr))){
				o <- match(attr(mu2,"parameters"),names(pr))
				pr <- unlist(pr)[o]
				if(sum(!is.na(o))!=length(pr))stop("invalid estimates for mu - probably wrong names")}
			else pr <- unlist(pr)
			if(npreg>0)preg <- pr else ptvc <- pr}}
	if(!is.null(mu2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			mu1 <- function(p) mu2(p)[cv]
			attributes(mu1) <- attributes(mu2)}
		else {
			mu1 <- mu2
			rm(mu2)}}}
else if(is.function(mu))mu1 <- mu
if(!is.null(mu1)&&is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=response))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=response))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu1))length(attr(mu1,"parameters"))
	else if(is.null(mu1))NULL
	else npt1
if(!is.null(nlp)){
	if(is.null(ptvc)&&nlp!=npreg)
		stop(paste("preg should have",nlp,"initial estimates"))
	else if(!is.null(ptvc)&&length(ptvc)!=nlp)
		stop(paste("ptvc should have",nlp,"initial estimates"))}
nps <- length(pshape)
if(inherits(shape,"formula")){
	sh2 <- if(respenv)finterp(shape,envir=response,name=envname)
		else finterp(shape,envir=envir,name=envname)
	npt2 <- length(attr(sh2,"parameters"))
	if(is.matrix(attr(sh2,"model"))){
		if(all(dim(attr(sh2,"model"))==1)){
			sh1 <- function(p) p[npl1]*rep(1,n)
			attributes(sh1) <- attributes(sh2)
			sh2 <- NULL}}
	else {
		if(nps!=npt2){
			cat("\nParameters are ")
			cat(attr(sh2,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh2,"parameters"),names(pshape))
				pshape <- unlist(pshape)[o]
				if(sum(!is.na(o))!=length(pshape))stop("invalid estimates for shape - probably wrong names")}
			else pshape <- unlist(pshape)}}
	if(!is.null(sh2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			sh1 <- function(p) sh2(p)[cv]
			attributes(sh1) <- attributes(sh2)}
		else {
			sh1 <- sh2
			rm(sh2)}}}
else if(is.function(shape))sh1 <- shape
if(!is.null(sh1)&&is.null(attributes(sh1)))
	attributes(sh1) <- if(is.function(shape)){
		if(!inherits(shape,"formulafn")){
			if(respenv)attributes(fnenvir(shape,envir=response))
			else attributes(fnenvir(shape,envir=envir))}
		else attributes(shape)}
		else {
			if(respenv)attributes(fnenvir(sh1,envir=response))
			attributes(fnenvir(sh1,envir=envir))}
nlp <- if(is.function(shape))length(attr(sh1,"parameters"))
	else if(is.null(shape))NULL
	else npt2
if(!is.null(nlp)&&nlp!=nps)
	stop(paste("pshape should have",nlp,"initial estimates"))
if(rf&&!is.function(mu1))stop("mu must be a formula or function")
if(sf&&!is.function(sh1))stop("shape must be a formula or function")
tvc <- length(ptvc)
if(intensity=="exponential"){
	sf <- F
	pshape <- NULL}
else {
	if(is.null(pshape))
		stop("Initial value of the shape parameter must be supplied")
	if(!sf){
		if(pshape<=0)stop("Shape must be positive")
		else pshape <- log(pshape)}}
if(intensity=="gen logistic"){
	if(is.null(pintercept))stop("Initial value of the intercept parameter must be supplied")}
else pintercept <- NULL
if(pinitial<=0)stop("Estimate of initial parameter must greater than 0")
else pinitial <- log(pinitial)
if(depend=="independence"||depend=="frailty")pdepend <- NULL
else {
	if(is.null(pdepend))
		stop("An estimate of the dependence parameter must be supplied")
	else if(pdepend<=0||pdepend>=1)
		stop("Dependence parameter must be between 0 and 1")
	else pdepend <- log(pdepend/(1-pdepend))}
if(is.null(resp$response$times)){
	if(depend=="serial")stop("No times. Serial dependence cannot be fitted.")
	ave <- times <- 0}
else {
	ave <- mean(resp$response$times)
	times <- resp$response$times-ave}
if(!is.null(interaction)){
	if(length(interaction)!=nccov)
		stop(paste(nccov,"interactions with time must be specified"))
	else if(any(interaction>torder))
		stop(paste("Interactions can be at most of order ",torder))}
else interaction <- rep(0,nccov)
npv <- torder+sum(interaction)
if(rf&&npreg>0)nccov <- npreg-1
if(!rf&&1+nccov+npv!=npreg)stop(paste(1+nccov+npv,"regression estimates must be supplied"))
y <- resp$response$y
nind <- length(resp$response$nobs)
if(!is.null(resp$response$delta))jacob <- if(length(resp$response$delta)==1)
		-length(resp$response$y)*log(resp$response$delta)
 	else -sum(log(resp$response$delta))
else jacob <- 0
if((mdl<=3||mdl>=8)&&any(y<=0))stop("All responses must be positive")
if(transform=="exp"){
	jacob <- jacob-sum(y)
	y <- exp(y)}
else if(transform!="identity"){
	if(any(y<0))stop("Negative response values: invalid transformation")
	else if(transform=="square"){
		jacob <- jacob-sum(log(y[y>0]))
		y  <- y^2}
	else if(transform=="sqrt"){
		jacob <- jacob+sum(log(y[y>0]))/2
		y <- sqrt(y)}
	else if(any(y==0))stop("Zero response values: invalid transformation")
	else if(transform=="log"){
		jacob <- jacob+sum(log(y[y>0]))
		y <- log(y)}}
if(!rf&&(ttvc>0&&tvc!=ttvc||ttvc==0&&tvc>0))stop(paste(ttvc,"initial estimates of coefficients for time-varying covariates must be supplied"))
if(rf){
	if(tvc>0&&nccov>0)stop("With a mean function or formula, initial estimates must be supplied either in preg or in ptvc")
	if(tvc>0){
		if(length(mu1(ptvc))!=length(resp$response$y))stop("The mu function must provide an estimate for each observation")
		tvc <- tvc-1}
	else if(length(mu1(preg))==1){
		if(nccov==0)mu1 <- function(p) rep(p[1],length(y))
		else stop("Number of estimates does not correspond to mu function")}
	else if(length(mu1(preg))!=nind)stop("The mu function or formula must provide an estimate for each individual")}
if(sf&&length(sh1(pshape))!=length(resp$response$y))stop("The shape function must provide an estimate for each observation")
np <- 1+nccov+npv+tvc+1+(depend=="serial"||depend=="Markov")+nps+(!is.null(pintercept))
nps1 <- np-nps-(!is.null(pintercept))+1
p <- c(preg,ptvc,pinitial,pdepend,pshape,pintercept)
if(dep==3)serie <- serief
else serie <- series
if(fscale==1)fscale <- serie(p)
if(is.na(serie(p)))
	stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(serie, p=p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
p <- z0$estimate
like <- z0$minimum+jacob
if(any(is.na(z0$hessian)))a <- 0
else a <- qr(z0$hessian)$rank
if(a==np)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
if(mdl==4)z <- list()
else {
	z <- if(depend=="frailty"){
		if(rf)b <- mu1(p)
		if(sf)v <- sh1(p[nps1:np])
		.C("krand",
			p=as.double(p),
			y=as.double(y),
			t=as.double(times),
			x=as.double(resp$ccov$ccov),
			nind=as.integer(nind),
			nobs=as.integer(resp$response$nobs),
			nbs=as.integer(length(y)),
			nccov=as.integer(nccov),
			npv=as.integer(npv),
			model=as.integer(mdl),
			link=as.integer(lnk),
			density=as.integer(density),
			torder=as.integer(torder),
			inter=as.integer(interaction),
			tvc=as.integer(tvc),
			tvcov=resp$tvcov$tvcov,
			fit=as.integer(1),
			pred=double(length(resp$response$y)),
			rpred=double(length(resp$response$y)),
			rf=as.integer(rf),
			bbb=as.double(b),
			sf=as.integer(sf),
			vv=as.double(v),
			like=double(1),
			DUP=F)}
	else {
		if(rf)b <- mu1(p)
		if(sf)v <- sh1(p[nps1:np])
		z <- .C("kserie",
			p=as.double(p),
			y=as.double(y),
			t=as.double(times),
			x=as.double(resp$ccov$ccov),
			nind=as.integer(nind),
			nobs=as.integer(resp$response$nobs),
			nbs=as.integer(length(y)),
			nccov=as.integer(nccov),
			npv=as.integer(npv),
			model=as.integer(mdl),
			link=as.integer(lnk),
			density=as.integer(density),
			dep=as.integer(dep),
			torder=as.integer(torder),
			inter=as.integer(interaction),
			tvc=as.integer(tvc),
			tvcov=resp$tvcov$tvcov,
			fit=as.integer(1),
			pred=double(length(resp$response$y)),
			rpred=double(length(resp$response$y)),
			rf=as.integer(rf),
			bbb=as.double(b),
			sf=as.integer(sf),
			vv=as.double(v),
			like=double(1),
			DUP=F)}}
if(rf&&tvc>0){
	nccov <- tvc
	tvc <- 0}
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
z <- list(
	call=call,
	intensity=intensity,
	mdl=mdl,
	mu=mu1,
	npr=1+nccov+tvc+torder+sum(interaction),
	shape=sh1,
	nps=np-nps,
	density=density,
	depend=depend,
	torder=torder,
	interaction=interaction,
	response=resp$response,
	pred=z$pred,
	rpred=z$rpred,
	transform=transform,
	ccov=resp$ccov,
	tvcov=resp$tvcov,
	link=link,
	maxlike=like,
	aic=like+np,
	df=length(y)-np,
	npt=np,
	npv=npv,
	coefficients=p,
	se=se,
	cov=cov,
	corr=corr,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z) <- if(mdl==4)"kalseries" else c("kalseries","recursive")
return(z)}

coefficients.kalseries <- function(z) z$coefficients
deviance.kalseries <- function(z) 2*z$maxlike
fitted.kalseries <- function(z, recursive=TRUE)
	if(recursive) z$rpred else z$pred
residuals.kalseries <- function(z, recursive=TRUE){
	if(z$transform=="exp")z$response$y <- exp(z$response$y)
	else if(z$transform=="square")z$response$y  <- z$response$y^2
	else if(z$transform=="sqrt")z$response$y <- sqrt(z$response$y)
	else if(z$transform=="log")z$response$y <- log(z$response$y)
	if(recursive) z$response$y-z$rpred else z$response$y-z$pred}

print.kalseries <- function(z, digits = max(3, .Options$digits - 3)) {
	if(!is.null(z$ccov))nccov <- ncol(z$ccov$ccov)
	else nccov <- 0
	expm <- z$intensity!="exponential"&&!is.function(z$shape)
	glm <- z$intensity=="gen logistic"
	nps <- if(is.function(z$shape)) z$nps else z$npt
	deppar <- (z$depend=="serial"||z$depend=="Markov")
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("Number of subjects    ",length(z$response$nobs),"\n")
	cat("Number of observations",length(z$response$y),"\n")
	cat("Times centred at      ",mean(z$response$time),"\n")
	cat("Transformation        ",z$trans,"\n")
	cat("Link function         ",z$link,"\n\n")
	if(z$density)cat(z$intensity," density",sep="")
	else cat(z$intensity," intensity",sep="")
	if(z$depend=="independence")cat(" with independence\n")
	else cat(" with",z$depend,"dependence\n")
	cat("\n-Log likelihood   ",z$maxlike,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	cat("Location parameters\n")
	if(!is.null(attr(z$mu,"formula")))
		cat(deparse(attr(z$mu,"formula")),sep="\n")
	else if(!is.null(attr(z$mu,"model"))){
		t <- deparse(attr(z$mu,"model"))
		t[1] <- sub("expression\\(","",t[1])
		t[length(t)] <- sub("\\)$","",t[length(t)])
		cat(t,sep="\n")}
	coef.table <- cbind(z$coef[1:z$npr],z$se[1:z$npr])
	if(inherits(z$mu,"formulafn"))
		cname <- if(is.matrix(attr(z$mu,"model")))
				colnames(attr(z$mu,"model"))
			else attr(z$mu,"parameters")
	else {
		cname <- "(Intercept)"
		if(nccov)cname <- c(cname,colnames(z$ccov$ccov))
		if(z$torder){
			cname <- c(cname,paste("t^",1:z$torder,sep=""))
			if(length(z$interaction)>0){
				for(i in 1:nccov)if(z$interaction[i]>0){
					cname <- c(cname,paste(colnames(z$ccov$ccov)[i],".t^",1:z$interaction[i],sep=""))}}}
		if(!is.null(z$tvcov))cname <- c(cname,colnames(z$tvcov$tvcov))}
	dimnames(coef.table) <- list(cname, c("estimate","se"))
	print.default(coef.table, digits=digits, print.gap=2)
	if(is.function(z$shape))cat("\nDependence parameters\n")
	else cat("\nNonlinear parameters\n")
	coef <- exp(z$coef[(nps-deppar-expm-glm):nps])
	cname <- "initial"
	if(deppar){
		coef[2] <- coef[2]/(1+coef[2])
		cname <- c(cname,"depend")}
	if(glm){
		cname <- c(cname,"asymptote","intercept")
		coef[length(coef)-1] <- 1/coef[length(coef)-1]
		coef[length(coef)] <- NA}
	else if(expm)cname <- c(cname,"shape")
	coef.table <- cbind(z$coef[(nps-deppar-expm-glm):nps],
		z$se[(nps-deppar-expm-glm):nps],coef)
	dimnames(coef.table) <- list(cname, c("estimate","se","parameter"))
	print.default(coef.table, digits=digits, print.gap=2)
	if(z$depend=="frailty"){
		tmp <- trigamma(exp(-z$coef[nps-deppar-expm]))
		cat("Correlation =",tmp/(tmp+trigamma(1)),"\n")}
	if(inherits(z$shape,"formulafn")){
		cat("\nShape parameters\n")
		if(!is.null(attr(z$shape,"formula")))
			cat(deparse(attr(z$shape,"formula")),sep="\n")
		else if(!is.null(attr(z$shape,"model"))){
			t <- deparse(attr(z$shape,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		cname <- if(is.matrix(attr(z$shape,"model")))
				colnames(attr(z$shape,"model"))
			else attr(z$shape,"parameters")
		coef.table <- cbind(z$coef[(z$nps+1):z$npt],
			z$se[(z$nps+1):z$npt])
		dimnames(coef.table) <- list(cname, c("estimate","se"))
		print.default(coef.table, digits=digits, print.gap=2)}
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     logitord(y, id, out.ccov=NULL, drop.ccov=NULL, tvcov=NULL,
#	out.tvcov=!is.null(tvcov), drop.tvcov=!is.null(tvcov),
#	pout, pdrop, prand.out, prand.drop,
#	random.out.int=T, random.out.slope=!is.null(tvcov),
#	random.drop.int=T, random.drop.slope=!is.null(tvcov),
#	binom.mix=5, fcalls=900, eps=0.0001, print.level=0)
#
#  DESCRIPTION
#
#    A function to fit binary or ordinal random effects models with dropouts.

logitord <- function(y, id, out.ccov=NULL, drop.ccov=NULL, tvcov=NULL,
	out.tvcov=!is.null(tvcov), drop.tvcov=!is.null(tvcov),
	pout, pdrop, prand.out, prand.drop,
	random.out.int=T, random.out.slope=!is.null(tvcov),
	random.drop.int=T, random.drop.slope=!is.null(tvcov),
	binom.mix=5, fcalls=900, eps=0.0001, print.level=0){
# Fortran constants
	maxsub <- 5200
	maxcas <- 10
	maxbet <- 25
	maxsig <- 10

	call <- sys.call()
	cg <- length(unique(y[y>0]))
	n1 <- length(y)
	n2 <- sum(y>0)
	if(!is.null(out.ccov)&&!is.matrix(out.ccov)){
		if(inherits(out.ccov,"formula")){
			mt <- terms(out.ccov)
			out.ccov <- model.matrix(mt,model.frame(mt,sys.frame(sys.parent()),na.action=na.fail))
			if(colnames(out.ccov)[1]=="(Intercept)")out.ccov <- out.ccov[,-1,drop=F]}
		else if(is.vector(out.ccov,mode="numeric")){
			frname <- paste(deparse(substitute(out.ccov)))
			out.ccov <- matrix(out.ccov,ncol=1)
			colnames(out.ccov) <- frname}
		else stop("out.ccov must be a vector, matrix, or model formula")}
	if(!is.null(out.ccov)&&nrow(out.ccov)!=n1)stop("y and out.ccov must have the same number of observations")
	if(!is.null(drop.ccov)&&!is.matrix(drop.ccov)){
		if(inherits(drop.ccov,"formula")){
			mt <- terms(drop.ccov)
			drop.ccov <- as.matrix(model.matrix(mt,model.frame(mt,sys.frame(sys.parent()),na.action=na.fail)))
			if(colnames(drop.ccov)[1]=="(Intercept)")drop.ccov <- drop.ccov[,-1,drop=F]}
		else if(is.vector(drop.ccov,mode="numeric")){
			frname <- paste(deparse(substitute(drop.ccov)))
			drop.ccov <- matrix(drop.ccov,ncol=1)
			colnames(drop.ccov) <- frname}
		else stop("drop.ccov must be a vector, matrix, or model formula")}
	if(!is.null(drop.ccov)&&nrow(drop.ccov)!=n1)stop("y and drop.ccov must have the same number of observations")
	if(!is.null(tvcov)){
		if(!is.vector(tvcov,mode="numeric"))stop("tvcov must be a vector")
		if(length(tvcov)!=n1)stop("y and tvcov must have the same number of observations")}
	else out.tvcov <- drop.tvcov <- F
	if(length(id)!=n1)stop("Every response value must have an id")
	if(length(unique(id))>maxsub)stop("Too many subjects")
	if(max(table(id))>maxcas)stop("Too many measurements for some subjects")
	if(!random.out.int||!out.tvcov)random.out.slope <- F
	if(!random.drop.int||!out.tvcov)random.drop.slope <- F
	id <- matrix(id,ncol=1)
	rownames(id) <- 1:nrow(id)
	y1 <- cbind(id,ifelse(y==0,2,1),rep(1,n1),drop.ccov)
	if(drop.tvcov)y1 <- cbind(y1,tvcov)
	y2 <- cbind(cbind(id,y)[y>0,],rep(0,n2))
	n3d <- 0
	if(!is.null(drop.ccov))n3d <- n3d+ncol(drop.ccov)
	if(drop.tvcov)n3d <- n3d+1
	if(n3d>0)for(i in 1:n3d)y2 <- cbind(y2,rep(0,n2))
	n3o <- 0
	if(!is.null(out.ccov))n3o <- n3o+ncol(out.ccov)
	if(out.tvcov)n3o <- n3o+1
	if(n3o>0)for(i in 1:n3o)y1 <- cbind(y1,rep(0,n1))
	ccov1 <- if(!is.null(out.ccov)) out.ccov[y>0] else NULL
	tvcov1 <- if(out.tvcov) tvcov[y>0] else NULL
	y2 <- cbind(y2,ccov1,tvcov1)
	if(random.out.int){
		y1 <- cbind(y1,rep(1,n1))
		y2 <- cbind(y2,rep(1,n2))}
	if(random.drop.int){
		y1 <- cbind(y1,rep(1,n1))
		y2 <- cbind(y2,rep(0,n2))}
	if(random.out.slope)y1 <- cbind(y1,tvcov,tvcov)
	if(random.drop.slope)y1 <- cbind(y1,tvcov,tvcov)
	for(i in 1:2){
		if(random.out.slope)y2 <- cbind(y2,tvcov[y>0])
		if(random.drop.slope)y2 <- cbind(y2,rep(0,n2))}
	outname <- if(cg==2) "(Intercept)"
		else c(paste("(Intercept)",1:(cg-1),sep=""))
	if(!is.null(out.ccov)){
		if(!is.null(colnames(out.ccov)))outname <- c(outname,colnames(out.ccov))
		else outname <- c(outname,paste("p",1:ncol(out.ccov),sep=""))}
	if(out.tvcov)outname <- c(outname,paste(deparse(substitute(tvcov))))
	dropname <- "(Intercept)"
	if(!is.null(drop.ccov)){
		if(!is.null(colnames(drop.ccov)))dropname <- c(dropname,colnames(drop.ccov))
		else dropname <- c(dropname,paste("p",1:ncol(drop.ccov),sep=""))}
	if(drop.tvcov)dropname <- c(dropname,paste(deparse(substitute(tvcov))))
	data <- rbind(y1,y2)
	data <- data[order(data[,1],rownames(data)),]
	total1 <- cg+n3o+n3d
	if(total1>maxbet)stop("too many regression parameters")
	total2a <- random.out.int+random.drop.int+random.out.slope+
		random.drop.slope
	total2b <- random.out.slope+random.drop.slope
	if(total2a>maxsig||total2b>maxsig)stop("too many random parameters")
	nobs <- nrow(data)
	if(missing(pout)||length(pout)!=cg+n3o-1)stop(paste(cg+n3o-1,"pout estimates must be supplied"))
	if(missing(pdrop)||length(pdrop)!=n3d+1)stop(paste(n3d+1,"pdrop estimates must be supplied"))
	p <- c(pout,pdrop)
	if(total2a+total2b>0){
		p <- c(p,rep(0.5,total2a+total2b))
		if(!missing(prand.out)){
			if(length(prand.out)!=random.out.int+2*random.out.slope)stop(paste(random.out.int+2*random.out.slope,"prand.out estimates must be supplied"))
			if(random.out.int)p[seq(total1+1,total1+total2a+total2b,by=2)] <- prand.out}
		if(!missing(prand.drop)){
			if(length(prand.drop)!=random.drop.int+2*random.drop.slope)stop(paste(random.drop.int+2*random.drop.slope,"prand.drop estimates must be supplied"))
			if(random.drop.int)p[seq(total1+random.out.int+1,total1+total2a+total2b,by=2)] <- prand.drop}}
	total <- total1+total2a+total2b
	z <- .Fortran("logitord",
		y=as.double(data),
		upk=as.integer(binom.mix),
		eps=as.double(eps),
		fcalls=as.integer(fcalls),
		iout=as.integer(print.level),
		cg=as.integer(cg),
		total1=as.integer(total1),
		total2a=as.integer(total2a),
		total2b=as.integer(total2b),
		nobs=as.integer(nobs),
		p=as.double(p),
		x=double(total),
		ster=double(total),
		hess=double(total*total),
		hessinv=double(total*total),
		nflag=integer(1),
		iter=integer(1),
		ifun=integer(1),
		like=double(1),
		DUP=F)
	if(z$nflag>0)switch(as.character(z$nflag),
			"1"=warning("Maximum number of function evaluations has been used"),
			"2"=stop("Linear search failed to improve the function value. Either the function or the gradient is incorrectly coded"),
			"3"=stop("Search vector was not a descent direction. The convergence criterion may be too strict"))
	z$df <- nobs-length(p)
	z$nobs <- nobs
	o <- 1:total1
	if(total2a+total2b>0&&total2a+total2b<=4){
		if(total2b==0||random.drop.slope||!random.drop.int)
			o <- c(o,(total1+1):(total1+total2a+total2b))
		else o <- c(o,total1+1,total1+3,total1+4,total1+2)}
	else if(total2a+total2b==6)o <- c(o,seq(total1+1,total1+total2a+total2b,by=2),seq(total1+2,total1+total2a+total2b,by=2))
	z$x <- z$x[o]
	z$corr <- (-z$hessinv/(z$ster%o%z$ster))[o,o]
	z$ster <- z$ster[o]
	z$outname <- outname
	z$dropname <- dropname
	z$cg <- cg
	z$n3o <- n3o
	z$n3d <- n3d
	z$random.out.int <- random.out.int
	z$random.drop.int <- random.drop.int
	z$random.out.slope <- random.out.slope
	z$random.drop.slope <- random.drop.slope
	z$call <- call
	class(z) <- "logitord"
	z}

print.logitord <- function(z){
	np <- z$total1+z$total2a+z$total2b
	cat("\nLogit ordinal dropout model\n")
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	cat("\n-Log likelihood     ",z$like,"\n")
	cat("Degrees of freedom  ",z$df,"\n")
	cat("AIC                 ",z$like+length(z$x),"\n")
	cat("Iterations          ",z$iter,"\n")
	cat("Function evaluations",z$ifun,"\n")
	cat("\nOutcome model\n")
	num <- 1:(z$cg-1+z$n3o)
	cat("Fixed effect parameters\n")
	coef.table <- cbind(z$x[num],z$ster[num])
	dimnames(coef.table) <- list(z$outname, c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	if(z$random.out.int){
		cat("\nRandom effect parameters\n")
		num <- (z$total1+1):(z$total1+z$random.out.int+2*z$random.out.slope)
		coef.table <- cbind(z$x[num],z$ster[num])
		cname <- "s11"
		if(z$random.out.slope)cname <- c(cname,"s12","s22")
		dimnames(coef.table) <- list(cname,c("estimate", "se"))
		print.default(coef.table, digits=4, print.gap=2)}
	cat("\nDropout model\n")
	cat("Fixed effect parameters\n")
	num <- (z$cg+z$n3o):z$total1
	coef.table <- cbind(z$x[num],z$ster[num])
	dimnames(coef.table) <- list(z$dropname, c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	if(z$random.drop.int){
		cat("\nRandom effect parameters\n")
		num <- (z$total1+z$random.out.int+2*z$random.out.slope+1):(z$total1+z$random.out.int+2*z$random.out.slope+z$random.drop.int+2*z$random.drop.slope)
		coef.table <- cbind(z$x[num],z$ster[num])
		cname <- "d11"
		if(z$random.drop.slope)cname <- c(cname,"d12","d22")
		dimnames(coef.table) <- list(cname,c("estimate", "se"))
		print.default(coef.table, digits=4, print.gap=2)}
	cat("\nCorrelations\n")
	dimnames(z$corr) <- list(seq(1,np),seq(1,np))
	print.default(z$corr, digits=4)
}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     marg.hom(freq,marg1,marg2)
#
#  DESCRIPTION
#
#    A function to fit the marginal homogeneity model to a square
#  contingency table

marg.hom <- function(freq,marg1,marg2){
	call <- sys.call()
	n <- length(unique(marg1))
	if(length(unique(marg2))!=n)stop("a square contingency table must be supplied")
	fit <- res <- freq
	dv <- 0
	test <- T
	a <- matrix(0,ncol=n-1,nrow=length(freq))
	while(test){
		pw <- 1/fit
		for(i in 1:(n-1))a[,i] <- ((marg1==i)-(marg2==i))*fit
		z0 <- glm(freq~a-1,weight=pw)
		fit <- freq-z0$fitted
		test <- (dv-z0$dev)^2>0.0001
		dv <- z0$dev}
	z <- list(call=call,
		model=z0,
		deviance=2*sum(freq*log(freq/fit)),
		df=n-1,
		aic=sum(fit-freq*log(fit)+lgamma(freq+1))+length(freq)-n+1,
		fitted=fit,
		residuals=(freq-fit)/sqrt(fit))
	class(z) <- "marginal"
	return(z)}

print.marginal <- function(z){
	cat("Marginal homogeneity model\n")
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	cat("Deviance          ",z$deviance,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n\n")
	cat("Parameter values\n")
	cat(z$model$coef,"\n")}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998 J.K. Lindsey
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     nbkal(response, times, mu, preg, pdepend, kalman=TRUE,
#	print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001,
#	fscale=1, iterlim=100, typsiz=abs(p), stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit a correlated negative binomial model with Kalman update
#  Adapted from Gauss code written by P. Lambert

nbkal <- function(response, times, mu, preg, pdepend, kalman=TRUE,
	print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001,
	fscale=1, iterlim=100, typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
likenb <- function(p){
	nu <- abs(p[length(p)])
	eta <- nu*exp(mu(p))
	sum(lgamma(response$response$y+1)+lgamma(eta)
		-lgamma(response$response$y+eta)+
		-eta*log(nu)+(response$response$y+eta)*log(1+nu))}
likekal <- function(p){
	eta <- exp(mu(p))
	phi <- exp(-abs(p[length(p)-np1+1]))
	if(np1>1){
		delta <- abs(p[length(p)-np1+2])
		alpha <- exp(p[length(p)-np1+3])
		alpha <- alpha/(1+alpha)}
	else delta <- alpha <- 1
	nm <- like <- 0
	for(ii in 1:nind){
		kapred <- 1
		upspred <- 1/0.000001
		for(jj in 1:response$response$nobs[ii]){
			nm <- nm+1
			if(jj>1){
				kapred <- kap
				upspred <- exp(-phi*(response$response$times[nm]-
					response$response$times[nm-1]))*ups}
			ups <- upspred+alpha*eta[nm]/delta
			kap <- kapred+alpha*(response$response$y[nm]-kapred*
				eta[nm])/(upspred*delta+eta[nm])
			tp3 <- upspred*delta
			tp4 <- kapred*tp3
			like <- like+(tp4-delta+1)*log(tp3)-
				(tp4-delta+1+response$response$y[nm])*
				log(tp3+eta[nm])+
				response$response$y[nm]*log(eta[nm])-
				log(response$response$y[nm]+tp4-delta+1)-
				lbeta(tp4-delta+1,response$response$y[nm]+1)}}
	-like}
likepred <- function(p){
	eta <- exp(mu(p))
	phi <- exp(-abs(p[length(p)-np1+1]))
	if(np1>1){
		delta <- abs(p[length(p)-np1+2])
		alpha <- exp(p[length(p)-np1+3])
		alpha <- alpha/(1+alpha)}
	else delta <- alpha <- 1
	nm <- 0
	rpred <- NULL
	for(ii in 1:nind){
		kapred <- 1
		upspred <- 1/0.000001
		for(jj in 1:response$response$nobs[ii]){
			nm <- nm+1
			if(jj>1){
				kapred <- kap
				upspred <- exp(-phi*(response$response$times[nm]-
					response$response$times[nm-1]))*ups}
			ups <- upspred+alpha*eta[nm]/delta
			kap <- kapred+alpha*(response$response$y[nm]-kapred*
				eta[nm])/(upspred*delta+eta[nm])
			rpred <- c(rpred,eta[nm]*(kap*ups*delta-delta+1)/
				(ups*delta))}}
	rpred}
call <- sys.call()
if(!inherits(response,"repeated")){
	if(!inherits(response,"response"))response <- restovec(response,times)
	response <- rmna(response=response)}
yy <- ifelse(response$response$y==0,1,response$response$y)
nind <- length(response$response$nobs)
p <- c(preg,pdepend)
np <- length(p)
np1 <- length(pdepend)
if(!kalman)z0 <- nlm(likenb, p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
else z0 <- nlm(likekal, p, hessian=T, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
rpred <- if(kalman)likepred(z0$estimate) else NULL
if(any(is.na(z0$hessian)))a <- 0
else a <- qr(z0$hessian)$rank
if(a==np)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
z <- list(
	call=call,
	mu=mu,
	response=response$response,
	maxlike=z0$minimum,
	aic=z0$minimum+np,
	df=length(response$response$y)-np,
	np=np,
	kalman=kalman,
	full=length(pdepend)==3,
	coefficients=z0$estimate,
	se=se,
	cov=cov,
	corr=corr,
	pred=exp(mu(z0$estimate)),
	rpred=rpred,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
if(kalman)class(z) <- c("nbkal","recursive")
else class(z) <- "nbkal"
return(z)}

coefficients.nbkal <- function(z) z$coefficients
deviance.nbkal <- function(z) 2*z$maxlike
fitted.nbkal <- function(z, recursive=TRUE)
	if(recursive) z$rpred else z$pred
residuals.nbkal <- function(z, recursive=TRUE)
	if(recursive) z$response$y-z$rpred else z$response$y-z$pred

print.nbkal <- function(z, digits = max(3, .Options$digits - 3)) {
	np1 <- ifelse(z$full&z$kalman,3,1)
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("Number of subjects    ",length(z$response$nobs),"\n")
	cat("Number of observations",length(z$response$y),"\n")
	t <- deparse(z$mu)
	cat("Location function:",t[2:length(t)],sep="\n")
	cat("\n-Log likelihood   ",z$maxlike,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	cat("Location parameters\n")
	coef.table <- cbind(z$coef[1:(z$np-np1)],z$se[1:(z$np-np1)])
	cname <- NULL
	for(i in 1:nrow(coef.table))cname <- c(cname,paste("p",i,sep=""))
	dimnames(coef.table) <- list(cname, c("estimate","se"))
	print.default(coef.table, digits=digits, print.gap=2)
	cat("\nNonlinear parameters\n")
	cname <- ifelse(z$kalman,"phi","nu")
	tmp <- exp(-exp(-z$coef[(z$np-np1+1)]))
	if(np1>1){
		cname <- c(cname,"delta","alpha")
		tmp <- c(tmp,z$coef[(z$np-np1+2)],exp(z$coef[(z$np-np1+3)])
			/(1+exp(z$coef[(z$np-np1+2)])))}
	coef.table <- cbind(z$coef[(z$np-np1+1):z$np],
		z$se[(z$np-np1+1):z$np],tmp)
	dimnames(coef.table) <- list(cname, c("estimate","se","parameter"))
	print.default(coef.table, digits=digits, print.gap=2)
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}
