.packageName <- "repeated"
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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()
#
# check initial estimates
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)
#
# calculate constants
#
total1 <- length(preg)
total2 <- length(pre1)
t2 <- if(total2>0)total2 else 1
total3 <- length(pre2)
t3 <- if(total3>0)total3 else 1
total <- total1+total2+total3
dimw <- total*(total+7)/2
#
# set up response and regression functions
#
type <- "unknown"
if(inherits(response,"repeated")){
	if(dim(response$response$y)[2]>1)
		stop("binnest only handles univariate responses")
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("binnest does not handle data with NAs")
	type <- response$response$type
	envname <- paste(deparse(substitute(response)))
	# prepare 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,dim(response$response$y)[1]))}
	else resp <- cbind(resp,response$response$n)
	# location function or formula
	if(inherits(mu,"formula")){
		if(as.character(mu)[2]!="1"&&is.character(attr(finterp(mu,.envir=response,.name=envname),"model"))){
			tmp <- wr(mu,data=response)$design
			if(dim(tmp)[2]!=total1)
				stop(paste("preg should contain",dim(tmp)[2],"initial estimates"))
			resp <- cbind(resp,tmp[,-1,drop=FALSE])
			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")
	# function or formula for first level of random effect
	if(inherits(re1,"formula")&&!is.null(pre1)){
		if(as.character(re1)[2]!="1"&&is.character(attr(finterp(re1,.envir=response,.name=envname),"model"))){
			tmp <- wr(re1,data=response)$design
			if(dim(tmp)[2]!=total2)
				stop(paste("pre1 should contain",dim(tmp)[2],"initial estimates"))
			resp <- cbind(resp,tmp[,-1,drop=FALSE])
			re1name <- gsub("\\[.i]","",colnames(tmp))}
		else {
			re1name <- "(Intercept)"
			if(total2!=1)
				stop("pre1 should contain 1 initial estimate")}}
	else pre1 <- re1name <- NULL
	# function or formula for second level of random effect
	if(inherits(re2,"formula")&&!is.null(pre2)){
		if(as.character(re2)[2]!="1"&&is.character(attr(finterp(re2,.envir=response,.name=envname),"model"))){
			tmp <- wr(re2,data=response)$design
			if(dim(tmp)[2]!=total3)
				stop(paste("pre2 should contain",dim(tmp)[2],"initial estimates"))
			resp <- cbind(resp,tmp[,-1,drop=FALSE])
			re2name <- gsub("\\[.i]","",colnames(tmp))}
		else {
			re2name <- "(Intercept)"
			if(total3!=1)
				stop("pre2 should contain 1 initial estimate")}}
	else pre2 <- re2name <- NULL
	nind <- length(nobs(response))
	numsubj <- dim(response$response$y)[1]
	nest <- response$response$nest}
else {
	# not a data object, so make one for the response
	if(inherits(response,"response")){
		if(dim(response$y)[2]>1)
			stop("binnest only handles univariate responses")}
	else {
		if(is.matrix(response)||is.data.frame(response))
			response <- restovec(response,totals=totals,nest=nest,times=FALSE)
		else if(is.list(response))
			response <- restovec(response,times=FALSE)
		else stop("response must be a matrix, data.frame, list, or object of type repeated or response")}
	resp <- response$y
	type <- response$type
	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,dim(response$y)[1]))}
	else resp <- cbind(resp,response$n)
	# prepare covariates by making data objects
	if(!is.null(ccov)){
		if(!inherits(ccov,"tccov"))ccov <- tcctomat(ccov)
		resp <- cbind(resp,ccov$ccov[covind(response),,drop=FALSE])}
	if(!is.null(tvcov)){
		if(!inherits(tvcov,"tvcov"))tvcov <- tvctomat(tvcov)
		resp <- cbind(resp,tvcov$tvcov)}
	nind <- length(nobs(response))
	numsubj <- dim(response$y)[1]
	nest <- response$nest
	regname <- if(dim(resp)[2]>2)
		c("(Intercept)",colnames(resp[,3:dim(resp)])[2])
		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)}
if(type!="unknown"&&type!="nominal")stop("nominal data required")
#
# calculate numbers of observations at two levels
#
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)
#
# call Fortran to optimize likelihood
#
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(dim(resp)[2]),
	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*t2),
	had=double(maxmother*t3),
	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*t2),
	uu2=double(nind*maxmother*maxkid*t3),
	w=double(dimw),
	habb=double(maxmother*total1*total1),
	habs1=double(maxmother*total1*t2),
	habs2=double(maxmother*total1*t3),
	has1s1=double(maxmother*t2*t2),
	has1s2=double(maxmother*t2*t3),
	has2s2=double(maxmother*t3*t3),
	ebb=double(maxmother*total1*total1),
	ebs1=double(maxmother*total1*t2),
	ebs2=double(maxmother*total1*t3),
	fs1s1=double(maxmother*t2*t2),
	fs1s2=double(maxmother*t2*t3),
	gs2s2=double(maxmother*t3*t3),
	e2bb=double(maxmother*maxmother*total1*total1),
	e2bs1=double(maxmother*maxmother*total1*t2),
	e2bs2=double(maxmother*maxmother*total1*t3),
	f2s1s1=double(maxmother*maxmother*t2*t2),
	f2s1s2=double(maxmother*maxmother*t2*t3),
	g2s2s2=double(maxmother*maxmother*t3*t3),
	DUP=TRUE,
	PACKAGE="repeated")
#
# warnings if convergence problems
#
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"))
#
# calculate se's
#
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=dim(resp)[1]-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 method
###
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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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=TRUE, 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=TRUE, print.level=0,
	typsiz=abs(p), ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p),
	steptol=0.00001, iterlim=100, fscale=1){
#
# set up likelihood function
#
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()
#
# check that correct data were supplied
#
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(!is.null(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"))
#
# optimize with nlm
#
pn <- depend+1
z0 <- nlm(like, p=p, hessian=TRUE, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
np <- length(p)
#
# calculate se's
#
a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
	else qr(z0$hessian)$rank
if(a==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 method
###
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)}}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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){
#
# set up likelihood function
#
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()
#
# check input and prepare constants
#
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(capply(freq,as.integer(gl(nn,4,n))),rep(4,nn))
ss <- rep(0,n)
#
# change formula for margins and interaction into matrices
#
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,parent.frame(),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,parent.frame(),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,parent.frame(),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"))
#
# call nlm to optimize
#
like1a <- function(p) like1(p)$like
z1 <- nlm(like1a, p=p, hessian=TRUE, 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
#
# calculate se's
#
a <- if(any(is.na(z1$hessian))||any(abs(z1$hessian)==Inf))0
	else qr(z1$hessian)$rank
if(a==np)cov <- solve(z1$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
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 method
###
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)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     capture(z,n)
#
#  DESCRIPTION
#
#    Functions to fit capture-recapture models.

### function to calculate capture-recapture parameters from a Poisson glm
###
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}

### produce the required variables for the number of periods, n, specified
###
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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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){
#
# check that input is valid
#
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")}
#
# calculate constants
#
nr <- dim(response)[1]
lf <- length(frequency)
ncr <- dim(response)[2]
response <- matrix(as.numeric(response),ncol=ncr)
res <- sort(unique(as.vector(response)),na.last=TRUE)
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)&&(dim(ccov)[1]*nr)!=lf)
	stop("ccov has incorrect number of rows")
#
# calculations for complete observations
#
pc <- resp <- NULL
for(i in 1:dim(response)[1])
	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=TRUE)
      pc <- c(pc,as.vector(t(tt/tot)))}
pc <- as.vector(matrix(pc,ncol=kron,byrow=TRUE))
coef.table <- cbind(pc,sqrt(pc*(1-pc)/rep(tot,rep(ncr,kron*nc))))
cnames <- c("complete","se")
#
# calculations for all observations
#
if(any(is.na(response))){
	total <- rep(capply(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")}
#
# set up table to return
#
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:dim(ccov)[1]){
		tmp <- NULL   
		for(j in 1:dim(ccov)[2])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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     chidden(response=NULL, totals=NULL, times=NULL, distribution="Bernoulli",
#       mu=NULL, cmu=NULL, tvmu=NULL, pgamma, pmu=NULL, pcmu=NULL, ptvmu=NULL,
#       pshape=NULL, pfamily=NULL, par=NULL, pintercept=NULL, delta=NULL,
#	envir=parent.frame(), 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=NULL, totals=NULL, times=NULL,
	distribution="Bernoulli", mu=NULL, cmu=NULL, tvmu=NULL, pgamma,
	pmu=NULL, pcmu=NULL, ptvmu=NULL, pshape=NULL, pfamily=NULL,
	par=NULL, pintercept=NULL, delta=NULL, envir=parent.frame(),
	print.level=0, ndigit=10,  gradtol=0.00001, steptol=0.00001,
	fscale=1, iterlim=100, typsiz=abs(p),stepmax=10*sqrt(p%*%p)){
#
# likelihood function for nlm
#
likel <- function(p){
	if(ord)for(i in 1:states){
		if(!all(diff(p[np4+l*(i-1)+(1:l)])>0))
			p[np4+l*(i-1)+(1:l)] <- p[np4+l*(i-1)+1]*seq(1,1.1,length=l)}
	if(is.function(muf))pmu0 <- muf(p[nm1:nmu])
	if(is.function(cmuf))pmu1 <- cmuf(p[nm1:ncmu])
	if(is.function(tvmuf))pmu2 <- tvmuf(p[ncmu1:np])
	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(nobs(response)),
		mobs=as.integer(mobs),
		s=as.double(if(mdl==4)y else 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),
		gamma2=double(states*states),
		val=double(states),
		vec=double(states*states),
		invec=double(states*states),
		model=as.integer(mdl),
		lgam=as.double(lgam),
		ismu=as.logical(ismu),
		pmu=as.double(pmu0),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np5]),
		ppar=as.logical(!is.null(par)),
		par=as.double(exp(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),
		work2=double(states),
		work3=double(states*states),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
z$like}
#
# likelihood function returning parameter values
#
like <- function(p){
	if(is.function(muf))pmu0 <- muf(p[nm1:nmu])
	if(is.function(cmuf))pmu1 <- cmuf(p[nm1:ncmu])
	if(is.function(tvmuf))pmu2 <- tvmuf(p[ncmu1:np])
	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(nobs(response)),
		mobs=as.integer(mobs),
		s=as.double(if(mdl==4)y else 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),
		gamma2=double(states*states),
		val=double(states),
		vec=double(states*states),
		invec=double(states*states),
		model=as.integer(mdl),
		lgam=as.double(lgam),
		ismu=as.logical(ismu),
		pmu=as.double(pmu0),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np5]),
		ppar=as.logical(!is.null(par)),
		par=as.double(exp(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),
		work2=double(states),
		work3=double(states*states),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$gamma <- matrix(0,ncol=states,nrow=states)
	z$gamma[ipos] <- exp(p[1:nm])
	diag(z$gamma) <- -z$gamma%*%rep(1,states)
z}
call <- sys.call()
#
# check distribution
#
tmp <- c("Bernoulli","Poisson","multinomial","continuation ratio",
	 "proportional odds","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",
	 "skew Laplace","Student t","discretized Poisson process")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
if(mdl>3)mdl <- mdl+1
ord <- distribution=="continuation ratio"||distribution=="proportional odds"
ord2 <- !(!is.null(cmu)&&!is.null(tvmu))
if(!is.null(par)){
	if(ord||distribution=="Bernoulli"||distribution=="multinomial")
		stop("par not allowed with multinomial and ordinal responses")
	else {
		if(par<=0)stop("par must be positive")
		par <- log(par)}}
#
# check estimates of transition matrix
#
if(!is.matrix(pgamma)||dim(pgamma)[2]!=dim(pgamma)[1]){
	if(length(pgamma)==1&&pgamma==1)pgamma <- as.matrix(pgamma)
	else stop("pgamma must be a square transition matrix")}
states <- dim(pgamma)[1]
ipos <- pg <- NULL
if(states>1)for(i in 1:states){
	if(pgamma[i,i]!=0&&round(sum(pgamma[i,]),2)!=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(any(pg<=0))stop("off-diagonal elements of pgamma must be non-negative")
#
# check extra parameters in distribution
#
if(mdl>8&&mdl!=30){
	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"))}
else pshape <- NULL
if(mdl>19&&mdl!=30){
	if(is.null(pfamily))stop("pfamily estimate must be supplied")
	else if(length(pshape)!=1)
		stop(paste("pshape must have one estimate"))}
else pfamily <- NULL
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1){
		if(mdl==3)mdl <- 4
		else stop("chidden only handles univariate responses")}
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("chidden does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)deparse(substitute(response))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
#if response is not a data object, make one
#
if(!respenv){
	if(inherits(envir,"repeated")){
		if(!is.null(envir$NAs)&&any(envir$NAs))
			stop("chidden does not handle data with NAs")
		cn <- deparse(substitute(response))
		if(length(grep("\"",cn))>0)cn <- response
		if(length(cn)>1){
			if(mdl==3)mdl <- 4
			else stop("only one response variable allowed")}
		response <- envir
		col <- match(cn,colnames(response$response$y))
		if(is.na(col))stop(paste("response variable",cn,"not found"))
		type <- response$response$type[col]
		if(dim(response$response$y)[2]>1){
			response$response$y <- response$response$y[,col,drop=FALSE]
			if(!is.null(response$response$delta)){
				response$response$delta <- response$response$delta[,col,drop=FALSE]
				if(all(response$response$delta==1)||all(is.na(response$response$delta)))response$response$delta <- NULL}}}
	else {
        	if(!inherits(response,"response")){
        		if(is.vector(response,mode="numeric"))
        			response <- matrix(response,nrow=1)
        		response <- restovec(response,times=times,totals=totals,delta=delta)}
		type <- response$type
		response <- rmna(response=response)}}
#
# check if response is appropriate for distribution
#
if(is.null(response$response$times))stop("no times available")
if(distribution=="binomial"||distribution=="beta binomial"){
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	if(is.null(response$response$n))stop("totals must be supplied")}
if(mdl<11){
	if((distribution=="Poisson"||distribution=="negative binomial")
		&&type!="unknown"&&type!="discrete")
		stop("discrete data required")
	if(distribution=="Bernoulli"){
		if(type!="unknown"&&type!="nominal")
			stop("nominal data required")
		if(any(response$response$y!=0&response$response$y!=1))
			stop("responses must be binary for Bernoulli")}
	if(distribution=="multinomial"
		&&type!="unknown"&&type!="nominal"&&type!="ordinal")
		stop("nominal or ordinal data required")
	if((distribution=="continuation ratio"||
		distribution=="proportional odds")
		&&type!="unknown"&&type!="ordinal")
		stop("ordinal data required")
	if(any(response$response$y<0))stop("all responses must be non-negative")}
else if(mdl!=11&&mdl!=13&&mdl!=14&&mdl!=15&&mdl!=16&&mdl!=21&&mdl!=27
	&&mdl!=28&&mdl!=29&&mdl!=30){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if(any(response$response$y<=0))stop("all responses must be positive")}
else if(mdl==30){
	if(any(response$response$y!=0&response$response$y!=1))
		stop(paste("responses must be binary for",distribution))}
else if(type!="unknown"&&type!="continuous"&&type!="duration")
	stop("continuous data required")
lgam <- NULL
if(mdl==3||ord){
	l <- length(unique(response$response$y))-1
	if(min(response$response$y)!=0||max(response$response$y)!=l)
		stop(paste("multinomial and ordinal categories must be numbered from 0 to",l))
	if(l<1)stop("multinomial and ordinal responses must have at least 2 categories")}
else if(mdl==4){
	l <- dim(response$response$y)[2]-1
	lgam <- lgamma(apply(response$response$y,1,sum)+1)-
		apply(lgamma(response$response$y+1),1,sum)
	y <- as.vector(t(response$response$y))}
else l <- 1
if(ord){
	if(length(pintercept)!=l*states)
		stop(paste("pintercept should contain",l*states,"estimates"))
	for(i in 1:states){
		if(!all(diff(pintercept[(i-1)*l+(1:l)])>0))
			stop("intercepts must be monotone increasing for each state")}}
else pintercept <- NULL
if(!is.null(response$response$nest)&&!is.null(par))
	stop("chidden does not handle two levels of nesting with an AR")
if(!is.null(response$response$censor))stop("chidden does not handle censoring")
nosubj <- length(nobs(response))
mobs <- max(nobs(response))
nob <- dim(response$response$y)[1]
ismu <- !is.null(mu)
if(ismu)cmu <- tvmu <- pcmu <- ptvmu <- NULL
else pmu <- NULL
#
# if a data object was supplied, modify formulae or functions to read from it
#
muf <- mu1 <- mu3 <- cmuf <- cmu1 <- cmu3 <- tvmuf <- tvmu1 <- tvmu3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(!is.null(mu)){
		cl <- is.list(mu)
		if(!cl)mu <- list(mu)
		tmp2 <- mu3 <- list()
		for(i in 1:length(mu)){
			if(inherits(mu[[i]],"formula")){
				mu3 <- c(mu3,list(if(respenv)finterp(mu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(mu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
				tmp2 <- c(tmp2,list(mu[[i]]))}
			else if(is.function(mu[[i]])){
				tmp <- parse(text=deparse(mu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(mu[[i]],.envir=response,.name=envname)
					else fnenvir(mu[[i]],.envir=envir,.name=envname)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				mu3 <- c(mu3,list(tmp1))}}
		mu <- tmp2
		rm(tmp2)
		if(!cl){
			mu <- mu[[1]]
			mu3 <- mu3[[1]]}}
	if(!is.null(cmu)){
		cl <- is.list(cmu)
		if(!cl)cmu <- list(cmu)
		tmp2 <- cmu3 <- list()
		for(i in 1:length(cmu)){
			if(inherits(cmu[[i]],"formula")){
				cmu3 <- c(cmu3,list(if(respenv)finterp(cmu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(cmu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
			tmp2 <- c(tmp2,list(cmu[[i]]))}
			else if(is.function(cmu[[i]])){
				tmp <- parse(text=deparse(cmu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(cmu[[i]],.envir=response,.name=envname,.expand=FALSE)
					else fnenvir(cmu[[i]],.envir=envir,.name=envname,.expand=FALSE)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				cmu3 <- c(cmu3,list(tmp1))}}
		cmu <- tmp2
		rm(tmp2)
		if(!cl){
			cmu <- cmu[[1]]
			cmu3 <- cmu3[[1]]}}
	if(!is.null(tvmu)){
		cl <- is.list(tvmu)
		if(!cl)tvmu <- list(tvmu)
		tmp2 <- tvmu3 <- list()
		for(i in 1:length(tvmu)){
			if(inherits(tvmu[[i]],"formula")){
				tvmu3 <- c(tvmu3,list(if(respenv)finterp(tvmu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(tvmu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
			tmp2 <- c(tmp2,list(tvmu[[i]]))}
			else if(is.function(tvmu[[i]])){
				tmp <- parse(text=deparse(tvmu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(tvmu[[i]],.envir=response,.name=envname)
					else fnenvir(tvmu[[i]],.envir=envir,.name=envname)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				tvmu3 <- c(tvmu3,list(tmp1))}}
		tvmu <- tmp2
		rm(tmp2)
		if(!cl){
			tvmu <- tvmu[[1]]
			tvmu3 <- tvmu3[[1]]}}}
#
# transform general formulae to functions and check number of parameters
#
npr0 <- if(ord)length(pmu)/states else length(pmu)/states/l
start <- NULL
if(inherits(mu,"formula")){
	mu1 <- if(respenv)finterp(mu,.envir=response,.name=envname,.intercept=!ord)
		else finterp(mu,.envir=envir,.name=envname,.intercept=!ord)
	npt0 <- length(attr(mu1,"parameters"))
	if(is.character(attr(mu1,"model"))){
	# W&R formula
		if(ord&&length(attr(mu1,"model"))==0)mu1 <- NULL}
	else {
	# formula with unknowns
		if(npr0!=npt0){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",if(ord) npt0*states else npt0*states*l,"estimates"))}
		if(is.list(pmu))pmu <- unlist(pmu)}
	if(is.null(mu1))pmu <- NULL}
else if(is.list(mu)){
	if(!ord&&length(mu)!=states*l)
		stop(paste("list of mu formulae or functions must have length",states*l))
	if(ord&&length(mu)!=states)
		stop(paste("list of mu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(mu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in mu)if(inherits(i,"formula")){
		mu1 <- if(respenv)finterp(i,.envir=response,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.name=envname,.start=start,.intercept=!ord)
		npt0 <- length(attr(mu1,"parameters"))
		if(ord&&is.null(attr(mu1,"model")))
			stop("all formulae must contain covariates")
		if(is.list(pmu))pmu <- unlist(pmu)
		# make new list and count parameters
		tmp <- c(tmp,list(mu1))
		start <- start+npt0}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	mu1 <- tmp
	rm(tmp)}
else if(!is.null(mu))mu1 <- mu
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.list(mu)){
	nlp <- if(is.function(mu1))length(attr(mu1,"parameters"))
		else if(is.null(mu1))NULL
		else npt0
	if(!is.null(nlp)&&nlp!=npr0)
		stop(paste("pmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(pmu))
	stop(paste("pmu should have",start,"initial estimates"))
#
# transform time-constant formulae to functions and check number of parameters
#
npr1 <- if(ord)length(pcmu)/states else length(pcmu)/states/l
start <- NULL
if(inherits(cmu,"formula")){
	cmu1 <- if(respenv)finterp(cmu,.envir=response,.expand=FALSE,.name=envname,.intercept=!ord)
		else finterp(cmu,.envir=envir,.expand=FALSE,.name=envname,.intercept=!ord)
	npt1 <- length(attr(cmu1,"parameters"))
	if(is.character(attr(cmu1,"model"))){
	# W&R formula
		if(length(attr(cmu1,"model"))==1&&length(cmu1(pcmu))!=nosubj){
			tmp <- function(p) rep(p[1],nosubj)
			attributes(tmp) <- attributes(cmu1)
			cmu1 <- tmp
			rm(tmp)}
		if(ord&&length(attr(cmu1,"model"))==0)cmu1 <- NULL}
	else {
	# formula with unknowns
		if(npr1!=npt1){
			cat("\nParameters are ")
			cat(attr(cmu1,"parameters"),"\n")
			stop(paste("pcmu should have",if(ord)npt1*states
				else npt1*states*l,"estimates"))}
		if(is.list(pcmu))pcmu <- unlist(pcmu)}
	if(is.null(cmu1))pcmu <- NULL}
else if(is.list(cmu)){
	if(!ord&&length(cmu)!=states*l)
		stop(paste("list of cmu formulae or functions must have length",states*l))
	if(ord&&length(cmu)!=states)
		stop(paste("list of cmu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(cmu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in cmu)if(inherits(i,"formula")){
		cmu1 <- if(respenv)finterp(i,.envir=response,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
		npt1 <- length(attr(cmu1,"parameters"))
		if(is.character(attr(cmu1,"model"))){
		# W&R formula
			if(ord&&length(attr(cmu1,"model"))==1)cm1 <- NULL}
		else if(is.list(pcmu))pcmu <- unlist(pcmu)
		# make new list and count parameters
		tmp <- c(tmp,list(cmu1))
		start <- start+length(attr(cmu1,"parameters"))}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	cmu1 <- tmp
	rm(tmp)}
else if(!is.null(cmu))cmu1 <- cmu
#
# give appropriate attributes to cmu1 for printing
#
if(!is.null(cmu1)&&is.null(attr(cmu1,"parameters"))){
	attributes(cmu1) <- if(is.function(cmu)){
		if(!inherits(cmu,"formulafn")){
			if(respenv)attributes(fnenvir(cmu,.envir=response))
			else attributes(fnenvir(cmu,.envir=envir))}
		else attributes(cmu)}
		else {
			if(respenv)attributes(fnenvir(cmu1,.envir=response))
			else attributes(fnenvir(cmu1,.envir=envir))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.function(cmu)&&!is.list(cmu)){
	nlp <- if(is.function(cmu1))length(attr(cmu1,"parameters"))
		else if(is.null(cmu1))NULL
		else npt1
	if(!is.null(nlp)&&nlp!=npr1)
		stop(paste("pcmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(pcmu))
	stop(paste("pcmu should have",start,"initial estimates"))
#
# transform time-varying formulae to functions and check number of parameters
#
npr2 <- if(ord)length(ptvmu)/states else length(ptvmu)/states/l
start <- NULL
if(inherits(tvmu,"formula")){
	tvmu1 <- if(respenv)finterp(tvmu,.envir=response,.name=envname,.intercept=!ord)
		else finterp(tvmu,.envir=envir,.name=envname,.intercept=!ord)
	npt2 <- length(attr(tvmu1,"parameters"))
	if(is.character(attr(tvmu1,"model"))){
	# W&R formula
		if(length(attr(tvmu1,"model"))==1&&length(tvmu1(ptvmu))!=mobs){
			tmp <- function(p) rep(p[1],mobs)
			attributes(tmp) <- attributes(tvmu1)
			tvmu1 <- tmp
			rm(tmp)}
		else if(ord&&length(attr(tvmu1,"model"))==0)tvmu1 <- NULL}
	else {
	# formula with unknowns
		if(npr2!=npt2){
			cat("\nParameters are ")
			cat(attr(tvmu1,"parameters"),"\n")
			stop(paste("ptvmu should have",if(ord) npt2*states else npt2*states*l,"estimates"))}
		if(is.list(ptvmu))ptvmu <- unlist(ptvmu)}
	if(is.null(tvmu1))ptvmu <- NULL}
else if(is.list(tvmu)){
	if(!ord&&length(tvmu)!=states*l)
		stop(paste("list of tvmu formulae or functions must have length",states*l))
	if(ord&&length(tvmu)!=states)
		stop(paste("list of tvmu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(tvmu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in tvmu)if(inherits(i,"formula")){
		tvmu1 <- if(respenv)finterp(i,.envir=response,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
		npt2 <- length(attr(tvmu1,"parameters"))
		if(is.character(attr(tvmu1,"model"))){
		# W&R formula (don't know how to change index of p[i])
			if(ord&&length(attr(tvmu1,"model"))==1)tvm1 <- NULL}
		else if(is.list(ptvmu))ptvmu <- unlist(ptvmu)
		# make new list and count parameters
		tmp <- c(tmp,list(tvmu1))
		start <- start+length(attr(tvmu1,"parameters"))}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	tvmu1 <- tmp
	rm(tmp)}
else if(!is.null(tvmu))tvmu1 <- tvmu
#
# give appropriate attributes to tvmu1 for printing
#
if(!is.null(tvmu1)&&is.null(attr(tvmu1,"parameters"))){
	attributes(tvmu1) <- if(is.function(tvmu)){
		if(!inherits(tvmu,"formulafn")){
			if(respenv)attributes(fnenvir(tvmu,.envir=response))
			else attributes(fnenvir(tvmu,.envir=envir))}
		else attributes(tvmu)}
		else {
			if(respenv)attributes(fnenvir(tvmu1,.envir=response))
			else attributes(fnenvir(tvmu1,.envir=envir))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.function(tvmu)&&!is.list(tvmu)){
	nlp <- if(is.function(tvmu1))length(attr(tvmu1,"parameters"))
		else if(is.null(tvmu1))NULL
		else npt2
	if(!is.null(nlp)&&nlp!=npr2)
		stop(paste("ptvmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(ptvmu))
	stop(paste("ptvmu should have",start,"initial estimates"))
#
# set up general regression function for likelihood
# if arg==FALSE, can print out general parameter estimates as matrices
#
arg <- TRUE
if(ord&&is.null(mu1))arg <- FALSE
if(is.function(mu1)){
	if(!ord&&is.null(pmu))stop("Initial values of pmu must be supplied")
	tmp <- mu1(pmu)
	if(length(tmp)!=nob)
		stop("mu function or formula must return a vector with one element per observation")
	if(any(is.na(tmp))||any(abs(tmp)==Inf))stop("mu returns NAs or Infs")
	rm(tmp)
	# will be able to print coefficients as matrices
	arg <- FALSE
	# create regression function by repeatedly calling
	# function or formula supplied
	if(distribution=="multinomial"){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zm[,i,j] <- mu1(p[(1:npr0)+(k-1)*npr0])}
			zm}}
	else if(ord){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- mu1(p[(1:npr0)+(i-1)*npr0])
				for(j in 1:l){
					k <- k+1
					zm[,i,j] <- p[np0+k]+tmp}}
			zm}}
	else {
		muf <- function(p){
			z <- NULL
			for(i in 1:states)
				z <- cbind(z,mu1(p[(1:npr0)+(i-1)*npr0]))
			z}}
	attributes(muf) <- attributes(mu)}
else if(is.list(mu1)){
	if(is.null(pmu))stop("Initial values of pmu must be supplied")
	for(i in mu1)if(length(i(pmu))!=nob)stop("each mu function or formula must return a vector with one element per observation")
	# create one regression function from list
	if(distribution=="multinomial"){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zm[,i,j] <- mu1[[k]](p)}
			zm}}
	else if(ord){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- mu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zm[,i,j] <- p[np0+k]+tmp}}
			zm}}
	else {
		muf <- function(p){
			z <- NULL
			for(i in mu1)z <- cbind(z,i(p))
			z}}}
else pmu0 <- NULL
#
# set up time-constant regression function for likelihood
# if arc==FALSE, can print out time-constant parameter estimates as matrices
#
arc <- TRUE
if(is.function(cmu1)){
	if(!ord&&is.null(pcmu))stop("Initial values of pcmu must be supplied")
	# check if array returned or one function/formula for all states
	tmp <- cmu1(pcmu)
	d <- dim(tmp)
	if(length(d)==0){
	# one formula or function
		if(length(tmp)!=nosubj)
			stop("cmu function or formula must return a vector with one element per individual")
		if(any(is.na(tmp))||any(abs(tmp)==Inf))
			stop("cmu returns NAs or Infs")
		rm(tmp)
		# will be able to print coefficients as matrices
		arc <- FALSE
		# create regression function by repeatedly calling
		# function or formula supplied
		if(distribution=="multinomial"){
			zmc <- array(0,c(nosubj,states,l))
			cmuf <- function(p){
				k <- 0
				for(j in 1:l)for(i in 1:states){
					k <- k+1
					zmc[,i,j] <- cmu1(p[(1:npr1)+(k-1)*npr1])}
				zmc}}
		else if(ord){
			zmc <- array(0,c(nosubj,states,l))
			cmuf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- cmu1(p[(1:npr1)+(i-1)*npr1])
					for(j in 1:l){
						k <- k+1
						zmc[,i,j] <- p[np0+k]+tmp}}
				zmc}}
		else {
			cmuf <- function(p){
				z <- NULL
				for(i in 1:states)
					z <- cbind(z,cmu1(p[(1:npr1)+(i-1)*npr1]))
				z}}
		attributes(cmuf) <- attributes(cmu)}
	else {
	# returns an array: check dimensions
		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 if(length(d)!=2)
				stop("cmu must return a 2 dimensional array")
		arc <- FALSE
		cmuf <- cmu1}}
else if(is.list(cmu1)){
	if(is.null(pcmu))stop("Initial values of pcmu must be supplied")
	for(i in cmu1)if(length(i(pcmu))!=nosubj)stop("each cmu function or formula must return a vector with one element per individual")
	# create one regression function from list
	if(distribution=="multinomial"){
		zmc <- array(0,c(nosubj,states,l))
		cmuf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zmc[,i,j] <- cmu1[[k]](p)}
			zmc}}
	else if(ord){
		zmc <- array(0,c(nosubj,states,l))
		cmuf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- cmu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zmc[,i,j] <- p[np0+k]+tmp}}
			zmc}}
	else {
		cmuf <- function(p){
			z <- NULL
			for(i in cmu1)z <- cbind(z,i(p))
			z}}}
else pmu1 <- array(0,c(states,nosubj,l))
#
# set up time-varying regression function for likelihood
# if arv==FALSE, can print out time-varying parameter estimates as matrices
#
arv <- TRUE
if(is.function(tvmu1)){
	if(!ord&&is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	# check if array returned or one function/formula for all states
	tmp <- tvmu1(ptvmu)
	d <- dim(tmp)
	if(length(d)==0){
	# one formula or function
		if(length(tmp)!=mobs)
			stop("tvmu function or formula must return a vector with one element per time point")
		if(any(is.na(tmp))||any(abs(tmp)==Inf))
			stop("tvmu returns NAs or Infs")
		rm(tmp)
		# will be able to print coefficients as matrices
		arv <- FALSE
		# create regression function by repeatedly calling
		# function or formula supplied
		if(distribution=="multinomial"){
			zmv <- array(0,c(mobs,states,l))
			tvmuf <- function(p){
				k <- 0
				for(j in 1:l)for(i in 1:states){
					k <- k+1
					zmv[,i,j] <- tvmu1(p[(1:npr2)+(k-1)*npr2])}
				zmv}}
		else if(ord){
			zmv <- array(0,c(mobs,states,l))
			tvmuf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- tvmu1(p[(1:npr2)+(i-1)*npr2])
					for(j in 1:l){
						k <- k+1
						zmv[,i,j] <- ord2*p[np0+k]+tmp}}
				zmv}}
		else {
			tvmuf <- function(p){
				z <- NULL
				for(i in 1:states)
					z <- cbind(z,tvmu1(p[(1:npr2)+(i-1)*npr2]))
				z}}
		attributes(tvmuf) <- attributes(tvmu)}
	else {
	# returns an array: check dimensions
		if(d[2]!=states)stop(paste("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 if(length(d)!=2)
				stop("tvmu must return a 2 dimensional array")
		arv <- FALSE
		tvmuf <- tvmu1}}
else if(is.list(tvmu1)){
	if(is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	for(i in tvmu1)if(length(i(ptvmu))!=mobs)stop("each tvmu function or formula must return a vector with one element per time point")
	# create one regression function from list
	if(distribution=="multinomial"){
		zmv <- array(0,c(mobs,states,l))
		tvmuf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zmv[,i,j] <- tvmu1[[k]](p)}
			zmv}}
	else if(ord){
		zmv <- array(0,c(mobs,states,l))
		tvmuf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- tvmu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zmv[,i,j] <- ord2*p[np0+k]+tmp}}
			zmv}}
	else {
		tvmuf <- function(p){
			z <- NULL
			for(i in tvmu1)z <- cbind(z,i(p))
			z}}}
else pmu2 <- array(0,c(states,mobs,l))
if(!is.function(muf)&&!is.function(cmuf)&&!is.function(tvmuf)){
	if(ord){
		if(is.null(pintercept))
			stop(paste("pintercept must contain ",l," initial estimates",sep=""))
		else {
			ismu <- TRUE
			zm <- array(0,c(nob,states,l))
			muf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- rep(1,nob)
					for(j in 1:l){
						k <- k+1
						zm[,i,j] <- p[np0+k]*tmp}}
				zm}}}
	else stop("Either mu, cmu or tvmu must be a list, function, or formula")}
#
# prepare to call nlm
#
nm <- length(pg)
nm1 <- nm+1
nmu <- nm+length(pmu)+length(pintercept)
ncmu <- nm+length(pcmu)+length(ptvmu)+length(pintercept)
ncmu1 <- nm+length(pcmu)+1
p <- c(log(pg),pmu,pcmu,ptvmu,pshape,pfamily,pintercept,par)
np <- length(p)
np0 <- np-nm-length(pintercept)-length(par)
np1 <- np-length(pshape)-length(pfamily)-length(pintercept)-length(par)
np2 <- np1+1
np3 <- np-length(pfamily)-length(pintercept)-length(par)
np4 <- np-length(pintercept)-length(par)
np5 <- np-length(par)
pshape <- rep(0,states)
z <- nlm(likel,p, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
#
# prepare mle's
#
delta <- if(!is.null(response$response$delta))
	sum(log(response$response$delta)) else 0
maxlike <- z$minimum - delta
z0 <- like(z$estimate)
#
# calculate se's
#
a <- if(any(is.na(z$hessian))||any(abs(z$hessian)==Inf))0
	else 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)
#
# calculate predicted values
#
if(mdl<3||mdl>6){
	rpred <- 0
	if(is.function(muf)){
		rpred <- rpred+t(muf(z$estimate[nm1:nmu]))
		if(dim(rpred)[2]!=nob)rpred <- rpred[,rep(1:nosubj,nobs(response))]}
	if(is.function(cmuf))rpred <- rpred+t(cmuf(z$estimate[nm1:ncmu]))[,rep(1:nosubj,nobs(response))]
	if(is.function(tvmuf))rpred <- rpred+t(tvmuf(z$estimate[ncmu1:np]))[,sequence(nobs(response))]
	if(mdl==1||mdl==7)rpred <- 1/(1+exp(-rpred))
	pred <- rep(1,states)%*%(rpred*z0$delta)
	rpred <- rep(1,states)%*%(rpred*matrix(z0$filter,nrow=states))}
else pred <- rpred <- NULL
#
# return appropriate attributes on functions
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(cmu3))cmu1 <- cmu3
if(!is.null(tvmu3))tvmu1 <- tvmu3
z1 <- list(
	call=call,
	type="continuous",
	distribution=distribution,
	response=response$response,
	maxlike=maxlike,
	aic=maxlike+np,
	df=length(response$response$y)-np,
	states=states,
	levels=l,
	mu=mu1,
	arg=arg,
	cmu=cmu1,
	arc=arc,
	arv=arv,
	tvmu=tvmu1,
	coef=z$estimate[nm1:np1],
	pshape=if(np3>np1&&!ord)z$estimate[np2:np3] else NULL,
	pfamily=if(np>np3+!is.null(par)&&!ord)z$estimate[np] else NULL,
	pintercept=if(is.null(pintercept)) NULL else z$estimate[np2:np],
	nmu=length(pmu),
	ncmu=length(pcmu),
	ntvmu=length(ptvmu),
	gamma=matrix(z0$gamma,ncol=states),
	delta=z0$delta,
	par=if(!is.null(par))z0$par else NULL,
	np=np,
	cov=cov,
	corr=corr,
	se=se,
	filter=matrix(z0$filter,nrow=states),
	pred=pred,
	rpred=rpred,
	iterations=z$iter,
	code=z$code)
class(z1) <- if(is.null(rpred))"hidden" else c("hidden","recursive")
z1}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     cmcre(response, covariate=NULL, parameters, pcov=NULL, gradient=FALSE,
#	hessian=FALSE, print.level=0, ndigit=10, gradtol=0.00001,
#	steptol=0.00001, iterlim=100, fscale=1, typsiz=abs(Params),
#	stepmax=Params)
#
#  DESCRIPTION
#
#    A function to fit a continuous-time two-state Markov process with a
#  random effect

cmcre <- function(response, covariate=NULL, parameters, pcov=NULL,
	gradient=FALSE, hessian=FALSE, print.level=0, ndigit=10,
	gradtol=0.00001, steptol=0.00001, iterlim=100, fscale=1,
	typsiz=abs(parameters), stepmax=parameters){
#
# set up likelihood functions
#
# ordinary Markov process
LogL1 <- function(Params){
	Params <- c(Params[1],0,Params[2],0,0)
	x <- .C("LogLikelihood1",
		as.double(Params),
		LogLikelihood=double(1),
		Error=integer(1),
		PACKAGE="repeated")
	like <- -x$LogLikelihood
	if(gradient){
		x <- .C("ScoreVector1",
			as.double(Params),
			SVector=double(2),
			PACKAGE="repeated")
		attr(like,"gradient") <- -x$SVector}
	if(hessian){
		x <- .C("Hessian1",
			as.double(Params),
			Hessian=double(4),
			PACKAGE="repeated")
		attr(like,"hessian") <- -x$Hessian}
	like}
# random effect for the equilibrium probability without covariate
LogL2 <- function(Params) {
	Params <- c(Params, 0, 0)
	x <- .C("LogLikelihood2",
		as.double(Params),
		LogLikelihood=double(1),
		Error=integer(1),
		PACKAGE="repeated")
	like <- -x$LogLikelihood
	if(gradient){
		x <- .C("ScoreVector2",
			as.double(Params),
			SVector=double(3),
			PACKAGE="repeated")
		attr(like,"gradient") <- -x$SVector}
	if(hessian){
		x <- .C("Hessian2",
			as.double(Params),
			Hessian=double(9),
			PACKAGE="repeated")
		attr(like,"hessian") <- -x$Hessian}
	like}
# random effect for the equilibrium probability with covariate
LogL3 <- function(Params) {
	Params <- if(cov) c(Params, 0) else c(Params[1],0,Params[2:3],0)
	x <- .C("LogLikelihood3",
		as.double(Params),
		LogLikelihood=double(1),
		Error=integer(1),
		PACKAGE="repeated")
	like <- -x$LogLikelihood
	if(gradient){
		x <- .C("ScoreVector3",
			as.double( Params ),
			SVector=double(np),
			cov=as.integer(cov),
			PACKAGE="repeated")
		attr(like,"gradient") <- -x$SVector}
	if(hessian){
		x <- .C("Hessian3",
			as.double(Params),
			Hessian=double(np*np),
			cov=as.integer(cov),
			PACKAGE="repeated")
		attr(like,"hessian") <- -x$Hessian}
	like}
# random effects for the equilibrium probability and sum of transition
#   intensities
LogL4 <- function(Params) {
	if(!cov) Params <- c(Params[1],0,Params[2:4])
	x <- .C("LogLikelihood4",
		as.double(Params),
		LogLikelihood=double(1),
		Error=integer(1),
		PACKAGE="repeated")
	like <- -x$LogLikelihood
	if(gradient){
		x <- .C("ScoreVector4",
			as.double(Params),
			SVector=double(np),
			cov=as.integer(cov),
			PACKAGE="repeated")
		attr(like,"gradient") <- -x$SVector}
	if(hessian){
		x <- .C("Hessian4",
			as.double(Params),
			Hessian=double(np*np),
			cov=as.integer(cov),
			PACKAGE="repeated")
		attr(like,"hessian") <-  -x$Hessian}
	like}
call <- sys.call()
if(!gradient)hessian <- FALSE
if(!is.matrix(response)||dim(response)[2]!=6)
	stop("response must be a six column matrix with subject id, time interval, and four transition frequencies")
cov <- !is.null(covariate)
if(cov&&(!is.vector(covariate)||length(covariate)!=dim(response)[1]))
	stop("covariate must be a vector with length equal to the number of rows of response")
if(cov){
	if(is.null(pcov)||length(pcov)!=1)stop("pcov must contain one initial estimate")
	parameters <- c(parameters[1],pcov,parameters[2:length(parameters)])}
#
# store data in memory
#
x <- .C("LoadData",
	response=as.double(t(cbind(response[,1],1,response[,2:6],covariate))),
	nrow=as.integer(dim(response)[1]),
	nSize=as.integer(dim(response)[2]+1+cov),
	NumSubjects=integer(1),
	Error=integer(1),
	PACKAGE="repeated")
if(x$Error>0)stop("error in storing data")
#
# define constants
#
nind <- x$NumSubjects
nobs <- sum(response[,3:6])
np <- length(parameters)
#
# choose model
#
if(np==2)mdl <- LogL1
else if(np==3)mdl <- if(cov)LogL2 else LogL3
else if(np==4)mdl <- if(cov)LogL3 else LogL4
else if(np==5&&cov)mdl <- LogL4
else stop("incorrect number of parameters")
#
# optimize with nlm
#
z0 <- nlm(mdl, parameters, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
like <- z0$minimum
#
# calculate se's
#
a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
	else qr(z0$hessian)$rank
if(a==np)covar <- solve(z0$hessian)
else covar <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(covar))
corr <- covar/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
#
# remove data from memory and return results
#
.C("PurgeSubjectData")
z <- list(
	call=call,
	covariate=cov,
	maxlike=like,
	aic=like+np,
	df=nobs-np,
	np=np,
	nobs=nobs,
	nind=nind,
	coefficients=z0$estimate,
	se=se,
	cov=covar,
	corr=corr,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code,
	PACKAGE="repeated")
class(z) <- c("cmcre")
return(z)}

### print method
###
print.cmcre <- function(z, digits = max(3, .Options$digits - 3)){
cat("\nTwo-state Markov chain")
if(length(z$coef)-z$covariate>2)cat(" with random effect\n")
else cat("\n")
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    ",z$nind,"\n")
cat("Number of observations",z$nobs,"\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("Parameters estimates\n")
prob <- c(exp(-exp(z$coef[1])),exp(z$coef[2+z$covariate]))
int <- c(prob[1]*prob[2],(1-prob[1])*prob[2])
cname <- "beta1"
if(z$covariate)cname <- c(cname,"covariate")
cname <- c(cname,"beta2")
if(length(z$coef)-z$covariate>2)cname <- c(cname,"log(tau1)")
if(length(z$coef)-z$covariate>3)cname <- c(cname,"log(tau2)")
coef.table <- cbind(z$coef,z$se)
colname <- c("estimate","se")
dimnames(coef.table) <- list(cname,colname)
print.default(coef.table, digits=digits, print.gap=2)
cat("\nEquilibrium probability:",prob[1],"in state 1\n")
cat("\nTransition intensities:\n","1->2:",int[1],"  2->1:",int[2],"\n")
if(length(z$coef)-z$covariate>2)
	cat("\nRandom effect variance for equilibrium probability:",exp(z$coef[3+z$covariate]),"\n")
if(length(z$coef)-z$covariate>3)
	cat("\nRandom effect variance for sum of transition intensities:",exp(z$coef[4+z$covariate]),"\n")
cat("\nCorrelation matrix\n")
print.default(z$corr, digits=digits)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     cphidden(response=NULL, totals=NULL, times=NULL, distribution="Bernoulli",
#       mu=NULL, cmu=NULL, tvmu=NULL, pgamma, pmu=NULL, pcmu=NULL, ptvmu=NULL,
#       pshape=NULL, pfamily=NULL, par=NULL, pintercept=NULL, delta=NULL,
#	envir=parent.frame(), 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 find a changepoint using a hidden Markov chain
#  model in continuous time

cphidden <- function(response=NULL, totals=NULL, times=NULL,
	distribution="Bernoulli", mu=NULL, cmu=NULL, tvmu=NULL, pgamma,
	pmu=NULL, pcmu=NULL, ptvmu=NULL, pshape=NULL, pfamily=NULL,
	par=NULL, pintercept=NULL, delta=NULL, envir=parent.frame(),
	print.level=0, ndigit=10,  gradtol=0.00001, steptol=0.00001,
	fscale=1, iterlim=100, typsiz=abs(p),stepmax=10*sqrt(p%*%p)){
#
# likelihood function for nlm
#
likel <- function(p){
	if(ord)for(i in 1:states){
		if(!all(diff(p[np4+l*(i-1)+(1:l)])>0))
			p[np4+l*(i-1)+(1:l)] <- p[np4+l*(i-1)+1]*seq(1,1.1,length=l)}
	if(is.function(muf))pmu0 <- muf(p[nm1:nmu])
	if(is.function(cmuf))pmu1 <- cmuf(p[nm1:ncmu])
	if(is.function(tvmuf))pmu2 <- tvmuf(p[ncmu1:np])
	if(np>np1){
		if(np3-np1==1)pshape <- rep(p[np3],states)
		else pshape <- p[np2:np3]}
	z <- .Fortran("cphidden",
		x=as.double(p),
		as.integer(states),
		iq=as.integer(nosubj),
		nobs=as.integer(nobs(response)),
		mobs=as.integer(mobs),
		s=as.double(if(mdl==4)y else 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),
		gamma2=double(states*states),
		val=double(states),
		vec=double(states*states),
		invec=double(states*states),
		model=as.integer(mdl),
		lgam=as.double(lgam),
		ismu=as.logical(ismu),
		pmu=as.double(pmu0),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np5]),
		ppar=as.logical(!is.null(par)),
		par=as.double(exp(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),
		work2=double(states),
		work3=double(states*states),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
z$like}
#
# likelihood function returning parameter values
#
like <- function(p){
	if(is.function(muf))pmu0 <- muf(p[nm1:nmu])
	if(is.function(cmuf))pmu1 <- cmuf(p[nm1:ncmu])
	if(is.function(tvmuf))pmu2 <- tvmuf(p[ncmu1:np])
	if(np>np1){
		if(np3-np1==1)pshape <- rep(p[np3],states)
		else pshape <- p[np2:np3]}
	z <- .Fortran("cphidden",
		x=as.double(p),
		as.integer(states),
		iq=as.integer(nosubj),
		nobs=as.integer(nobs(response)),
		mobs=as.integer(mobs),
		s=as.double(if(mdl==4)y else 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),
		gamma2=double(states*states),
		val=double(states),
		vec=double(states*states),
		invec=double(states*states),
		model=as.integer(mdl),
		lgam=as.double(lgam),
		ismu=as.logical(ismu),
		pmu=as.double(pmu0),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np5]),
		ppar=as.logical(!is.null(par)),
		par=as.double(exp(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),
		work2=double(states),
		work3=double(states*states),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$gamma <- exp(p[1:nm])
	z$gamma <- matrix(c(-z$gamma,z$gamma,0,0),byrow=TRUE,nrow=2)
z}
call <- sys.call()
#
# check distribution
#
tmp <- c("Bernoulli","Poisson","multinomial","continuation ratio",
	 "proportional odds","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",
	 "skew Laplace","Student t")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
if(mdl>3)mdl <- mdl+1
ord <- distribution=="continuation ratio"||distribution=="proportional odds"
ord2 <- !(!is.null(cmu)&&!is.null(tvmu))
if(!is.null(par)){
	if(ord||distribution=="Bernoulli"||distribution=="multinomial")
		stop("par not allowed with multinomial and ordinal responses")
	else {
		if(par<=0)stop("par must be positive")
		par <- log(par)}}
states <- 2
#
# check extra parameters in distribution
#
if(mdl>8&&mdl!=30){
	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"))}
else pshape <- NULL
if(mdl>19&&mdl!=30){
	if(is.null(pfamily))stop("pfamily estimate must be supplied")
	else if(length(pshape)!=1)
		stop(paste("pshape must have one estimate"))}
else pfamily <- NULL
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1){
		if(mdl==3)mdl <- 4
		else stop("cphidden only handles univariate responses")}
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("cphidden does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)deparse(substitute(response))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
#if response is not a data object, make one
#
if(!respenv){
	if(inherits(envir,"repeated")){
		if(!is.null(envir$NAs)&&any(envir$NAs))
			stop("cphidden does not handle data with NAs")
		cn <- deparse(substitute(response))
		if(length(grep("\"",cn))>0)cn <- response
		if(length(cn)>1){
			if(mdl==3)mdl <- 4
			else stop("only one response variable allowed")}
		response <- envir
		col <- match(cn,colnames(response$response$y))
		if(is.na(col))stop(paste("response variable",cn,"not found"))
		type <- response$response$type[col]
		if(dim(response$response$y)[2]>1){
			response$response$y <- response$response$y[,col,drop=FALSE]
			if(!is.null(response$response$delta)){
				response$response$delta <- response$response$delta[,col,drop=FALSE]
				if(all(response$response$delta==1)||all(is.na(response$response$delta)))response$response$delta <- NULL}}}
	else {
        	if(!inherits(response,"response")){
        		if(is.vector(response,mode="numeric"))
        			response <- matrix(response,nrow=1)
        		response <- restovec(response,times=times,totals=totals,delta=delta)}
		type <- response$type
		response <- rmna(response=response)}}
#
# check if response is appropriate for distribution
#
if(is.null(response$response$times))stop("no times available")
if(distribution=="binomial"||distribution=="beta binomial"){
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	if(is.null(response$response$n))stop("totals must be supplied")}
if(mdl<11){
	if((distribution=="Poisson"||distribution=="negative binomial")
		&&type!="unknown"&&type!="discrete")
		stop("discrete data required")
	if(distribution=="Bernoulli"){
		if(type!="unknown"&&type!="nominal")
			stop("nominal data required")
		if(any(response$response$y!=0&response$response$y!=1))
			stop("responses must be binary for Bernoulli")}
	if(distribution=="multinomial"
		&&type!="unknown"&&type!="nominal"&&type!="ordinal")
		stop("nominal or ordinal data required")
	if((distribution=="continuation ratio"||
		distribution=="proportional odds")
		&&type!="unknown"&&type!="ordinal")
		stop("ordinal data required")
	if(any(response$response$y<0))stop("all responses must be non-negative")}
else if(mdl!=11&&mdl!=13&&mdl!=14&&mdl!=15&&mdl!=16&&mdl!=21&&mdl!=27
	&&mdl!=28&&mdl!=29&&mdl!=30){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if(any(response$response$y<=0))stop("all responses must be positive")}
else if(mdl==30){
	if(any(response$response$y!=0&response$response$y!=1))
		stop(paste("responses must be binary for",distribution))}
else if(type!="unknown"&&type!="continuous"&&type!="duration")
	stop("continuous data required")
lgam <- NULL
if(mdl==3||ord){
	l <- length(unique(response$response$y))-1
	if(min(response$response$y)!=0||max(response$response$y)!=l)
		stop(paste("multinomial and ordinal categories must be numbered from 0 to",l))
	if(l<1)stop("multinomial and ordinal responses must have at least 2 categories")}
else if(mdl==4){
	l <- dim(response$response$y)[2]-1
	lgam <- lgamma(apply(response$response$y,1,sum)+1)-
		apply(lgamma(response$response$y+1),1,sum)
	y <- as.vector(t(response$response$y))}
else l <- 1
if(ord){
	if(length(pintercept)!=l*states)
		stop(paste("pintercept should contain",l*states,"estimates"))
	for(i in 1:states){
		if(!all(diff(pintercept[(i-1)*l+(1:l)])>0))
			stop("intercepts must be monotone increasing for each state")}}
else pintercept <- NULL
if(!is.null(response$response$nest)&&!is.null(par))
	stop("cphidden does not handle two levels of nesting with an AR")
if(!is.null(response$response$censor))
	stop("cphidden does not handle censoring")
nosubj <- length(nobs(response))
mobs <- max(nobs(response))
nob <- dim(response$response$y)[1]
ismu <- !is.null(mu)
if(ismu)cmu <- tvmu <- pcmu <- ptvmu <- NULL
else pmu <- NULL
#
# if a data object was supplied, modify formulae or functions to read from it
#
muf <- mu1 <- mu3 <- cmuf <- cmu1 <- cmu3 <- tvmuf <- tvmu1 <- tvmu3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(!is.null(mu)){
		cl <- is.list(mu)
		if(!cl)mu <- list(mu)
		tmp2 <- mu3 <- list()
		for(i in 1:length(mu)){
			if(inherits(mu[[i]],"formula")){
				mu3 <- c(mu3,list(if(respenv)finterp(mu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(mu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
				tmp2 <- c(tmp2,list(mu[[i]]))}
			else if(is.function(mu[[i]])){
				tmp <- parse(text=deparse(mu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(mu[[i]],.envir=response,.name=envname)
					else fnenvir(mu[[i]],.envir=envir,.name=envname)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				mu3 <- c(mu3,list(tmp1))}}
		mu <- tmp2
		rm(tmp2)
		if(!cl){
			mu <- mu[[1]]
			mu3 <- mu3[[1]]}}
	if(!is.null(cmu)){
		cl <- is.list(cmu)
		if(!cl)cmu <- list(cmu)
		tmp2 <- cmu3 <- list()
		for(i in 1:length(cmu)){
			if(inherits(cmu[[i]],"formula")){
				cmu3 <- c(cmu3,list(if(respenv)finterp(cmu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(cmu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
			tmp2 <- c(tmp2,list(cmu[[i]]))}
			else if(is.function(cmu[[i]])){
				tmp <- parse(text=deparse(cmu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(cmu[[i]],.envir=response,.name=envname,.expand=FALSE)
					else fnenvir(cmu[[i]],.envir=envir,.name=envname,.expand=FALSE)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				cmu3 <- c(cmu3,list(tmp1))}}
		cmu <- tmp2
		rm(tmp2)
		if(!cl){
			cmu <- cmu[[1]]
			cmu3 <- cmu3[[1]]}}
	if(!is.null(tvmu)){
		cl <- is.list(tvmu)
		if(!cl)tvmu <- list(tvmu)
		tmp2 <- tvmu3 <- list()
		for(i in 1:length(tvmu)){
			if(inherits(tvmu[[i]],"formula")){
				tvmu3 <- c(tvmu3,list(if(respenv)finterp(tvmu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(tvmu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
			tmp2 <- c(tmp2,list(tvmu[[i]]))}
			else if(is.function(tvmu[[i]])){
				tmp <- parse(text=deparse(tvmu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(tvmu[[i]],.envir=response,.name=envname)
					else fnenvir(tvmu[[i]],.envir=envir,.name=envname)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				tvmu3 <- c(tvmu3,list(tmp1))}}
		tvmu <- tmp2
		rm(tmp2)
		if(!cl){
			tvmu <- tvmu[[1]]
			tvmu3 <- tvmu3[[1]]}}}
#
# transform general formulae to functions and check number of parameters
#
npr0 <- if(ord)length(pmu)/states else length(pmu)/states/l
start <- NULL
if(inherits(mu,"formula")){
	mu1 <- if(respenv)finterp(mu,.envir=response,.name=envname,.intercept=!ord)
		else finterp(mu,.envir=envir,.name=envname,.intercept=!ord)
	npt0 <- length(attr(mu1,"parameters"))
	if(is.character(attr(mu1,"model"))){
	# W&R formula
		if(ord&&length(attr(mu1,"model"))==0)mu1 <- NULL}
	else {
	# formula with unknowns
		if(npr0!=npt0){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",if(ord) npt0*states else npt0*states*l,"estimates"))}
		if(is.list(pmu))pmu <- unlist(pmu)}
	if(is.null(mu1))pmu <- NULL}
else if(is.list(mu)){
	if(!ord&&length(mu)!=states*l)
		stop(paste("list of mu formulae or functions must have length",states*l))
	if(ord&&length(mu)!=states)
		stop(paste("list of mu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(mu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in mu)if(inherits(i,"formula")){
		mu1 <- if(respenv)finterp(i,.envir=response,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.name=envname,.start=start,.intercept=!ord)
		npt0 <- length(attr(mu1,"parameters"))
		if(ord&&is.null(attr(mu1,"model")))
			stop("all formulae must contain covariates")
		if(is.list(pmu))pmu <- unlist(pmu)
		# make new list and count parameters
		tmp <- c(tmp,list(mu1))
		start <- start+npt0}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	mu1 <- tmp
	rm(tmp)}
else if(!is.null(mu))mu1 <- mu
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.list(mu)){
	nlp <- if(is.function(mu1))length(attr(mu1,"parameters"))
		else if(is.null(mu1))NULL
		else npt0
	if(!is.null(nlp)&&nlp!=npr0)
		stop(paste("pmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(pmu))
	stop(paste("pmu should have",start,"initial estimates"))
#
# transform time-constant formulae to functions and check number of parameters
#
npr1 <- if(ord)length(pcmu)/states else length(pcmu)/states/l
start <- NULL
if(inherits(cmu,"formula")){
	cmu1 <- if(respenv)finterp(cmu,.envir=response,.expand=FALSE,.name=envname,.intercept=!ord)
		else finterp(cmu,.envir=envir,.expand=FALSE,.name=envname,.intercept=!ord)
	npt1 <- length(attr(cmu1,"parameters"))
	if(is.character(attr(cmu1,"model"))){
	# W&R formula
		if(length(attr(cmu1,"model"))==1&&length(cmu1(pcmu))!=nosubj){
			tmp <- function(p) rep(p[1],nosubj)
			attributes(tmp) <- attributes(cmu1)
			cmu1 <- tmp
			rm(tmp)}
		if(ord&&length(attr(cmu1,"model"))==0)cmu1 <- NULL}
	else {
	# formula with unknowns
		if(npr1!=npt1){
			cat("\nParameters are ")
			cat(attr(cmu1,"parameters"),"\n")
			stop(paste("pcmu should have",if(ord)npt1*states
				else npt1*states*l,"estimates"))}
		if(is.list(pcmu))pcmu <- unlist(pcmu)}
	if(is.null(cmu1))pcmu <- NULL}
else if(is.list(cmu)){
	if(!ord&&length(cmu)!=states*l)
		stop(paste("list of cmu formulae or functions must have length",states*l))
	if(ord&&length(cmu)!=states)
		stop(paste("list of cmu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(cmu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in cmu)if(inherits(i,"formula")){
		cmu1 <- if(respenv)finterp(i,.envir=response,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
		npt1 <- length(attr(cmu1,"parameters"))
		if(is.character(attr(cmu1,"model"))){
		# W&R formula
			if(ord&&length(attr(cmu1,"model"))==1)cm1 <- NULL}
		else if(is.list(pcmu))pcmu <- unlist(pcmu)
		# make new list and count parameters
		tmp <- c(tmp,list(cmu1))
		start <- start+length(attr(cmu1,"parameters"))}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	cmu1 <- tmp
	rm(tmp)}
else if(!is.null(cmu))cmu1 <- cmu
#
# give appropriate attributes to cmu1 for printing
#
if(!is.null(cmu1)&&is.null(attr(cmu1,"parameters"))){
	attributes(cmu1) <- if(is.function(cmu)){
		if(!inherits(cmu,"formulafn")){
			if(respenv)attributes(fnenvir(cmu,.envir=response))
			else attributes(fnenvir(cmu,.envir=envir))}
		else attributes(cmu)}
		else {
			if(respenv)attributes(fnenvir(cmu1,.envir=response))
			else attributes(fnenvir(cmu1,.envir=envir))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.function(cmu)&&!is.list(cmu)){
	nlp <- if(is.function(cmu1))length(attr(cmu1,"parameters"))
		else if(is.null(cmu1))NULL
		else npt1
	if(!is.null(nlp)&&nlp!=npr1)
		stop(paste("pcmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(pcmu))
	stop(paste("pcmu should have",start,"initial estimates"))
#
# transform time-varying formulae to functions and check number of parameters
#
npr2 <- if(ord)length(ptvmu)/states else length(ptvmu)/states/l
start <- NULL
if(inherits(tvmu,"formula")){
	tvmu1 <- if(respenv)finterp(tvmu,.envir=response,.name=envname,.intercept=!ord)
		else finterp(tvmu,.envir=envir,.name=envname,.intercept=!ord)
	npt2 <- length(attr(tvmu1,"parameters"))
	if(is.character(attr(tvmu1,"model"))){
	# W&R formula
		if(length(attr(tvmu1,"model"))==1&&length(tvmu1(ptvmu))!=mobs){
			tmp <- function(p) rep(p[1],mobs)
			attributes(tmp) <- attributes(tvmu1)
			tvmu1 <- tmp
			rm(tmp)}
		else if(ord&&length(attr(tvmu1,"model"))==0)tvmu1 <- NULL}
	else {
	# formula with unknowns
		if(npr2!=npt2){
			cat("\nParameters are ")
			cat(attr(tvmu1,"parameters"),"\n")
			stop(paste("ptvmu should have",if(ord) npt2*states else npt2*states*l,"estimates"))}
		if(is.list(ptvmu))ptvmu <- unlist(ptvmu)}
	if(is.null(tvmu1))ptvmu <- NULL}
else if(is.list(tvmu)){
	if(!ord&&length(tvmu)!=states*l)
		stop(paste("list of tvmu formulae or functions must have length",states*l))
	if(ord&&length(tvmu)!=states)
		stop(paste("list of tvmu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(tvmu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in tvmu)if(inherits(i,"formula")){
		tvmu1 <- if(respenv)finterp(i,.envir=response,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
		npt2 <- length(attr(tvmu1,"parameters"))
		if(is.character(attr(tvmu1,"model"))){
		# W&R formula (don't know how to change index of p[i])
			if(ord&&length(attr(tvmu1,"model"))==1)tvm1 <- NULL}
		else if(is.list(ptvmu))ptvmu <- unlist(ptvmu)
		# make new list and count parameters
		tmp <- c(tmp,list(tvmu1))
		start <- start+length(attr(tvmu1,"parameters"))}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	tvmu1 <- tmp
	rm(tmp)}
else if(!is.null(tvmu))tvmu1 <- tvmu
#
# give appropriate attributes to tvmu1 for printing
#
if(!is.null(tvmu1)&&is.null(attr(tvmu1,"parameters"))){
	attributes(tvmu1) <- if(is.function(tvmu)){
		if(!inherits(tvmu,"formulafn")){
			if(respenv)attributes(fnenvir(tvmu,.envir=response))
			else attributes(fnenvir(tvmu,.envir=envir))}
		else attributes(tvmu)}
		else {
			if(respenv)attributes(fnenvir(tvmu1,.envir=response))
			else attributes(fnenvir(tvmu1,.envir=envir))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.function(tvmu)&&!is.list(tvmu)){
	nlp <- if(is.function(tvmu1))length(attr(tvmu1,"parameters"))
		else if(is.null(tvmu1))NULL
		else npt2
	if(!is.null(nlp)&&nlp!=npr2)
		stop(paste("ptvmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(ptvmu))
	stop(paste("ptvmu should have",start,"initial estimates"))
#
# set up general regression function for likelihood
# if arg==FALSE, can print out general parameter estimates as matrices
#
arg <- TRUE
if(ord&&is.null(mu1))arg <- FALSE
if(is.function(mu1)){
	if(!ord&&is.null(pmu))stop("Initial values of pmu must be supplied")
	tmp <- mu1(pmu)
	if(length(tmp)!=nob)
		stop("mu function or formula must return a vector with one element per observation")
	if(any(is.na(tmp))||any(abs(tmp)==Inf))stop("mu returns NAs or Infs")
	rm(tmp)
	# will be able to print coefficients as matrices
	arg <- FALSE
	# create regression function by repeatedly calling
	# function or formula supplied
	if(distribution=="multinomial"){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zm[,i,j] <- mu1(p[(1:npr0)+(k-1)*npr0])}
			zm}}
	else if(ord){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- mu1(p[(1:npr0)+(i-1)*npr0])
				for(j in 1:l){
					k <- k+1
					zm[,i,j] <- p[np0+k]+tmp}}
			zm}}
	else {
		muf <- function(p){
			z <- NULL
			for(i in 1:states)
				z <- cbind(z,mu1(p[(1:npr0)+(i-1)*npr0]))
			z}}
	attributes(muf) <- attributes(mu)}
else if(is.list(mu1)){
	if(is.null(pmu))stop("Initial values of pmu must be supplied")
	for(i in mu1)if(length(i(pmu))!=nob)stop("each mu function or formula must return a vector with one element per observation")
	# create one regression function from list
	if(distribution=="multinomial"){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zm[,i,j] <- mu1[[k]](p)}
			zm}}
	else if(ord){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- mu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zm[,i,j] <- p[np0+k]+tmp}}
			zm}}
	else {
		muf <- function(p){
			z <- NULL
			for(i in mu1)z <- cbind(z,i(p))
			z}}}
else pmu0 <- NULL
#
# set up time-constant regression function for likelihood
# if arc==FALSE, can print out time-constant parameter estimates as matrices
#
arc <- TRUE
if(is.function(cmu1)){
	if(!ord&&is.null(pcmu))stop("Initial values of pcmu must be supplied")
	# check if array returned or one function/formula for all states
	tmp <- cmu1(pcmu)
	d <- dim(tmp)
	if(length(d)==0){
	# one formula or function
		if(length(tmp)!=nosubj)
			stop("cmu function or formula must return a vector with one element per individual")
		if(any(is.na(tmp))||any(abs(tmp)==Inf))
			stop("cmu returns NAs or Infs")
		rm(tmp)
		# will be able to print coefficients as matrices
		arc <- FALSE
		# create regression function by repeatedly calling
		# function or formula supplied
		if(distribution=="multinomial"){
			zmc <- array(0,c(nosubj,states,l))
			cmuf <- function(p){
				k <- 0
				for(j in 1:l)for(i in 1:states){
					k <- k+1
					zmc[,i,j] <- cmu1(p[(1:npr1)+(k-1)*npr1])}
				zmc}}
		else if(ord){
			zmc <- array(0,c(nosubj,states,l))
			cmuf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- cmu1(p[(1:npr1)+(i-1)*npr1])
					for(j in 1:l){
						k <- k+1
						zmc[,i,j] <- p[np0+k]+tmp}}
				zmc}}
		else {
			cmuf <- function(p){
				z <- NULL
				for(i in 1:states)
					z <- cbind(z,cmu1(p[(1:npr1)+(i-1)*npr1]))
				z}}
		attributes(cmuf) <- attributes(cmu)}
	else {
	# returns an array: check dimensions
		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 if(length(d)!=2)
				stop("cmu must return a 2 dimensional array")
		arc <- FALSE
		cmuf <- cmu1}}
else if(is.list(cmu1)){
	if(is.null(pcmu))stop("Initial values of pcmu must be supplied")
	for(i in cmu1)if(length(i(pcmu))!=nosubj)stop("each cmu function or formula must return a vector with one element per individual")
	# create one regression function from list
	if(distribution=="multinomial"){
		zmc <- array(0,c(nosubj,states,l))
		cmuf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zmc[,i,j] <- cmu1[[k]](p)}
			zmc}}
	else if(ord){
		zmc <- array(0,c(nosubj,states,l))
		cmuf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- cmu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zmc[,i,j] <- p[np0+k]+tmp}}
			zmc}}
	else {
		cmuf <- function(p){
			z <- NULL
			for(i in cmu1)z <- cbind(z,i(p))
			z}}}
else pmu1 <- array(0,c(states,nosubj,l))
#
# set up time-varying regression function for likelihood
# if arv==FALSE, can print out time-varying parameter estimates as matrices
#
arv <- TRUE
if(is.function(tvmu1)){
	if(!ord&&is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	# check if array returned or one function/formula for all states
	tmp <- tvmu1(ptvmu)
	d <- dim(tmp)
	if(length(d)==0){
	# one formula or function
		if(length(tmp)!=mobs)
			stop("tvmu function or formula must return a vector with one element per time point")
		if(any(is.na(tmp))||any(abs(tmp)==Inf))
			stop("tvmu returns NAs or Infs")
		rm(tmp)
		# will be able to print coefficients as matrices
		arv <- FALSE
		# create regression function by repeatedly calling
		# function or formula supplied
		if(distribution=="multinomial"){
			zmv <- array(0,c(mobs,states,l))
			tvmuf <- function(p){
				k <- 0
				for(j in 1:l)for(i in 1:states){
					k <- k+1
					zmv[,i,j] <- tvmu1(p[(1:npr2)+(k-1)*npr2])}
				zmv}}
		else if(ord){
			zmv <- array(0,c(mobs,states,l))
			tvmuf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- tvmu1(p[(1:npr2)+(i-1)*npr2])
					for(j in 1:l){
						k <- k+1
						zmv[,i,j] <- ord2*p[np0+k]+tmp}}
				zmv}}
		else {
			tvmuf <- function(p){
				z <- NULL
				for(i in 1:states)
					z <- cbind(z,tvmu1(p[(1:npr2)+(i-1)*npr2]))
				z}}
		attributes(tvmuf) <- attributes(tvmu)}
	else {
	# returns an array: check dimensions
		if(d[2]!=states)stop(paste("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 if(length(d)!=2)
				stop("tvmu must return a 2 dimensional array")
		arv <- FALSE
		tvmuf <- tvmu1}}
else if(is.list(tvmu1)){
	if(is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	for(i in tvmu1)if(length(i(ptvmu))!=mobs)stop("each tvmu function or formula must return a vector with one element per time point")
	# create one regression function from list
	if(distribution=="multinomial"){
		zmv <- array(0,c(mobs,states,l))
		tvmuf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zmv[,i,j] <- tvmu1[[k]](p)}
			zmv}}
	else if(ord){
		zmv <- array(0,c(mobs,states,l))
		tvmuf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- tvmu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zmv[,i,j] <- ord2*p[np0+k]+tmp}}
			zmv}}
	else {
		tvmuf <- function(p){
			z <- NULL
			for(i in tvmu1)z <- cbind(z,i(p))
			z}}}
else pmu2 <- array(0,c(states,mobs,l))
if(!is.function(muf)&&!is.function(cmuf)&&!is.function(tvmuf)){
	if(ord){
		if(is.null(pintercept))
			stop(paste("pintercept must contain ",l," initial estimates",sep=""))
		else {
			ismu <- TRUE
			zm <- array(0,c(nob,states,l))
			muf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- rep(1,nob)
					for(j in 1:l){
						k <- k+1
						zm[,i,j] <- p[np0+k]*tmp}}
				zm}}}
	else stop("Either mu, cmu or tvmu must be a list, function, or formula")}
#
# prepare to call nlm
#
nm <- length(pgamma)
nm1 <- nm+1
nmu <- nm+length(pmu)+length(pintercept)
ncmu <- nm+length(pcmu)+length(ptvmu)+length(pintercept)
ncmu1 <- nm+length(pcmu)+1
p <- c(log(pgamma),pmu,pcmu,ptvmu,pshape,pfamily,pintercept,par)
np <- length(p)
np0 <- np-nm-length(pintercept)-length(par)
np1 <- np-length(pshape)-length(pfamily)-length(pintercept)-length(par)
np2 <- np1+1
np3 <- np-length(pfamily)-length(pintercept)-length(par)
np4 <- np-length(pintercept)-length(par)
np5 <- np-length(par)
pshape <- rep(0,states)
z <- nlm(likel,p, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
#
# prepare mle's
#
delta <- if(!is.null(response$response$delta))
	sum(log(response$response$delta)) else 0
maxlike <- z$minimum - delta
z0 <- like(z$estimate)
#
# calculate se's
#
a <- if(any(is.na(z$hessian))||any(abs(z$hessian)==Inf))0
	else 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)
#
# calculate predicted values
#
if(mdl<3||mdl>6){
	rpred <- 0
	if(is.function(muf)){
		rpred <- rpred+t(muf(z$estimate[nm1:nmu]))
		if(dim(rpred)[2]!=nob)rpred <- rpred[,rep(1:nosubj,nobs(response))]}
	if(is.function(cmuf))rpred <- rpred+t(cmuf(z$estimate[nm1:ncmu]))[,rep(1:nosubj,nobs(response))]
	if(is.function(tvmuf))rpred <- rpred+t(tvmuf(z$estimate[ncmu1:np]))[,sequence(nobs(response))]
	if(mdl==1||mdl==7)rpred <- 1/(1+exp(-rpred))
	pred <- rep(1,states)%*%(rpred*z0$delta)
	rpred <- rep(1,states)%*%(rpred*matrix(z0$filter,nrow=states))}
else pred <- rpred <- NULL
#
# return appropriate attributes on functions
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(cmu3))cmu1 <- cmu3
if(!is.null(tvmu3))tvmu1 <- tvmu3
z1 <- list(
	call=call,
	type="continuous",
	changepoint=TRUE,
	distribution=distribution,
	response=response$response,
	maxlike=maxlike,
	aic=maxlike+np,
	df=length(response$response$y)-np,
	states=states,
	levels=l,
	mu=mu1,
	arg=arg,
	cmu=cmu1,
	arc=arc,
	arv=arv,
	tvmu=tvmu1,
	coef=z$estimate[nm1:np1],
	pshape=if(np3>np1&&!ord)z$estimate[np2:np3] else NULL,
	pfamily=if(np>np3+!is.null(par)&&!ord)z$estimate[np] else NULL,
	pintercept=if(is.null(pintercept)) NULL else z$estimate[np2:np],
	nmu=length(pmu),
	ncmu=length(pcmu),
	ntvmu=length(ptvmu),
	gamma=matrix(z0$gamma,ncol=states),
	delta=z0$delta,
	par=if(!is.null(par))z0$par else NULL,
	np=np,
	cov=cov,
	corr=corr,
	se=se,
	filter=matrix(z0$filter,nrow=states),
	pred=pred,
	rpred=rpred,
	iterations=z$iter,
	code=z$code)
class(z1) <- if(is.null(rpred))"hidden" else c("hidden","recursive")
z1}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gar(response=NULL, distribution="normal", times=NULL, totals=NULL,
#	censor=NULL, delta=NULL, mu=NULL, shape=NULL, depend=NULL,
#	shfn=FALSE, common=FALSE, preg=NULL, pshape=NULL, pdepend=NULL,
#	parch=NULL, arch="square", transform="identity", link="identity",
#	autocorr="exponential", order=1, envir=parent.frame(), 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=NULL, distribution="normal", times=NULL, totals=NULL,
	censor=NULL, delta=NULL, mu=NULL, shape=NULL, depend=NULL, shfn=FALSE,
	common=FALSE, preg=NULL, pshape=NULL, pdepend=NULL, parch=NULL,
	arch="square", transform="identity", link="identity",
	autocorr="exponential", order=1, envir=parent.frame(), print.level=0,
	ndigit=10, gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
	typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
#
# set up likelihood to call C code
#
likekal <- function(p){
	eta <- mu1(p)
	if(sh){
		shr <- sh1(p)
		theta <- exp(p[np])
		if(!tm)theta <- c(p[npr1:nprd],theta)}
	else theta <- if(tm)p[nprd1:np] else p[npr1:np]
	if(tm)dep <- dep1(p)
	if(archtype>0)parch <- p[npa]
	z <- .C("gar",
		y=as.double(y),
		total=as.double(response$response$n),
		my=as.integer(3*max(y)),
		nobs=as.integer(nobs(response)),
		nind=as.integer(nind),
		times=as.double(response$response$times),
		censor=as.integer(censor),
		cens=as.integer(!is.null(response$response$censor)),
		eta=as.double(eta),
		tm=as.integer(tm),
		theta=as.double(theta),
		dep=as.double(dep),
		model=as.integer(mdl),
		thp=as.integer(thp),
		shape=as.double(shr),
		sh=as.integer(sh),
		link=as.integer(lnk),
		ar=as.integer(ar),
		order=as.integer(order),
		parch=as.double(parch),
		arch=as.integer(archtype),
		pred=double(n),
		rpred=double(n),
		volatility=double(n),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$like+jacob}
call <- sys.call()
#
# check model required
#
tmp <- c("binomial","Poisson","exponential","negative binomial",
	"mult Poisson","double Poisson","Consul","beta binomial",
	"mult binomial","double binomial","normal","logistic","Cauchy",
	"Weibull","gamma","Laplace","inverse Gauss","Pareto","Levy",
	"beta","simplex","two-sided power","gen gamma","gen logistic","Hjorth",
	"Burr","gen Weibull","gen extreme value","gen inverse Gauss",
	"power exponential","power variance function Poisson",
	"skew Laplace","Student t")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
bmdl <- mdl==1||mdl==8||mdl==9||mdl==10
par1 <- distribution=="binomial"||distribution=="Poisson"||
	distribution=="exponential"
par3 <- mdl>22
tmp <- c("exponential","gaussian","cauchy","spherical","IOU")
ar <- match(autocorr <- match.arg(autocorr,tmp),tmp)
#
# check transformation and link function
#
transform <- match.arg(transform,c("identity","exp","square","sqrt","log"))
if(transform!="identity"&&((mdl<11&&mdl!=3)||mdl==31))
	stop("transformations not valid for discrete data models")
tmp <- c("identity","exp","square","sqrt","log","logit","cloglog","loglog")
lnk <- match(link <- match.arg(link,tmp),tmp)
if((link=="logit"||link=="cloglog"||link=="loglog")&&!bmdl)
	stop("logit, cloglog, and loglog links can only be used with binary data")
#
# check that either AR or ARCH is being fitted
#
if(is.null(pdepend)&&is.null(parch))
	stop("Either pdepend or parch must be supplied")
if(!is.null(parch)){
	if(par1)stop(paste("arch model not possible for",distribution,"distribution"))
	if(length(parch)!=1)stop("parch should contain one value")
	tmp <- c("square","absolute value","exponential")
	archtype <- match(match.arg(arch,tmp),tmp)
	if(archtype!=3&&parch<=0)
		stop("parch must be positive for square and absolute value models")}
else archtype <- 0
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1)
		stop("gar only handles univariate responses")
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("gar does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)deparse(substitute(response))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
#if response is not a data object, find or make one
#
if(!respenv){
	if(inherits(envir,"repeated")){
	# if envir, remove extra (multivariate) responses
		if(!is.null(envir$NAs)&&any(envir$NAs))
			stop("gar does not handle data with NAs")
		cn <- deparse(substitute(response))
		if(length(grep("\"",cn))>0)cn <- response
		if(length(cn)>1)stop("only one response variable allowed")
		response <- envir
		col <- match(cn,colnames(response$response$y))
		if(is.na(col))stop(paste("response variable",cn,"not found"))
		type <- response$response$type[col]
		if(dim(response$response$y)[2]>1){
			response$response$y <- response$response$y[,col,drop=FALSE]
			if(!is.null(response$response$delta)){
				response$response$delta <- response$response$delta[,col,drop=FALSE]
				if(all(response$response$delta==1)||all(is.na(response$response$delta)))response$response$delta <- NULL}
			if(!is.null(response$response$n)){
				response$response$n <- response$response$n[,col,drop=FALSE]
				if(all(is.na(response$response$n)))response$response$n <- NULL}
			if(!is.null(envir$response$censor)){
				response$response$censor <- response$response$censor[,col,drop=FALSE]
				if(all(is.na(response$response$censor)))response$response$censor <- NULL}}}
	else {
		if(!inherits(response,"response")){
			if(is.null(times)){
				if(is.matrix(response))times <- matrix(1:dim(response)[2],nrow=dim(response)[1],ncol=dim(response)[2],byrow=T)
				else if(is.vector(response))times <- 1:length(response)}
			response <- if(bmdl)
				restovec(response, times=times, totals=totals)
				else restovec(response, times=times, censor=censor, delta=delta)}
		type <- response$type
		response <- rmna(response=response)}}
if(is.null(times(response)))stop("No times available")
if((inherits(envir,"repeated")&&
	(length(nobs(response))!=length(nobs(envir))||
	any(nobs(response)!=nobs(envir))))||(inherits(envir,"tvcov")&&
	(length(nobs(response))!=length(envir$tvcov$nobs)||
	any(nobs(response)!=envir$tvcov$nobs))))
	stop("response and envir objects are incompatible")
if(bmdl){
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	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,dim(response$response$y)[1])}}
y <- response$response$y
n <- dim(y)[1]
#
# if a data object was supplied, modify formulae or functions to read from it
#
mu3 <- sh3 <- dep3 <- dep <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	# location function or formula
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,.envir=response,.name=envname)
			else finterp(mu,.envir=envir,.name=envname)}
	else if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
		        tmp <- parse(text=deparse(mu)[-1])
		        mu <- if(respenv)fnenvir(mu,.envir=response,.name=envname)
		        	else fnenvir(mu,.envir=envir,.name=envname)
		        mu3 <- mu
		        attr(mu3,"model") <- tmp}
		else mu3 <- mu}
	# shape function or formula
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,.envir=response,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	else if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=response,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh3 <- shape
			if(shfn){
				pos <- grep("mu",attr(sh3,"parameters"))
				attr(sh3,"parameters") <- attr(sh3,"parameters")[-pos]}
		        attr(sh3,"model") <- tmp}
		else sh3 <- shape}
	# AR function or formula
	if(inherits(depend,"formula")){
		dep3 <- if(respenv)finterp(depend,.envir=response,.name=envname)
			else finterp(depend,.envir=envir,.name=envname)}
	else if(is.function(depend)){
		if(is.null(attr(depend,"model"))){
		        tmp <- parse(text=deparse(depend)[-1])
		        depend <- if(respenv)fnenvir(depend,.envir=response,.name=envname)
		        	else fnenvir(depend,.envir=envir,.name=envname)
		        dep3 <- depend
		        attr(dep3,"model") <- tmp}
		else dep3 <- depend}}
#
# transform location formula to function and check number of parameters
#
npr <- length(preg)
npr1a <- npr1 <- npr+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.character(attr(mu2,"model"))){
	# W&R formula
		if(length(attr(mu2,"model"))==1){
		# intercept model
			mu1 <- function(p) p[1]*rep(1,n)
			attributes(mu1) <- attributes(mu2)
			mu2 <- NULL}}
	else {
	# formula with unknowns
		if(npr!=npt1&&!common){
			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
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# check that correct number of estimates was supplied
#
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"))
#
# transform shape formula to function and check number of parameters
#
nprd <- npr+length(pdepend)
nprd1 <- if(common&&!inherits(shape,"formula")) 1 else nprd+1
nps1 <- nps <- length(pshape)
if(par3)nps1 <- nps1-1
if(inherits(shape,"formula")){
	old <- if(common)mu1 else NULL
	mufn <- if(shfn)"mu" else NULL
	sh3 <- if(respenv)finterp(shape,.envir=response,.start=nprd1,.name=envname,.old=old,.args=mufn)
		else finterp(shape,.envir=envir,.start=nprd1,.name=envname,.old=old,.args=mufn)
	tmp <- attributes(sh3)
	sh2 <- if(shfn)function(p) sh3(p,mu1(p)) else sh3
	attributes(sh2) <- tmp
	npt2 <- length(attr(sh2,"parameters"))
	if(is.character(attr(sh2,"model"))){
	# W&R formula
		if(length(attr(sh2,"model"))==1){
		# intercept model
			sh1 <- function(p) p[nprd1]*rep(1,n)
			attributes(sh1) <- attributes(sh2)
			sh2 <- NULL}}
	else {
	# formula with unknowns
		if(nps1!=npt2&&!common){
			cat("\nParameters are ")
			cat(attr(sh2,"parameters"),"\n")
			stop(paste("pshape should have",npt2+par3,"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)&&!par1){
	sh1 <- function(p) p[nprd1]*rep(1,n)
	npt2 <- 1
	if(length(pshape)!=1+par3)
		stop(paste("pshape must contain",1+par3,"estimate(s)"))}
else sh1 <- if(shfn)function(p) shape(p[nprd1:np], mu1(p))
	else function(p) shape(p[nprd1:np])
#
# give appropriate attributes to sh1 for printing
#
if(!is.null(sh1)&&is.null(attr(sh1,"parameters")))
	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))}
#
# check that correct number of estimates was supplied
#
nlp <- if(is.function(shape))length(attr(sh1,"parameters"))-shfn
	else if(is.null(shape))NULL
	else npt2
if(!is.null(nlp)&&!common&&nlp!=nps1)
	stop(paste("pshape should have",nlp+par3,"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"))}
#
# transform AR formula to function and check number of parameters
#
npd <- length(pdepend)
if(inherits(depend,"formula")){
	dep2 <- if(respenv)finterp(depend,.envir=response,.start=npr1,.name=envname)
		else finterp(depend,.envir=envir,.start=npr1,.name=envname)
	npt3 <- length(attr(dep2,"parameters"))
	if(is.character(attr(dep2,"model"))){
	# W&R formula
		if(length(attr(dep2,"model"))==1){
		# intercept model
			dep1 <- function(p) p[npr1]*rep(1,n)
			attributes(dep1) <- attributes(dep2)
			dep2 <- NULL}}
	else {
	# formula with unknowns
		if(npd!=npt3){
			cat("\nParameters are ")
			cat(attr(dep2,"parameters"),"\n")
			stop(paste("pdepend should have",npt3,"estimates"))}
		if(is.list(pdepend)){
			if(!is.null(names(pdepend))){
				o <- match(attr(dep2,"parameters"),names(pdepend))
				pdepend <- unlist(pdepend)[o]
				if(sum(!is.na(o))!=length(pdepend))stop("invalid estimates for depend - probably wrong names")}
			else pdepend <- unlist(pdepend)}}
	if(!is.null(dep2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			dep1 <- function(p) dep2(p)[cv]
			attributes(dep1) <- attributes(dep2)}
		else {
			dep1 <- dep2
			rm(dep2)}}}
else if(is.function(dep))dep1 <- dep
else {
	dep1 <- NULL
	npt3 <- 1}
#
# give appropriate attributes to dep1 for printing
#
if(!is.null(dep1)&&is.null(attr(dep1,"parameters")))
	attributes(dep1) <- if(is.function(depend)){
		if(!inherits(depend,"formulafn")){
			if(respenv)attributes(fnenvir(depend,.envir=response))
			else attributes(fnenvir(depend,.envir=envir))}
		else attributes(depend)}
		else {
			if(respenv)attributes(fnenvir(dep1,.envir=response))
			else attributes(fnenvir(dep1,.envir=envir))}
#
# check that correct number of estimates was supplied
#
nlp <- if(is.function(depend))length(attr(dep1,"parameters"))
	else if(is.null(depend))NULL
	else npt3
if(!is.null(nlp)&&nlp!=npd)
	stop(paste("pdepend should have",nlp,"initial estimates"))
#
# check response and functions
#
if(mdl<11){
	if((distribution=="Poisson"||distribution=="negative binomial"
		||distribution=="mult Poisson"
		||distribution=="double Poisson"||distribution=="Consul")
		&&type!="unknown"&&type!="discrete")
		stop("discrete data required")
	if(distribution=="exponential"&&type!="unknown"&&type!="duration")
		stop("duration data required")
	if(any(y<0))stop("All responses must be non-negative")}
else if(mdl==20||mdl==21||mdl==22){
	if(type!="unknown"&&type!="continuous")stop("continuous data required")
	if(any(y<=0)||any(y>=1))stop("All responses must be between 0 and 1")}
else if(mdl==31){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y<0))stop("All responses must be non-negative")}
else if(mdl!=11&&mdl!=12&&mdl!=13&&mdl!=16&&mdl!=19&&mdl!=24&&mdl!=30&&
	mdl!=32&&mdl!=33){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if(any(y<=0))stop("All responses must be positive")}
else {
	if(type!="unknown"&&type!="continuous"&&type!="duration")
		stop("continuous data required")
	if(distribution=="Levy"&&any(response$response$y<=mu1(preg)))
		stop("Location function must give values strictly less than corresponding observations")}
if(distribution=="Pareto"&&any(sh1(pshape)<=1))
	stop("shape function must be > 1")
#
# set up censoring indicator
#
censor <- response$response$censor
if(is.null(censor))censor <- rep(1,n)
else if(bmdl||mdl==2||mdl==4||mdl==5||mdl==6||mdl==7||mdl==31)
	stop(paste("Censored data not allowed for",distribution,"distribution"))
#
# set up transformation and Jacobian
#
nind <- length(nobs(response))
if(transform=="identity")jacob <- 0
else if(transform=="exp"){
	jacob <- -sum(y[censor==1])
	y <- exp(y)}
else if(any(y==0))stop("Zero response values: invalid transformation")
else if(transform=="square"){
	jacob <- -sum(log(abs(y[censor==1])))-n*log(2)
	y  <- y^2}
else if(any(y<0))stop("Nonpositive response values: invalid transformation")
else if(transform=="sqrt"){
	jacob <- sum(log(y[censor==1]))/2+n*log(2)
	y <- sqrt(y)}
else if(transform=="log"){
	jacob <- sum(log(y[censor==1]))
	y <- log(y)}
#
# set up unit of measurement
#
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]))}
#
# check AR model
#
if(is.null(pdepend))order <- 0
else if(order!=1&&order!=2)stop("Autoregression must have order 1 or 2")
tm <- !is.null(depend)
if(tm)order <- 0
if(order==2&&length(pdepend)!=2)
	stop("2 estimates of dependence parameters must be given")
else if(order>0&&!tm&&length(pdepend)!=1&&length(pdepend)!=2)
     stop("One or two estimates of dependence parameters must be given")
thp <- length(pdepend)==2&&order==1&&!tm
if(!tm&&any(pdepend<=0))stop("All dependence parameters must be positive")
#
# check location function
#
if(length(mu1(preg))!=dim(response$response$y)[1])
	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")
#
# set up parameter vector
#
p <- if(tm)c(preg,pdepend) else if(order>0)c(preg,-log(pdepend)) else preg
sh <- mdl>3&&(is.function(shape)||inherits(shape,"formula"))
if(!par1){
	if(!sh)p <- c(p,if(mdl==31)c(log(pshape[1]),pshape[2])else log(pshape))
	else {
		if(par3){
			if(pshape[nps]<=0&&mdl!=31)
				stop("extra shape parameter must be positive")
			p <- if(common)c(p,if(mdl==31)pshape[nps]
				else log(pshape[nps]))
				else c(p,pshape[1:(nps-1)],if(mdl==31)
				pshape[nps] else log(pshape[nps]))}
		else p <- c(p,pshape)}}
np <- length(p)
if(archtype>0)p <- c(p,if(archtype==1)log(parch)else parch)
npa <- length(p)
#
# check shape function
#
if(!sh){
	if((mdl<=3&&nps!=0)||(mdl>3&&mdl<23&&nps!=1)||(mdl>=23&&nps!=2))
		stop("Incorrect number of shape parameter estimates")
	else if(nps>0){
		if(mdl!=31&&any(pshape<=0)||mdl==31&&pshape[1]<=0)
			stop("All shape parameters must be positive")}
	shr <- rep(0,dim(response$response$y)[1])}
else {
	if(any(is.na(sh1(p))))
		stop("The shape model returns NAs: probably invalid initial values")
	if(length(sh1(p))!=dim(response$response$y)[1])
		stop("The shape function must provide an estimate for each observation")}
#
# check likelihood function and optimize with nlm
#
if(fscale==1)fscale <- likekal(p)
if(is.na(likekal(p)))
	stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(likekal, p, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
like <- z0$minimum
#
# calculate se's
#
a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
	else qr(z0$hessian)$rank
if(a==npa)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=npa,nrow=npa)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:npa,1:npa)
#
# back transform parameters
#
eta <- mu1(z0$estimate)
if(sh){
	shr <- sh1(z0$estimate)
	theta <- exp(z0$estimate[np])
	if(!tm)theta <- c(z0$estimate[npr1:nprd],theta)}
else theta <- if(tm)z0$estimate[nprd1:np] else z0$estimate[npr1:np]
if(tm)dep <- dep1(z0$estimate)
#
# calculate predicted values (and volatility)
#
if(archtype>0)parch <- z0$estmate[npa]
z <- .C("gar",
	y=as.double(y),
	total=as.double(response$response$n),
	my=as.integer(3*max(y)),
	nobs=as.integer(nobs(response)),
	nind=as.integer(nind),
	times=as.double(response$response$times),
	censor=as.integer(censor),
	cens=as.integer(!is.null(response$response$censor)),
	eta=as.double(eta),
	tm=as.integer(tm),
	theta=as.double(theta),
	dep=as.double(dep),
	model=as.integer(mdl),
	thp=as.integer(thp),
	shape=as.double(shr),
	sh=as.integer(sh),
	link=as.integer(lnk),
	ar=as.integer(ar),
	order=as.integer(order),
	parch=as.double(parch),
	arch=as.integer(archtype),
	pred=double(n),
	rpred=double(n),
	volatility=double(n),
	like=double(1),
	DUP=FALSE,
	PACKAGE="repeated")
if(archtype==0)z$volatility <- NULL
#
# return object
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
if(!is.null(dep3))dep1 <- dep3
z <- list(
	call=call,
	distribution=distribution,
	mu=mu1,
	formula=mu,
	shape=shape,
	depend=depend,
	sh1=sh1,
	shfn=shfn,
	common=common,
	dep1=dep1,
	response=response$response,
	link=link,
	order=order,
	autocorr=autocorr,
	transform=transform,
	maxlike=like,
	aic=like+npa,
	df=dim(response$response$y)[1]-npa,
	np=np,
	npa=npa,
	npr=npr,
	nps=nps,
	npd=npd,
	thp=thp,
	tm=tm,
	archtype=archtype,
	coefficients=z0$estimate,
	se=se,
	cov=cov,
	corr=corr,
	pred=z$pred,
	rpred=z$rpred,
	volatility=z$volatility,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z) <- c("gar","recursive")
return(z)}

### standard methods
###

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 method
###
print.gar <- function(z,digits=max(3,.Options$digits-3),correlation=TRUE){
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"
		||z$distribution=="power variance function Poisson"
		||z$distribution=="skew Laplace"
		||z$distribution=="Student t") 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(nobs(z)),"\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<2)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.character(attr(z$mu,"model")))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.character(attr(z$sh1,"model")))
			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$order>0||z$tm){
	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 if(z$tm){
		cat("\nDependence parameters\n")
		if(!is.null(attr(z$dep1,"formula")))
			cat(deparse(attr(z$dep1,"formula")),sep="\n")
		else if(!is.null(attr(z$dep1,"model"))){
			t <- deparse(attr(z$dep1,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		cname <- if(is.character(attr(z$dep1,"model")))
			attr(z$dep1,"model")
			else attr(z$dep1,"parameters")
		coef.table <- cbind(z$coef[(z$npr+1):(z$npr+z$npd)],
			z$se[(z$npr+1):(z$npr+z$npd)])
		colname <- c("estimate","se")
		dimnames(coef.table) <- list(cname,colname)}
	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]))}
	if(!z$tm)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],if(z$distribution==
		"power variance function Poisson")
		c(exp(z$coef[(z$np-np1+1):(z$np-1)]),z$coef[z$np]) else 
		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.character(attr(z$sh1,"model")))
				attr(z$sh1,"model")
			else attr(z$sh1,"parameters")
		np2 <- length(cname)+(np1==2)
		coef.table <- cbind(z$coef[(z$np-np2+1):z$np],
			z$se[(z$np-np2+1):z$np])
                if(np1==2){
                	cname <- c(cname,"psi")
                	coef.table <- cbind(coef.table,
				c(coef.table[1:(dim(coef.table)[1]-1),1],
				if(z$distribution==
				"power variance function Poisson")
				z$coef[z$np] else exp(z$coef[z$np])))
                	colname <- c(colname,"parameter")}
		dimnames(coef.table) <- list(cname,colname)}
	print.default(coef.table,digits=digits,print.gap=2)}
if(z$archtype>0){
	cat(if(z$archtype==1)"\nSquare"else if(z$archtype==2)"\nAbsolute value"
		else "\nExponential","ARCH parameter\n")
	cname <- c("estimate","se",if(z$archtype!=3)"arch")
	coef.table <- cbind(z$coef[z$npa],z$se[z$npa],
		if(z$archtype!=3)exp(z$coef[z$npa]))
	dimnames(coef.table) <- list("", cname)
	print.default(coef.table,digits=digits,print.gap=2)}
if(correlation){
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}}

### volatility method
###
volatility <- function(z, ...) UseMethod("volatility")

volatility.gar <- function(z, nind=NULL){
if(is.null(nind))nind <- 1:dim(z$response$y)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
if(is.null(z$volatility))return(NULL)
z$volatility[nind]}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gausscop(response=NULL, distribution="gamma", mu=NULL, shape=NULL,
#	autocorr="exponential", pmu=NULL, pshape=NULL,
#	par=NULL, pre=NULL, delta=NULL, shfn=FALSE, common=FALSE,
#	envir=parent.frame(), print.level=0, ndigit=10,
#	gradtol=0.00001, steptol=0.00001, iterlim=100, fscale=1,
#	stepmax=10*sqrt(theta%*%theta), typsiz=abs(c(theta)))
#
#  DESCRIPTION
#
#    Function to fit the multivariate Gaussian copulas with various
# marginal distributions, various autocorrelation functions, one or
# two levels of random effects, and nonlinear regression.

gausscop <- function(response=NULL, distribution="gamma", mu=NULL, shape=NULL,
	autocorr="exponential", pmu=NULL, pshape=NULL, par=NULL,
	pre=NULL, delta=NULL, shfn=FALSE, common=FALSE, envir=parent.frame(),
	print.level=0, ndigit=10, gradtol=0.00001, steptol=0.00001,
	iterlim=100, fscale=1, stepmax=10*sqrt(theta%*%theta),
	typsiz=abs(c(theta))){
#
# distribution functions and densities
#
pinvgauss <- function(q, m, s){
	t <- q/m
	v <- sqrt(q*s)
	pnorm((t-1)/v)+exp(2/(m*s))*pnorm(-(t+1)/v)}
dinvgauss <- function(y, m, s)
	exp(-(y-m)^2/(2*y*s*m^2))/sqrt(2*pi*s*y^3)
plaplace <- function(q, m=0, s=1){
	u <- (q-m)/s
	t <- exp(-abs(u))/2
	ifelse(u<0,t,1-t)}
dlaplace <- function(y, m=0, s=1)
	exp(-abs(y-m)/s)/(2*s)
plevy <- function(q, m=0, s=1){
	if(any(q<m))stop("some y <= m")
	len <- length(q)
	z <- .C("plevy",
		as.double(q),
		as.double(m),
		as.double(s),
		as.double(1),
		len=as.integer(len),
		eps=as.double(1.0e-6),
		pts=as.integer(5),
		max=as.integer(16),
		err=integer(1),
		res=double(len),
		DUP=FALSE,
		PACKAGE="rmutil")
	z$res}
dlevy <- function(y, m=0, s=1){
	if(any(y<=m))stop("some y <= m")
	sqrt(s/(2*pi*(y-m)^3))*exp(-s/(2*(y-m)))}
ppareto <- function(q, m, s){
	if(any(s<=1))stop("s must be > 1")
	1-(1+q/(m*(s-1)))^-s}
dpareto <- function(y, m, s){
	if(any(s<=1))stop("s must be > 1")
	m <- m*(s-1)
	s*(1+y/m)^(-s-1)/m}
#
# likelihood function
#
gcopula <- function(theta){
	mu <- mu1(theta)
	if(dst>1)shape <- exp(shape1(theta))
	if(!indep){
		corr <- 1/(1+exp(-theta[npd1:np]))
		switch(dst,
			"1"=u <- pexp(y,exp(mu)),
			"2"=u <- pgamma(y,shape,scale=exp(mu)/shape),
			"3"=u <- pweibull(y,shape,exp(mu)),
			"4"=u <- ppareto(y,exp(mu),shape),
			"5"=u <- pinvgauss(y,exp(mu),shape),
			"6"=u <- plogis(y,mu,shape),
			"7"=u <- pcauchy(y,mu,shape),
			"8"=u <- plaplace(y,mu,shape),
			"9"=u <- plevy(y,mu,shape))
		if(any(u==1,na.rm=TRUE))u[u==1] <- 1-1e-15
		if(any(u==0,na.rm=TRUE))u[u==0] <- 1e-15
		q <- qnorm(u)
		z <- .Fortran("gcopula",
			theta=as.double(corr),
			like=double(1),
			x=as.double(response$response$times),
			y=as.double(q),
			nobs=as.integer(nobs),
			nest=as.integer(response$response$nest),
			lnest=as.integer(lnest),
			nind=as.integer(nind),
			nld=as.integer(nld),
			npre=as.integer(npre),
			npar=as.integer(npar),
			ar=as.integer(ar),
			v=double(nld*nld),
			tmp1=double(nld),
			tmp2=double(nld),
			tmp3=double(nld),
			warn=logical(1),
			DUP=FALSE,
			PACKAGE="repeated")
		if(z$warn)stop("Correlation matrix for some individuals not positive definite")}
	switch(dst,
		"1"=u <- sum(dexp(y,exp(mu),TRUE)),
		"2"=u <- sum(dgamma(y,shape,scale=exp(mu)/shape,log=TRUE)),
		"3"=u <- sum(dweibull(y,shape,exp(mu),TRUE)),
		"4"=u <- sum(log(dpareto(y,exp(mu),shape))),
		"5"=u <- sum(log(dinvgauss(y,exp(mu),shape))),
		"6"=u <- sum(dlogis(y,mu,shape,TRUE)),
		"7"=u <- sum(dcauchy(y,mu,shape,TRUE)),
		"8"=u <- sum(log(dlaplace(y,mu,shape))),
		"9"=u <- sum(log(dlevy(y,mu,shape))))
	if(indep) -u else z$like-u}
call <- sys.call()
#
# check type of model to be fitted
#
tmp <- c("exponential","gamma","Weibull","Pareto",
	"inverse Gauss","logistic","Cauchy","Laplace","Levy")
dst <- match(distribution <- match.arg(distribution,tmp),tmp)
tmp <- c("exponential","gaussian","cauchy","spherical")
ar <- match(autocorr <- match.arg(autocorr,tmp),tmp)
npr <- length(pmu)
npr1 <- npr+1
npshape <- length(pshape)
npd1 <- npr+npshape+1
if(dst==1){
	npshape <- 0
	pshape <- NULL}
npar <- length(par)
npre <- length(pre)
indep <- (npar+npre)==0
#
# check if location and shape can have common parameters
#
if(common){
	if(!is.function(mu)&&!inherits(mu,"formula"))
		stop("with common parameters, mu must be a function or formula")
	if(!is.function(shape)&&!inherits(shape,"formula"))
		stop("with common parameters, shape must be a function or formula")
	pshape <- NULL}
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1)
		stop("gausscop only handles univariate responses")
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("gausscop does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)paste(deparse(substitute(response)))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
# if envir, remove extra (multivariate) responses
#
if(!respenv&&inherits(envir,"repeated")){
	if(!is.null(envir$NAs)&&any(envir$NAs))
		stop("gausscop does not handle data with NAs")
	cn <- deparse(substitute(response))
	if(length(grep("\"",cn))>0)cn <- response
	if(length(cn)>1)stop("only one response variable allowed")
	response <- envir
	col <- match(cn,colnames(response$response$y))
	if(is.na(col))stop(paste("response variable",cn,"not found"))
	type <- response$response$type[col]
	if(dim(response$response$y)[2]>1){
		response$response$y <- response$response$y[,col,drop=FALSE]
		if(!is.null(response$response$delta)){
			response$response$delta <- response$response$delta[,col,drop=FALSE]
			if(all(response$response$delta==1)||all(is.na(response$response$delta)))response$response$delta <- NULL}}}
if(inherits(response,"response")){
	type <- response$type
	response <- rmna(response)}
if((inherits(envir,"repeated")&&(length(nobs(response))!=length(nobs(envir))||
	any(nobs(response)!=nobs(envir))))||(inherits(envir,"tvcov")&&
	(length(nobs(response))!=length(envir$tvcov$nobs)||
	any(nobs(response)!=envir$tvcov$nobs))))
	stop("response and envir objects are incompatible")
if((distribution=="exponential"||distribution=="gamma"||distribution=="Weibull"
	||distribution=="Pareto"||distribution=="inverse Gauss")
	&&type!="unknown"&&type!="duration"&&type!="continuous")
	stop("duration data required")
if((distribution=="logistic"||distribution=="Cauchy"||distribution=="Laplace"
	||distribution=="Levy")&&type!="unknown"&&type!="continuous"
	&&type!="duration")stop("continuous data required")
y <- response$response$y
if(dst<6&&any(y<=0))
	stop(paste("all responses must be positive for",distribution,"distribution"))
n <- length(y)
nobs <- nobs(response)
nind <- length(nobs)
nld <- max(nobs)
#
# if a data object was supplied, modify formulae or functions to read from it
#
mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,.envir=response,.name=envname)
			else finterp(mu,.envir=envir,.name=envname)}
	else if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
		        tmp <- parse(text=deparse(mu)[-1])
		        mu <- if(respenv)fnenvir(mu,.envir=response,.name=envname)
		        	else fnenvir(mu,.envir=envir,.name=envname)
		        mu3 <- mu
		        attr(mu3,"model") <- tmp}
		else mu3 <- mu}
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,.envir=response,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	else if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=response,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh3 <- shape
		        attr(sh3,"model") <- tmp}
		else sh3 <- shape}}
#
# transform mu formula to function and check number of parameters
#
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.character(attr(mu2,"model"))){
	# W&R formula
		if(length(attr(mu2,"model"))==1){
			mu1 <- function(p) p[1]*rep(1,n)
			attributes(mu1) <- attributes(mu2)
			mu2 <- NULL}}
	else {
	# formula with unknowns
		if(npr!=npt1&&!common){
			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")){
		# fix length if only time-constant covariates
			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
else {
	if(npr!=1)stop("pmu should have one estimate")
	mu1 <- function(p) rep(p[1],n)}
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# if possible, check that correct number of estimates was supplied
#
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("pmu should have",nlp,"initial estimates"))
if(length(mu1(pmu))!=sum(nobs(response)))
	stop("The location function must provide an estimate for each observation")
n1 <- if(common&&!inherits(shape,"formula")) 1 else npr1
n2 <- npr+npshape
#
# transform shape formula to function and check number of parameters
#
if(inherits(shape,"formula")){
	old <- if(common)mu1 else NULL
	mufn <- if(shfn)"mu" else NULL
	shape4 <- if(respenv)finterp(shape,.envir=response,.start=n1,.name=envname,.old=old,.args=mufn)
		else finterp(shape,.envir=envir,.start=n1,.name=envname,.old=old,.args=mufn)
	tmp <- attributes(shape4)
	shape2 <- if(shfn)function(p) shape4(p,mu1(p)) else shape4
	attributes(shape2) <- tmp
	npt2 <- length(attr(shape2,"parameters"))
	if(is.character(attr(shape2,"model"))){
	# W&R formula
		if(length(attr(shape2,"model"))==1){
			shape1 <- function(p) p[n1]*rep(1,n)
			attributes(shape1) <- attributes(shape2)
			shape2 <- NULL}}
	else {
	# formula with unknowns
		if(npshape!=npt2&&!common){
			cat("\nParameters are ")
			cat(attr(shape2,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(shape2,"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(shape2)){
		if(inherits(envir,"tccov")){
			cv <- covind(response)
			shape1 <- function(p) shape2(p)[cv]
			attributes(shape1) <- attributes(shape2)}
		else {
			shape1 <- shape2
			rm(shape2)}}}
else if(is.function(shape))shape1 <- if(shfn) function(p) shape(p[n1:n2],mu1(p))
		else function(p) shape(p[n1:n2])
else if(dst>1){
	if(npshape!=1)stop("pshape should have one estimate")
	shape1 <- function(p) rep(p[npr1],n)}
else shape1 <- NULL
#
# give appropriate attributes to shape1 for printing
#
if(dst>1){
	if(!is.null(shape1)&&is.null(attr(shape1,"parameters")))
		attributes(shape1) <- 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(shape1,.envir=response))
		else attributes(fnenvir(shape1,.envir=envir))}
	nlp <- if(is.function(shape))length(attr(shape1,"parameters"))-shfn
		else if(is.null(shape)||is.character(shape))NULL
		else if(!inherits(shape,"formula"))stop("shape must be a function or formula")
		else npt2}
#
# set up nesting indicator
#
if(!is.null(response$response$nest))lnest <- max(response$response$nest)
else {
	lnest <- 0
	response$response$nest <- rep(1,length(y))}
#
# check times
#
if(is.null(response$response$times)&&!is.null(par))
	stop("No times. AR cannot be fitted")
nm <- sum(nobs(response))
#
# include delta in Jacobian
#
jacob <- 0
if(!is.null(response$response$delta)){
	if(length(response$response$delta)==1)jacob <- jacob-nm*log(response$response$delta)
	else jacob <- jacob -sum(log(response$response$delta))}
#
# set up shape function if there is one and check initial estimates
#
theta <- c(pmu,pshape)
#
# check AR and random effect
#
np <- npr+npshape+npre+npar
if(!indep&&sum(c(pre,par))>=1)
	stop("Sum of correlations (pre+par) must be less than 1")
if(npre>0){
	if(any(pre<=0)||any(pre>=1))
		stop("All variance components must lie between 0 and 1")
	theta <- c(theta,log(pre/(1-pre)))}
if(npar>0){
	if(par<=0||(par>=1))
		stop("Estimate of autocorrelation must lie between 0 and 1")
	theta <- c(theta,log(par/(1-par)))}
#
# estimate model
#
if(fscale==1)fscale <- gcopula(theta)
z0 <- nlm(gcopula, p=theta, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
p <- z0$estimate
z <- gcopula(p)
like <- z+jacob
pred <- if(dst<6)exp(mu1(p)) else mu1(p)
#
# get parameters
#
if(npre>0){
	tausq <- exp(p[npd1:(npr+npshape+npre)])
	tausq <- tausq/(1+tausq)}
else tausq <- 0
if(npar>0){
	rho <- exp(p[npd1+npre])
	rho <- rho/(1+rho)}
else rho <- 0
#
# calculate se's
#
if(np==1){
	nlcov <- 1/z0$hessian
	nlse <- sqrt(nlcov)}
else {
	a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
		else qr(z0$hessian)$rank
	if(a==np)nlcov <- solve(z0$hessian)
	else nlcov <- matrix(NA,ncol=np,nrow=np)
	nlse <- sqrt(diag(nlcov))}
if(length(nlse)>1)nlcorr <- nlcov/(nlse%o%nlse)
else nlcorr <- as.matrix(nlcov/nlse^2)
dimnames(nlcorr) <- list(seq(1,np),seq(1,np))
#
# return list
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))shape1 <- sh3
z <- list(
	call=call,
	distribution=distribution,
	mu1=mu1,
	shape1=shape1,
	common=common,
	shfn=shfn,
	autocorr=autocorr,
	response=response$response,
	maxlike=like,
	aic=like+np,
	df=nm-np,
	np=np,
	npr=npr,
	npshape=npshape,
	npar=npar,
	npre=npre,
	coefficients=p,
	nlse=nlse,
	nlcov=nlcov,
	nlcorr=nlcorr,
	tausq=tausq,
	rho=rho,
	residuals=z$res,
	pred=pred,
	grad=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z) <- "gausscop"
return(z)}

### standard methods
###

deviance.gausscop <- function(z) 2*z$maxlike

fitted.gausscop <- function(z) z$pred

residuals.gausscop <- function(z) z$response$y-z$pred

### print method
###
print.gausscop <- function(z,digits=max(3,.Options$digits-3),correlation=TRUE){
cat("\nMultivariate normal copula with",z$distribution,"marginals\n")
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(nobs(z)),"\n")
cat("Number of observations",length(z$response$y),"\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")
if(z$common)cat("Location function\n")
else cat("Location function parameters\n")
if(!is.null(attr(z$mu1,"formula")))
	cat(deparse(attr(z$mu1,"formula")),sep="\n")
else if(!is.null(attr(z$mu1,"model"))){
	t <- deparse(attr(z$mu1,"model"))
	t[1] <- sub("expression\\(","",t[1])
	t[length(t)] <- sub("\\)$","",t[length(t)])
	cat(t,sep="\n")}
cname <- if(is.character(attr(z$mu1,"model")))attr(z$mu1,"model")
	else attr(z$mu1,"parameters")
coef.table <- cbind(z$coef[1:z$npr],z$nlse[1:z$npr])
if(!z$common){
	dimnames(coef.table) <- list(cname,c("estimate","se"))
	print.default(coef.table,digits=digits,print.gap=2)}
if(inherits(z$shape1,"formulafn")){
	if(z$common)cat("\nShape function\n")
	else {
		cat("\nShape function parameters\n")
		cname <- NULL}
	if(!is.null(attr(z$shape1,"formula")))
		cat(deparse(attr(z$shape1,"formula")),sep="\n")
	else if(!is.null(attr(z$shape1,"model"))){
		t <- deparse(attr(z$shape1,"model"))
		t[1] <- sub("expression\\(","",t[1])
		t[length(t)] <- sub("\\)$","",t[length(t)])
		cat(t,sep="\n")}
	cname <- c(cname,if(is.character(attr(z$shape1,"model")))
		attr(z$shape1,"model")
		else attr(z$shape1,"parameters")[1:z$npshape])
	if(!z$common)coef.table <- cbind(z$coef[(z$npr+1):(z$npr+z$npshape)], z$nlse[(z$npr+1):(z$npr+z$npshape)])
	else cat("\nCommon parameters\n")
	dimnames(coef.table) <- list(unique(cname),c("estimate","se"))
	print.default(coef.table,digits=digits,print.gap=2)}
else if(!is.null(z$shape1)) {
	if(z$npshape==1)cat("\nShape\n")
	else cat("\nShape parameters\n")
	if(z$npshape>1)
		vname <- c("(Intercept)",paste("t^",1:(z$npshape-1),sep=""))
	else vname <- ""
	coef.table <- cbind(z$coef[(z$npr+1):(z$npr+z$npshape)],
		z$nlse[(z$npr+1):(z$npr+z$npshape)])
	dimnames(coef.table) <- list(vname,c("estimate","se"))
	print.default(coef.table,digits=digits,print.gap=2)}
if(z$npre>0){
	cat("\nVariance components\n")
	coef.table <- cbind(z$coef[(z$npr+z$npshape+1):(z$npr+z$npshape+z$npre)],
		z$nlse[(z$npr+z$npshape+1):(z$npr+z$npshape+z$npre)],z$tausq)
	if(z$npre==1)cname <- "tausq"
	else cname <- c("Level 1","Level 2")
	dimnames(coef.table) <- list(cname,c("estimate","se",""))
	print.default(coef.table,digits=digits,print.gap=2)}
if(z$rho!=0){
	cat("\n",z$autocorr," autocorrelation\n",sep="")
	coef.table <- cbind(z$coef[z$npr+z$npshape+z$npre+1],
		z$nlse[z$npr+z$npshape+z$npre+1],z$rho)
	dimnames(coef.table) <- list("rho",c("estimate","se",""))
	print.default(coef.table,digits=digits,print.gap=2)}
if(z$np>1&&correlation){
	cat("\nCorrelation matrix\n")
	print.default(z$nlcorr,digits=digits)}}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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()
#
# find the design matrix
#
md <- missing(data)
if(missing(data))data <- parent.frame()
else if(inherits(data,"repeated"))data <- as.data.frame(data)
mf <- model.frame(terms(formula,data=data),data,na.action=na.fail)
#
# find the distribution
#
if(is.character(family))family <- get(family)
if(is.function(family))family <- family()
if(is.vector(mf[,1])||(is.matrix(mf[,1])&&dim(mf[,1])[2]==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])}
#
# check the nesting variable
#
slen <- length(y)
if(!md)nest <- model.frame(terms(as.formula(paste("~",deparse(substitute(nest)),sep="")),data=data),data,na.action=na.fail)[[1]]
if(length(nest)!=slen)
	stop("the nesting variable is not the same length as the other variables")
if(is.factor(nest))nest <- as.numeric(nest)
else nest <- as.numeric(factor(nest))
if(length(unique(nest))!=max(nest))
	stop("(codes of) the nesting variable must be consecutively numbered")
nind <- length(unique(nest))
if(length(nest)==nind&&family$family!="binomial"&&family$family!="poisson")
	stop("Some individuals must have more than one observation")
#
# set up Gauss-Hermite quadrature points
#
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]
#
# modify formula to contain standard deviation of mixture
#
nmodel <- update.formula(formula,.~.+sd)
nnmf <- if(md)mf[i,,drop=FALSE] else data[i,,drop=FALSE]
#
# set up adjusted weights and offset
#
if(missing(weights))lwt <- rep(1,slen)
else {
	if(!md){
		col <- match(deparse(substitute(weights)),names(data))
		if(is.na(col))stop("weights not found")
		lwt <- data[[col]]}
	else lwt <- as.vector(weights)}
nobs <- sum(lwt)
if(missing(offset))off <- rep(0,slen)
else if(md)
	stop("offset can only be used when a data.frame is specified")
else {
	col <- match(deparse(substitute(offset)),names(data))
	if(is.na(col))stop("offset not found")
	off <- data[[col]]}
#
# put everything in dataframe and run glm to find initial estimates
#
if(!md){
	data <- data.frame(data,lwt,off)
	zz <- glm(formula,family=family,data=data,control=control,
		weights=lwt,offset=off)}
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)}
#
# expand offset and find deviance and d.f.
#
offset <- off[i]
ndev <- zz$deviance
rdf <- zz$df.res-1
ndf <- zz$df.null
fv <- family$linkinv(zz$linear[i]+sd)
sc <- ndev/nobs
#
# define log likelihood function
#
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))
#
# iterate, calling glm and checking for underflow
#
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}
#
# prepare object to return
#
z$deviance <- -2*sum(log(pr)-under)
formula <- update.formula(formula,.~1)
class(formula) <- "formula"
if(!md)
	zz <- glm(formula,family=family,data=data,control=control,
		weights=lwt,offset=off)
else zz <- glm(formula,family=family,data=data,control=control)
#
# calculate corrected AIC and deviance
#
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}

### standard print methods
###
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) 2000, 2001, 2002 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gnlmix(y=NULL, distribution="normal", mixture="normal",
#	random=NULL, nest=NULL, mu=NULL, shape=NULL, linear=NULL,
#	pmu=NULL, pshape=NULL, pmix=NULL, delta=1, common=FALSE,
#	envir=parent.frame(), print.level=0, typsiz=abs(p),
#	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p), steptol=0.00001,
#	iterlim=100, fscale=1, eps=1.0e-4, points=5, steps=10)
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models with one arbitrary
#  random parameter

gnlmix <- function(y=NULL, distribution="normal", mixture="normal",
	random=NULL, nest=NULL, mu=NULL, shape=NULL, linear=NULL,
	pmu=NULL, pshape=NULL, pmix=NULL, delta=1, common=FALSE,
	envir=parent.frame(), print.level=0, typsiz=abs(p),
	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p), steptol=0.00001,
	iterlim=100, fscale=1, eps=1.0e-4, points=5, steps=10){

int1 <- function(ff, aa, bb)
	.C("romberg",
		ff,
		as.double(aa),
		as.double(bb),
		len=as.integer(nnest),
		eps=as.double(eps),
		pts=as.integer(points),
		max=as.integer(steps),
		err=integer(1),
		res=double(nnest),
		PACKAGE="rmutil")$res
inta <- function(f){
	ff <- function(x) f(1/x)/(x*x)
	int1(ff,neg1,zero)+int1(f,neg1,pos1)+int1(ff,zero,pos1)}
intb <- function(f){
	ff <- function(x) f(1/x)/(x*x)
	int1(f,zero,pos1)+int1(ff,zero,pos1)}
call <- sys.call()
#
# check 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","beta",
	"simplex","two-sided power"))
shp <- distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"
#
# check mixture
#
mixture <- match.arg(mixture,c("normal","logistic","Cauchy","Laplace",
	"gamma","inverse gamma","inverse Gauss","Weibull","Levy","beta",
	"simplex","two-sided power"))
#
# check random parameters
#
if(is.null(random))stop("name of random parameter must be supplied")
if(!is.character(random))stop("random must be the name of a parameter")
if(length(random)>1)stop("only one random parameter allowed")
#
# check for parameters common to location and shape functions
#
if(common&&!is.null(linear))
	stop("linear cannot be used with common parameters")
#
# count number of parameters
#
npl <- length(pmu)
nps <- length(pshape)
np <- npl+nps+1
#
# check if a data object is being supplied
#
respenv <- exists(deparse(substitute(y)),envir=parent.frame())&&
	inherits(y,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(y$response$y)[2]>1)
		stop("gnlmix only handles univariate responses")
	if(!is.null(y$NAs)&&any(y$NAs))
		stop("gnlmix does not handle data with NAs")}
envname <- if(respenv)deparse(substitute(y))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
# check that formulae with unknowns are supplied
#
if(!inherits(mu,"formula"))stop("mu must be a formula")
if(shp&&!is.null(shape)&&!inherits(shape,"formula"))
	stop("shape must be a formula")
#
# find linear part of each regression
#
lin1 <- lin2 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]}
else lin1 <- linear
#
# if a data object was supplied, modify formulae or functions to read from it
#
lin1a <- lin2a <- mu2 <- sh2 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	# modify formulae
	if(inherits(mu,"formula")){
		mu2 <- if(respenv)finterp(mu,.envir=y,.name=envname,.args=random)
			else finterp(mu,.envir=envir,.name=envname,.args=random)}
	if(inherits(shape,"formula")){
		sh2 <- if(respenv)finterp(shape,.envir=y,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	if(inherits(lin1,"formula")){
		lin1a <- if(respenv)finterp(lin1,.envir=y,.name=envname)
			else finterp(lin1,.envir=envir,.name=envname)}
	if(inherits(lin2,"formula")){
		lin2a <- if(respenv)finterp(lin2,.envir=y,.name=envname)
			else finterp(lin2,.envir=envir,.name=envname)}
	# modify functions
	if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
			tmp <- parse(text=deparse(mu)[-1])
			mu <- if(respenv)fnenvir(mu,.envir=y,.name=envname)
				else fnenvir(mu,.envir=envir,.name=envname)
			mu2 <- mu
			attr(mu2,"model") <- tmp}
		else mu2 <- mu}
	if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=y,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh2 <- shape
		        attr(sh2,"model") <- tmp}
		else sh2 <- shape}}
else {
     if(is.function(mu)&&is.null(attr(mu,"model")))mu <- fnenvir(mu)
     if(is.function(shape)&&is.null(attr(shape,"model")))
		shape <- fnenvir(shape)}
#
# check if linear contains W&R formula
#
if(inherits(lin1,"formula")){
	tmp <- attributes(if(respenv)finterp(lin1,.envir=y,.name=envname)
		else finterp(lin1,.envir=envir,.name=envname))
	lf1 <- length(tmp$parameters)
	if(!is.character(tmp$model))stop("linear must be a W&R formula")
	else if(length(tmp$model)==1)stop("linear must contain covariates")
	rm(tmp)}
else lf1 <- 0
if(inherits(lin2,"formula")){
	tmp <- attributes(if(respenv)finterp(lin2,.envir=y,.name=envname)
		else finterp(lin2,.envir=envir,.name=envname))
	lf2 <- length(tmp$parameters)
	if(!is.character(tmp$model))stop("linear must be a W&R formula")
	else if(length(tmp$model)==1)stop("linear must contain covariates")
	rm(tmp)}
else lf2 <- 0
#
# transform location formula to function and check number of parameters
#
if(lf1>0)random <- c(random,"linear")
mu3 <- if(respenv)finterp(mu,.envir=y,.name=envname,.args=random)
	else finterp(mu,.envir=envir,.name=envname,.args=random)
npt1 <- length(attr(mu3,"parameters"))
if(is.character(attr(mu3,"model")))stop("mu cannot be a W&R formula")
if(npl!=npt1&&!common&&lf1==0){
	cat("\nParameters are ")
	cat(attr(mu3,"parameters"),"\n")
	stop(paste("pmu should have",npt1,"estimates"))}
if(is.list(pmu)){
	if(!is.null(names(pmu))){
		o <- match(attr(mu3,"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 linear part, modify location function appropriately
#
if(lf1>0){
	dm1 <- if(respenv)wr(lin1,data=y)$design
		else wr(lin1,data=envir)$design
	if(is.null(mu2))mu2 <- mu3
	mu1 <- function(p,random)mu3(p,random,dm1%*%p[(npt1+1):(npt1+lf1)])}
else {
	mu1 <- mu3
	rm(mu3)}
#
# check that correct number of estimates was supplied
#
nlp <- npt1+lf1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl1 <- if(common&&!inherits(shape,"formula")) 1 else nlp+1
#
# transform shape formula to function and check number of parameters
#
sh3 <- NULL
if(inherits(shape,"formula")){
        old <- if(common)mu1 else NULL
        mufn <- if(lf2>0) "linear" else NULL
        sh3 <- if(respenv)finterp(shape,.envir=y,.start=npl1,.name=envname,.old=old,.args=mufn)
        	else finterp(shape,.envir=envir,.start=npl1,.name=envname,.old=old,.args=mufn)
        npt2 <- length(attr(sh3,"parameters"))
        if(is.character(attr(sh3,"model")))stop("shape cannot be a W&R formula")
        if(nps!=npt2&&!common&&lf2==0){
        	cat("\nParameters are ")
        	cat(attr(sh3,"parameters"),"\n")
        	stop(paste("pshape should have",npt2,"estimates"))}
        if(is.list(pshape)){
        	if(!is.null(names(pshape))){
        		o <- match(attr(sh3,"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)}}
else if(is.null(shape)&&shp){
	sh3 <- function(p) p[npl1]*rep(1,n)
	sh2 <- fnenvir(function(p) p[1]*rep(1,n))
	npt2 <- 1}
#
# if linear part, modify shape function appropriately
#
if(lf2>0){
	dm2 <- if(respenv)wr(lin2,data=y)$design
		else wr(lin2,data=envir)$design
	if(is.null(sh2))sh2 <- sh3
	sh1 <- sh3(p,dm2%*%p[(npl1+lf2-1):np])}
else {
	sh1 <- sh3
	rm(sh3)}
#
# if distribution has a shape parameter, check that correct number of
# estimates was supplied
#
if(shp){
	nlp <- npt2+lf2
	if(!common&&nlp!=nps)stop(paste("pshape should have",nlp,"initial estimates"))}
#
# when there are parameters common to location and shape functions,
# check that correct number of estimates was supplied
#
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(sh1,"parameters"))))
	if(nlp!=npl)stop(paste("with a common parameter model, pmu should contain",nlp,"estimates"))}
if(is.null(pmix))stop("a value must be supplied for pmix")
p <- c(pmu,pshape,pmix)
#
# if data object supplied, find response information in it
#
type <- "unknown"
if(respenv){
	if(inherits(envir,"repeated")&&(length(nobs(y))!=length(nobs(envir))||any(nobs(y)!=nobs(envir))))
		stop("y and envir objects are incompatible")
	if(!is.null(y$response$delta))
		delta <- as.vector(y$response$delta)
	nest <- covind(y)
	type <- y$response$type
	y <- response(y)}
else if(inherits(envir,"repeated")){
	if(!is.null(envir$NAs)&&any(envir$NAs))
		stop("gnlmix does not handle data with NAs")
	cn <- deparse(substitute(y))
	if(length(grep("\"",cn))>0)cn <- y
	if(length(cn)>1)stop("only one y variable allowed")
	col <- match(cn,colnames(envir$response$y))
	if(is.na(col))stop(paste("response variable",cn,"not found"))
	nest <- covind(envir)
	type <- envir$response$type[col]
	y <- envir$response$y[,col]
	if(!is.null(envir$response$n)&&!all(is.na(envir$response$n[,col])))
		y <- cbind(y,envir$response$n[,col]-y)
	else if(!is.null(envir$response$censor)&&!all(is.na(envir$response$censor[,col])))
		y <- cbind(y,envir$response$censor[,col])
	if(!is.null(envir$response$delta))
		delta <- as.vector(envir$response$delta[,col])}
else if(inherits(y,"response")){
	if(dim(y$y)[2]>1)stop("gnlmix only handles univariate responses")
	if(!is.null(y$delta))delta <- as.vector(y$delta)
	nest <- covind(y)
	type <- y$type
	y <- response(y)}
if(is.null(nest)||length(unique(nest))==1)
	stop("appropriate nest indicator required")
if(any(is.na(y)))stop("NAs in y - use rmna")
#
# check that data are appropriate for distribution
#
if(distribution=="binomial"||distribution=="double binomial"||
	distribution=="beta binomial"||distribution=="mult binomial"){
	# binomial data
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	if(distribution=="binomial"&&(is.vector(y)||(length(dim(y))==2&&
		dim(y)[2]==1))&&all(y==0|y==1))y <- cbind(y,1-y)
	if(length(dim(y))!=2||dim(y)[2]!=2)
		stop(paste("Two column matrix required for response: successes and failures"))
	if(any(y<0))stop("All response values must be positive")
	n <- dim(y)[1]
	nn <- y[,1]+y[,2]
	censor <- FALSE}
else {
	# censoring present?
	censor <- length(dim(y))==2&&dim(y)[2]==2
	if(censor&&all(y[,2]==1)){
		y <- y[,1]
		censor <- FALSE}
	if(!censor)if(!is.vector(y,mode="numeric"))stop("y must be a vector")
	if(censor&&(distribution=="beta"||distribution=="simplex"||
		distribution=="two-sided power"||distribution=="gamma count"||
		distribution=="gamma count"||distribution=="logarithmic"))
		stop("Censoring not allowed for this distribution")
	if(distribution=="double Poisson"||distribution=="mult Poisson")
		my <- if(censor)3*max(y[,1]) else 3*max(y)
	n <- if(length(dim(y))==2)dim(y)[1] else length(y)}
if(distribution=="inverse Gauss"||distribution=="exponential"||
	distribution=="gamma"||distribution=="Weibull"||
	distribution=="extreme value"){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if((censor&&any(y[,1]<=0))||(!censor&&any(y<=0)))
		stop("All response values must be > 0")}
else if(distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="gamma count"||distribution=="double Poisson"||
	distribution=="mult Poisson"){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y<0))stop("All response values must be >= 0")}
else if(distribution=="logarithmic"){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y<1))stop("All response values must be integers > 0")}
else if(distribution=="beta"||distribution=="simplex"||
	distribution=="two-sided power"){
	if(type!="unknown"&&type!="continuous")stop("continuous data required")
	if(any(y<=0)||any(y>=1))
		stop("All response values must lie between 0 and 1")}
else if(distribution!="binomial"&&distribution!="double binomial"&&
	distribution!="beta binomial"&&distribution!="mult binomial"&&
	type!="unknown"&&type!="continuous"&&type!="duration")
	stop("continuous data required")
#
# if there is censoring, set up censoring indicators for likelihood
#
if(censor){
	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)}
else cc <- 1
#
# fixed values for integration routines
#
nnest <- length(unique(nest))
neg1 <- rep(-1,nnest)
pos1 <- rep(1,nnest)
zero <- rep(0,nnest)
#
# prepare weights and unit of measurement
#
wt <- rep(1,n)
if(length(delta)==1)delta <- rep(delta,n)
else if(length(delta)!=n)
	stop("delta must be the same length as the other variables")
#
# check that location function returns appropriate values
#
if(any(is.na(mu1(pmu,0))))stop("The location model returns NAs: probably invalid initial values")
if(distribution=="Levy"&&any(y<=mu1(p)))
	stop("location parameter must be strictly less than corresponding observation")
#
# check that shape function returns appropriate values
#
if(distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"&&any(is.na(sh1(p))))
	stop("The shape model returns NAs: probably invalid initial values")
if(distribution=="Pareto"&&exp(sh1(p))<=1)stop("shape parameters must be > 0")
#
# set up distribution
#
if(!censor)fcn <- switch(distribution,
	binomial=function(p,r) dbinom(y[,1],y[,1]+y[,2],mu1(p,r)),
	"beta binomial"=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p))
		t <- s*m
		u <- s*(1-m)
		exp(lbeta(y[,1]+t,y[,2]+u)-lbeta(t,u)+lchoose(nn,y[,1]))},
	"double binomial"=function(p,r)
		exp(.C("ddb",as.integer(y[,1]),as.integer(nn),
			as.double(mu1(p,r)),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),
			DUP=FALSE,PACKAGE="rmutil")$res),
	"mult binomial"=function(p,r)
		exp(.C("dmb",as.integer(y[,1]),as.integer(nn),
			as.double(mu1(p,r)),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),
			DUP=FALSE,PACKAGE="rmutil")$res),
	Poisson=function(p,r)dpois(y,mu1(p,r)),
	"negative binomial"=function(p,r)dnbinom(y,exp(sh1(p)),mu1(p,r)),
	"double Poisson"=function(p,r)
		exp(.C("ddp",as.integer(y),as.integer(my),
			as.double(mu1(p,r)),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),DUP=FALSE,
			PACKAGE="rmutil")$res),
	"mult Poisson"=function(p,r)
		exp(.C("dmp",as.integer(y),as.integer(my),
			as.double(mu1(p,r)),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),DUP=FALSE,
			PACKAGE="rmutil")$res),
	"gamma count"=function(p,r) {
		m <- mu1(p,r)
		s <- exp(sh1(p))
		u <- m*s
		ifelse(y==0,pgamma(u,(y+1)*s,1,lower=FALSE),
			pgamma(u,y*s+(y==0),1)-pgamma(u,(y+1)*s,1))},
	Consul=function(p,r) {
		m <- mu1(p,r)
		t <- sh1(p)
		s <- exp(t)
		exp(log(m)-(m+y*(s-1))/s+(y-1)*log(m+y*(s-1))-
			y*t-lgamma(y+1))},
	logarithmic=function(p,r) {
		m <- 1/(1+exp(-mu1(p,r)))
		exp(y*log(m)-log(y)-log(-log(1-m)))},
	geometric=function(p,r) {
		m <- mu1(p,r)
		exp(y*log(m)-(y+1)*log(1+m))},
	normal=function(p,r) dnorm(y,mu1(p,r),exp(sh1(p)/2)),
	"inverse Gauss"=function(p,r) {
		m <- mu1(p,r)
		t <- sh1(p)
		exp(-(t+(y-m)^2/(y*exp(t)*m^2)+log(2*pi*y^3))/2)},
	logistic=function(p,r)dlogis(y,mu1(p,r),exp(sh1(p))*sqrt(3)/pi),
	Cauchy=function(p,r) dcauchy(y,mu1(p,r),exp(sh1(p)/2)),
	Laplace=function(p,r) {
		t <- sh1(p)
		exp(-(abs(y-mu1(p,r))/exp(t)+t))/2},
	Levy=function(p,r) {
		m <- mu1(p,r)
		s <- exp(sh1(p))
		exp(0.5*log(s/(2*pi))-1.5*log(y-m)-s/(2*(y-m)))/2},
	Pareto=function(p,r) {
		s <- exp(sh1(p))
		t <- 1/(mu1(p,r)*(s-1))
		exp(log(s*t)-(s+1)*log(1+y*t))},
	exponential=function(p,r) dexp(y,1/mu1(p,r)),
	gamma=function(p,r){
		s <- exp(sh1(p))
		dgamma(y,s,scale=mu1(p,r)/s)},
	Weibull=function(p,r) dweibull(y,exp(sh1(p)),mu1(p,r)),
	"extreme value"=function(p,r)
		exp(y)*dweibull(exp(y),exp(sh1(p)),mu1(p,r)),
	beta=function(p,r) {
		s <- exp(sh1(p))
		m <- mu1(p,r)*s
		s <- s-m
		dbeta(y,m,s)},
	simplex=function(p,r) {
		m <- mu1(p,r)
		t <- sh1(p)
		s <- exp(t)
		exp(-(((y-m)/(m*(1-m)))^2/(y*(1-y)*s)+
			t+3*log(y*(1-y))/2+log(2*pi)/2))},
	"two-sided power"=function(p,r){
		m <- mu1(p,r)
		t <- sh1(p)
		s <- exp(t)
		exp(t+(s-1)*ifelse(y<m,log(y/m),log((1-y)/(1-m))))})
else fcn <- switch(distribution,
	Poisson=function(p,r){
		m <- mu1(p,r)
		dpois(y[,1],m)^cc*(lc-rc*ppois(y[,1],m))},
	"negative binomial"=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p))
		dnbinom(y[,1],s,m)^cc*(lc-rc*pnbinom(y[,1],s,m))},
	geometric=function(p,r){
		m <- mu1(p,r)
		(y[,1]*log(m)-(y[,1]+1)*log(1+m))^cc*
			(lc-rc*pgeom(y[,1],1/(1+m)))},
	normal=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p)/2)
		dnorm(y[,1],m,s)^cc*(lc-rc*pnorm(y[,1],m,s))},
	"inverse Gauss"=function(p,r){
		m <- mu1(p,r)
		t <- sh1(p)
		s <- exp(t)
		v <- sqrt(s*y[,1]/2)
		exp(-cc*(t+(y[,1]-m)^2/(y[,1]*s*m^2)+log(2*pi*y[,1]^3))/2)*
			(lc-rc*(pnorm((y[,1]/m-1)/v)+
			exp(2/(m*s))*pnorm(-(y[,1]/m+1)/v)))},
	logistic=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p))*sqrt(3)/pi
		dlogis(y[,1],m,s)^cc*(lc-rc*plogis(y[,1],m,s))},
	Cauchy=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p)/2)
		dcauchy(y[,1],m,s)^cc*(lc-rc*pcauchy(y[,1],m,s))},
	Laplace=function(p,r){
		u <- abs(y[,1]-mu1(p,r))/s
		t <- exp(-u)/2
		v <- sh1(p)
		s <- exp(v)
		-exp(cc*(u+v+log(2)))*(lc-rc*(ifelse(u<0,t,1-t)))},
	Pareto=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p))
		t <- 1/(m*(s-1))
		exp(cc*(log(s*t)-(s+1)*log(1+y[,1]*t)))*
			(lc-rc*((1+y[,1]/(m*(s-1)))^(-s)))},
	exponential=function(p,r){
		m <- mu1(p,r)
		dexp(y[,1],1/m)^cc*(lc-rc*pexp(y[,1],1/m))},
	gamma=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p))
		dgamma(y[,1],s,scale=m/s)^cc*
			(lc-rc*pgamma(y[,1],s,scale=m/s))},
	Weibull=function(p,r){
		m <- mu1(p,r)
		s <- exp(sh1(p))
		dweibull(y[,1],s,m)^cc*(lc-rc*pweibull(y[,1],s,m))},
	"extreme value"=function(p,r){
		yy <- exp(y[,1])
		m <- mu1(p,r)
		s <- exp(sh1(p))
		(yy*dweibull(yy,s,m))^cc*(lc-rc*pweibull(yy,s,m))})
#
# set up mixing distribution
#
mix <- switch(mixture,
        normal=function(p,r) dnorm(r,0,exp(p/2)),
	logistic=function(p,r) dlogis(r,0,exp(p)*sqrt(3)/pi),
	Cauchy=function(p,r) dcauchy(r,0,exp(p)),
        Laplace=function(p,r) {
		tmp <- exp(p)
		exp(-abs(r)/tmp)/(2*tmp)},
	gamma=function(p,r) {
		tmp <- exp(p)
		dgamma(r,tmp,scale=1/tmp)},
	"inverse gamma"=function(p,r) {
		tmp <- exp(p)
		dgamma(1/r,tmp,scale=1/tmp)/r^2},
        "inverse Gauss"=function(p,r)
        	exp(-((r-1)^2/(r*exp(p))+p+log(2*pi*r^3))/2),
	Weibull=function(p,r) dweibull(r,exp(p),1),
	beta=function(p,r) {
		tmp <- 0.5*exp(p)
		dbeta(r,tmp,tmp)},
        simplex=function(p,r) exp(-(((r-0.5)/0.25)^2/(r*(1-r)*exp(p))+
			p+3*log(r*(1-r))/2+log(2*pi)/2)),
	"two-sided power"=function(p,r)
		p*exp((p-1)*ifelse(r<0.5,log(r/0.5),log((1-r)/0.5))))
#
# combine to create the appropriate likelihood function
#
if(mixture=="normal"||mixture=="logistic"||mixture=="Cauchy"||mixture=="Laplace")
	like <- function(p){
		fn <- function(r)
			mix(p[np],r)*capply(fcn(p,r[nest])*delta^cc,nest,prod)
		-sum(log(inta(fn)))}
else if(mixture=="gamma"||mixture=="inverse gamma"||mixture=="inverse Gauss"||
	mixture=="Weibull")
	like <- function(p){
		fn <- function(r)
			mix(p[np],r)*capply(fcn(p,r[nest])*delta^cc,nest,prod)
		-sum(log(intb(fn)))}
else like <- function(p){
		fn <- function(r)
			mix(p[np],r)*capply(fcn(p,r[nest])*delta^cc,nest,prod)
		-sum(log(int1(fn,0,1)))}
#
# check that the likelihood returns an appropriate value and optimize
#
tmp <- like(p)
if(is.na(tmp)||abs(tmp)==Inf)
	stop("Likelihood returns Inf or NAs: invalid initial values, wrong model, or probabilities too small to calculate")
if(fscale==1)fscale <- tmp
z0 <- nlm(like,p=p,hessian=TRUE,print.level=print.level,typsiz=typsiz,
	ndigit=ndigit,gradtol=gradtol,stepmax=stepmax,steptol=steptol,
	iterlim=iterlim,fscale=fscale)
#
# calculate fitted values and raw residuals
#
fitted.values <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial")
		as.vector((y[,1]+y[,2])*mu1(z0$estimate,0))
	else as.vector(mu1(z0$estimate,0))
residuals <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial")
		y[,1]-fitted.values
	else y-fitted.values
#
# calculate se's
#
if(np==0)cov <- NULL
else if(np==1)cov <- 1/z0$hessian
else {
	a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
		else qr(z0$hessian)$rank
	if(a==np)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=np,nrow=np)}
se <- sqrt(diag(cov))
#
# return appropriate attributes on functions
#
if(!is.null(mu2))mu1 <- mu2
if(!is.null(sh2))sh1 <- sh2
if(!is.null(lin1a))lin1 <- lin1a
if(!is.null(lin2a))lin2 <- lin2a
z1 <- list(
	call=call,
	delta=delta,
	distribution=distribution,
	mixture=mixture,
	likefn=like,
	mu=mu1,
	shape=sh1,
	mix=NULL,
	censor=censor,
	linear=list(lin1,lin2),
	common=common,
	maxlike=z0$minimum,
	fitted.values=fitted.values,
	residuals=residuals,
	aic=z0$minimum+np,
	df=n-np,
	coefficients=z0$estimate,
	npl=npl,
	npm=1,
	nps=nps,
	npf=0,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "gnlm"
return(z1)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gnlmm(y=NULL, distribution="normal", mu=NULL, shape=NULL, linear=NULL,
#	nest=NULL, pmu=NULL, pshape=NULL, psd=NULL, exact=FALSE, wt=1,
#	delta=1, shfn=FALSE, scale=NULL, points=10, common=FALSE,
#	envir=parent.frame(), 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=NULL, distribution="normal", mu=NULL, shape=NULL,
	linear=NULL, nest=NULL, pmu=NULL, pshape=NULL, psd=NULL, exact=FALSE,
	wt=1, delta=1, shfn=FALSE, scale=NULL, points=10, common=FALSE,
	envir=parent.frame(), print.level=0, typsiz=abs(p),
	ndigit=10, gradtol=0.00001, stepmax=sqrt(p%*%p)/10, steptol=0.00001,
	iterlim=100, fscale=1){
#
# inverse Gaussian cdf
#
pinvgauss <- function(y,m,s){
	t <- y/m
	v <- sqrt(y*s)
	pnorm((t-1)/v)+exp(2/(m*s))*pnorm(-(t+1)/v)}
#
# Laplace cdf
#
plaplace <- function(y,m,s){
	u <- (y-m)/s
	t <- exp(-abs(u))/2
	ifelse(u<0,t,1-t)}
#
# Levy cdf
#
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=FALSE,
		PACKAGE="rmutil")$res
#
# simplex cdf
#
psimplex <- function(y, m, s)
        z <- .C("psimplex",
        	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=FALSE,
		PACKAGE="rmutil")$res

call <- sys.call()
#
# check 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","beta",
	"simplex","two-sided power"))
shp <- distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"
if(!shp){
	pshape <- NULL
	shfn <- common <- FALSE}
#
# check for parameters common to location and shape functions
#
if(common){
	if(!is.function(mu)&&!inherits(mu,"formula"))
		stop("with common parameters, mu must be a function or formula")
	if(!is.function(shape)&&!inherits(shape,"formula"))
		stop("with common parameters, shape must be a function or formula")
	if(!is.null(linear))stop("linear cannot be used with common parameters")}
if(!is.null(scale))scale <- match.arg(scale,c("identity","log","logit",
	"reciprocal","exp"))
#
# count number of parameters
#
npl <- length(pmu)
nps <- length(pshape)
if(is.null(psd))stop("An initial value of psd must be supplied")
np <- npl+nps+1
#
# find number of observations now for creating null functions
#
n <- if(inherits(envir,"repeated")||inherits(envir,"response"))sum(nobs(envir))
	else if(is.vector(y,mode="numeric"))length(y)
	else if(is.matrix(y))dim(y)[1]
	else sum(nobs(y))
if(n==0)stop(paste(deparse(substitute(y)),"not found or of incorrect type"))
#
# check if a data object is being supplied
#
respenv <- exists(deparse(substitute(y)),env=parent.frame())&&
	inherits(y,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(y$response$y)[2]>1)
		stop("gnlmm only handles univariate responses")
	if(!is.null(y$NAs)&&any(y$NAs))
		stop("gnlmm does not handle data with NAs")}
envname <- if(respenv)deparse(substitute(y))
	else if(inherits(envir,"repeated")||inherits(envir,"response"))
		deparse(substitute(envir))
	else NULL
#
# find linear part of each regression and save model for printing
#
lin1 <- lin2 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]}
else lin1 <- linear
if(inherits(lin1,"formula")&&is.null(mu)){
	mu <- lin1
	lin1 <- NULL}
if(inherits(lin2,"formula")&&is.null(shape)){
	shape <- lin2
	lin2 <- NULL}
if(inherits(lin1,"formula")){
	lin1model <- if(respenv){
		if(!is.null(attr(finterp(lin1,.envir=y,.name=envname),"parameters")))
			attr(finterp(lin1,.envir=y,.name=envname),"model")}
	else {if(!is.null(attr(finterp(lin1,.envir=envir,.name=envname),"parameters")))
			attr(finterp(lin1,.envir=envir,.name=envname),"model")}}
else lin1model <- NULL
if(inherits(lin2,"formula")){
	lin2model <- if(respenv){
		if(!is.null(attr(finterp(lin2,.envir=y,.name=envname),"parameters")))
			attr(finterp(lin2,.envir=y,.name=envname),"model")}
	else {if(!is.null(attr(finterp(lin2,.envir=envir,.name=envname),"parameters")))
			attr(finterp(lin2,.envir=envir,.name=envname),"model")}}
else lin2model <- NULL
#
# check if linear contains W&R formula
#
if(inherits(lin1,"formula")){
	tmp <- attributes(if(respenv)finterp(lin1,.envir=y,.name=envname)
		else finterp(lin1,.envir=envir,.name=envname))
	lf1 <- length(tmp$parameters)
	if(!is.character(tmp$model))stop("linear must be a W&R formula")
	if(length(tmp$model)==1){
		if(is.null(mu))mu <- ~1
		else stop("linear must contain covariates")}
	rm(tmp)}
else lf1 <- 0
if(inherits(lin2,"formula")){
	tmp <- attributes(if(respenv)finterp(lin2,.envir=y,.name=envname)
		else finterp(lin2,.envir=envir,.name=envname))
	lf2 <- length(tmp$parameters)
	if(!is.character(tmp$model))stop("linear must be a W&R formula")
	if(length(tmp$model)==1){
		if(is.null(shape))shape <- ~1
		else stop("linear must contain covariates")}
	rm(tmp)}
else lf2 <- 0
#
# if a data object was supplied, modify formulae or functions to read from it
#
mu2 <- sh2 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")||inherits(envir,"data.frame")){
	# modify formulae
	if(inherits(mu,"formula")){
		mu2 <- if(respenv)finterp(mu,.envir=y,.name=envname)
			else finterp(mu,.envir=envir,.name=envname)}
	if(inherits(shape,"formula")){
		sh2 <- if(respenv)finterp(shape,.envir=y,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	# modify functions
	if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
		        tmp <- parse(text=deparse(mu)[-1])
		        mu <- if(respenv)fnenvir(mu,.envir=y,.name=envname)
		        	else fnenvir(mu,.envir=envir,.name=envname)
		        mu2 <- mu
		        attr(mu2,"model") <- tmp}
		else mu2 <- mu}
	if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=y,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh2 <- shape
		        attr(sh2,"model") <- tmp}
		else sh2 <- shape}}
else {
     if(is.function(mu)&&is.null(attr(mu,"model")))mu <- fnenvir(mu)
     if(is.function(shape)&&is.null(attr(shape,"model")))
		shape <- fnenvir(shape)}
#
# transform location formula to function and check number of parameters
#
if(inherits(mu,"formula")){
	if(npl==0)stop("formula for mu cannot be used if no parameters are estimated")
	linarg <- if(lf1>0) "linear" else NULL
	mu3 <- if(respenv)finterp(mu,.envir=y,.name=envname,.args=linarg)
		else finterp(mu,.envir=envir,.name=envname,.args=linarg)
	npt1 <- length(attr(mu3,"parameters"))
	if(is.character(attr(mu3,"model"))){
	# W&R formula
		if(length(attr(mu3,"model"))==1){
		# intercept model
			tmp <- attributes(mu3)
			mu3 <- function(p) p[1]*rep(1,n)
			attributes(mu3) <- tmp}}
	else {
	# formula with unknowns
		if(npl!=npt1&&!common&&lf1==0){
			cat("\nParameters are ")
			cat(attr(mu3,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu3,"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)}}}
else if(!is.function(mu)){
	mu3 <- function(p) p[1]*rep(1,n)
	npt1 <- 1}
else {
	mu3 <- mu
	npt1 <- length(attr(mu3,"parameters"))-(lf1>0)}
#
# if linear part, modify location function appropriately
#
if(lf1>0){
	if(is.character(attr(mu3,"model")))
		stop("mu cannot be a W&R formula if linear is supplied")
	dm1 <- if(respenv)wr(lin1,data=y)$design
		else wr(lin1,data=envir)$design
	if(is.null(mu2))mu2 <- mu3
	mu1 <- function(p)mu3(p,dm1%*%p[(npt1+1):(npt1+lf1)])}
else {
	if(lf1==0&&length(mu3(pmu))==1){
		mu1 <- function(p) mu3(p)*rep(1,n)
		attributes(mu1) <- attributes(mu3)}
	else {
		mu1 <- mu3
		rm(mu3)}}
#
# give appropriate attributes to mu1 for printing
#
if(is.null(attr(mu1,"parameters"))){
	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 attributes(fnenvir(mu1))}
#
# check that correct number of estimates was supplied
#
nlp <- npt1+lf1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl <- if(common) 1 else npl+1
npl1 <- if(common&&!inherits(lin2,"formula")) 1 else nlp+2
#
# transform shape formula to function and check number of parameters
#
if(inherits(shape,"formula")){
	if(nps==0&&!common)
		stop("formula for shape cannot be used if no parameters are estimated")
	old <- if(common)mu1 else NULL
	mufn <- if(shfn)"mu" else NULL
	mufn <- c(mufn,if(lf2>0) "linear" else NULL)
	sh4 <- if(respenv)finterp(shape,.envir=y,.start=npl1,.name=envname,.old=old,.args=mufn)
		else finterp(shape,.envir=envir,.start=npl1,.name=envname,.old=old,.args=mufn)
	tmp <- attributes(sh4)
	sh3 <- if(shfn)function(p) sh4(p,mu1(p)) else sh4
	attributes(sh3) <- tmp
	npt2 <- length(attr(sh3,"parameters"))
	if(is.character(attr(sh3,"model"))){
	# W&R formula
		if(length(attr(sh3,"model"))==1){
		# intercept model
			tmp <- attributes(sh3)
			sh3 <- function(p) p[npl1]*rep(1,n)
			sh2 <- fnenvir(function(p) p[1]*rep(1,n))
			attributes(sh3) <- tmp}}
	else {
	# formula with unknowns
		if(nps!=npt2&&!common){
			cat("\nParameters are ")
			cat(attr(sh3,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh3,"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)}}}
else if(!is.function(shape)&&shp){
	sh3 <- function(p) p[npl1]*rep(1,n)
	sh2 <- fnenvir(function(p) p[1]*rep(1,n))
	npt2 <- 1}
else if(shp){
	sh3 <- if(shfn)function(p) shape(p[npl1:np], mu1(p))
		else function(p) shape(p[npl1:np])
	attributes(sh3) <- attributes(shape)
	npt2 <- length(attr(sh3,"parameters"))-(lf2>0)-shfn}
else sh3 <- NULL
#
# if linear part, modify shape function appropriately
#
if(lf2>0){
	if(is.character(attr(sh3,"model")))
		stop("shape cannot be a W&R formula if linear is supplied")
	dm2 <- if(respenv)wr(lin2,data=y)$design
		else wr(lin2,data=envir)$design
	if(is.null(sh2))sh2 <- sh3
	sh1 <- if(shfn)function(p)sh3(p,dm2%*%p[(npl1+lf2-1):np],mu1(p))
		else sh3(p,dm2%*%p[(npl1+lf2-1):np])}
else {
	sh1 <- sh3
	rm(sh3)}
#
# if distribution has a shape parameter, give appropriate attributes to
# sh1 for printing and check that correct number of estimates was supplied
#
if(shp){
	if(is.null(attr(sh1,"parameters"))){
		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 attributes(fnenvir(sh1))}
	nlp <- npt2+lf2
	if(!common&&nlp!=nps)stop(paste("pshape should have",nlp,"initial estimates"))}
#
# when there are parameters common to location and shape functions,
# check that correct number of estimates was supplied
#
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 data object supplied, find response information in it
#
type <- "unknown"
if(respenv){
	if(inherits(envir,"repeated")&&(length(nobs(y))!=length(nobs(envir))||any(nobs(y)!=nobs(envir))))
		stop("y and envir objects are incompatible")
	if(!is.null(y$response$wt)&&any(!is.na(y$response$wt)))
		wt <- as.vector(y$response$wt)
	if(!is.null(y$response$delta))
		delta <- as.vector(y$response$delta)
	if(length(nobs(y))==1&&nobs(y)==1)
		nest <- 1:length(y$response$y)
	else nest <- covind(y)
	type <- y$response$type
	y <- response(y)}
else if(inherits(envir,"repeated")){
	if(!is.null(envir$NAs)&&any(envir$NAs))
		stop("gnlmm does not handle data with NAs")
	cn <- deparse(substitute(y))
	if(length(grep("\"",cn))>0)cn <- y
	if(length(cn)>1)stop("only one y variable allowed")
	col <- match(cn,colnames(envir$response$y))
	if(is.na(col))stop(paste("response variable",cn,"not found"))
	type <- envir$response$type[col]
	y <- envir$response$y[,col]
	if(length(nobs(envir))==1&&nobs(envir)==1)nest <- 1:length(y)
	else nest <- covind(envir)
	if(!is.null(envir$response$n)&&!all(is.na(envir$response$n[,col])))
		y <- cbind(y,envir$response$n[,col]-y)
	else if(!is.null(envir$response$censor)&&!all(is.na(envir$response$censor[,col])))
		y <- cbind(y,envir$response$censor[,col])
	if(!is.null(envir$response$wt))wt <- as.vector(envir$response$wt)
	if(!is.null(envir$response$delta))
		delta <- as.vector(envir$response$delta[,col])}
else if(inherits(envir,"data.frame"))y <- envir[[deparse(substitute(y))]]
else if(inherits(y,"response")){
	if(dim(y$y)[2]>1)stop("gnlmm only handles univariate responses")
	if(!is.null(y$wt)&&any(!is.na(y$wt)))wt <- as.vector(y$wt)
	if(!is.null(y$delta))delta <- as.vector(y$delta)
	nest <- covind(y)
	type <- y$type
	y <- response(y)}
if(any(is.na(y)))stop("NAs in y - use rmna")
#
# check that data are appropriate for distribution
#
if(distribution=="binomial"||distribution=="double binomial"||
	distribution=="beta binomial"||distribution=="mult binomial"){
	# binomial data
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	if(distribution=="binomial"&&(is.vector(y)||(length(dim(y))==2&&
		dim(y)[2]==1))&&all(y==0|y==1))y <- cbind(y,1-y)
	if(length(dim(y))!=2||dim(y)[2]!=2)
		stop(paste("Two column matrix required for response: successes and failures"))
	if(any(y<0))stop("All response values must be positive")
	nn <- y[,1]+y[,2]
	censor <- FALSE}
else {
	# censoring present?
	censor <- length(dim(y))==2&&dim(y)[2]==2
	if(censor&&all(y[,2]==1)){
		y <- y[,1]
		censor <- FALSE}
	if(!censor)if(!is.vector(y,mode="numeric"))stop("y must be a vector")
	if(censor&&(distribution=="beta"||distribution=="simplex"||
		distribution=="two-sided power"||distribution=="gamma count"||
		distribution=="gamma count"||distribution=="logarithmic"))
		stop("Censoring not allowed for this distribution")
	if(distribution=="double Poisson"||distribution=="mult Poisson")
		my <- if(censor)3*max(y[,1]) else 3*max(y)}
if(distribution=="inverse Gauss"||distribution=="exponential"||
	distribution=="gamma"||distribution=="Weibull"||
	distribution=="extreme value"){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if((censor&&any(y[,1]<=0))||(!censor&&any(y<=0)))
		stop("All response values must be > 0")}
else if(distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="gamma count"||distribution=="double Poisson"||
	distribution=="mult Poisson"){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y<0))stop("All response values must be >= 0")}
else if(distribution=="logarithmic"){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y[wt>0]<1))stop("All response values must be integers > 0")}
else if(distribution=="beta"||distribution=="simplex"||
	distribution=="two-sided power"){
	if(type!="unknown"&&type!="continuous")stop("continuous data required")
	if(any(y<=0)||any(y>=1))
		stop("All response values must lie between 0 and 1")
	if(distribution=="two-sided power"){
		y1 <- y+delta/2
		y2 <- y-delta/2}}
else if(distribution!="binomial"&&distribution!="double binomial"&&
	distribution!="beta binomial"&&distribution!="mult binomial"&&
	type!="unknown"&&type!="continuous"&&type!="duration")
	stop("continuous data required")
#
# if there is censoring, set up censoring indicators for likelihood
#
if(censor){
	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")}
#
# prepare weights and unit of measurement
#
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")
#
# check nesting vector
#
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 <- as.numeric(nest)
nind <- length(unique(nest))
#
# prepare Gauss-Hermite integration
#
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)
#
# calculate quadrature points
#
quad <- gauss.hermite(points)
sd <- quad[rep(1:points,rep(n,points)),1]
qw <- quad[rep(1:points,rep(nind,points)),2]
#
# set default scale for random effect, if not specified
#
if(is.null(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"}
#
# modify location function to proper scale for random effect
#
mu4 <- 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)
#
# check that location function returns appropriate values
#
if(any(is.na(mu4(pmu))))stop("The location regression 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")
#
# check that shape function returns appropriate values
#
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 regression returns NAs")
	if(od)stop("Some individuals must have more than one observation")}
#
# create the appropriate likelihood function of one observation
#
if (!censor){
	ret <- switch(distribution,
	binomial={
		fcn <- function(p) {
			m <- mu4(p)
			-wt*(y[,1]*log(m)+y[,2]*log(1-m))}
		const <- -wt*lchoose(nn,y[,1])},
	"beta binomial"={
		fcn <- function(p) {
			m <- mu4(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=FALSE,PACKAGE="rmutil")$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=FALSE,PACKAGE="rmutil")$res}
		const <- 0},
	Poisson={
		fcn <- function(p) {
			m <- mu4(p)
			-wt*(-m+y*log(m))}
		const <- wt*lgamma(y+1)},
	"negative binomial"={
		fcn <- function(p) {
			m <- mu4(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=FALSE,
				PACKAGE="rmutil")$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=FALSE,
				PACKAGE="rmutil")$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 <- mu4(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(mu4(p))
			m <- m/(1+m)
			-wt*(y*log(m)-log(y)-log(-log(1-m)))}
		const <- 0},
	geometric={
		fcn <- function(p) {
			m <- mu4(p)
			-wt*(y*log(m)-(y+1)*log(1+m))}
		const <- 0},
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu4(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-mu4(p))^2/exp(t))/2}
			const <- wt*(log(2*pi)/2-log(delta))}},
        "inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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-mu4(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 <- mu4(p)
				-wt*log(-exp(-(y+delta/2)/m)
					+exp(-(y-delta/2)/m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu4(p)
				wt*(log(m)+y/m)}
			const <- -wt*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu4(p)
				s <- exp(sh1(p))
				u <- m/s
				-wt*log(pgamma(y+delta/2,s,scale=u)
					-pgamma(y-delta/2,s,scale=u))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(t+s*y-s*log(m)-(exp(y)/m)^s)}
			const <- -wt*log(delta)}},
        beta={
		if(exact){
			fcn <- function(p) {
				s <- exp(sh1(p))
				m <- mu1(p)*s
				s <- s-m
				-sum(wt*log(pbeta(y+delta/2,m,s)
					-pbeta(y-delta/2,m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- exp(sh1(p))
				m <- mu1(p)*s
				s <- s-m
				-sum(wt*dbeta(y,m,s,0,TRUE))}
			const <- -wt*log(delta)}},
        simplex={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-sum(wt*log(psimplex(y+delta/2,m,s)
					-psimplex(y-delta/2,m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				sum(wt*(((y-m)/(m*(1-m)))^2/(y*(1-y)*s)+
					t+3*log(y*(1-y)))/2)}
			const <- wt*(log(2*pi)/2-log(delta))}},
        "two-sided power"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-sum(wt*log(ifelse(y1<m,m*(y1/m)^s,
					1-(1-m)*((1-y1)/(1-m))^s)
					-ifelse(y2<m,m*(y2/m)^s,
					1-(1-m)*((1-y2)/(1-m))^s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-sum(wt*(t+ifelse(y<m,(s-1)*log(y/m),
					(s-1)*log((1-y)/(1-m)))))}
			const <- -wt*log(delta)}})}
else {
	# censored data
	ret <- switch(distribution,
	Poisson={
		fcn <- function(p) {
			m <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(p)
				s <- exp(sh1(p))
				u <- m/s
				-wt*(cc*log(pgamma(y[,1]+delta/2,s,scale=u)-
					pgamma(y[,1]-delta/2,s,scale=u))
					+log(lc-rc*pgamma(y[,1],s,scale=u)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu4(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,scale=m/s)))}
			const <- -wt*cc*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu4(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 <- mu4(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 <- mu4(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 <- mu4(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)}})}
#
# put the individual elements of likelihood together, checking for underflow
#
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)}
#
# check that the likelihood returns an appropriate value and optimize
#
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=TRUE, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
z0$minimum <- z0$minimum+sum(const)
#
# calculate fitted values and raw residuals
#
fitted.values <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial")
		as.vector((y[,1]+y[,2])*mu4(z0$estimate))
	else as.vector(mu4(z0$estimate))
residuals <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial"||censor)
		y[,1]-fitted.values
	else y-fitted.values
#
# calculate se's
#
if(npl+nps==1){
	cov <- 1/z0$hessian
	se <- sqrt(cov)}
else {
	a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
		else 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))}
#
# return appropriate attributes on functions
#
if(!is.null(mu2))mu1 <- mu2
if(!is.null(sh2))sh1 <- sh2
z1 <- list(
	call=call,
	delta=delta,
	distribution=distribution,
	likefn=fcn,
	mu=mu1,
	shape=sh1,
	linear=list(lin1,lin2),
	linmodel=list(lin1model,lin2model),
	common=common,
	scale=scale,
	points=points,
	prior.weights=wt,
	censor=censor,
	maxlike=z0$minimum,
	fitted.values=fitted.values,
	residuals=residuals,
	aic=z0$minimum+np,
	df=sum(wt)-np,
	coefficients=z0$estimate,
	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) <- "gnlm"
return(z1)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     hidden(response=NULL, totals=NULL, distribution="Bernoulli",
#	mu=NULL, cmu=NULL, tvmu=NULL, pgamma, pmu=NULL, pcmu=NULL,
#       ptvmu=NULL, pshape=NULL, pfamily=NULL, par=NULL, delta=NULL,
#       envir=parent.frame(), 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
# Authors: J.K. Lindsey and P.J. Lindsey for the ordinal models

hidden <- function(response=NULL, totals=NULL, distribution="Bernoulli",
	mu=NULL, cmu=NULL, tvmu=NULL, pgamma, pmu=NULL, pcmu=NULL, ptvmu=NULL,
	pshape=NULL, pfamily=NULL, par=NULL, pintercept=NULL, delta=NULL,
	envir=parent.frame(), print.level=0, ndigit=10, gradtol=0.00001,
	steptol=0.00001, fscale=1, iterlim=100, typsiz=abs(p),
	stepmax=10*sqrt(p%*%p)){
#
# likelihood function for nlm
#
likel <- function(p){
	if(ord)for(i in 1:states){
		if(!all(diff(p[np4+l*(i-1)+(1:l)])>0))
			p[np4+l*(i-1)+(1:l)] <- p[np4+l*(i-1)+1]*seq(1,1.1,length=l)}
	if(is.function(muf))pmu0 <- muf(p[nm1:nmu])
	if(is.function(cmuf))pmu1 <- cmuf(p[nm1:ncmu])
	if(is.function(tvmuf))pmu2 <- tvmuf(p[ncmu1:np])
	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(nobs(response)),
		mobs=as.integer(mobs),
		s=as.double(if(mdl==4)y else 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),
		lgam=as.double(lgam),
		ismu=as.logical(ismu),
		pmu=as.double(pmu0),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np5]),
		ppar=as.logical(!is.null(par)),
		par=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),
		work2=double(states),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
z$like}
#
# likelihood function returning parameter values
#
like <- function(p){
	if(is.function(muf))pmu0 <- muf(p[nm1:nmu])
	if(is.function(cmuf))pmu1 <- cmuf(p[nm1:ncmu])
	if(is.function(tvmuf))pmu2 <- tvmuf(p[ncmu1:np])
	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(nobs(response)),
		mobs=as.integer(mobs),
		s=as.double(if(mdl==4)y else 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),
		lgam=as.double(lgam),
		ismu=as.logical(ismu),
		pmu=as.double(pmu0),
		pcmu=as.double(pmu1),
		ptvmu=as.double(pmu2),
		pshape=as.double(pshape),
		pfam=as.double(p[np5]),
		ppar=as.logical(!is.null(par)),
		par=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),
		work2=double(states),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
z}
call <- sys.call()
#
# check distribution
#
tmp <- c("Bernoulli","Poisson","multinomial","continuation ratio",
	 "proportional odds","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",
	 "skew Laplace","Student t")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
if(mdl>3)mdl <- mdl+1
ord <- distribution=="continuation ratio"||distribution=="proportional odds"
ord2 <- !(!is.null(cmu)&&!is.null(tvmu))
if(!is.null(par)&&(ord||distribution=="Bernoulli"||distribution=="multinomial"))
	stop("par not allowed with multinomial and ordinal responses")
#
# check estimates of transition matrix
#
if(!is.matrix(pgamma)||dim(pgamma)[2]!=dim(pgamma)[1]){
	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 <- dim(pgamma)[1]
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(round(sum(pgamma[i,]),2)!=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))}
#
# check extra parameters in distribution
#
if(mdl>8){
	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"))}
else pshape <- NULL
if(mdl>19){
	if(is.null(pfamily))stop("pfamily estimate must be supplied")
	else if(length(pshape)!=1)
		stop(paste("pshape must have one estimate"))}
else pfamily <- NULL
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1){
		if(mdl==3)mdl <- 4
		else stop("hidden only handles univariate responses")}
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("hidden does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)deparse(substitute(response))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
#if response is not a data object, make one
#
if(!respenv){
	if(inherits(envir,"repeated")){
		if(!is.null(envir$NAs)&&any(envir$NAs))
			stop("hidden does not handle data with NAs")
		cn <- deparse(substitute(response))
		if(length(grep("\"",cn))>0)cn <- response
		if(length(cn)>1){
			if(mdl==3)mdl <- 4
			else stop("only one response variable allowed")}
		response <- envir
		col <- match(cn,colnames(response$response$y))
		if(is.na(col))stop(paste("response variable",cn,"not found"))
		type <- response$response$type[col]
		if(dim(response$response$y)[2]>1){
			response$response$y <- response$response$y[,col,drop=FALSE]
			if(!is.null(response$response$delta)){
				response$response$delta <- response$response$delta[,col,drop=FALSE]
				if(all(response$response$delta==1)||all(is.na(response$response$delta)))response$response$delta <- NULL}}}
	else {
        	if(!inherits(response,"response")){
        		if(is.vector(response,mode="numeric")){
        			times <- 1:length(response)
        			response <- matrix(response,nrow=1)}
        		else if(is.matrix(response))times <- 1:dim(response)[2]
        		else if(is.array(response)&&length(dim(response))==3&&mdl==3){
				times <- 1:dim(response)[2]
				mdl <- 4}
			else stop("response must be a vector, matrix, or array")
			response <- restovec(response,times=times,totals=totals,delta=delta)
			rm(times)}
		type <- response$type
		response <- rmna(response=response)}}
#
# check if response is appropriate for distribution
#
if(is.null(response$response$times))stop("no times available")
if(distribution=="binomial"||distribution=="beta binomial"){
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	if(is.null(response$response$n))stop("totals must be supplied")}
if(mdl<11){
	if((distribution=="Poisson"||distribution=="negative binomial")
		&&type!="unknown"&&type!="discrete")
		stop("discrete data required")
	if(distribution=="Bernoulli"){
		if(type!="unknown"&&type!="nominal")
			stop("nominal data required")
		if(any(response$response$y!=0&response$response$y!=1))
			stop("responses must be binary for Bernoulli")}
	if(distribution=="multinomial"
		&&type!="unknown"&&type!="nominal"&&type!="ordinal")
		stop("nominal or ordinal data required")
	if((distribution=="continuation ratio"||
		distribution=="proportional odds")
		&&type!="unknown"&&type!="ordinal")
		stop("ordinal data required")
	if(any(response$response$y<0))
		stop("all responses must be non-negative")}
else if(mdl!=11&&mdl!=13&&mdl!=14&&mdl!=15&&mdl!=16&&mdl!=21&&mdl!=27
	&&mdl!=28&&mdl!=29){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if(any(response$response$y<=0))stop("all responses must be positive")}
else if(type!="unknown"&&type!="continuous"&&type!="duration")
	stop("continuous data required")
lgam <- NULL
if(mdl==3||ord){
	l <- length(unique(response$response$y))-1
	if(min(response$response$y)!=0||max(response$response$y)!=l)
		stop(paste("multinomial and ordinal categories must be numbered from 0 to",l))
	if(l<1)stop("multinomial and ordinal responses must have at least 2 categories")}
else if(mdl==4){
	l <- dim(response$response$y)[2]-1
	lgam <- lgamma(apply(response$response$y,1,sum)+1)-
		apply(lgamma(response$response$y+1),1,sum)
	y <- as.vector(t(response$response$y))}
else l <- 1
if(ord){
	if(length(pintercept)!=l*states)
		stop(paste("pintercept should contain",l*states,"estimates"))
	for(i in 1:states){
		if(!all(diff(pintercept[(i-1)*l+(1:l)])>0))
			stop("intercepts must be monotone increasing for each state")}}
else pintercept <- NULL
if(!is.null(response$response$nest)&&!is.null(par))
	stop("hidden does not handle two levels of nesting with an AR")
if(!is.null(response$response$censor))stop("hidden does not handle censoring")
nosubj <- length(nobs(response))
mobs <- max(nobs(response))
nob <- dim(response$response$y)[1]
ismu <- !is.null(mu)
if(ismu)cmu <- tvmu <- pcmu <- ptvmu <- NULL
else pmu <- NULL
#
# if a data object was supplied, modify formulae or functions to read from it
#
muf <- mu1 <- mu3 <- cmuf <- cmu1 <- cmu3 <- tvmuf <- tvmu1 <- tvmu3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	if(!is.null(mu)){
		cl <- is.list(mu)
		if(!cl)mu <- list(mu)
		tmp2 <- mu3 <- list()
		for(i in 1:length(mu)){
			if(inherits(mu[[i]],"formula")){
				mu3 <- c(mu3,list(if(respenv)finterp(mu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(mu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
				tmp2 <- c(tmp2,list(mu[[i]]))}
			else if(is.function(mu[[i]])){
				tmp <- parse(text=deparse(mu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(mu[[i]],.envir=response,.name=envname)
					else fnenvir(mu[[i]],.envir=envir,.name=envname)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				mu3 <- c(mu3,list(tmp1))}}
		mu <- tmp2
		rm(tmp2)
		if(!cl){
			mu <- mu[[1]]
			mu3 <- mu3[[1]]}}
	if(!is.null(cmu)){
		cl <- is.list(cmu)
		if(!cl)cmu <- list(cmu)
		tmp2 <- cmu3 <- list()
		for(i in 1:length(cmu)){
			if(inherits(cmu[[i]],"formula")){
				cmu3 <- c(cmu3,list(if(respenv)finterp(cmu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(cmu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
			tmp2 <- c(tmp2,list(cmu[[i]]))}
			else if(is.function(cmu[[i]])){
				tmp <- parse(text=deparse(cmu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(cmu[[i]],.envir=response,.name=envname,.expand=FALSE)
					else fnenvir(cmu[[i]],.envir=envir,.name=envname,.expand=FALSE)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				cmu3 <- c(cmu3,list(tmp1))}}
		cmu <- tmp2
		rm(tmp2)
		if(!cl){
			cmu <- cmu[[1]]
			cmu3 <- cmu3[[1]]}}
	if(!is.null(tvmu)){
		cl <- is.list(tvmu)
		if(!cl)tvmu <- list(tvmu)
		tmp2 <- tvmu3 <- list()
		for(i in 1:length(tvmu)){
			if(inherits(tvmu[[i]],"formula")){
				tvmu3 <- c(tvmu3,list(if(respenv)finterp(tvmu[[i]],.envir=response,.name=envname,.intercept=!ord)
					else finterp(tvmu[[i]],.envir=envir,.name=envname,.intercept=!ord)))
			tmp2 <- c(tmp2,list(tvmu[[i]]))}
			else if(is.function(tvmu[[i]])){
				tmp <- parse(text=deparse(tvmu[[i]])[-1])
				tmp1 <- if(respenv)fnenvir(tvmu[[i]],.envir=response,.name=envname)
					else fnenvir(tvmu[[i]],.envir=envir,.name=envname)
				tmp2 <- c(tmp2,list(tmp1))
				attr(tmp1,"model") <- tmp
				tvmu3 <- c(tvmu3,list(tmp1))}}
		tvmu <- tmp2
		rm(tmp2)
		if(!cl){
			tvmu <- tvmu[[1]]
			tvmu3 <- tvmu3[[1]]}}}
#
# transform general formulae to functions and check number of parameters
#
npr0 <- if(ord)length(pmu)/states else length(pmu)/states/l
start <- NULL
if(inherits(mu,"formula")){
	mu1 <- if(respenv)finterp(mu,.envir=response,.name=envname,.intercept=!ord)
		else finterp(mu,.envir=envir,.name=envname,.intercept=!ord)
	npt0 <- length(attr(mu1,"parameters"))
	if(is.character(attr(mu1,"model"))){
	# W&R formula
		if(ord&&length(attr(mu1,"model"))==0)mu1 <- NULL}
	else {
	# formula with unknowns
		if(npr0!=npt0){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",if(ord) npt0*states else npt0*states*l,"estimates"))}
		if(is.list(pmu))pmu <- unlist(pmu)}
	if(is.null(mu1))pmu <- NULL}
else if(is.list(mu)){
	if(!ord&&length(mu)!=states*l)
		stop(paste("list of mu formulae or functions must have length",states*l))
	if(ord&&length(mu)!=states)
		stop(paste("list of mu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(mu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in mu)if(inherits(i,"formula")){
		mu1 <- if(respenv)finterp(i,.envir=response,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.name=envname,.start=start,.intercept=!ord)
		npt0 <- length(attr(mu1,"parameters"))
		if(ord&&is.null(attr(mu1,"model")))
			stop("all formulae must contain covariates")
		if(is.list(pmu))pmu <- unlist(pmu)
		# make new list and count parameters
		tmp <- c(tmp,list(mu1))
		start <- start+npt0}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	mu1 <- tmp
	rm(tmp)}
else if(!is.null(mu))mu1 <- mu
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.list(mu)){
	nlp <- if(is.function(mu1))length(attr(mu1,"parameters"))
		else if(is.null(mu1))NULL
		else npt0
	if(!is.null(nlp)&&nlp!=npr0)
		stop(paste("pmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(pmu))
	stop(paste("pmu should have",start,"initial estimates"))
#
# transform time-constant formulae to functions and check number of parameters
#
npr1 <- if(ord)length(pcmu)/states else length(pcmu)/states/l
start <- NULL
if(inherits(cmu,"formula")){
	cmu1 <- if(respenv)finterp(cmu,.envir=response,.expand=FALSE,.name=envname,.intercept=!ord)
		else finterp(cmu,.envir=envir,.expand=FALSE,.name=envname,.intercept=!ord)
	npt1 <- length(attr(cmu1,"parameters"))
	if(is.character(attr(cmu1,"model"))){
	# W&R formula
		if(length(attr(cmu1,"model"))==1&&length(cmu1(pcmu))!=nosubj){
			tmp <- function(p) rep(p[1],nosubj)
			attributes(tmp) <- attributes(cmu1)
			cmu1 <- tmp
			rm(tmp)}
		if(ord&&length(attr(cmu1,"model"))==0)cmu1 <- NULL}
	else {
	# formula with unknowns
		if(npr1!=npt1){
			cat("\nParameters are ")
			cat(attr(cmu1,"parameters"),"\n")
			stop(paste("pcmu should have",if(ord)npt1*states
				else npt1*states*l,"estimates"))}
		if(is.list(pcmu))pcmu <- unlist(pcmu)}
	if(is.null(cmu1))pcmu <- NULL}
else if(is.list(cmu)){
	if(!ord&&length(cmu)!=states*l)
		stop(paste("list of cmu formulae or functions must have length",states*l))
	if(ord&&length(cmu)!=states)
		stop(paste("list of cmu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(cmu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in cmu)if(inherits(i,"formula")){
		cmu1 <- if(respenv)finterp(i,.envir=response,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
		npt1 <- length(attr(cmu1,"parameters"))
		if(is.character(attr(cmu1,"model"))){
		# W&R formula
			if(ord&&length(attr(cmu1,"model"))==1)cm1 <- NULL}
		else if(is.list(pcmu))pcmu <- unlist(pcmu)
		# make new list and count parameters
		tmp <- c(tmp,list(cmu1))
		start <- start+length(attr(cmu1,"parameters"))}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	cmu1 <- tmp
	rm(tmp)}
else if(!is.null(cmu))cmu1 <- cmu
#
# give appropriate attributes to cmu1 for printing
#
if(!is.null(cmu1)&&is.null(attr(cmu1,"parameters"))){
	attributes(cmu1) <- if(is.function(cmu)){
		if(!inherits(cmu,"formulafn")){
			if(respenv)attributes(fnenvir(cmu,.envir=response))
			else attributes(fnenvir(cmu,.envir=envir))}
		else attributes(cmu)}
		else {
			if(respenv)attributes(fnenvir(cmu1,.envir=response))
			else attributes(fnenvir(cmu1,.envir=envir))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.function(cmu)&&!is.list(cmu)){
	nlp <- if(is.function(cmu1))length(attr(cmu1,"parameters"))
		else if(is.null(cmu1))NULL
		else npt1
	if(!is.null(nlp)&&nlp!=npr1)
		stop(paste("pcmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(pcmu))
	stop(paste("pcmu should have",start,"initial estimates"))
#
# transform time-varying formulae to functions and check number of parameters
#
npr2 <- if(ord)length(ptvmu)/states else length(ptvmu)/states/l
start <- NULL
if(inherits(tvmu,"formula")){
	tvmu1 <- if(respenv)finterp(tvmu,.envir=response,.name=envname,.intercept=!ord)
		else finterp(tvmu,.envir=envir,.name=envname,.intercept=!ord)
	npt2 <- length(attr(tvmu1,"parameters"))
	if(is.character(attr(tvmu1,"model"))){
	# W&R formula
		if(length(attr(tvmu1,"model"))==1&&length(tvmu1(ptvmu))!=mobs){
			tmp <- function(p) rep(p[1],mobs)
			attributes(tmp) <- attributes(tvmu1)
			tvmu1 <- tmp
			rm(tmp)}
		else if(ord&&length(attr(tvmu1,"model"))==0)tvmu1 <- NULL}
	else {
	# formula with unknowns
		if(npr2!=npt2){
			cat("\nParameters are ")
			cat(attr(tvmu1,"parameters"),"\n")
			stop(paste("ptvmu should have",if(ord) npt2*states else npt2*states*l,"estimates"))}
		if(is.list(ptvmu))ptvmu <- unlist(ptvmu)}
	if(is.null(tvmu1))ptvmu <- NULL}
else if(is.list(tvmu)){
	if(!ord&&length(tvmu)!=states*l)
		stop(paste("list of tvmu formulae or functions must have length",states*l))
	if(ord&&length(tvmu)!=states)
		stop(paste("list of tvmu formulae or functions must have length",states))
	# only count parameters if list of formulae
	if(inherits(tvmu[[1]],"formula"))start <- 1
	tmp <- list()
	for(i in tvmu)if(inherits(i,"formula")){
		tvmu1 <- if(respenv)finterp(i,.envir=response,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
			else finterp(i,.envir=envir,.expand=FALSE,.name=envname,.start=start,.intercept=!ord)
		npt2 <- length(attr(tvmu1,"parameters"))
		if(is.character(attr(tvmu1,"model"))){
		# W&R formula (don't know how to change index of p[i])
			if(ord&&length(attr(tvmu1,"model"))==1)tvm1 <- NULL}
		else if(is.list(ptvmu))ptvmu <- unlist(ptvmu)
		# make new list and count parameters
		tmp <- c(tmp,list(tvmu1))
		start <- start+length(attr(tvmu1,"parameters"))}
	else if(is.function(i)){
		if(inherits(i,"formulafn"))start <- c(start,attr(i,"parameters"))
		tmp <- c(tmp,list(i))}
	if(!is.null(start)){
		if(is.numeric(start))start <- start-1
		else start <- length(unique(start))}
	tvmu1 <- tmp
	rm(tmp)}
else if(!is.null(tvmu))tvmu1 <- tvmu
#
# give appropriate attributes to tvmu1 for printing
#
if(!is.null(tvmu1)&&is.null(attr(tvmu1,"parameters"))){
	attributes(tvmu1) <- if(is.function(tvmu)){
		if(!inherits(tvmu,"formulafn")){
			if(respenv)attributes(fnenvir(tvmu,.envir=response))
			else attributes(fnenvir(tvmu,.envir=envir))}
		else attributes(tvmu)}
		else {
			if(respenv)attributes(fnenvir(tvmu1,.envir=response))
			else attributes(fnenvir(tvmu1,.envir=envir))}}
#
# if possible, check that correct number of estimates was supplied
#
if(!is.function(tvmu)&&!is.list(tvmu)){
	nlp <- if(is.function(tvmu1))length(attr(tvmu1,"parameters"))
		else if(is.null(tvmu1))NULL
		else npt2
	if(!is.null(nlp)&&nlp!=npr2)
		stop(paste("ptvmu should have",if(ord)nlp*states else nlp*states*l,"initial estimates"))}
if(!is.null(start)&&start!=length(ptvmu))
	stop(paste("ptvmu should have",start,"initial estimates"))
#
# set up general regression function for likelihood
# if arg==FALSE, can print out general parameter estimates as matrices
#
arg <- TRUE
if(ord&&is.null(mu1))arg <- FALSE
if(is.function(mu1)){
	if(!ord&&is.null(pmu))stop("Initial values of pmu must be supplied")
	tmp <- mu1(pmu)
	if(length(tmp)!=nob)
		stop("mu function or formula must return a vector with one element per observation")
	if(any(is.na(tmp))||any(abs(tmp)==Inf))stop("mu returns NAs or Infs")
	rm(tmp)
	# will be able to print coefficients as matrices
	arg <- FALSE
	# create regression function by repeatedly calling
	# function or formula supplied
	if(distribution=="multinomial"){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zm[,i,j] <- mu1(p[(1:npr0)+(k-1)*npr0])}
			zm}}
	else if(ord){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- mu1(p[(1:npr0)+(i-1)*npr0])
				for(j in 1:l){
					k <- k+1
					zm[,i,j] <- p[np0+k]+tmp}}
#				zm[,i,] <- rep(p[np0+(k+1):(k+l)],rep(nob,l))+
#					rep(mu1(p[(1:npr0)+(i-1)*npr0]),l)
#				k <- k+l}
			zm}}
	else {
		muf <- function(p){
			z <- NULL
			for(i in 1:states)
				z <- cbind(z,mu1(p[(1:npr0)+(i-1)*npr0]))
			z}}
	attributes(muf) <- attributes(mu)}
else if(is.list(mu1)){
	if(is.null(pmu))stop("Initial values of pmu must be supplied")
	for(i in mu1)if(length(i(pmu))!=nob)stop("each mu function or formula must return a vector with one element per observation")
	# create one regression function from list
	if(distribution=="multinomial"){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zm[,i,j] <- mu1[[k]](p)}
			zm}}
	else if(ord){
		zm <- array(0,c(nob,states,l))
		muf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- mu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zm[,i,j] <- p[np0+k]+tmp}}
			zm}}
	else {
		muf <- function(p){
			z <- NULL
			for(i in mu1)z <- cbind(z,i(p))
			z}}}
else pmu0 <- NULL
#
# set up time-constant regression function for likelihood
# if arc==FALSE, can print out time-constant parameter estimates as matrices
#
arc <- TRUE
if(is.function(cmu1)){
	if(!ord&&is.null(pcmu))stop("Initial values of pcmu must be supplied")
	# check if array returned or one function/formula for all states
	tmp <- cmu1(pcmu)
	d <- dim(tmp)
	if(length(d)==0){
	# one formula or function
		if(length(tmp)!=nosubj)
			stop("cmu function or formula must return a vector with one element per individual")
		if(any(is.na(tmp))||any(abs(tmp)==Inf))
			stop("cmu returns NAs or Infs")
		rm(tmp)
		# will be able to print coefficients as matrices
		arc <- FALSE
		# create regression function by repeatedly calling
		# function or formula supplied
		if(distribution=="multinomial"){
			zmc <- array(0,c(nosubj,states,l))
			cmuf <- function(p){
				k <- 0
				for(j in 1:l)for(i in 1:states){
					k <- k+1
					zmc[,i,j] <- cmu1(p[(1:npr1)+(k-1)*npr1])}
				zmc}}
		else if(ord){
			zmc <- array(0,c(nosubj,states,l))
			cmuf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- cmu1(p[(1:npr1)+(i-1)*npr1])
					for(j in 1:l){
						k <- k+1
						zmc[,i,j] <- p[np0+k]+tmp}}
				zmc}}
		else {
			cmuf <- function(p){
				z <- NULL
				for(i in 1:states)
					z <- cbind(z,cmu1(p[(1:npr1)+(i-1)*npr1]))
				z}}
		attributes(cmuf) <- attributes(cmu)}
	else {
	# returns an array: check dimensions
		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 if(length(d)!=2)
				stop("cmu must return a 2 dimensional array")
		arc <- FALSE
		cmuf <- cmu1}}
else if(is.list(cmu1)){
	if(is.null(pcmu))stop("Initial values of pcmu must be supplied")
	for(i in cmu1)if(length(i(pcmu))!=nosubj)stop("each cmu function or formula must return a vector with one element per individual")
	# create one regression function from list
	if(distribution=="multinomial"){
		zmc <- array(0,c(nosubj,states,l))
		cmuf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zmc[,i,j] <- cmu1[[k]](p)}
			zmc}}
	else if(ord){
		zmc <- array(0,c(nosubj,states,l))
		cmuf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- cmu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zmc[,i,j] <- p[np0+k]+tmp}}
			zmc}}
	else {
		cmuf <- function(p){
			z <- NULL
			for(i in cmu1)z <- cbind(z,i(p))
			z}}}
else pmu1 <- array(0,c(states,nosubj,l))
#
# set up time-varying regression function for likelihood
# if arv==FALSE, can print out time-varying parameter estimates as matrices
#
arv <- TRUE
if(is.function(tvmu1)){
	if(!ord&&is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	# check if array returned or one function/formula for all states
	tmp <- tvmu1(ptvmu)
	d <- dim(tmp)
	if(length(d)==0){
	# one formula or function
		if(length(tmp)!=mobs)
			stop("tvmu function or formula must return a vector with one element per time point")
		if(any(is.na(tmp))||any(abs(tmp)==Inf))
			stop("tvmu returns NAs or Infs")
		rm(tmp)
		# will be able to print coefficients as matrices
		arv <- FALSE
		# create regression function by repeatedly calling
		# function or formula supplied
		if(distribution=="multinomial"){
			zmv <- array(0,c(mobs,states,l))
			tvmuf <- function(p){
				k <- 0
				for(j in 1:l)for(i in 1:states){
					k <- k+1
					zmv[,i,j] <- tvmu1(p[(1:npr2)+(k-1)*npr2])}
				zmv}}
		else if(ord){
			zmv <- array(0,c(mobs,states,l))
			tvmuf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- tvmu1(p[(1:npr2)+(i-1)*npr2])
					for(j in 1:l){
						k <- k+1
						zmv[,i,j] <- ord2*p[np0+k]+tmp}}
				zmv}}
		else {
			tvmuf <- function(p){
				z <- NULL
				for(i in 1:states)
					z <- cbind(z,tvmu1(p[(1:npr2)+(i-1)*npr2]))
				z}}
		attributes(tvmuf) <- attributes(tvmu)}
	else {
	# returns an array: check dimensions
		if(d[2]!=states)stop(paste("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 if(length(d)!=2)
				stop("tvmu must return a 2 dimensional array")
		arv <- FALSE
		tvmuf <- tvmu1}}
else if(is.list(tvmu1)){
	if(is.null(ptvmu))stop("Initial values of ptvmu must be supplied")
	for(i in tvmu1)if(length(i(ptvmu))!=mobs)stop("each tvmu function or formula must return a vector with one element per time point")
	# create one regression function from list
	if(distribution=="multinomial"){
		zmv <- array(0,c(mobs,states,l))
		tvmuf <- function(p){
			k <- 0
			for(j in 1:l)for(i in 1:states){
				k <- k+1
				zmv[,i,j] <- tvmu1[[k]](p)}
			zmv}}
	else if(ord){
		zmv <- array(0,c(mobs,states,l))
		tvmuf <- function(p){
			k <- 0
			for(i in 1:states){
				tmp <- tvmu1[[i]](p)
				for(j in 1:l){
					k <- k+1
					zmv[,i,j] <- ord2*p[np0+k]+tmp}}
			zmv}}
	else {
		tvmuf <- function(p){
			z <- NULL
			for(i in tvmu1)z <- cbind(z,i(p))
			z}}}
else pmu2 <- array(0,c(states,mobs,l))
if(!is.function(muf)&&!is.function(cmuf)&&!is.function(tvmuf)){
	if(ord){
		if(is.null(pintercept))
			stop(paste("pintercept must contain ",l," initial estimates",sep=""))
		else {
			ismu <- TRUE
			zm <- array(0,c(nob,states,l))
			muf <- function(p){
				k <- 0
				for(i in 1:states){
					tmp <- rep(1,nob)
					for(j in 1:l){
						k <- k+1
						zm[,i,j] <- p[np0+k]*tmp}}
				zm}}}
	else stop("Either mu, cmu or tvmu must be a list, function, or formula")}
#
# prepare to call nlm
#
nm1 <- length(pg)+1
nmu <- length(pg)+length(pmu)+length(pintercept)
ncmu <- length(pg)+length(pcmu)+length(ptvmu)+length(pintercept)
ncmu1 <- length(pg)+length(pcmu)+1
p <- c(pg,pmu,pcmu,ptvmu,pshape,pfamily,pintercept,par)
np <- length(p)
np0 <- np-length(pg)-length(pintercept)-length(par)
np1 <- np-length(pshape)-length(pfamily)-length(pintercept)-length(par)
np2 <- np1+1
np3 <- np-length(pfamily)-length(pintercept)-length(par)
np4 <- np-length(pintercept)-length(par)
np5 <- np-length(par)
pshape <- rep(0,states)
z <- nlm(likel,p, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
#
# prepare mle's
#
delta <- if(!is.null(response$response$delta))
	sum(log(response$response$delta)) else 0
maxlike <- z$minimum - delta
z0 <- like(z$estimate)
#
# calculate se's
#
a <- if(any(is.na(z$hessian))||any(abs(z$hessian)==Inf))0
	else 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)
#
# calculate predicted values
#
if(mdl<3||mdl>6){
	rpred <- 0
	if(is.function(muf)){
		rpred <- rpred+t(muf(z$estimate[nm1:nmu]))
		if(dim(rpred)[2]!=nob)rpred <- rpred[,rep(1:nosubj,nobs(response))]}
	if(is.function(cmuf))rpred <- rpred+t(cmuf(z$estimate[nm1:ncmu]))[,rep(1:nosubj,nobs(response))]
	if(is.function(tvmuf))rpred <- rpred+t(tvmuf(z$estimate[ncmu1:np]))[,sequence(nobs(response))]
	if(mdl==1||mdl==7)rpred <- 1/(1+exp(-rpred))
	pred <- rep(1,states)%*%(rpred*z0$delta)
	rpred <- rep(1,states)%*%(rpred*matrix(z0$filter,nrow=states))}
else pred <- rpred <- NULL
#
# return appropriate attributes on functions
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(cmu3))cmu1 <- cmu3
if(!is.null(tvmu3))tvmu1 <- tvmu3
z1 <- list(
	call=call,
	type="discrete",
	distribution=distribution,
	response=response$response,
	maxlike=maxlike,
	aic=maxlike+np,
	df=length(response$response$y)-np,
	states=states,
	levels=l,
	mu=mu1,
	arg=arg,
	cmu=cmu1,
	arc=arc,
	arv=arv,
	tvmu=tvmu1,
	coef=z$estimate[nm1:np1],
	pshape=if(np3>np1&&!ord)z$estimate[np2:np3] else NULL,
	pfamily=if(np>np3+!is.null(par)&&!ord)z$estimate[np] else NULL,
	pintercept=if(is.null(pintercept)) NULL else z$estimate[np2:np],
	nmu=length(pmu),
	ncmu=length(pcmu),
	ntvmu=length(ptvmu),
	gamma=matrix(z0$gamma,ncol=states),
	delta=z0$delta,
	par=if(!is.null(par))z0$par else NULL,
	np=np,
	cov=cov,
	corr=corr,
	se=se,
	filter=matrix(z0$filter,nrow=states),
	pred=pred,
	rpred=rpred,
	iterations=z$iter,
	code=z$code)
class(z1) <- if(is.null(rpred))"hidden" else c("hidden","recursive")
z1}

print.hidden <- function(z,digits=max(3,.Options$digits-3),correlation=FALSE){
ord <- z$distribution=="continuation ratio"||
	z$distribution=="proportional odds"
m <- z$states
cat("\nCall:",deparse(z$call),sep="\n")
cat("\n")
if(m>1)cat(z$type,"")
cat(z$distribution)
if(m>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(nobs(z)),"\n")
cat("Number of observations",length(z$response$y),"\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")
if(ord){
# intercept coefficients for ordinal models
	cat("\nIntercepts\n")
	# first check that intercepts are valid
	for(i in 1:m){
		tmp <- diff(z$pintercept[(i-1)*z$levels+(1:z$levels)])
		if(!all(tmp>0))cat(paste("intercepts not monotone increasing for state",i,"\n"))}
	coef <- matrix(z$pintercept,byrow=TRUE,nrow=m)
	dimnames(coef) <- list(paste("state ",1:m,sep=""),
		(1:z$levels)-1)
	print.default(coef,digits=digits,print.gap=2)}
if(z$nmu>0){
# general coefficients
	cat("\nRegression coefficients\n")
	if(!is.list(z$mu))z$mu <- list(z$mu)
	ll <- j <- l <- 0
	cname <- NULL
	for(i in z$mu){
	# print out functions/formulae used, by state if possible
		cname <- c(cname,if(is.character(attr(i,"model")))
			attr(i,"model") else attr(i,"parameters"))
		ll <- c(ll,length(cname))
		l <- l+1
		if(l==1&&length(z$mu)>1&&((!is.null(attr(i,"formula"))&&!is.null(attr(i,"model")))||is.function(i))){
			j <- j+1
			tmp <- paste("state",j)
			cat(tmp,"\n")}
		if(ord||l==z$levels)l <- 0
		if(!is.null(attr(i,"formula")))
			cat(deparse(attr(i,"formula")),sep="\n")
		else if(!is.null(attr(i,"model"))){
			t <- deparse(attr(i,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		else if(is.function(i))cat(deparse(i)[-1],sep="\n")}
	coef <- matrix(z$coef[1:z$nmu],nrow=1)
	if(z$arg){
		if(is.null(cname)||length(cname)!=z$nmu){
		# print out coefficients as one vector
			dimnames(coef) <- list(1,1:z$nmu)
			print.default(coef,digits=digits,print.gap=2)}
		else {
		# print out coefficients by state
			l2 <- if(ord)1 else z$levels
			for(i in 1:m){
				if(m>1)cat("state",i,"\n")
				coef1 <- NULL
				for(j in 1:l2){
					coef1 <- coef[,(ll[i+(j-1)*m]+1):ll[i+(j-1)*m+1],drop=FALSE]
					dimnames(coef1) <- list(1,cname[(ll[i+(j-1)*m]+1):ll[i+(j-1)*m+1]])
					print.default(coef1,digits=digits,print.gap=2)}}}}
	else {
	# print out coefficients as matrices
		if(z$distribution=="multinomial"){
			npr0 <- z$nmu/m/z$levels
			if(is.null(cname)||length(cname)!=npr0)
				cname <- 1:npr0
			for(i in 1:m){
				if(m>1)cat("state",i,"\n")
				coef1 <- NULL
				for(j in 1:z$levels)
					coef1 <- rbind(coef1,coef[(1:npr0)+(i-1)*npr0+(j-1)*npr0*m])
				dimnames(coef1) <- list(1:z$levels,cname)
				print.default(coef1,digits=digits,print.gap=2)}}
		else {
			npr0 <- z$nmu/m
			if(is.null(cname)||length(cname)!=npr0)
				cname <- 1:npr0
			coef1 <- matrix(coef,nrow=m,byrow=TRUE)
			dimnames(coef1) <- list(paste("state",1:m),cname)
			print.default(coef1,digits=digits,print.gap=2)}}}
if(z$ncmu>0){
# time-constant coefficients
	cat("\nTime-constant coefficients\n")
	if(!is.list(z$cmu))z$cmu <- list(z$cmu)
	ll <- j <- l <- 0
	cname <- NULL
	for(i in z$cmu){
	# print out functions/formulae used, by state if possible
		cname <- c(cname,if(is.character(attr(i,"model")))
			attr(i,"model") else attr(i,"parameters"))
		ll <- c(ll,length(cname))
		l <- l+1
		if(l==1&&length(z$cmu)>1&&((!is.null(attr(i,"formula"))&&!is.null(attr(i,"model")))||is.function(i))){
			j <- j+1
			tmp <- paste("state",j)
			cat(tmp,"\n")}
		if(ord||l==z$levels)l <- 0
		if(!is.null(attr(i,"formula")))
			cat(deparse(attr(i,"formula")),sep="\n")
		else if(!is.null(attr(i,"model"))){
			t <- deparse(attr(i,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		else if(is.function(i))cat(deparse(i)[-1],sep="\n")}
	coef <- matrix(z$coef[1:z$ncmu],nrow=1)
	if(z$arc){
		if(is.null(cname)||length(cname)!=z$ncmu){
		# print out coefficients as one vector
			dimnames(coef) <- list(1,1:z$ncmu)
			print.default(coef,digits=digits,print.gap=2)}
		else {
		# print out coefficients by state
			l2 <- if(ord)1 else z$levels
			for(i in 1:m){
				if(m>1)cat("state",i,"\n")
				coef1 <- NULL
				for(j in 1:l2){
					coef1 <- coef[,(ll[i+(j-1)*m]+1):ll[i+(j-1)*m+1],drop=FALSE]
					dimnames(coef1) <- list(1,cname[(ll[i+(j-1)*m]+1):ll[i+(j-1)*m+1]])
					print.default(coef1,digits=digits,print.gap=2)}}}}
	else {
	# print out coefficients as matrices
		if(z$distribution=="multinomial"){
			npr1 <- z$ncmu/m/z$levels
			if(is.null(cname)||length(cname)!=npr1)
				cname <- 1:npr1
			k <- 0
			for(i in 1:m){
				if(m>1)cat("state",i,"\n")
				coef1 <- NULL
				for(j in 1:z$levels){
					k <- k+1
					coef1 <- rbind(coef1,coef[(1:npr1)+(i-1)*npr1+(j-1)*npr1*m])}
				dimnames(coef1) <- list(1:z$levels,cname)
				print.default(coef1,digits=digits,print.gap=2)}}
		else {
			npr1 <- z$ncmu/m
			if(is.null(cname)||length(cname)!=npr1)
				cname <- 1:npr1
			coef1 <- matrix(coef,nrow=m,byrow=TRUE)
			dimnames(coef1) <- list(paste("state",1:m),cname)
			print.default(coef1,digits=digits,print.gap=2)}}}
if(z$ntvmu>0){
# time-varying coefficients
	cat("\nTime-varying coefficients\n")
	if(!is.list(z$tvmu))z$tvmu <- list(z$tvmu)
	ll <- j <- l <- 0
	cname <- NULL
	for(i in z$tvmu){
	# print out functions/formulae used, by state if possible
		cname <- c(cname,if(is.character(attr(i,"model")))
			attr(i,"model") else attr(i,"parameters"))
		ll <- c(ll,length(cname))
		l <- l+1
		if(l==1&&length(z$tvmu)>1&&((!is.null(attr(i,"formula"))&&!is.null(attr(i,"model")))||is.function(i))){
			j <- j+1
			tmp <- paste("state",j)
			cat(tmp,"\n")}
		if(ord||l==z$levels)l <- 0
		if(!is.null(attr(i,"formula")))
			cat(deparse(attr(i,"formula")),sep="\n")
		else if(!is.null(attr(i,"model"))){
			t <- deparse(attr(i,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		else if(is.function(i))cat(deparse(i)[-1],sep="\n")}
	coef <- matrix(z$coef[(z$ncmu+1):(z$ncmu+z$ntvmu)],nrow=1)
	if(z$arv){
		if(is.null(cname)||length(cname)!=z$ntvmu){
		# print out coefficients as one vector
			dimnames(coef) <- list(1,1:z$ntvmu)
			print.default(coef,digits=digits,print.gap=2)}
		else {
		# print out coefficients by state
			l2 <- if(ord)1 else z$levels
			for(i in 1:m){
				if(m>1)cat("state",i,"\n")
				coef1 <- NULL
				for(j in 1:l2){
					coef1 <- coef[,(ll[i+(j-1)*m]+1):ll[i+(j-1)*m+1],drop=FALSE]
					dimnames(coef1) <- list(1,cname[(ll[i+(j-1)*m]+1):ll[i+(j-1)*m+1]])
					print.default(coef1,digits=digits,print.gap=2)}}}}
	else {
	# print out coefficients as matrices
		if(z$distribution=="multinomial"){
			npr2 <- z$ntvmu/m/z$levels
			if(is.null(cname)||length(cname)!=npr2)
				cname <- 1:npr2
			k <- 0
			for(i in 1:m){
				if(m>1)cat("state",i,"\n")
				coef1 <- NULL
				for(j in 1:z$levels){
					k <- k+1
					coef1 <- rbind(coef1,coef[(1:npr2)+(i-1)*npr2+(j-1)*npr2*m])}
				dimnames(coef1) <- list(1:z$levels,cname)
				print.default(coef1,digits=digits,print.gap=2)}}
		else {
			npr2 <- z$ntvmu/m
			if(is.null(cname)||length(cname)!=npr2)
				cname <- 1:npr2
			coef1 <- matrix(coef,nrow=m,byrow=TRUE)
			dimnames(coef1) <- list(paste("state",1:m),cname)
			print.default(coef1,digits=digits,print.gap=2)}}}
if(!is.null(z$pshape)){
	cat("\nDispersion parameters\n")
	coef <- matrix(z$pshape,nrow=1)
	dimnames(coef) <- list(1,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(1,1)
	print.default(coef, digits=digits, print.gap=2)}
if(z$states>1){
	cat("\nTransition matrix\n")
	dimnames(z$gamma) <- list(1:m,1:m)
	print.default(z$gamma, digits=digits, print.gap=2)
	if(is.null(z$changepoint)){
		cat("\nStationary distribution\n")
		z$delta <- matrix(z$delta,nrow=1)
		dimnames(z$delta) <- list(1,1:m)
		print.default(z$delta, digits=digits, print.gap=2)}}
if(!is.null(z$par)){
	cat("\nAutoregression parameter\n")
	if(z$type=="discrete"){
		coef <- matrix(z$par,nrow=1)
		dimnames(coef) <- list(1,1)}
	else {
		coef <- matrix(c(log(z$par),z$par),nrow=1)
		dimnames(coef) <- list(1,c("estimate","parameter"))}
	print.default(coef, digits=digits, print.gap=2)}
if(correlation){
	cat("\nCorrelations:\n")
	dimnames(z$corr) <- list(seq(1,z$np),seq(1,z$np))
	print.default(z$corr,digits=digits)}}

# plot probability of being in each state at each time point
plot.hidden <- function(z, nind=1, state=NULL, smooth=FALSE, main=NULL,
ylab=NULL, xlab="Time", xlim=NULL, ...){
if(max(nind)>length(nobs(z)))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 <- if(z$states>2&&is.null(state))par(mfcol=c(z$states,ns))
	else NULL
if(is.null(state)&&z$state==2)state <- 1
k <- 0
for(i in nind){
	k <- k+1
	lenf <- sum(ii==i)
	for(j in 1:z$states)if(is.null(state)||any(j==state)){
		xl <- if(j==z$states||z$states==2||!is.null(state))xlab else ""
		mn <- if(j==1)main[k] else ""
		yl <- if(k==1||z$states==2||!is.null(state)){
			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,xlim=xlim,ylim=c(0,1),...)}}
if(!is.null(oldpar))par(oldpar)}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 2002 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     hnlmix(y=NULL, distribution="normal", mixture="normal",
#	random=NULL, nest=NULL, mu=NULL, shape=NULL, linear=NULL,
#	pmu=NULL, pshape=NULL, pmix=NULL, prandom=NULL, delta=1, common=FALSE,
#	envir=parent.frame(), print.level=0, typsiz=abs(p),
#	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p), steptol=0.00001,
#	iterlim=100, fscale=1, eps=1.0e-4)
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models with one arbitrary
#  random parameter using h-likelihood

hnlmix <- function(y=NULL, distribution="normal", mixture="normal",
	random=NULL, nest=NULL, mu=NULL, shape=NULL, linear=NULL,
	pmu=NULL, pshape=NULL, pmix=NULL, prandom=NULL, delta=1, common=FALSE,
	envir=parent.frame(), print.level=0, typsiz=abs(p),
	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p), steptol=0.00001,
	iterlim=100, fscale=1, eps=1.0e-4, points=5){
#
call <- sys.call()
#
# check 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","beta",
	"simplex","two-sided power"))
shp <- distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"
bindata <- distribution=="binomial"||distribution=="double binomial"||
	distribution=="beta binomial"||distribution=="mult binomial"
#
# check mixture
#
#mixture <- match.arg(mixture,c("normal","logistic","Cauchy","Laplace",
#	"gamma","inverse Gauss","Weibull","beta"))
mixture <- match.arg(mixture,c("normal","logistic","gamma","inverse gamma",
	"inverse Gauss","Weibull","beta"))
mean0 <- if(mixture=="normal"||mixture=="logistic"||mixture=="Cauchy"||
	 mixture=="Laplace")0 else if(mixture=="beta")2 else 1
fixed <- !is.null(pmix)
if(fixed&&pmix<0)stop("pmix must be positive")
#
# check random parameters
#
if(is.null(random))stop("name of random parameter must be supplied")
if(!is.character(random))stop("random must be the name of a parameter")
if(length(random)>1)stop("only one random parameter allowed")
#
# check for parameters common to location and shape functions
#
if(common&&!is.null(linear))
	stop("linear cannot be used with common parameters")
#
# count number of parameters
#
npl <- length(pmu)
nps <- length(pshape)
np1 <- npl+nps
#
# check if a data object is being supplied
#
respenv <- exists(deparse(substitute(y)),envir=parent.frame())&&
	inherits(y,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(y$response$y)[2]>1)
		stop("hnlmix only handles univariate responses")
	if(!is.null(y$NAs)&&any(y$NAs))
		stop("hnlmix does not handle data with NAs")}
envname <- if(respenv)deparse(substitute(y))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
# check that formulae with unknowns are supplied
#
if(!inherits(mu,"formula"))stop("mu must be a formula")
if(shp&&!is.null(shape)&&!inherits(shape,"formula"))
	stop("shape must be a formula")
#
# find linear part of each regression
#
lin1 <- lin2 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]}
else lin1 <- linear
#
# if a data object was supplied, modify formulae or functions to read from it
#
lin1a <- lin2a <- mu2 <- sh2 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	# modify formulae
	if(inherits(mu,"formula")){
		mu2 <- if(respenv)finterp(mu,.envir=y,.name=envname,.args=random)
			else finterp(mu,.envir=envir,.name=envname,.args=random)}
	if(inherits(shape,"formula")){
		sh2 <- if(respenv)finterp(shape,.envir=y,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	if(inherits(lin1,"formula")){
		lin1a <- if(respenv)finterp(lin1,.envir=y,.name=envname)
			else finterp(lin1,.envir=envir,.name=envname)}
	if(inherits(lin2,"formula")){
		lin2a <- if(respenv)finterp(lin2,.envir=y,.name=envname)
			else finterp(lin2,.envir=envir,.name=envname)}
	# modify functions
	if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
			tmp <- parse(text=deparse(mu)[-1])
			mu <- if(respenv)fnenvir(mu,.envir=y,.name=envname)
				else fnenvir(mu,.envir=envir,.name=envname)
			mu2 <- mu
			attr(mu2,"model") <- tmp}
		else mu2 <- mu}
	if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=y,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh2 <- shape
		        attr(sh2,"model") <- tmp}
		else sh2 <- shape}}
else {
     if(is.function(mu)&&is.null(attr(mu,"model")))mu <- fnenvir(mu)
     if(is.function(shape)&&is.null(attr(shape,"model")))
		shape <- fnenvir(shape)}
#
# check if linear contains W&R formula
#
if(inherits(lin1,"formula")){
	tmp <- attributes(if(respenv)finterp(lin1,.envir=y,.name=envname)
		else finterp(lin1,.envir=envir,.name=envname))
	lf1 <- length(tmp$parameters)
	if(!is.character(tmp$model))stop("linear must be a W&R formula")
	else if(length(tmp$model)==1)stop("linear must contain covariates")
	rm(tmp)}
else lf1 <- 0
if(inherits(lin2,"formula")){
	tmp <- attributes(if(respenv)finterp(lin2,.envir=y,.name=envname)
		else finterp(lin2,.envir=envir,.name=envname))
	lf2 <- length(tmp$parameters)
	if(!is.character(tmp$model))stop("linear must be a W&R formula")
	else if(length(tmp$model)==1)stop("linear must contain covariates")
	rm(tmp)}
else lf2 <- 0
#
# transform location formula to function and check number of parameters
#
if(lf1>0)random <- c(random,"linear")
mu3 <- if(respenv)finterp(mu,.envir=y,.name=envname,.args=random)
	else finterp(mu,.envir=envir,.name=envname,.args=random)
npt1 <- length(attr(mu3,"parameters"))
if(is.character(attr(mu3,"model")))stop("mu cannot be a W&R formula")
if(npl!=npt1&&!common&&lf1==0){
	cat("\nParameters are ")
	cat(attr(mu3,"parameters"),"\n")
	stop(paste("pmu should have",npt1,"estimates"))}
if(is.list(pmu)){
	if(!is.null(names(pmu))){
		o <- match(attr(mu3,"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 linear part, modify location function appropriately
#
if(lf1>0){
	dm1 <- if(respenv)wr(lin1,data=y)$design
		else wr(lin1,data=envir)$design
	if(is.null(mu2))mu2 <- mu3
	mu1 <- function(p,random)mu3(p,random,dm1%*%p[(npt1+1):(npt1+lf1)])}
else {
	mu1 <- mu3
	rm(mu3)}
#
# check that correct number of estimates was supplied
#
nlp <- npt1+lf1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl1 <- if(common&&!inherits(shape,"formula")) 1 else nlp+1
#
# transform shape formula to function and check number of parameters
#
sh3 <- NULL
if(inherits(shape,"formula")){
        old <- if(common)mu1 else NULL
        mufn <- if(lf2>0) "linear" else NULL
        sh3 <- if(respenv)finterp(shape,.envir=y,.start=npl1,.name=envname,.old=old,.args=mufn)
        	else finterp(shape,.envir=envir,.start=npl1,.name=envname,.old=old,.args=mufn)
        npt2 <- length(attr(sh3,"parameters"))
        if(is.character(attr(sh3,"model")))stop("shape cannot be a W&R formula")
        if(nps!=npt2&&!common&&lf2==0){
        	cat("\nParameters are ")
        	cat(attr(sh3,"parameters"),"\n")
        	stop(paste("pshape should have",npt2,"estimates"))}
        if(is.list(pshape)){
        	if(!is.null(names(pshape))){
        		o <- match(attr(sh3,"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)}}
else if(is.null(shape)&&shp){
	sh3 <- function(p) p[npl1]*rep(1,n)
	sh2 <- fnenvir(function(p) p[1]*rep(1,n))
	npt2 <- 1}
#
# if linear part, modify shape function appropriately
#
if(lf2>0){
	dm2 <- if(respenv)wr(lin2,data=y)$design
		else wr(lin2,data=envir)$design
	if(is.null(sh2))sh2 <- sh3
	sh1 <- sh3(p,dm2%*%p[(npl1+lf2-1):np])}
else {
	sh1 <- sh3
	rm(sh3)}
#
# if distribution has a shape parameter, check that correct number of
# estimates was supplied
#
if(shp){
	nlp <- npt2+lf2
	if(!common&&nlp!=nps)stop(paste("pshape should have",nlp,"initial estimates"))}
#
# when there are parameters common to location and shape functions,
# check that correct number of estimates was supplied
#
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(sh1,"parameters"))))
	if(nlp!=npl)stop(paste("with a common parameter model, pmu should contain",nlp,"estimates"))}
#
# if data object supplied, find response information in it
#
type <- "unknown"
if(respenv){
	if(inherits(envir,"repeated")&&(length(nobs(y))!=length(nobs(envir))||any(nobs(y)!=nobs(envir))))
		stop("y and envir objects are incompatible")
	if(!is.null(y$response$delta))
		delta <- as.vector(y$response$delta)
	nest <- covind(y)
	type <- y$response$type
	envir <- y$response
	y <- response(y)}
else if(inherits(envir,"repeated")){
	if(!is.null(envir$NAs)&&any(envir$NAs))
		stop("hnlmix does not handle data with NAs")
	cn <- deparse(substitute(y))
	if(length(grep("\"",cn))>0)cn <- y
	if(length(cn)>1)stop("only one y variable allowed")
	col <- match(cn,colnames(envir$response$y))
	if(is.na(col))stop(paste("response variable",cn,"not found"))
	nest <- covind(envir)
	type <- envir$response$type[col]
	y <- envir$response$y[,col]
	if(!is.null(envir$response$n)&&!all(is.na(envir$response$n[,col])))
		y <- cbind(y,envir$response$n[,col]-y)
	else if(!is.null(envir$response$censor)&&!all(is.na(envir$response$censor[,col])))
		y <- cbind(y,envir$response$censor[,col])
	if(!is.null(envir$response$delta))
		delta <- as.vector(envir$response$delta[,col])
	envir <- envir$response
	envir$y <- envir$y[,col,drop=FALSE]
	if(!is.null(envir$n))envir$n <- envir$n[,col,drop=FALSE]
	else if(!is.null(envir$censor))envir$censor <- envir$censor[,col,drop=FALSE]
	if(!is.null(envir$delta))envir$delta <- envir$delta[,col,drop=FALSE]}
else if(inherits(y,"response")){
	if(dim(y$y)[2]>1)stop("hnlmix only handles univariate responses")
	if(!is.null(y$delta))delta <- as.vector(y$delta)
	nest <- covind(y)
	type <- y$type
	envir <- y
	y <- response(y)}
unest <- unique(nest)
nnest <- length(unest)
unest <- unest[-nnest]
if(is.null(nest)||nnest==1)stop("appropriate nest indicator required")
if(is.null(prandom))
	stop(paste("one or",nnest,"values must be supplied for prandom"))
if(length(prandom)==1)prandom <- rep(prandom,nnest)
else if(length(prandom)!=nnest)
	stop(paste(nnest,"values must be supplied for prandom"))
if(mean0==1){
	if(any(prandom<=0))stop("prandom must all be positive")
	prandom <- log(prandom)}
else if(mean0==2){
	if(any(prandom<=0|prandom>=1))stop("prandom must all be in (0,1)")
	prandom <- log(prandom/(1-prandom))}
p <- c(pmu,pshape,prandom[-nnest])
np <- length(p)
if(any(is.na(y)))stop("NAs in y - use rmna")
#
# check that data are appropriate for distribution
#
if(bindata){
	# binomial data
	if(type!="unknown"&&type!="nominal")stop("nominal data required")
	if((is.vector(y)||(length(dim(y))==2&&dim(y)[2]==1))&&all(y==0|y==1))
		y <- cbind(y,1-y)
	if(length(dim(y))!=2||dim(y)[2]!=2)
		stop(paste("Two column matrix required for response: successes and failures"))
	if(any(y<0))stop("All response values must be positive")
	n <- dim(y)[1]
	nn <- y[,1]+y[,2]
	censor <- FALSE}
else {
	# censoring present?
	censor <- length(dim(y))==2&&dim(y)[2]==2
	if(censor&&all(y[,2]==1)){
		y <- y[,1]
		censor <- FALSE}
	if(!censor)if(!is.vector(y,mode="numeric"))stop("y must be a vector")
	if(censor&&(distribution=="beta"||distribution=="simplex"||
		distribution=="two-sided power"||distribution=="gamma count"||
		distribution=="gamma count"||distribution=="logarithmic"))
		stop("Censoring not allowed for this distribution")
	if(distribution=="double Poisson"||distribution=="mult Poisson")
		my <- if(censor)3*max(y[,1]) else 3*max(y)
	n <- if(length(dim(y))==2)dim(y)[1] else length(y)}
if(distribution=="inverse Gauss"||distribution=="exponential"||
	distribution=="gamma"||distribution=="Weibull"||
	distribution=="extreme value"){
	if(type!="unknown"&&type!="duration"&&type!="continuous")
		stop("duration data required")
	if((censor&&any(y[,1]<=0))||(!censor&&any(y<=0)))
		stop("All response values must be > 0")}
else if(distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="gamma count"||distribution=="double Poisson"||
	distribution=="mult Poisson"){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y<0))stop("All response values must be >= 0")}
else if(distribution=="logarithmic"){
	if(type!="unknown"&&type!="discrete")stop("discrete data required")
	if(any(y<1))stop("All response values must be integers > 0")}
else if(distribution=="beta"||distribution=="simplex"||
	distribution=="two-sided power"){
	if(type!="unknown"&&type!="continuous")stop("continuous data required")
	if(any(y<=0)||any(y>=1))
		stop("All response values must lie between 0 and 1")}
else if(!bindata&&type!="unknown"&&type!="continuous"&&type!="duration")
	stop("continuous data required")
#
# if there is censoring, set up censoring indicators for likelihood
#
if(censor){
	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)}
else cc <- 1
#
# prepare weights and unit of measurement
#
wt <- rep(1,n)
if(length(delta)==1)delta <- rep(delta,n)
else if(length(delta)!=n)
	stop("delta must be the same length as the other variables")
delta2 <- mean(delta)
#
# check that location function returns appropriate values
#
if(any(is.na(mu1(pmu,0))))stop("The location model returns NAs: probably invalid initial values")
if(distribution=="Levy"&&any(y<=mu1(p)))
	stop("location parameter must be strictly less than corresponding observation")
#
# check that shape function returns appropriate values
#
if(shp&&any(is.na(sh1(p))))
	stop("The shape model returns NAs: probably invalid initial values")
if(distribution=="Pareto"&&exp(sh1(p))<=1)stop("shape parameters must be > 0")
#
# set up distribution
#
if(!censor)fcn <- switch(distribution,
	binomial=function(m,p) dbinom(y[,1],nn,m,TRUE),
	"beta binomial"=function(m,p){
		s <- exp(sh1(p))
		t <- s*m
		u <- s*(1-m)
		lbeta(y[,1]+t,y[,2]+u)-lbeta(t,u)+lchoose(nn,y[,1])},
	"double binomial"=function(m,p)
		.C("ddb",as.integer(y[,1]),as.integer(nn),
			as.double(m),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),
			DUP=FALSE,PACKAGE="rmutil")$res,
	"mult binomial"=function(m,p)
		.C("dmb",as.integer(y[,1]),as.integer(nn),
			as.double(m),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),
			DUP=FALSE,PACKAGE="rmutil")$res,
	Poisson=function(m,p)dpois(y,m,TRUE),
	"negative binomial"=function(m,p)dnbinom(y,exp(sh1(p)),mu=m,log=TRUE),
	"double Poisson"=function(m,p)
		.C("ddp",as.integer(y),as.integer(my),as.double(m),
			as.double(exp(sh1(p))),as.integer(n),as.double(wt),
			res=double(n),DUP=FALSE,PACKAGE="rmutil")$res,
	"mult Poisson"=function(m,p)
		.C("dmp",as.integer(y),as.integer(my),
			as.double(m),as.double(exp(sh1(p))),
			as.integer(n),as.double(wt),res=double(n),DUP=FALSE,
			PACKAGE="rmutil")$res,
	"gamma count"=function(m,p){
		s <- exp(sh1(p))
		u <- m*s
		ifelse(y==0,pgamma(u,(y+1)*s,1,lower=FALSE,log=TRUE),
			log(pgamma(u,y*s+(y==0),1)-pgamma(u,(y+1)*s,1)))},
	Consul=function(m,p){
		s <- exp(sh1(p))
		log(m)-(m+y*(s-1))/s+(y-1)*log(m+y*(s-1))-y*log(s)-
			lgamma(y+1)},
	logarithmic=function(m,p){
		m <- 1/(1+exp(-m))
		y*log(m)-log(y)-log(-log(1-m))},
	geometric=function(m,p)y*log(m)-(y+1)*log(1+m),
	normal=function(m,p)dnorm(y,m,exp(sh1(p)/2),TRUE),
	"inverse Gauss"=function(m,p){
		t <- sh1(p)
		s <- exp(t)
		-(t+(y-m)^2/(y*s*m^2)+log(2*pi*y^3))/2},
	logistic=function(m,p)dlogis(y,m,exp(sh1(p))*sqrt(3)/pi,TRUE),
	Cauchy=function(m,p)dcauchy(y,m,exp(sh1(p)/2),TRUE),
	Laplace=function(m,p){
		t <- sh1(p)
		s <- exp(t)
		-abs(y-m)/s-t-log(2)},
	Pareto=function(m,p){
		s <- exp(sh1(p))
		t <- 1/(m*(s-1))
		log(s*t)-(s+1)*log(1+y*t)},
	exponential=function(m,p)dexp(y,1/m,TRUE),
	gamma=function(m,p){
		s <- exp(sh1(p))
		dgamma(y,s,scale=m/s,log=TRUE)},
	Weibull=function(m,p)dweibull(y,exp(sh1(p)),m,TRUE),
	"extreme value"=function(m,p)y+dweibull(exp(y),exp(sh1(p)),m,TRUE),
	beta=function(m,p){
		s <- exp(sh1(p))
		m <- m*s
		s <- s-m
		dbeta(y,m,s,log=TRUE)},
	simplex=function(m,p){
		t <- sh1(p)
		s <- exp(t)
		-(((y-m)/(m*(1-m)))^2/(y*(1-y)*s)+t+3*log(y*(1-y))+
			log(2*pi))/2},
	"two-sided power"=function(m,p){
		t <- sh1(p)
		s <- exp(t)
		t+(s-1)*ifelse(y<m,log(y/m),log((1-y)/(1-m)))})
else fcn <- switch(distribution,
	Poisson=function(m,p)cc*dpois(y[,1],m,TRUE)+log(lc-rc*ppois(y[,1],m)),
	"negative binomial"=function(m,p){
		s <- exp(sh1(p))
		cc*dnbinom(y[,1],s,mu=m,log=TRUE)+log(lc-rc*pnbinom(y[,1],s,m))},
	geometric=function(m,p)
		cc*(y[,1]*log(m)-(y[,1]+1)*log(1+m))+
			log(lc-rc*pgeom(y[,1],1/(1+m))),
	normal=function(m,p){
		s <- exp(sh1(p)/2)
		cc*dnorm(y[,1],m,s,TRUE)+log(lc-rc*pnorm(y[,1],m,s))},
	"inverse Gauss"=function(m,p){
		s <- exp(sh1(p))
		v <- sqrt(s*y[,1]/2)
		-cc*(log(s)+(y[,1]-m)^2/(y[,1]*s*m^2)+log(2*pi*y[,1]^3))/2+
			log(lc-rc*(pnorm((y[,1]/m-1)/v)+
			exp(2/(m*s))*pnorm(-(y[,1]/m+1)/v)))},
	logistic=function(m,p){
		s <- exp(sh1(p))
		cc*dlogis(y[,1],m,s*sqrt(3)/pi,TRUE)+
			log(lc-rc*plogis(y[,1],m,s*sqrt(3)/pi))},
	Cauchy=function(m,p){
		s <- exp(sh1(p)/2)
		cc*dcauchy(y[,1],m,s,TRUE)+log(lc-rc*pcauchy(y[,1],m,s))},
	Laplace=function(m,p){
		v <- sh1(p)
		s <- exp(v)
		u <- abs(y[,1]-m)/s
		t <- exp(-u)/2
		-cc*(u+v+log(2))+log(lc-rc*(ifelse(u<0,t,1-t)))},
	Pareto=function(m,p){
		s <- exp(sh1(p))
		t <- 1/(m*(s-1))
		cc*(log(s*t)-(s+1)*log(1+y[,1]*t))+
			log(lc-rc*((1+y[,1]/(m*(s-1)))^(-s)))},
	exponential=function(m,p)
		cc*dexp(y[,1],1/m,TRUE)+log(lc-rc*pexp(y[,1],1/m)),
	gamma=function(m,p){
		s <- exp(sh1(p))
		t <- m/s
		cc*dgamma(y[,1],s,scale=t,log=TRUE)+
			log(lc-rc*pgamma(y[,1],s,scale=t))},
	Weibull=function(m,p){
		s <- exp(sh1(p))
		cc*dweibull(y[,1],s,m,TRUE)+log(lc-rc*pweibull(y[,1],s,m))},
	"extreme value"=function(m,p){
		s <- exp(sh1(p))
		yy <- exp(y[,1])
		cc*(y[,1]+dweibull(yy,s,m,TRUE))+log(lc-rc*pweibull(yy,s,m))})
#
# set up mixing distribution
#
mix <- switch(mixture,
        normal=function(r,ss)dnorm(r,0,sqrt(ss),log=TRUE),
	logistic=function(r,ss)dlogis(r,0,sqrt(3*ss)/pi,log=TRUE),
	Cauchy=function(r,ss){
#		s <- ??
		dcauchy(r,0,s,log=TRUE)},
        Laplace=function(r,ss){
#		s <- ??
		-abs(r)/s-log(s)-log(2)},
	gamma=function(r,ss)dgamma(r,1/ss,scale=ss,log=TRUE),
        "inverse gamma"=function(r,ss)dgamma(1/r,1/ss,scale=ss,log=TRUE)/r^2,
        "inverse Gauss"=function(r,ss)
		-(log(ss)+(r-1)^2/(r*ss)+log(2*pi*r^3))/2,
	Weibull=function(r,ss){
		fn <- function(z)gamma(1+2/z)-gamma(1+1/z)^2-ss
		s <- uniroot(fn,c(0.02,20))$root
		dweibull(r,s,1,log=TRUE)},
	beta=function(r,ss){
#		ss <- 0.25*ss/(1+ss) # variance <= 0.25
#		s  <- 0.125/ss-0.5
		s <- 0.5/ss
		dbeta(r,s,s,log=TRUE)})
#
# combine to create the appropriate likelihood function
#
like <- if(mean0==0)function(p){
		r <- c(p[np1+unest],-sum(p[np1+unest]))
		ss <- if(!fixed)sum(r^2)/nnest else pmix
		m <- mu1(p,r[nest])
		var0 <- if(censor)sum((y[,1]-m)^2)/n
			else if(bindata)sum((y[,1]-m*nn)^2)/n
			else sum((y-m)^2)/n
		-sum(fcn(m,p))-sum(mix(r,var0+ss))}
	else if(mean0==1) function(p){
		r <- exp(p[np1+unest])
		r <- c(r,nnest-sum(r))
		ss <- if(!fixed)sum((r-1)^2)/nnest else pmix
		m <- mu1(p,r[nest])
		var0 <- if(censor)sum((y[,1]-m)^2)/n
			else if(bindata)sum((y[,1]-m*nn)^2)/n
			else sum((y-m)^2)/n
		-sum(fcn(m,p))-sum(mix(r,var0+ss))}
	else function(p){
		r <- 1/(1+exp(-p[np1+unest]))
		r <- c(r,0.5*nnest-sum(r))
		ss <- if(!fixed)sum((r-0.5)^2)/nnest else pmix
		m <- mu1(p,r[nest])
		var0 <- if(censor)sum((y[,1]-m)^2)/n
			else if(bindata)sum((y[,1]-m*nn)^2)/n
			else sum((y-m)^2)/n
		-sum(fcn(m,p))-sum(mix(r,var0+ss))}
tlike <- function(p){
	if(mean0==0)r <- c(p[np1+unest],-sum(p[np1+unest]))
	else if(mean0==1){
		r <- exp(p[np1+unest])
		r <- c(r,nnest-sum(r))}
	else if(mean0==2){
		r <- 1/(1+exp(-p[np1+unest]))
		r <- c(r,0.5*nnest-sum(r))}
	m <- mu1(p,r[nest])
	-sum(fcn(m,p)+cc*log(delta))}
#
# check that the likelihood returns an appropriate value and optimize
#
tmp <- like(p)
if(is.na(tmp)||abs(tmp)==Inf)
	stop("Likelihood returns Inf or NA: invalid initial values, wrong model, or probabilities too small to calculate")
if(fscale==1)fscale <- tmp
z0 <- nlm(like,p=p,hessian=TRUE,print.level=print.level,typsiz=typsiz,
	ndigit=ndigit,gradtol=gradtol,stepmax=stepmax,steptol=steptol,
	iterlim=iterlim,fscale=fscale)
z0$minimum <- z0$minimum-sum(log(delta))
#
# calculate se's
#
if(np==0)cov <- NULL
else if(np==1)cov <- 1/z0$hessian
else {
	a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
		else qr(z0$hessian)$rank
	if(a==np)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=np,nrow=np)}
se <- sqrt(diag(cov))
maxlike <- sum(tlike(z0$estimate))
#
# calculate random effects, variances, fitted values, and
# mixing shape parameter
#
if(mean0==0){
	r <- c(z0$estimate[np1+unest],-sum(z0$estimate[np1+unest]))
	var <- sum(r^2)/nnest}
else if(mean0==1){
	r <- exp(z0$estimate[np1+unest])
	r <- c(r,nnest-sum(r))
	if(mean0==1)var <- sum((r-1)^2)/nnest}
else if(mean0==2){
	r <- 1/(1+exp(-z0$estimate[np1+unest]))
	r <- c(r,0.5*nnest-sum(r))
	var <- sum((r-0.5)^2)/nnest}
pred <- mu1(z0$estimate,if(mean0==0)0 else if(mean0==1)1 else 0.5)
if(bindata)pred <- nn*pred
rpred <- mu1(z0$estimate,r[nest])
if(bindata)rpred <- nn*rpred
var0 <- if(censor||bindata)sum((y[,1]-rpred)^2)/n else sum((y-rpred)^2)/n
if(!fixed)pmix <- switch(mixture,
	normal=var,
	logistic=sqrt(3*var)/pi,
	gamma=1/var,
	"inverse gamma"=1/var,
	"inverse Gauss"=var,
	Weibull={
		fn <- function(z)gamma(1+2/z)-gamma(1+1/z)^2-var
		uniroot(fn,c(0.02,20))$root},
	beta=0.125/var-0.5)
#
# return appropriate attributes on functions
#
if(!is.null(mu2))mu1 <- mu2
if(!is.null(sh2))sh1 <- sh2
if(!is.null(lin1a))lin1 <- lin1a
if(!is.null(lin2a))lin2 <- lin2a
z1 <- list(
	call=call,
	response=envir,
	delta=delta,
	distribution=distribution,
	mixture=mixture,
	mixvar=c(var0,var),
	mu=mu1,
	shape=sh1,
	linear=list(lin1,lin2),
	common=common,
	maxlike=maxlike,
	penalty=z0$minimum-maxlike,
	pred=pred,
	rpred=rpred,
	aic=maxlike+np-1,
	df=n-np+1,
	coefficients=z0$estimate,
	npl=npl,
	npr=nnest-1,
	nps=nps,
	pmix=pmix,
	fixed=fixed,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- c("hnlm","recursive")
return(z1)}

### standard methods
###

deviance.hnlm <- function(z) 2*z$maxlike

fitted.hnlm <- function(z, recursive=TRUE) if(recursive) z$rpred else z$pred

residuals.hnlm <- function(z, recursive=TRUE)
	if(recursive) z$response$y-z$rpred else z$response$y-z$pred

### print method
###
print.hnlm <- function(z, correlation=TRUE) {
sht <- z$nps>0||!is.null(z$shape)
npl <- z$npl
np1 <- z$npl+1
np1a <- z$npl+1
np2 <- z$npl+z$nps
np3 <- np2
np4 <- np3+1
np <- z$npl+z$nps+z$npr
mean0 <- if(z$mixture=="normal"||z$mixture=="logistic"||z$mixture=="Cauchy"||
	 z$mixture=="Laplace")0 else if(z$mixture=="beta")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")
if(!is.null(z$dist))cat(z$dist,"distribution\n\n")
cat(z$mixture,"mixing distribution\n\n")
if(z$npl>0||!is.null(z$mu)){
	cat("Location function:\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")}
	if(!is.null(z$linear[[1]])){
		cat("Linear part:\n")
		print(z$linear[[1]])}}
if(sht){
	cat("\nLog shape function:\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")}
	if(!is.null(z$linear[[2]])){
		cat("Linear part:\n")
		print(z$linear[[2]])}
	if(!is.null(z$family)){
		cat("\n(Log) family function:\n")
		if(!is.null(attr(z$family,"formula")))
			cat(deparse(attr(z$family,"formula")),sep="\n")
		else if(!is.null(attr(z$family,"model"))){
			t <- deparse(attr(z$family,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		if(!is.null(z$linear[[3]])){
			cat("Linear part:\n")
			print(z$linear[[3]])}}}
cat("\n-Log likelihood   ",z$maxlike,"\n")
cat("Penalty           ",z$penalty,"\n")
cat("Degrees of freedom",z$df,"\n")
cat("AIC               ",z$aic,"\n")
cat("Iterations        ",z$iterations,"\n\n")
if(npl>0){
	if(z$common)cat("Common parameters:\n")
	else cat("Location parameters:\n")
	cname <- if(is.character(attr(z$mu,"model")))attr(z$mu,"model")
		else if(length(grep("linear",attr(z$mu,"parameters")))>0)
		attr(z$mu,"parameters")[grep("\\[",attr(z$mu,"parameters"))]
		else attr(z$mu,"parameters")
	if(!is.null(z$linmodel[[1]]))cname <- c(cname,z$linmodel[[1]])
	coef.table <- cbind(z$coefficients[1:npl],z$se[1:npl])
	if(!z$common){
		dimnames(coef.table) <- list(cname, c("estimate", "se"))
		print.default(coef.table,digits=4,print.gap=2)
		cname <- coef.table <- NULL}}
if(z$common||z$nps>0){
	if(!is.null(z$shape))cname <- c(cname,
			if(is.character(attr(z$shape,"model")))
			attr(z$shape,"model")
		else if(length(grep("linear",attr(z$shape,"parameters")))>0||
			length(grep("mu",attr(z$shape,"parameters")))>0)
			attr(z$shape,"parameters")[grep("\\[",attr(z$shape,"parameters"))]
		else attr(z$shape,"parameters"))
	if(!is.null(z$linmodel[[2]]))cname <- c(cname,z$linmodel[[2]])
	if(!z$common)coef.table <- cbind(z$coefficients[np1a:np2],
		z$se[np1a:np2])
	if(z$common&&is.null(z$family)){
		dimnames(coef.table) <- list(unique(cname),c("estimate","se"))
		print.default(coef.table,digits=4,print.gap=2)}
	if(is.null(z$shape)&&z$nps==1){
		coef.table <- cbind(z$coefficients[np2],z$se[np2])
		cname <- " "}}
if(z$nps>0&&!z$common){
	cat("\nShape parameters:\n")
	dimnames(coef.table) <- list(cname,c("estimate","se"))
	print.default(coef.table,digits=4,print.gap=2)
	cname <- coef.table <- NULL}
if(!is.null(z$family)){
	if(!z$common)cat("\nFamily parameters:\n")
	cname <- c(cname,if(is.character(attr(z$family,"model")))
		attr(z$family,"model")
		else if(length(grep("linear",attr(z$family,"parameters")))>0)
		attr(z$family,"parameters")[grep("\\[",attr(z$family,"parameters"))]
		else attr(z$family,"parameters"))
	if(!is.null(z$linmodel[[3]]))cname <- c(cname,z$linmodel[[3]])
	if(z$common){
		dimnames(coef.table) <- list(unique(cname),c("estimate","se"))
		print.default(coef.table,digits=4,print.gap=2)}
	else {
		coef.table <- cbind(z$coefficients[np3:np],z$se[np3:np])
		dimnames(coef.table) <- list(cname,c("estimate","se"))
		print.default(coef.table,digits=4,print.gap=2)}}
if(z$fixed)
	cat("\nFixed mixing shape parameter:",z$pmix,"\n")
else
	cat("\nMixing shape parameter:",z$pmix,"\n")
cat("\nVariances: conditional = ",z$mixvar[1],", mixing = ",z$mixvar[2],"\n",
	sep="")
cat("\nRandom effect parameters:\n")
r <- c(z$coefficients[np4:np],-sum(z$coefficients[np4:np]))
if(mean0==1){
	rr <- exp(z$coefficients[np4:np])
	rr <- c(rr,z$npr+1-sum(rr))
	r[z$npr+1] <- log(rr[z$npr+1])}
else if(mean0==2){
	rr <- 1/(1+exp(-z$coefficients[np4:np]))
	rr <- c(rr,0.5*z$npr+0.5-sum(rr))
	r[z$npr+1] <- log(rr[z$npr+1]/(1-rr[z$npr+1]))}
coef.table <- cbind(r,c(z$se[np4:np],NA))
if(mean0)coef.table <- cbind(coef.table,rr)
dimnames(coef.table) <- list(1:(z$npr+1),
	c(if(mean0)"estimate"else"effect","se",if(mean0)"effect"))
print.default(coef.table,digits=4,print.gap=2)
if(correlation){
	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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     kalcount(response=NULL, times=NULL, origin=0, intensity="exponential",
#	depend="independence", update="Markov", mu=NULL, shape=NULL,
#	density=FALSE, ccov=NULL, tvcov=NULL, preg=NULL, ptvc=NULL,
#	pbirth=NULL, pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL,
#	pfamily=NULL, envir=parent.frame(), 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=NULL, times=NULL, origin=0,
	intensity="exponential", depend="independence", update="Markov",
	mu=NULL, shape=NULL, density=FALSE, ccov=NULL, tvcov=NULL, preg=NULL,
	ptvc=NULL, pbirth=NULL, pintercept=NULL, pshape=NULL, pinitial=1,
	pdepend=NULL, pfamily=NULL, envir=parent.frame(), print.level=0,
	ndigit=10, gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
	typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
#
# Pareto (beta) likelihood function for serial dependence
#
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(nobs),
		nbs=as.integer(n),
		nccov=as.integer(nccov),
		model=as.integer(mdl),
		density=as.integer(density),
		pfamily=as.integer(!is.null(pfamily)),
		dep=as.integer(dep),
		birth=as.integer(birth),
		tvc=as.integer(tvc),
		tvcov=as.double(resp$tvcov$tvcov),
		fit=as.integer(0),
		pred=double(n),
		rpred=double(n),
		rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$like}
#
# Pareto (beta) likelihood function for frailty
#
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(nobs),
		nbs=as.integer(n),
		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(n),
		rpred=double(n),
		rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		frser=as.integer(frser),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$like}
call <- sys.call()
#
# check model
#
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)
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1)
		stop("kalcount only handles univariate responses")
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("kalcount does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)deparse(substitute(response))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
# if envir, remove extra (multivariate) responses
#
if(!respenv&&inherits(envir,"repeated")){
	if(!is.null(envir$NAs)&&any(envir$NAs))
		stop("kalcount does not handle data with NAs")
	cn <- deparse(substitute(response))
	if(length(grep("\"",cn))>0)cn <- response
	if(length(cn)>1)stop("only one response variable allowed")
	response <- envir
	col <- match(cn,colnames(response$response$y))
	if(is.na(col))stop(paste("response variable",cn,"not found"))
	type <- response$response$type[col]
	if(dim(response$response$y)[2]>1){
		response$response$y <- response$response$y[,col,drop=FALSE]}}
#
# find the covariates
#
if(respenv||inherits(envir,"repeated")){
	if(rf)resp <- rmna(response$response)
	else {
		resp <- response
		# time-constant covariates
		if(is.null(ccov))resp$ccov <- NULL
		else if(inherits(ccov,"formula")){
			if(any(is.na(match(rownames(attr(terms(ccov,data=response),"factors")),colnames(response$ccov$ccov)))))
				stop("ccov covariate(s) not found")
			tmp <- wr(ccov,data=response,expand=FALSE)$design
			resp$ccov$ccov <- tmp[,-1,drop=FALSE]
			rm(tmp)}
		else stop("ccov must be a W&R formula")
		# time-varying covariates
		if(is.null(tvcov))resp$tvcov <- NULL
		else if(inherits(tvcov,"formula")){
			if(any(is.na(match(rownames(attr(terms(tvcov,data=response),"factors")),colnames(response$tvcov$tvcov)))))
				stop("tvcov covariate(s) not found")
			tmp <- wr(tvcov,data=response)$design
			resp$tvcov$tvcov <- tmp[,-1,drop=FALSE]
			rm(tmp)}
		else stop("tvcov must be a W&R formula")}
	nccov <- if(rf||is.null(resp$ccov$ccov)) 0
		 else  dim(resp$ccov$ccov)[2]
	ttvc <- if(rf||is.null(resp$tvcov$tvcov)) 0
		 else  dim(resp$tvcov$tvcov)[2]}
else {
	# make response object
	if(inherits(response,"response")){
		resp <- response
		type <- response$type}
	else resp <- restovec(response,times)
	# time-constant covariates
	if(is.null(ccov))nccov <- 0
	else {
		if(!inherits(ccov,"tccov")){
			ccname <- deparse(substitute(ccov))
			if((is.matrix(ccov)&&is.null(colnames(ccov)))){
				ccname <- deparse(substitute(ccov))
				if(dim(ccov)[2]>1){
					tmp <- NULL
					for(i in 1:dim(ccov)[2])tmp <- c(tmp,paste(ccname,i,sep=""))
					ccname <- tmp}}
			ccov <- tcctomat(ccov,names=ccname)}
		nccov <- if(rf) 0 else dim(ccov$ccov)[2]}
	# time-varying covariates
	if(is.null(tvcov))ttvc <- 0
	else {
		if(!inherits(tvcov,"tvcov")){
			tvcname <- deparse(substitute(tvcov))
			if(is.list(tvcov)&&dim(tvcov[[1]])[2]>1){
				if(is.null(colnames(tvcov[[1]]))){
					tvcname <- deparse(substitute(tvcov))
					tmp <- NULL
					for(i in 1:dim(tvcov[[1]])[2])tmp <- c(tmp,paste(tvcname,i,sep=""))
					tvcname <- tmp}
				else tvcname <- colnames(tvcov[[1]])}
			tvcov <- tvctomat(tvcov, names=tvcname)}
		ttvc <- if(rf) 0 else dim(tvcov$tvcov)[2]}
	resp <- rmna(response=resp, tvcov=tvcov, ccov=ccov)
	if(!is.null(ccov))rm(ccov)
	if(!is.null(tvcov))rm(tvcov)}
n <- dim(resp$response$y)[1]
nobs <- nobs(resp)
nind <- length(nobs)
if((inherits(envir,"repeated")&&(length(nobs)!=length(nobs(envir))||
	any(nobs!=nobs(envir))))||(inherits(envir,"tvcov")&&
	(length(nobs)!=length(envir$tvcov$nobs)||any(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.")
if(!is.null(resp$response$nest)&&depend=="serial")
	stop("kalcount does not handle two levels of nesting with serial dependence")
if(type!="unknown"&&type!="discrete")stop("discrete data required")
#
# if a data object was supplied, modify formulae or functions to read from it
#
mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,.envir=response,.name=envname)
			else finterp(mu,.envir=envir,.name=envname)}
	else if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
		        tmp <- parse(text=deparse(mu)[-1])
		        mu <- if(respenv)fnenvir(mu,.envir=response,.name=envname)
		        	else fnenvir(mu,.envir=envir,.name=envname)
		        mu3 <- mu
		        attr(mu3,"model") <- tmp}
		else mu3 <- mu}
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,.envir=response,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	else if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=response,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh3 <- shape
		        attr(sh3,"model") <- tmp}
		else sh3 <- shape}}
#
# transform location formula to function and check number of parameters
#
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.character(attr(mu2,"model"))){
	# W&R formula
		if(length(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 {
	# formula with unknowns
		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.character(attr(mu2,"model"))){
			mu1 <- mu2
			rm(mu2)}}}
else if(is.function(mu))mu1 <- mu
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# check that correct number of estimates was supplied
#
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"))}
#
# transform shape formula to function and check number of parameters
#
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"))
	# W&R formula
	if(is.character(attr(sh2,"model"))){
		if(length(attr(sh2,"model"))==1){
			sh1 <- function(p) p[npl1]*rep(1,n)
			attributes(sh1) <- attributes(sh2)
			sh2 <- NULL}}
	else {
	# formula with unknowns
		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
#
# give appropriate attributes to sh1 for printing
#
if(!is.null(sh1)&&is.null(attr(sh1,"parameters")))
	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))}
#
# check that correct number of estimates was supplied
#
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"))
#
# check that appropriate functions supplied
#
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&&(ttvc>0&&tvc!=ttvc||ttvc==0&&tvc>0))
	stop(paste(ttvc,"initial estimates of coefficients for time-varying covariates must be supplied"))
if(rf&&birth)stop("Birth models cannot be fitted with a mean function")
if(intensity=="exponential"){
	sf <- FALSE
	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)
#
# check what dependence is required
#
frser <- FALSE
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"){
	frser <- !is.null(pdepend)
	if(frser){
		if(pdepend<=0)stop("Dependence parameter must be positive")
		pdepend <- log(pdepend)}
	if(update=="time")dep <- 1
	else {
		dep <- 0
		update <- "no"}}
#
# check number of parameter estimates
#
if(!is.null(pfamily)&&depend=="frailty")
		stop("pfamily cannot be used with frailty dependence")
if(rf&&npreg>0)nccov <- npreg-1
if(!rf&&1+nccov!=npreg)
	stop(paste(1+nccov,"regression estimates must be supplied"))
#
# set up for location function and make sure it gives correct number
# of values
#
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))!=n)
			stop("The mu function or formula must provide an estimate for each observation")
		tvc <- tvc-1}
	else {
		lp <- length(mu1(preg))
		if(lp==1){
			if(nccov==0)mu1 <- function(p) rep(p[1],nind)
			else stop("Number of estimates does not correspond to mu function")}
		else if(lp!=nind)
		     stop("The mu function or formula must provide an estimate for each individual")}}
if(sf&&length(sh1(pshape))!=n)
	stop("The shape function must provide an estimate for each observation")
#
# check that the likelihood function gives appropriate values and call nlm
#
np <- 1+nccov+tvc+1+(depend=="serial")+birth+nps+(!is.null(pintercept))+frser+
	(!is.null(pfamily))
nps1 <- np-nps+1
p <- c(preg,pbirth,ptvc,pinitial,pdepend,pfamily,pintercept,pshape)
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=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
	else qr(z0$hessian)$rank
if(a==np)cov <- solve(z0$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
#
# calculate se's
#
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
#
# calculate recursive fitted values
#
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(nobs),
        	nbs=as.integer(n),
        	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(n),
		rpred=double(n),
        	rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		frser=as.integer(frser),
        	like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")}
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(nobs),
        	nbs=as.integer(n),
        	nccov=as.integer(nccov),
        	model=as.integer(mdl),
        	density=as.integer(density),
		pfamily=as.integer(!is.null(pfamily)),
        	dep=as.integer(dep),
        	birth=as.integer(birth),
        	tvc=as.integer(tvc),
        	tvcov=resp$tvcov$tvcov,
        	fit=as.integer(1),
        	pred=double(n),
		rpred=double(n),
		rf=as.integer(rf),
		bb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")}
#
# return appropriate attributes on functions
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
z <- list(
	call=call,
	intensity=intensity,
	pfamily=!is.null(pfamily),
	mdl=mdl,
	frser=frser,
	mu=mu1,
	npr=1+nccov+tvc+birth,
	shape=sh1,
	nps=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=n-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)}

### standard methods
###

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 method
###
print.kalcount <- function(z,digits=max(3,.Options$digits-3),correlation=TRUE){
if(!is.null(z$ccov))nccov <- dim(z$ccov$ccov)[2]
else nccov <- 0
expm <- z$intensity!="exponential"&&!is.function(z$shape)
glm <- z$intensity=="gen logistic"
npt <- if(is.function(z$shape)) z$npt-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(nobs(z)),"\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",if(!z$frser)"and",z$update,
		"weight",if(z$frser)"and AR","\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.character(attr(z$mu,"model")))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[(npt-deppar-z$frser-z$pfamily-glm-expm):npt])
cname <- "initial"
if(deppar){
	coef[2] <- coef[2]/(1+coef[2])
	cname <- c(cname,"depend")}
if(z$frser)cname <- c(cname,"AR")
if(z$pfamily){
	cname <- c(cname,"family")
	coef[length(coef)-glm-expm] <- z$coef[npt-glm-expm]}
if(glm){
	cname <- c(cname,"intercept")
	coef[length(coef)-expm] <- z$coef[npt-expm]
	if(expm){
		cname <- c(cname,"asymptote")
		coef[length(coef)] <- 1/coef[length(coef)]}}
else if(expm)cname <- c(cname,"shape")
coef.table <- cbind(z$coef[(npt-deppar-z$frser-z$pfamily-glm-expm):npt],
	z$se[(npt-deppar-z$frser-z$pfamily-glm-expm):npt],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$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.character(attr(z$shape,"model")))
		attr(z$shape,"model")
		else attr(z$shape,"parameters")
	coef.table <- cbind(z$coef[(z$npt-z$nps+1):z$npt],
		z$se[(z$npt-z$nps+1):z$npt])
	dimnames(coef.table) <- list(cname, c("estimate","se"))
	print.default(coef.table, digits=digits, print.gap=2)}
if(correlation){
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     kalseries(response=NULL, times=NULL, intensity="exponential",
#	depend="independence", mu=NULL, shape=NULL, density=FALSE, ccov=NULL,
#	tvcov=NULL, torder=0, interaction=NULL, preg=NULL, ptvc=NULL,
#	pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL,
#	pfamily=NULL, delta=NULL, transform="identity", link="identity",
#	envir=parent.frame(), 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)
require(rmutil)

kalseries <- function(response=NULL, times=NULL, intensity="exponential",
	depend="independence", mu=NULL, shape=NULL, density=FALSE, ccov=NULL,
	tvcov=NULL, torder=0, interaction=NULL, preg=NULL, ptvc=NULL,
	pintercept=NULL, pshape=NULL, pinitial=1, pdepend=NULL,
	pfamily=NULL, delta=NULL, transform="identity", link="identity",
	envir=parent.frame(), print.level=0, ndigit=10, gradtol=0.00001,
	steptol=0.00001, fscale=1, iterlim=100, typsiz=abs(p),
	stepmax=10*sqrt(p%*%p)){
#
# Pareto (beta) likelihood function for serial dependence
#
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(nobs),
		nbs=as.integer(n),
		nccov=as.integer(nccov),
		npv=as.integer(npv),
		model=as.integer(mdl),
		link=as.integer(lnk),
		density=as.integer(density),
		pfamily=as.integer(!is.null(pfamily)),
		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(n),
		rpred=double(n),
		rf=as.integer(rf),
		bbb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$like}
#
# Pareto (beta) likelihood function for frailty
#
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(nobs),
		nbs=as.integer(n),
		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(n),
		rpred=double(n),
		rf=as.integer(rf),
		bbb=as.double(b),
		sf=as.integer(sf),
		vv=as.double(v),
		frser=as.integer(frser),
		like=double(1),
		DUP=FALSE,
		PACKAGE="repeated")
	z$like}
call <- sys.call()
#
# check model
#
tmp <- c("exponential","Weibull","gamma","gen logistic","normal",
	"logistic","Cauchy","Laplace","log normal","log logistic",
	"log Cauchy","log Laplace","inverse Gauss")
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)
#
# check if a data object is being supplied
#
type <- "unknown"
respenv <- exists(deparse(substitute(response)),envir=parent.frame())&&
	inherits(response,"repeated")&&!inherits(envir,"repeated")
if(respenv){
	if(dim(response$response$y)[2]>1)
		stop("kalseries only handles univariate responses")
	if(!is.null(response$NAs)&&any(response$NAs))
		stop("kalseries does not handle data with NAs")
	type <- response$response$type}
envname <- if(respenv)deparse(substitute(response))
	else if(!is.null(class(envir)))deparse(substitute(envir))
	else NULL
#
# if envir, remove extra (multivariate) responses
#
if(!respenv&&inherits(envir,"repeated")){
	if(!is.null(envir$NAs)&&any(envir$NAs))
		stop("kalseries does not handle data with NAs")
	cn <- deparse(substitute(response))
	if(length(grep("\"",cn))>0)cn <- response
	if(length(cn)>1)stop("only one response variable allowed")
	response <- envir
	col <- match(cn,colnames(response$response$y))
	if(is.na(col))stop(paste("response variable",cn,"not found"))
	type <- response$response$type[col]
	if(dim(response$response$y)[2]>1){
		response$response$y <- response$response$y[,col,drop=FALSE]
		if(!is.null(response$response$delta)){
			response$response$delta <- response$response$delta[,col,drop=FALSE]
			if(all(response$response$delta==1)||all(is.na(response$response$delta)))response$response$delta <- NULL}}}
#
# find the covariates
#
if(respenv||inherits(envir,"repeated")){
	if(rf)resp <- rmna(response$response)
	else {
		resp <- response
		# time-constant covariates
		if(is.null(ccov))resp$ccov <- NULL
		else if(inherits(ccov,"formula")){
			if(any(is.na(match(rownames(attr(terms(ccov,data=response),"factors")),colnames(response$ccov$ccov)))))
				stop("ccov covariate(s) not found")
			tmp <- wr(ccov,data=response,expand=FALSE)$design
			resp$ccov$ccov <- tmp[,-1,drop=FALSE]
			rm(tmp)}
		else stop("ccov must be a W&R formula")
		# time-varying covariates
		if(is.null(tvcov))resp$tvcov <- NULL
		else if(inherits(tvcov,"formula")){
			if(any(is.na(match(rownames(attr(terms(tvcov,data=response),"factors")),colnames(response$tvcov$tvcov)))))
				stop("tvcov covariate(s) not found")
			tmp <- wr(tvcov,data=response)$design
			resp$tvcov$tvcov <- tmp[,-1,drop=FALSE]
			rm(tmp)}
		else stop("tvcov must be a W&R formula")}
	nccov <- if(rf||is.null(resp$ccov$ccov)) 0
		 else  dim(resp$ccov$ccov)[2]
	ttvc <- if(rf||is.null(resp$tvcov$tvcov)) 0
		 else  dim(resp$tvcov$tvcov)[2]}
else {
	# make response object
	if(inherits(response,"response")){
		resp <- response
		type <- response$type}
	else resp <- restovec(response,times,delta=delta)
	# time-constant covariates
	if(is.null(ccov))nccov <- 0
	else {
		if(!inherits(ccov,"tccov")){
			ccname <- deparse(substitute(ccov))
			if((is.matrix(ccov)&&is.null(colnames(ccov)))){
				ccname <- deparse(substitute(ccov))
				if(dim(ccov)[2]>1){
					tmp <- NULL
					for(i in 1:dim(ccov)[2])
						tmp <- c(tmp,paste(ccname,i,sep=""))
					ccname <- tmp}}
			ccov <- tcctomat(ccov,names=ccname)}
		nccov <- if(rf) 0 else dim(ccov$ccov)[2]}
	# time-varying covariates
	if(is.null(tvcov))ttvc <- 0
	else {
		if(!inherits(tvcov,"tvcov")){
			tvcname <- deparse(substitute(tvcov))
			if(is.list(tvcov)&&dim(tvcov[[1]])[2]>1){
				if(is.null(colnames(tvcov[[1]]))){
					tvcname <- deparse(substitute(tvcov))
					tmp <- NULL
					for(i in 1:dim(tvcov[[1]])[2])
						tmp <- c(tmp,paste(tvcname,i,sep=""))
					tvcname <- tmp}
				else tvcname <- colnames(tvcov[[1]])}
			tvcov <- tvctomat(tvcov,names=tvcname)}
		ttvc <- if(rf) 0 else dim(tvcov$tvcov)[2]}
	resp <- rmna(response=resp, tvcov=tvcov, ccov=ccov)
	if(!is.null(ccov))rm(ccov)
	if(!is.null(tvcov))rm(tvcov)}
n <- dim(resp$response$y)[1]
nobs <- nobs(resp)
nind <- length(nobs)
if((inherits(envir,"repeated")&&(length(nobs)!=length(nobs(envir))||
	any(nobs!=nobs(envir))))||(inherits(envir,"tvcov")&&
	(length(nobs)!=length(envir$tvcov$nobs)||any(nobs!=envir$tvcov$nobs))))
	stop("response and envir objects are incompatible")
if((intensity=="exponential"||intensity=="Weibull"||intensity=="gamma"
	||intensity=="log normal"||intensity=="log logistic"
	||intensity=="log Cauchy"||intensity=="log Laplace"
	||intensity=="inverse Gauss")&&type!="unknown"&&type!="duration"
	&&type!="continuous")stop("duration data required")
if((intensity=="gen logistic"||intensity=="normal"||intensity=="logistic"
	||intensity=="Cauchy"||intensity=="Laplace")&&type!="unknown"
	&&type!="continuous"&&type!="duration")stop("continuous data required")
if(!is.null(resp$response$censor))stop("kalseries does not handle censoring")
#
# if a data object was supplied, modify formulae or functions to read from it
#
mu3 <- sh3 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")||inherits(envir,"tvcov")){
	if(is.null(envname))envname <- deparse(substitute(envir))
	if(inherits(mu,"formula")){
		mu3 <- if(respenv)finterp(mu,.envir=response,.name=envname)
			else finterp(mu,.envir=envir,.name=envname)}
	else if(is.function(mu)){
		if(is.null(attr(mu,"model"))){
		        tmp <- parse(text=deparse(mu)[-1])
		        mu <- if(respenv)fnenvir(mu,.envir=response,.name=envname)
		        	else fnenvir(mu,.envir=envir,.name=envname)
		        mu3 <- mu
		        attr(mu3,"model") <- tmp}
		else mu3 <- mu}
	if(inherits(shape,"formula")){
		sh3 <- if(respenv)finterp(shape,.envir=response,.name=envname)
			else finterp(shape,.envir=envir,.name=envname)}
	else if(is.function(shape)){
		if(is.null(attr(shape,"model"))){
		        tmp <- parse(text=deparse(shape)[-1])
		        shape <- if(respenv)fnenvir(shape,.envir=response,.name=envname)
		        	else fnenvir(shape,.envir=envir,.name=envname)
		        sh3 <- shape
		        attr(sh3,"model") <- tmp}
		else sh3 <- shape}}
#
# transform location formula to function and check number of parameters
#
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.character(attr(mu2,"model"))){
	# W&R formula
		if(length(attr(mu2,"model"))==1){
			mu1 <- function(p) p[1]*rep(1,n)
			attributes(mu1) <- attributes(mu2)
			mu2 <- NULL}}
	else {
	# formula with unknowns
		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
#
# give appropriate attributes to mu1 for printing
#
if(!is.null(mu1)&&is.null(attr(mu1,"parameters"))){
	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))}}
#
# check that correct number of estimates was supplied
#
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"))}
#
# transform shape formula to function and check number of parameters
#
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"))
	# W&R formula
	if(is.character(attr(sh2,"model"))){
		if(length(attr(sh2,"model"))==1){
			sh1 <- function(p) p[npl1]*rep(1,n)
			attributes(sh1) <- attributes(sh2)
			sh2 <- NULL}}
	else {
	# formula with unknowns
		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
#
# give appropriate attributes to sh1 for printing
#
if(!is.null(sh1)&&is.null(attr(sh1,"parameters")))
	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))}
#
# check that correct number of estimates was supplied
#
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"))
#
# check that appropriate functions supplied
#
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(!rf&&(ttvc>0&&tvc!=ttvc||ttvc==0&&tvc>0))
	stop(paste(ttvc,"initial estimates of coefficients for time-varying covariates must be supplied"))
if(intensity=="exponential"){
	sf <- FALSE
	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)
#
# check what dependence is required
#
frser <- FALSE
if(depend=="independence")pdepend <- NULL
else if(depend=="frailty"){
	frser <- !is.null(pdepend)
	if(frser){
		if(pdepend<=0)stop("Dependence parameter must be positive")
		pdepend <- log(pdepend)}}
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))}
#
# check times
#
if(is.null(resp$response$times)){
	if(depend=="serial"||depend=="Markov")
		stop("No times. Serial and Markov dependence cannot be fitted.")
	ave <- times <- 0}
else {
	if(torder>length(unique(resp$response$times)))
		stop("torder is too large for the number of distinct times")
	ave <- mean(resp$response$times)
	times <- resp$response$times-ave}
#
# check interactions with time
#
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)
#
# check number of parameter estimates
#
if(!is.null(pfamily)&&depend=="frailty")
		stop("pfamily cannot be used with frailty dependence")
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
#
# check Jacobian and transformations
if(!is.null(resp$response$delta))jacob <- if(length(resp$response$delta)==1)
		-n*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("Zero response values: invalid transformation")
	if(transform=="square"){
		jacob <- jacob-sum(log(abs(y)))-n*log(2)
		y  <- y^2}
	if(any(y<0))stop("Nonpositive response values: invalid transformation")
	if(transform=="sqrt"){
		jacob <- jacob+sum(log(y))/2+n*log(2)
		y <- sqrt(y)}
	else if(transform=="log"){
		jacob <- jacob+sum(log(y))
		y <- log(y)}}
#
# set up for location function and make sure it gives correct number
# of values
#
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))!=n)
			stop("The mu function or formula must provide an estimate for each observation")
		tvc <- tvc-1}
	else {
		lp <- length(mu1(preg))
		if(lp==1){
			if(nccov==0)mu1 <- function(p) rep(p[1],nind)
			else stop("Number of estimates does not correspond to mu function")}
		else if(lp!=nind)
			stop("The mu function or formula must provide an estimate for each individual")}}
if(sf&&length(sh1(pshape))!=n)
	stop("The shape function must provide an estimate for each observation")
#
# check that the likelihood function gives appropriate values and call nlm
#
np <- 1+nccov+npv+tvc+1+(depend=="serial"||depend=="Markov")+
	nps+(!is.null(pintercept))+frser+(!is.null(pfamily))
nps1 <- np-nps+1
p <- c(preg,ptvc,pinitial,pdepend,pfamily,pintercept,pshape)
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=TRUE, 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
#
# calculate se's
#
a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
	else 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)
#
# calculate recursive fitted values
#
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(nobs),
			nbs=as.integer(n),
			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(n),
			rpred=double(n),
			rf=as.integer(rf),
			bbb=as.double(b),
			sf=as.integer(sf),
			vv=as.double(v),
			frser=as.integer(frser),
			like=double(1),
			DUP=FALSE,
			PACKAGE="repeated")}
	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(nobs),
			nbs=as.integer(n),
			nccov=as.integer(nccov),
			npv=as.integer(npv),
			model=as.integer(mdl),
			link=as.integer(lnk),
			density=as.integer(density),
			pfamily=as.integer(!is.null(pfamily)),
			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(n),
			rpred=double(n),
			rf=as.integer(rf),
			bbb=as.double(b),
			sf=as.integer(sf),
			vv=as.double(v),
			like=double(1),
			DUP=FALSE,
			PACKAGE="repeated")}}
if(rf&&tvc>0){
	nccov <- tvc
	tvc <- 0}
#
# return appropriate attributes on functions
#
if(!is.null(mu3))mu1 <- mu3
if(!is.null(sh3))sh1 <- sh3
z <- list(
	call=call,
	intensity=intensity,
	pfamily=!is.null(pfamily),
	mdl=mdl,
	frser=frser,
	mu=mu1,
	npr=1+nccov+tvc+torder+sum(interaction),
	shape=sh1,
	nps=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=n-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)}

### standard methods
###

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)
res <- if(recursive)z$response$y-z$rpred else z$response$y-z$pred
class(res) <- "residuals"
res}

### print method
###
print.kalseries <- function(z,digits=max(3,.Options$digits-3),correlation=TRUE){
if(!is.null(z$ccov))nccov <- dim(z$ccov$ccov)[2]
else nccov <- 0
expm <- z$intensity!="exponential"&&!is.function(z$shape)
glm <- z$intensity=="gen logistic"
npt <- if(is.function(z$shape)) z$npt-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(nobs(z)),"\n")
cat("Number of observations",length(z$response$y),"\n")
if(!is.null(z$response$time))
	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",if(z$frser)"and AR","\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.character(attr(z$mu,"model")))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[(npt-deppar-z$frser-z$pfamily-glm-expm):npt])
cname <- "initial"
if(deppar){
	cname <- c(cname,"depend")
	coef[2] <- coef[2]/(1+coef[2])}
if(z$frser)cname <- c(cname,"AR")
if(z$pfamily){
	cname <- c(cname,"family")
	coef[length(coef)-glm-expm] <- z$coef[npt-glm-expm]}
if(glm){
	cname <- c(cname,"intercept")
	coef[length(coef)-expm] <- z$coef[npt-expm]
	if(expm){
		cname <- c(cname,"asymptote")
		coef[length(coef)] <- 1/coef[length(coef)]}}
else if(expm)cname <- c(cname,"shape")
coef.table <- cbind(z$coef[(npt-deppar-z$frser-z$pfamily-glm-expm):npt],
	z$se[(npt-deppar-z$frser-z$pfamily-glm-expm):npt],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[npt-deppar-expm-z$frser]))
	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.character(attr(z$shape,"model")))
			attr(z$shape,"model")
		else attr(z$shape,"parameters")
	coef.table <- cbind(z$coef[(z$npt-z$nps+1):z$npt],
		z$se[(z$npt-z$nps+1):z$npt])
	dimnames(coef.table) <- list(cname, c("estimate","se"))
	print.default(coef.table, digits=digits, print.gap=2)}
if(correlation){
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)}}
#
#  repeated : A Library of Repeated Measurements Models
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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=TRUE, random.out.slope=!is.null(tvcov),
#	random.drop.int=TRUE, 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=TRUE, random.out.slope=!is.null(tvcov),
	random.drop.int=TRUE, 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)
#
# find covariates in repeated measurements model
#
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,parent.frame(),na.action=na.fail))
		if(colnames(out.ccov)[1]=="(Intercept)")
			out.ccov <- out.ccov[,-1,drop=FALSE]}
	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)&&dim(out.ccov)[1]!=n1)
	stop("y and out.ccov must have the same number of observations")
#
# find covariates in dropout model
#
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,parent.frame(),na.action=na.fail)))
		if(colnames(drop.ccov)[1]=="(Intercept)")
			drop.ccov <- drop.ccov[,-1,drop=FALSE]}
	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)&&dim(drop.ccov)[1]!=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 <- FALSE
#
# check individual id
#
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")
id <- matrix(id,ncol=1)
rownames(id) <- 1:dim(id)[1]
y1 <- cbind(id,ifelse(y==0,2,1),rep(1,n1),drop.ccov)
#
# set up time-varying covariates
#
if(!random.out.int||!out.tvcov)random.out.slope <- FALSE
if(!random.drop.int||!out.tvcov)random.drop.slope <- FALSE
if(drop.tvcov)y1 <- cbind(y1,tvcov)
y2 <- cbind(cbind(id,y)[y>0,],rep(0,n2))
#
# set up time-constant covariates
#
n3d <- 0
if(!is.null(drop.ccov))n3d <- n3d+dim(drop.ccov)[2]
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+dim(out.ccov)[2]
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)
#
# set up for random intercepts and slopes
#
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))}
#
# set up variable names
#
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:dim(out.ccov)[2],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:dim(drop.ccov)[2],sep=""))}
if(drop.tvcov)dropname <- c(dropname,paste(deparse(substitute(tvcov))))
#
# prepare final data matrix and constants
#
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 <- dim(data)[1]
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
#
# call Fortran to optimize likelihood
#
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=FALSE)
#
# print warnings, if any
#
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"))
#
# prepare results to return
#
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 method
###
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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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()
#
# check input and initialize for iteration
#
n <- length(unique(marg1))
if(length(unique(marg2))!=n)stop("a square contingency table must be supplied")
fit <- res <- freq
dv <- 0
test <- TRUE
lev <- levels(marg1)
a <- matrix(0,ncol=n-1,nrow=length(freq))
#
# iterate, calling glm with least squares
#
while(test){
	pw <- ifelse(fit>0,1/fit,0)
	for(i in 1:(n-1))a[,i] <- ((marg1==lev[i])-(marg2==lev[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(ifelse(freq>0&fit>0,freq/fit,1))),
	df=n-1,
	aic=-sum(dpois(freq,fit,TRUE))+length(freq)-n+1,
	fitted=fit,
	residuals=(freq-fit)/sqrt(fit))
class(z) <- "marginal"
return(z)}

### print method
###
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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, 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 Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  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)){
#
# negative binomial likelihood function
#
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))}
#
# dynamic negative binomial likelihood function
#
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:nobs(response)[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}
#
# negative binomial likelihood function for recursive prediction
#
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:nobs(response)[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()
#
# set up response if not a data object
#
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)
#
# optimize using nlm
#
nind <- length(nobs(response))
p <- c(preg,pdepend)
np <- length(p)
np1 <- length(pdepend)
if(!kalman)z0 <- nlm(likenb, p, hessian=TRUE, print.level=print.level,
	typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
else z0 <- nlm(likekal, p, hessian=TRUE, 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
#
# calculate se's
#
a <- if(any(is.na(z0$hessian))||any(abs(z0$hessian)==Inf))0
	else 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=dim(response$response$y)[1]-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)}

### standard methods
###

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 method
###
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(nobs(z)),"\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:dim(coef.table)[1])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)}
