#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     pinvgauss(q, m, s)
#     dinvgauss(y, m, s)
#     plaplace(q, m=0, s=1)
#     dlaplace(y, m=0, s=1)
#     plevy(y, m=0, s=1)
#     dlevy(y, m=0, s=1)
#     ppareto(q, m, s)
#     dpareto(y, m, s)
#
#     pboxcox(y, m, s, f)
#     dboxcox(y, m, s, f)
#     pburr(y, m, s, f)
#     dburr(y, m, s, f)
#     pgextval(y, s, m, f)
#     dgextval(y, s, m, f)
#     pggamma(y, s, m, f)
#     dggamma(y, s, m, f)
#     pginvgauss(y, m, s, f)
#     dginvgauss(y, m, s, f)
#     pglogis(y, m, s, f)
#     dglogis(y, m, s, f)
#     pgweibull(y, s, m, f)
#     dgweibull(y, s, m, f)
#     phjorth(y, m, s, f)
#     dhjorth(y, m, s, f)
#     ppowexp(y, m, s, f)
#     dpowexp(y, m, s, f)
#
#     pdoublepois(q, m, s)
#     ddoublepois(y, m, s)
#     pmultpois(q, m, s)
#     dmultpois(y, m, s)
#     pgammacount(q, m, s)
#     dgammacount(y, m, s)
#     pdoublebinom(q, n, m, s)
#     ddoublebinom(y, n, m, s)
#     pmultbinom(q, n, m, s)
#     dmultbinom(y, n, m, s)
#     pbetabinom(q, n, m, s)
#     dbetabinom(y, n, m, s)
#
#  DESCRIPTION
#
#    Functions to compute the probability and cumulative probability
# functions for
# continuous two parameter distributions:
#  inverse Gaussian, Laplace, Levy, Pareto
# continuous three parameter distributions:
#  Box-Cox, Burr, generalized extreme value, generalized gamma, generalized
#  inverse Gaussian, generalized logistic, generalized Weibull, Hjorth
# discrete two parameter distributions:
#  double Poisson, multiplicative Poisson, double binomial,
#  multiplicative binomial, beta binomial 

# continuous two parameter distributions

pinvgauss <- function(q, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	t <- q/m
	v <- sqrt(q*s)
	pnorm((t-1)/v)+exp(2/(m*s))*pnorm(-(t+1)/v)}

dinvgauss <- function(y, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	exp(-(y-m)^2/(2*y*s*m^2))/sqrt(2*pi*s*y^3)}

plaplace <- function(q, m=0, s=1){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(s<=0))stop("s must be positive")
	u <- (q-m)/s
	t <- exp(-abs(u))/2
	ifelse(u<0,t,1-t)}

dlaplace <- function(y, m=0, s=1){
	if(any(s<=0))stop("s must be positive")
	exp(-abs(y-m)/s)/(2*s)}

plevy <- function(q, m=0, s=1){
	if(any(q<m))stop("some y <= m")
	if(any(s<=0))stop("s must be positive")
	len <- length(q)
	if(length(m)!=len){
		if(length(m)!=1)stop("m has incorrect length")
		else m <- rep(m,len)}
	if(length(s)!=len){
		if(length(s)!=1)stop("s has incorrect length")
		else s <- rep(s,len)}
	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=F)
	if(z$err==1)warning("Unable to allocate memory for integration")
	if(z$err==2)warning("Division by zero in integration")
	else if(z$err==3)warning("No convergence in integration")
	z$res}

dlevy <- function(y, m=0, s=1){
	if(any(y<=m))stop("some y <= m")
	if(any(s<=0))stop("s must be positive")
	sqrt(s/(2*pi*(y-m)^3))*exp(-s/(2*(y-m)))}

ppareto <- function(q, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=1))stop("s must be > 1")
	1-(1+q/(m*(s-1)))^-s}

dpareto <- function(y, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=1))stop("s must be > 1")
	m <- m*(s-1)
	s*(1+y/m)^(-s-1)/m}

# continuous three parameter distributions

# normed to make it a real distribution with y > 0
pboxcox <- function(q, m, s, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	norm <- sign(f)*pnorm(0,m,sqrt(s))
	ind <- f<0
	(pnorm(q^f/f,m,sqrt(s))-(f>0)*norm)/(1-ind-norm)}

dboxcox <- function(y, m, s, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	norm <- sign(f)*pnorm(0,m,sqrt(s))
	ind <- f<0
	y^(f-1)*dnorm(y^f/f,m,sqrt(s))/(1-ind-norm)}

pburr <- function(q, m, s, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	1-(1+(q/m)^s/f)^-f}

dburr <- function(y, m, s, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	y1 <- y/m
	s*y1^(s-1)/(m^s*(1+y1^s/f)^(f+1))}

# normed to make it a real distribution with y > 0
pgextval <- function(q, s, m, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	norm <- sign(f)*exp(-m^-s)
	ind <- f>0
	(pweibull(exp(q^f/f),s,m)-ind+(f>0)*norm)/(1-ind+norm)}

dgextval <- function(y, s, m, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	norm <- sign(f)*exp(-m^-s)
	ind <- f>0
	y1 <- exp(y^f/f)
	y^(f-1)*y1*dweibull(y1,s,m)/(1-ind+norm)}

pggamma <- function(q, s, m, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	pgamma(q^f,s,(m/s)^f)}

dggamma <- function(y, s, m, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	f*y^(f-1)*dgamma(y^f,s,(m/s)^f)}

pginvgauss <- function(q, m, s, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	len <- length(q)
	if(length(m)!=len){
		if(length(m)!=1)stop("m has incorrect length")
		else m <- rep(m,len)}
	if(length(s)!=len){
		if(length(s)!=1)stop("s has incorrect length")
		else s <- rep(s,len)}
	if(length(f)!=len){
		if(length(f)!=1)stop("f has incorrect length")
		else f <- rep(f,len)}
	z <- .C("pginvgauss",
		as.double(q),
		as.double(m),
		as.double(s),
		as.double(f),
		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=F)
	if(z$err==1)warning("Unable to allocate memory for integration")
	if(z$err==2)warning("Division by zero in integration")
	else if(z$err==3)warning("No convergence in integration")
	z$res}

dginvgauss <- function(y, m, s, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	y^(f-1)*exp(-(1/y+y/m^2)/(2*s))/(m^f*(2*besselK(1/(s*m),abs(f))))}

pglogis <- function(q, m, s, f){
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	(1+exp(-sqrt(3)*(q-m)/(s*pi)))^-f}

dglogis <- function(y, m, s, f) {
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	y1 <- exp(-sqrt(3)*(y-m)/(s*pi))
	sqrt(3)*f*y1/(pi*s*(1+y1)^(f+1))}

pgweibull <- function(q, s, m, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	(1-exp(-(q/m)^s))^f}

dgweibull <- function(y, s, m, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	y1 <- exp(-(y/m)^s)
	s*f*y^(s-1)*(1-y1)^(f-1)*y1/m^s}

phjorth <- function(q, m, s, f){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	1-(1+s*q)^(-f/s)*exp(-(q/m)^2/2)}

dhjorth <- function(y, m, s, f){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	(1+s*y)^(-f/s)*exp(-(y/m)^2/2)*(y/m^2+f/(1+s*y))}

ppowexp <- function(q, m=0, s=1, f=1){
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	len <- length(q)
	if(length(m)!=len){
		if(length(m)!=1)stop("m has incorrect length")
		else m <- rep(m,len)}
	if(length(s)!=len){
		if(length(s)!=1)stop("s has incorrect length")
		else s <- rep(s,len)}
	if(length(f)!=len){
		if(length(f)!=1)stop("f has incorrect length")
		else f <- rep(f,len)}
	z <- .C("ppowexp",
		as.double(q),
		as.double(m),
		as.double(s),
		as.double(f),
		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=F)
	if(z$err==1)warning("Unable to allocate memory for integration")
	if(z$err==2)warning("Division by zero in integration")
	else if(z$err==3)warning("No convergence in integration")
	ifelse(q-m>0,0.5+z$res,0.5-z$res)}

dpowexp <- function(y, m=0, s=1, f=1){
	if(any(s<=0))stop("s must be positive")
	if(any(f<=0))stop("f must be positive")
	s <- sqrt(s)
	b <- 1+1/(2*f)
	exp(-(abs(y-m)/s)^(2*f)/2)/(s*gamma(b)*2^b)}

# discrete (overdispersed) two parameter distributions

pdoublepois <- function(q, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(q)){
		if(length(m)==1)m <- rep(m,length(q))
		else stop("m and q must have the same length")}
	if(length(s)!=length(q)){
		if(length(s)==1)s <- rep(s,length(q))
		else stop("s and q must have the same length")}
	.C("pdp",
		as.integer(q),
		as.integer(3*max(c(q,100))),
		as.double(m),
		as.double(s),
		as.integer(length(q)),
		res=double(length(q)),
		DUP=F)$res}

ddoublepois <- function(y, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(y)){
		if(length(m)==1)m <- rep(m,length(y))
		else stop("m and y must have the same length")}
	if(length(s)!=length(y)){
		if(length(s)==1)s <- rep(s,length(y))
		else stop("s and y must have the same length")}
	exp(.C("ddp",
		as.integer(y),
		as.integer(3*max(c(y,100))),
		as.double(m),
		as.double(s),
		as.integer(length(y)),
		as.double(rep(1,length(y))),
		res=double(length(y)),
		DUP=F)$res)}

pmultpois <- function(q, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(q)){
		if(length(m)==1)m <- rep(m,length(q))
		else stop("m and q must have the same length")}
	if(length(s)!=length(q)){
		if(length(s)==1)s <- rep(s,length(q))
		else stop("s and q must have the same length")}
	.C("pmp",
		as.integer(q),
		as.integer(3*max(c(q,100))),
		as.double(m),
		as.double(s),
		as.integer(length(q)),
		res=double(length(q)),
		DUP=F)$res}

dmultpois <- function(y, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(y)){
		if(length(m)==1)m <- rep(m,length(y))
		else stop("m and y must have the same length")}
	if(length(s)!=length(y)){
		if(length(s)==1)s <- rep(s,length(y))
		else stop("s and y must have the same length")}
	exp(.C("dmp",
		as.integer(y),
		as.integer(3*max(c(y,100))),
		as.double(m),
		as.double(s),
		as.integer(length(y)),
		as.double(rep(1,length(y))),
		res=double(length(y)),
		DUP=F)$res)}

pgammacount <- function(q, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	1-pgamma(m*s,(q+1)*s,1)}

dgammacount <- function(y, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(m<=0))stop("m must be positive")
	if(any(s<=0))stop("s must be positive")
	ifelse(y==0,1-pgamma(m*s,(y+1)*s,1),
		pgamma(m*s,y*s+(y==0),1)-pgamma(m*s,(y+1)*s,1))}

pdoublebinom <- function(q, n, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(n<0))stop("n must contain non-negative values")
	if(length(n)!=length(q)){
		if(length(n)==1)n <- rep(n,length(q))
		else stop("n must be the same length as q")}
	if(any(q>n))stop("q must be <= n")
	if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(q)){
		if(length(m)==1)m <- rep(m,length(q))
		else stop("m and q must have the same length")}
	if(length(s)!=length(q)){
		if(length(s)==1)s <- rep(s,length(q))
		else stop("s and q must have the same length")}
	.C("pdb",
		as.integer(q),
		as.integer(n),
		as.double(m),
		as.double(s),
		as.integer(length(q)),
		res=double(length(q)),
		DUP=F)$res}

ddoublebinom <- function(y, n, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(n<0))stop("n must contain non-negative values")
	if(length(n)!=length(y)){
		if(length(n)==1)n <- rep(n,length(y))
		else stop("n must be the same length as y")}
	if(any(y>n))stop("y must be <= n")
	if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(y)){
		if(length(m)==1)m <- rep(m,length(y))
		else stop("m and y must have the same length")}
	if(length(s)!=length(y)){
		if(length(s)==1)s <- rep(s,length(y))
		else stop("s and y must have the same length")}
	exp(.C("ddb",
		as.integer(y),
		as.integer(n),
		as.double(m),
		as.double(s),
		as.integer(length(y)),
		as.double(rep(1,length(y))),
		res=double(length(y)),
		DUP=F)$res)}

pmultbinom <- function(q, n, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(n<0))stop("n must contain non-negative values")
	if(length(n)!=length(q)){
		if(length(n)==1)n <- rep(n,length(q))
		else stop("n must be the same length as q")}
	if(any(q>n))stop("q must be <= n")
	if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(q)){
		if(length(m)==1)m <- rep(m,length(q))
		else stop("m and q must have the same length")}
	if(length(s)!=length(q)){
		if(length(s)==1)s <- rep(s,length(q))
		else stop("s and q must have the same length")}
	.C("pmb",
		as.integer(q),
		as.integer(n),
		as.double(m),
		as.double(s),
		as.integer(length(q)),
		res=double(length(q)),
		DUP=F)$res}

dmultbinom <- function(y, n, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(n<0))stop("n must contain non-negative values")
	if(length(n)!=length(y)){
		if(length(n)==1)n <- rep(n,length(y))
		else stop("n must be the same length as y")}
	if(any(y>n))stop("y must be <= n")
	if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(y)){
		if(length(m)==1)m <- rep(m,length(y))
		else stop("m and y must have the same length")}
	if(length(s)!=length(y)){
		if(length(s)==1)s <- rep(s,length(y))
		else stop("s and y must have the same length")}
	exp(.C("dmb",
		as.integer(y),
		as.integer(n),
		as.double(m),
		as.double(s),
		as.integer(length(y)),
		as.double(rep(1,length(y))),
		res=double(length(y)),
		DUP=F)$res)}

pbetabinom <- function(q, n, m, s){
	if(any(q<0))stop("q must contain non-negative values")
	if(any(n<0))stop("n must contain non-negative values")
	if(length(n)!=length(q)){
		if(length(n)==1)n <- rep(n,length(q))
		else stop("n must be the same length as q")}
	if(any(q>n))stop("q must be <= n")
	if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(q)){
		if(length(m)==1)m <- rep(m,length(q))
		else stop("m and q must have the same length")}
	if(length(s)!=length(q)){
		if(length(s)==1)s <- rep(s,length(q))
		else stop("s and q must have the same length")}
	t <- s*m
	u <- s*(1-m)
	res <- NULL
	for(i in 1:length(q)){
		qq <- 0:q[i]
		res <- c(res,sum(exp(lbeta(qq+t[i],n[i]-qq+u[i])-
			lbeta(t[i],u[i])+lchoose(n[i],qq))))}
	res}

dbetabinom <- function(y, n, m, s){
	if(any(y<0))stop("y must contain non-negative values")
	if(any(n<0))stop("n must contain non-negative values")
	if(length(n)!=length(y)){
		if(length(n)==1)n <- rep(n,length(y))
		else stop("n must be the same length as y")}
	if(any(y>n))stop("y must be <= n")
	if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
	if(any(s<=0))stop("s must be positive")
	if(length(m)!=length(y)&&length(m)!=1)
		stop("m and y must have the same length")
	if(length(s)!=length(y)&&length(s)!=1)
		stop("s and y must have the same length")
	t <- s*m
	u <- s*(1-m)
	exp(lbeta(y+t,n-y+u)-lbeta(t,u)+lchoose(n,y))}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1999 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#   finterp(z, envir=sys.frame(sys.parent()), formula=FALSE,
#	parameters=FALSE, start=1, name=NULL, expand=TRUE)
#   fnenvir(z, envir=sys.frame(sys.parent()), name=NULL,
#	expand=TRUE)
#
#  DESCRIPTION
#
#    Function to translate a model formula with unknown parameters
#  into a function.

finterp <- function(z, ...) UseMethod("finterp")

finterp.default <- function(z, envir=sys.frame(sys.parent()), formula=FALSE,
	vector=TRUE, start=1, name=NULL, expand=TRUE){
	if(!inherits(z,"formula"))return(NULL)
	if(is.name(envir)){
		if(is.null(name))name <- as.character(envir)
		envir <- eval(envir)}
	if(!is.environment(envir)){
		if(is.null(name))name <- paste(deparse(substitute(envir)))
		if(inherits(envir,"repeated"))return(finterp.repeated(z,envir,formula,start,name=name,expand))
		if(inherits(envir,"tccov"))return(finterp.tccov(z,envir,formula,start,name=name,expand))
		if(inherits(envir,"tvcov"))return(finterp.tvcov(z,envir,formula,start,name=name,expand))}
	ch1 <- deparse(z[[length(z)]])
	fac <- fcn <- ex <- ch <- par <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(length(mem)>0){
		for(i in 1:length(mem)){
			ex <- c(ex,exists(mem[i],envir=envir))
			fcn <- c(fcn,if(exists(mem[i]))
				is.function(eval(parse(text=mem[i])))
				else F)
			fac <- c(fac,if(!fcn[i]&&exists(mem[i],envir=envir))
				!is.vector(eval(parse(text=mem[i]),envir=envir),mode="numeric")
				else F)}
		un <- unique(mem[!ex])
		if(length(unique(mem[ex&!fcn]))==0&&length(un)==0)
			stop("finterp.default: no variables found")}
	if(is.null(ex)||all(ex|fcn)){
		if(formula)return(z)
		else {
			mt <- terms(z)
			if(is.numeric(mt[[2]])){
				dm <- matrix(1)
				colnames(dm) <- "(Intercept)"}
			else dm <- model.matrix(mt,model.frame(mt,envir))
			.fn <- function(.p) as.vector(attr(.fn,"model")%*%
				.p[attr(.fn,"range")[1]:attr(.fn,"range")[2]])
			attributes(.fn) <- list(formula=z,model=dm,
				covariates=if(length(mem)>0)
					unique(mem[ex&!fcn]) else NULL,
				parameters=paste("p[",1:ncol(dm),"]",sep=""),
				range=c(start,start+ncol(dm)-1),
				class="formulafn")
			rm(list=ls())
			return(.fn)}}
	if(!is.null(fac)&&any(fac))stop(paste("finterp.default:\ncovariates in formulae with unknowns must be numeric vectors\ncheck",mem[fac]))
	.fn <- function(.p) eval(attr(.fn,"model"))
	if(vector){
		ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
		ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",ch)))
		ch <- gsub("\\+","+ ",gsub(":"," :",ch))
		ch <- paste(" ",gsub("\\("," ( ",ch)," ",sep="")
		for(i in 1:length(un))ch <- gsub(paste(" ",un[i]," ",sep=""),
			paste(" .p[",start+i-1,"] ",sep=""),ch)}
	else {
		par <- "alist("
		for(i in 1:length(un)){
			if(i>1)par <- paste(par,",",collapse="")
			par <- paste(par,un[i],"=",collapse="")}
# bug in 0.64.0
		if(length(un)==1)par <- paste(par,",...=",collapse="")
		par <- paste(par,")",collapse="")
		formals(.fn) <- eval(parse(text=par))}
	attributes(.fn) <- list(formula=z,model=parse(text=ch),parameters=un,
		covariates=unique(mem[ex&!fcn]),
		range=c(start,start+length(un)-1),class="formulafn")
	rm(list=ls())
	return(.fn)}

finterp.repeated <- function(z, envir=NULL, formula=FALSE, start=1,
	name=NULL, expand=TRUE){
	if(!inherits(z,"formula"))return(NULL)
	if(is.name(envir)){
		if(is.null(name))name <- as.character(envir)
		envir <- eval(envir)}
	if(is.null(envir)||!inherits(envir,"repeated"))stop("envir must be an object of class, repeated")
	ndata <- if(is.null(name))paste(deparse(substitute(envir))) else name
	ch1 <- deparse(z[[length(z)]])
	fcn <- ex1 <- ex2 <- ex3 <- ex4 <- ex5 <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(length(mem)>0){
		ex1 <- match(mem,colnames(envir$ccov$ccov))
		ex2 <- match(mem,colnames(envir$tvcov$tvcov))
		ex3 <- match(mem,"times")
		ex4 <- match(mem,"individuals")
		if(any(!is.na(ex4))&&length(envir$response$nobs)==1)stop("finterp.repeated: these are not repeated measurements")
		ex5 <- match(mem,"nesting")
		if(any(!is.na(ex5))&&is.null(envir$response$nest))stop("finterp.repeated: no nesting variable available")
		if(any(!is.na(ex2))&&!expand)stop("time-varying covariates present - time-constant ones must be expanded")
		for(i in 1:length(mem)){
			fcn <- c(fcn,if(exists(mem[i]))
				is.function(eval(parse(text=mem[i])))&&is.na(ex1[i])&&is.na(ex2[i])&&is.na(ex3[i])&&is.na(ex4[i])&&is.na(ex5[i])
				else F)}
		un <- unique(mem[is.na(ex1)&is.na(ex2)&is.na(ex3)&is.na(ex4)&is.na(ex5)&!fcn])
		if(length(unique(mem[(!is.na(ex1)|!is.na(ex2)|!is.na(ex3)|!is.na(ex4)|!is.na(ex5))&!fcn]))==0&&length(un)==0)
			stop("finterp.repeated: no variables found")}
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	if(expand).i <- covind(envir)
	ex1a <- if(is.null(ex1)) NULL else ex1[!is.na(ex1)]
	if(length(ex1a)>0)for(i in 1:length(ex1a))
		ch <- if(expand)gsub(paste(" ",colnames(envir$ccov$ccov)[ex1a[i]],
			" ",sep=""),paste(" ",ndata,"$ccov$ccov[,",
			ex1a[i],"][.i] ",sep=""),ch)
			else gsub(paste(" ",colnames(envir$ccov$ccov)[ex1a[i]],
			" ",sep=""),paste(" ",ndata,"$ccov$ccov[,",
			ex1a[i],"] ",sep=""),ch)
	ex2a <- if(is.null(ex2)) NULL else ex2[!is.na(ex2)]
	if(length(ex2a)>0)for(i in 1:length(ex2a))
		ch <- gsub(paste(" ",colnames(envir$tvcov$tvcov)[ex2a[i]],
			" ",sep=""),paste(" ",ndata,"$tvcov$tvcov[,",
			ex2a[i],"] ",sep=""),ch)
	ex3a <- if(is.null(ex3)) NULL else ex3[!is.na(ex3)]
	if(length(ex3a)>0)
		ch <- gsub(" times ",paste(" ",ndata,"$response$times ",sep=""),ch)
	ex4a <- if(is.null(ex4)) NULL else ex4[!is.na(ex4)]
	if(length(ex4a)>0)
		ch <- gsub(" individuals ",paste(" as.factor(covind(",ndata,")) ",sep=""),ch)
	ex5a <- if(is.null(ex5)) NULL else ex5[!is.na(ex5)]
	if(length(ex5a)>0)
		ch <- gsub(" nesting ",paste(" as.factor(",ndata,"$response$nest) ",sep=""),ch)
	if((is.null(ex1)&&is.null(ex2)&&is.null(ex3)&&is.null(ex4)&&is.null(ex5))||all(!is.na(ex1)|!is.na(ex2)|!is.na(ex3)|!is.na(ex4)|!is.na(ex5)|fcn)){
		if(formula)return(z)
		else {
			ch <- as.formula(paste("~",ch))
			mt <- terms(ch)
			if(is.numeric(mt[[2]])){
				dm <- matrix(1)
				colnames(dm) <- "(Intercept)"}
			else {
				dm <- model.matrix(mt,model.frame(mt))
				if(length(ex1a)>0)for(i in 1:length(ex1a))
					colnames(dm) <- gsub(paste(ndata,"\\$ccov\\$ccov\\[, ",ex1a[i],"\\]",sep=""),paste(colnames(envir$ccov$ccov)[ex1a[i]],sep=""),colnames(dm))
				if(length(ex2a)>0)for(i in 1:length(ex2a))
					colnames(dm) <- gsub(paste(ndata,"\\$tvcov\\$tvcov\\[, ",ex2a[i],"\\]",sep=""),paste(colnames(envir$tvcov$tvcov)[ex2a[i]],sep=""),colnames(dm))
				if(length(ex3a)>0)colnames(dm) <- gsub(paste(ndata,"\\$response\\$times",sep=""),"times",colnames(dm))
				if(length(ex4a)>0)colnames(dm) <- gsub(paste("as.factor\\(covind\\(",ndata,"\\)\\)",sep=""),"individuals",colnames(dm))
				if(length(ex5a)>0)colnames(dm) <- gsub(paste("as.factor\\(",ndata,"\\$response\\$nest\\)",sep=""),"nesting",colnames(dm))}
			.fn <- function(.p) as.vector(attr(.fn,"model")%*%
				.p[attr(.fn,"range")[1]:attr(.fn,"range")[2]])
			attributes(.fn) <- list(formula=z,model=dm,
				covariates=if(length(mem)>0)
					unique(mem[(!is.na(ex1)|!is.na(ex2)|!is.na(ex3)|!is.na(ex4)|!is.na(ex5))&!fcn]) else NULL,
				parameters=paste("p[",1:ncol(dm),"]",sep=""),
				range=c(start,start+ncol(dm)-1),
				class="formulafn")
			rm(list=ls())
			return(.fn)}}
	if(length(ex1a)>0)for(i in 1:length(ex1a))if(!is.vector(envir$ccov$ccov[,ex1a[i]],mode="numeric"))stop(paste("finterp.repeated: ",colnames(envir$ccov$ccov)[ex1a[i]],"is not a numeric covariate"))
	if(length(ex2a)>0)for(i in 1:length(ex2a))if(!is.vector(envir$tvcov$tvcov[,ex2a[i]],mode="numeric"))stop(paste("finterp.repeated: ",colnames(envir$tvcov$tvcov)[ex2a[i]],"is not a numeric covariate"))
	if(length(ex4a)>0)stop("finterp.repeated: index for individuals cannot be used in formulae with unknowns")
	if(length(ex5a)>0)stop("finterp.repeated: index for nesting cannot be used in formulae with unknowns")
	.fn <- function(.p) eval(attr(.fn,"model"))
	for(i in 1:length(un))ch <- gsub(paste(" ",un[i]," ",sep=""),
		paste(" .p[",start+i-1,"] ",sep=""),ch)
	attributes(.fn) <- list(formula=z,model=parse(text=ch),parameters=un,
		covariates=unique(mem[(!is.na(ex1)|!is.na(ex2)|!is.na(ex3)|!is.na(ex4)|!is.na(ex5))&!fcn]),
		range=c(start,start+length(un)-1),class="formulafn")
	rm(list=ls())
	return(.fn)}

finterp.tccov <- function(z, envir=NULL, formula=FALSE, start=1,
	name=NULL, expand=NULL){
	if(!inherits(z,"formula"))return(NULL)
	if(is.null(envir)||(!inherits(envir,"repeated")&&!inherits(envir,"tccov")))stop("envir must be an object of class, repeated or tccov")
	ndata <- if(is.null(name))paste(deparse(substitute(envir))) else name
	ch1 <- deparse(z[[length(z)]])
	fcn <- ex1 <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(inherits(envir,"repeated")){
		cn <- colnames(envir$ccov$ccov)
		cc <- "$ccov"
		cc2 <- "\\$ccov"}
	else {
		cn <- colnames(envir$ccov)
		cc2 <- cc <- ""}
	if(length(mem)>0){
		ex1 <- match(mem,cn)
		for(i in 1:length(mem)){
			fcn <- c(fcn,if(exists(mem[i]))
				is.function(eval(parse(text=mem[i])))&&is.na(ex1[i])
				else F)}
		un <- unique(mem[is.na(ex1)&!fcn])
		if(length(unique(mem[!is.na(ex1)&!fcn]))==0&&length(un)==0)
			stop("finterp.tccov: no variables found")}
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	ex1a <- if(is.null(ex1)) NULL else ex1[!is.na(ex1)]
	if(length(ex1a)>0)for(i in 1:length(ex1a))
		ch <- gsub(paste(" ",cn[ex1a[i]]," ",sep=""),
			paste(" ",ndata,cc,"$ccov[,",
			ex1a[i],"] ",sep=""),ch)
	if(is.null(ex1)||all(!is.na(ex1)|fcn)){
		if(formula)return(z)
		else {
			ch <- as.formula(paste("~",ch))
			mt <- terms(ch)
			if(is.numeric(mt[[2]])){
				dm <- matrix(1)
				colnames(dm) <- "(Intercept)"}
			else {
				dm <- model.matrix(mt,model.frame(mt))
				if(length(ex1a)>0)for(i in 1:length(ex1a))
					colnames(dm) <- gsub(paste(ndata,cc2,"\\$ccov\\[, ",ex1a[i],"\\]",sep=""),paste(cn[ex1a[i]],sep=""),colnames(dm))}
			.fn <- function(.p) as.vector(attr(.fn,"model")%*%
				.p[attr(.fn,"range")[1]:attr(.fn,"range")[2]])
			attributes(.fn) <- list(formula=z,model=dm,
				covariates=if(length(mem)>0)
					unique(mem[!is.na(ex1)&!fcn]) else NULL,
				parameters=paste("p[",1:ncol(dm),"]",sep=""),
				range=c(start,start+ncol(dm)-1),
				class="formulafn")
			rm(list=ls())
			return(.fn)}}
	if(inherits(envir,"repeated")){
		if(length(ex1a)>0)for(i in 1:length(ex1a))if(!is.vector(envir$ccov$ccov[,ex1a[i]],mode="numeric"))stop(paste("finterp.tccov: ",colnames(envir$ccov$ccov)[ex1a[i]],"is not a numeric covariate"))}
	else {
		if(length(ex1a)>0)for(i in 1:length(ex1a))if(!is.vector(envir$ccov[,ex1a[i]],mode="numeric"))stop(paste("finterp.tccov: ",colnames(envir$ccov$ccov)[ex1a[i]],"is not a numeric covariate"))}
	.fn <- function(.p) eval(attr(.fn,"model"))
	for(i in 1:length(un))ch <- gsub(paste(" ",un[i]," ",sep=""),
		paste(" .p[",start+i-1,"] ",sep=""),ch)
	attributes(.fn) <- list(formula=z,model=parse(text=ch),parameters=un,
		covariates=unique(mem[!is.na(ex1)&!fcn]),
		range=c(start,start+length(un)-1),class="formulafn")
	rm(list=ls())
	return(.fn)}

finterp.tvcov <- function(z, envir=NULL, formula=FALSE, start=1,
	name=NULL, expand=NULL){
	if(!inherits(z,"formula"))return(NULL)
	if(is.null(envir)||(!inherits(envir,"repeated")&&!inherits(envir,"tvcov")))stop("envir must be an object of class, repeated or tvcov")
	ndata <- if(is.null(name))paste(deparse(substitute(envir))) else name
	ch1 <- deparse(z[[length(z)]])
	fcn <- ex1 <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(inherits(envir,"repeated")){
		cn <- colnames(envir$tvcov$tvcov)
		cc <- "$tvcov"
		cc2 <- "\\$tvcov"}
	else {
		cn <- colnames(envir$tvcov)
		cc2 <- cc <- ""}
	if(length(mem)>0){
		ex1 <- match(mem,cn)
		for(i in 1:length(mem)){
			fcn <- c(fcn,if(exists(mem[i]))
				is.function(eval(parse(text=mem[i])))&&is.na(ex1[i])
				else F)}
		un <- unique(mem[is.na(ex1)&!fcn])
		if(length(unique(mem[!is.na(ex1)&!fcn]))==0&&length(un)==0)
			stop("finterp.tvcov: no variables found")}
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	ex1a <- if(is.null(ex1)) NULL else ex1[!is.na(ex1)]
	if(length(ex1a)>0)for(i in 1:length(ex1a))
		ch <- gsub(paste(" ",cn[ex1a[i]]," ",sep=""),
			paste(" ",ndata,cc,"$tvcov[,",
			ex1a[i],"] ",sep=""),ch)
	if(is.null(ex1)||all(!is.na(ex1)|fcn)){
		if(formula)return(z)
		else {
			ch <- as.formula(paste("~",ch))
			mt <- terms(ch)
			if(is.numeric(mt[[2]]))dm <- matrix(1)
			else {
				dm <- model.matrix(mt,model.frame(mt))
				if(length(ex1a)>0)for(i in 1:length(ex1a))
					colnames(dm) <- gsub(paste(ndata,cc2,"\\$ccov\\[, ",ex1a[i],"\\]",sep=""),paste(cn[ex1a[i]],sep=""),colnames(dm))}
			.fn <- function(.p) as.vector(attr(.fn,"model")%*%
				.p[attr(.fn,"range")[1]:attr(.fn,"range")[2]])
			attributes(.fn) <- list(formula=z,model=dm,
				covariates=if(length(mem)>0)
					unique(mem[!is.na(ex1)&!fcn]) else NULL,
				parameters=paste("p[",1:ncol(dm),"]",sep=""),
				range=c(start,start+ncol(dm)-1),
				class="formulafn")
			rm(list=ls())
			return(.fn)}}
	if(inherits(envir,"repeated")){
		if(length(ex1a)>0)for(i in 1:length(ex1a))if(!is.vector(envir$tvcov$tvcov[,ex1a[i]],mode="numeric"))stop(paste("finterp.tvcov: ",colnames(envir$tvcov$tvcov)[ex1a[i]],"is not a numeric covariate"))}
	else {
		if(length(ex1a)>0)for(i in 1:length(ex1a))if(!is.vector(envir$tvcov[,ex1a[i]],mode="numeric"))stop(paste("finterp.tvcov: ",colnames(envir$tvcov$tvcov)[ex1a[i]],"is not a numeric covariate"))}
	.fn <- function(.p) eval(attr(.fn,"model"))
	for(i in 1:length(un))ch <- gsub(paste(" ",un[i]," ",sep=""),
		paste(" .p[",start+i-1,"] ",sep=""),ch)
	attributes(.fn) <- list(formula=z,model=parse(text=ch),parameters=un,
		covariates=unique(mem[!is.na(ex1)&!fcn]),
		range=c(start,start+length(un)-1),class="formulafn")
	rm(list=ls())
	return(.fn)}

fnenvir <- function(z, ...) UseMethod("fnenvir")

fnenvir.default <- function(z, envir=sys.frame(sys.parent()),
	name=NULL, expand=TRUE){
	if(!is.function(z))return(NULL)
	if(is.name(envir)){
		if(is.null(name))name <- as.character(envir)
		envir <- eval(envir)}
	if(!is.environment(envir)){
		if(is.null(name))name <- paste(deparse(substitute(envir)))
		if(inherits(envir,"repeated"))return(fnenvir.repeated(z,envir,name=name,expand))
		if(inherits(envir,"tccov"))return(fnenvir.tccov(z,envir,name=name,expand))
		if(inherits(envir,"tvcov"))return(fnenvir.tvcov(z,envir,name=name,expand))}
	ch1 <- deparse(z,width=500)
	ch2 <- ch1[1]
	ch1 <- ch1[-1]
	mem2 <- strsplit(gsub("[(),]"," ",ch2)," ")[[1]]
	if(length(mem2)>1)mem2 <- mem2[2:length(mem2)]
	else mem2 <- NULL
	fcn <- ex <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(length(mem)>0){
		for(i in 1:length(mem)){
			ex <- c(ex,exists(mem[i],envir=envir))
			fcn <- c(fcn,if(exists(mem[i])){
				if(mem[i]=="function"||mem[i]=="if"||
					mem[i]=="else"||mem[i]=="for"||
					mem[i]=="while"||mem[i]=="repeat") T
				else is.function(eval(parse(text=mem[i])))}
				else F)}
		for(i in 1:length(mem)){
			if(!fcn[i]&&ex[i]&&!is.vector(eval(parse(text=mem[i]),envir=envir),mode="numeric"))stop(paste("fnenvir.default: ",mem[i],"is not a numeric covariate"))}
		un <- unique(mem[!ex])
		if(length(unique(mem[ex&!fcn]))==0&&length(un)==0)
			stop("fnenvir.default: no variables found")}
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	ch2 <- strsplit(ch," ")[[1]]
	ex2a <- un <- un0 <- un1 <- NULL
	if(length(mem2)>0)for(i in 1:length(mem2)){
		ex1a <- NULL
		for(j in 1:length(ch2))
			if(mem2[i]==ch2[j]){
				if(j<length(ch2)&&length(grep("^\\[",ch2[j+1]))>0){
					ex1a <- c(ex1a,paste(ch2[j],ch2[j+1],sep=""))
					un1 <- c(un1,ch2[j])}
				else un0 <- c(un0,ch2[j])}
		if(!is.null(ex1a)){
			ex1a <- unique(ex1a)
			ex2a <- c(ex2a,length(ex1a))
			o <- gsub("(^[[:alnum:]]\\[)|(\\])","",ex1a)
			un <- if(length(grep("[[:alpha:]]",o))>0)c(un,ex1a)
				else c(un,ex1a[order(as.numeric(o))])}}
	if(length(un0)>0){
		un <- if(length(un1)>0&&length(grep(un1,un0))>0)
			c(un,unique(un0[-grep(un1,un0)]))
			else c(un,unique(un0))}
	.fn <- eval(parse(text=paste("function(",paste(mem2,collapse=","),")",paste("eval(attr(.fn,\"model\"))"))))
	attributes(.fn) <- list(model=parse(text=ch1),parameters=un,
		covariates=unique(mem[ex&!fcn]),class="formulafn")
	rm(list=ls())
	return(.fn)}

fnenvir.repeated <- function(z, envir=NULL, name=NULL, expand=TRUE){
	if(!is.function(z))return(NULL)
	if(is.name(envir)){
		if(is.null(name))name <- as.character(envir)
		envir <- eval(envir)}
	if(is.null(envir)||!inherits(envir,"repeated"))stop("envir must be an object of class, repeated")
	ndata <- if(is.null(name))paste(deparse(substitute(envir)))
	else name
	ch1 <- deparse(z,width=500)
	ch2 <- ch1[1]
	ch1 <- ch1[-1]
	mem2 <- strsplit(gsub("[(),]"," ",ch2)," ")[[1]]
	if(length(mem2)>1)mem2 <- mem2[2:length(mem2)]
	else mem2 <- NULL
	fcn <- ex1 <- ex2 <- ex3 <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(length(mem)>0){
		ex1 <- match(mem,colnames(envir$ccov$ccov))
		ex2 <- match(mem,colnames(envir$tvcov$tvcov))
		ex3 <- match(mem,"times")
		if(any(!is.na(ex2))&&!expand)stop("time-varying covariates present - time-constant ones must be expanded")
		for(i in 1:length(mem)){
			fcn <- c(fcn,if(exists(mem[i])){
				if(mem[i]=="function"||mem[i]=="if"||
					mem[i]=="else"||mem[i]=="for"||
					mem[i]=="while"||mem[i]=="repeat") T
				else is.function(eval(parse(text=mem[i])))&&is.na(ex1[i])&&is.na(ex2[i])&&is.na(ex3[i])}
				else F)}
		un <- unique(mem[is.na(ex1)&is.na(ex2)&is.na(ex3)&!fcn])
		if(length(unique(mem[(!is.na(ex1)|!is.na(ex2)|!is.na(ex3))&!fcn]))==0&&length(un)==0)
			stop("fnenvir.repeated: no variables found")}
	for(i in 1:length(ch1)){
		ch1[i] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch1[i])))
		ch1[i] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",ch1[i])))
		ch1[i] <- paste(" ",gsub("\\("," ( ",ch1[i])," ",sep="")}
	if(expand).i <- covind(envir)
	ex1a <- ex1[!is.na(ex1)]
	if(length(ex1a)>0)for(i in 1:length(ex1a)){
		if(!is.vector(envir$ccov$ccov[,ex1a[i]],mode="numeric"))stop(paste("fnenvir.repeated: ",colnames(envir$ccov$ccov)[ex1a[i]],"is not a numeric covariate"))
		for(j in 1:length(ch1))
		ch1[j] <- if(expand)gsub(paste(" ",colnames(envir$ccov$ccov)[ex1a[i]],
			" ",sep=""),paste(" ",ndata,"$ccov$ccov[,",
			ex1a[i],"][.i] ",sep=""),ch1[j])
			else gsub(paste(" ",colnames(envir$ccov$ccov)[ex1a[i]],
			" ",sep=""),paste(" ",ndata,"$ccov$ccov[,",
			ex1a[i],"] ",sep=""),ch1[j])}
	ex2a <- ex2[!is.na(ex2)]
	if(length(ex2a)>0)for(i in 1:length(ex2a)){
		if(!is.vector(envir$tvcov$tvcov[,ex2a[i]],mode="numeric"))stop(paste("fnenvir.repeated: ",colnames(envir$tvcov$tvcov)[ex2a[i]],"is not a numeric covariate"))
		for(j in 1:length(ch1))
		ch1[j] <- gsub(paste(" ",colnames(envir$tvcov$tvcov)[ex2a[i]],
			" ",sep=""),paste(" ",ndata,"$tvcov$tvcov[,",
			ex2a[i],"] ",sep=""),ch1[j])}
	ex3a <- if(is.null(ex3)) NULL else ex3[!is.na(ex3)]
	if(length(ex3a)>0)for(j in 1:length(ch1))
		ch1[j] <- gsub(" times ",paste(" ",ndata,"$response$times ",sep=""),ch1[j])
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	ch2 <- strsplit(ch," ")[[1]]
	ex2a <- un <- un0 <- un1 <- NULL
	if(length(mem2)>0)for(i in 1:length(mem2)){
		ex1a <- NULL
		for(j in 1:length(ch2))
			if(mem2[i]==ch2[j]){
				if(j<length(ch2)&&length(grep("^\\[",ch2[j+1]))>0){
					ex1a <- c(ex1a,paste(ch2[j],ch2[j+1],sep=""))
					un1 <- c(un1,ch2[j])}
				else un0 <- c(un0,ch2[j])}
		if(!is.null(ex1a)){
			ex1a <- unique(ex1a)
			ex2a <- c(ex2a,length(ex1a))
			o <- gsub("(^[[:alnum:]]\\[)|(\\])","",ex1a)
			un <- if(length(grep("[[:alpha:]]",o))>0)c(un,ex1a)
				else c(un,ex1a[order(as.numeric(o))])}}
	if(length(un0)>0){
		un <- if(length(un1)>0&&length(grep(un1,un0))>0)
			c(un,unique(un0[-grep(un1,un0)]))
			else c(un,unique(un0))}
	.fn <- eval(parse(text=paste("function(",paste(mem2,collapse=","),")",paste("eval(attr(.fn,\"model\"))"))))
	attributes(.fn) <- list(model=parse(text=ch1),parameters=un,
		covariates=unique(mem[(!is.na(ex1)|!is.na(ex2)|!is.na(ex3))&!fcn]),
		class="formulafn")
	rm(list=ls())
	return(.fn)}

fnenvir.tccov <- function(z, envir=NULL, name=NULL, expand=TRUE){
	if(!is.function(z))return(NULL)
	if(is.null(envir)||(!inherits(envir,"repeated")&&!inherits(envir,"tccov")))stop("envir must be an object of class, repeated or tccov")
	ndata <- if(is.null(name))paste(deparse(substitute(envir)))
	else name
	ch1 <- deparse(z,width=500)
	ch2 <- ch1[1]
	ch1 <- ch1[-1]
	mem2 <- strsplit(gsub("[(),]"," ",ch2)," ")[[1]]
	if(length(mem2)>1)mem2 <- mem2[2:length(mem2)]
	else mem2 <- NULL
	fcn <- ex1 <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(inherits(envir,"repeated")){
		cn <- colnames(envir$ccov$ccov)
		cc <- "$ccov"}
	else {
		cn <- colnames(envir$ccov)
		cc <- ""}
	if(length(mem)>0){
		ex1 <- match(mem,cn)
		for(i in 1:length(mem)){
			fcn <- c(fcn,if(exists(mem[i])){
				if(mem[i]=="function"||mem[i]=="if"||
					mem[i]=="else"||mem[i]=="for"||
					mem[i]=="while"||mem[i]=="repeat") T
				else is.function(eval(parse(text=mem[i])))&&is.na(ex1[i])}
				else F)}
		un <- unique(mem[is.na(ex1)&!fcn])
		if(length(unique(mem[!is.na(ex1)&!fcn]))==0&&length(un)==0)
			stop("fnenvir.tccov: no variables found")}
	for(i in 1:length(ch1)){
		ch1[i] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch1[i])))
		ch1[i] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",ch1[i])))
		ch1[i] <- paste(" ",gsub("\\("," ( ",ch1[i])," ",sep="")}
	ex1a <- ex1[!is.na(ex1)]
	if(length(ex1a)>0)for(i in 1:length(ex1a)){
		if(inherits(envir,"repeated")){
			if(!is.vector(envir$ccov$ccov[,ex1a[i]],mode="numeric"))stop(paste("fnenvir.tccov: ",colnames(envir$ccov$ccov)[ex1a[i]],"is not a numeric covariate"))}
		else if(!is.vector(envir$ccov[,ex1a[i]],mode="numeric"))stop(paste("fnenvir.tccov: ",colnames(envir$ccov$ccov)[ex1a[i]],"is not a numeric covariate"))
		for(j in 1:length(ch1))ch1[j] <- gsub(paste(" ",cn[ex1a[i]],
			" ",sep=""),paste(" ",ndata,cc,"$ccov[,",
			ex1a[i],"] ",sep=""),ch1[j])}
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	ch2 <- strsplit(ch," ")[[1]]
	ex2a <- un <- un0 <- un1 <- NULL
	if(length(mem2)>0)for(i in 1:length(mem2)){
		ex1a <- NULL
		for(j in 1:length(ch2))
			if(mem2[i]==ch2[j]){
				if(j<length(ch2)&&length(grep("^\\[",ch2[j+1]))>0){
					ex1a <- c(ex1a,paste(ch2[j],ch2[j+1],sep=""))
					un1 <- c(un1,ch2[j])}
				else un0 <- c(un0,ch2[j])}
		if(!is.null(ex1a)){
			ex1a <- unique(ex1a)
			ex2a <- c(ex2a,length(ex1a))
			o <- gsub("(^[[:alnum:]]\\[)|(\\])","",ex1a)
			un <- if(length(grep("[[:alpha:]]",o))>0)c(un,ex1a)
				else c(un,ex1a[order(as.numeric(o))])}}
	if(length(un0)>0){
		un <- if(length(un1)>0&&length(grep(un1,un0))>0)
			c(un,unique(un0[-grep(un1,un0)]))
			else c(un,unique(un0))}
	.fn <- eval(parse(text=paste("function(",paste(mem2,collapse=","),")",paste("eval(attr(.fn,\"model\"))"))))
	attributes(.fn) <- list(model=parse(text=ch1),parameters=un,
		covariates=unique(mem[!is.na(ex1)&!fcn]),
		class="formulafn")
	rm(list=ls())
	return(.fn)}

fnenvir.tvcov <- function(z, envir=NULL, name=NULL, expand=TRUE){
	if(!is.function(z))return(NULL)
	if(is.null(envir)||(!inherits(envir,"repeated")&&!inherits(envir,"tvcov")))stop("envir must be an object of class, repeated or tvcov")
	ndata <- if(is.null(name))paste(deparse(substitute(envir)))
	else name
	ch1 <- deparse(z,width=500)
	ch2 <- ch1[1]
	ch1 <- ch1[-1]
	mem2 <- strsplit(gsub("[(),]"," ",ch2)," ")[[1]]
	if(length(mem2)>1)mem2 <- mem2[2:length(mem2)]
	else mem2 <- NULL
	fcn <- ex2 <- ch <- NULL
	for(i in 1:length(ch1))ch <- paste(ch,ch1[i],collapse=" ")
	mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(^[0-9]+)"," ",ch)," ")[[1]]
	if(inherits(envir,"repeated")){
		cn <- colnames(envir$tvcov$tvcov)
		cc <- "$tvcov"}
	else {
		cn <- colnames(envir$tvcov)
		cc <- ""}
	if(length(mem)>0){
		ex2 <- match(mem,cn)
		for(i in 1:length(mem)){
			fcn <- c(fcn,if(exists(mem[i])){
				if(mem[i]=="function"||mem[i]=="if"||
					mem[i]=="else"||mem[i]=="for"||
					mem[i]=="while"||mem[i]=="repeat") T
				else is.function(eval(parse(text=mem[i])))&&is.na(ex1[i])}
				else F)}
		un <- unique(mem[is.na(ex2)&!fcn])
		if(length(unique(mem[!is.na(ex2)&!fcn]))==0&&length(un)==0)
			stop("fnenvir.tvcov: no variables found")}
	for(i in 1:length(ch1)){
		ch1[i] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch1[i])))
		ch1[i] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",ch1[i])))
		ch1[i] <- paste(" ",gsub("\\("," ( ",ch1[i])," ",sep="")}
	ex2a <- ex2[!is.na(ex2)]
	if(length(ex2a)>0)for(i in 1:length(ex2a)){
		if(inherits(envir,"repeated")){
			if(!is.vector(envir$tvcov$tvcov[,ex1a[i]],mode="numeric"))stop(paste("fnenvir.tvcov: ",colnames(envir$tvcov$tvcov)[ex1a[i]],"is not a numeric covariate"))}
		else if(!is.vector(envir$tvcov[,ex1a[i]],mode="numeric"))stop(paste("fnenvir.tvcov: ",colnames(envir$tvcov$tvcov)[ex1a[i]],"is not a numeric covariate"))
		for(j in 1:length(ch1))ch1[j] <- gsub(paste(" ",cn[ex2a[i]],
			" ",sep=""),paste(" ",ndata,cc,"$tvcov[,",
			ex2a[i],"] ",sep=""),ch1[j])}
	ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",ch)))
	ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",ch))))
	ch <- paste(" ",gsub("\\("," ( ",gsub(":"," :",ch))," ",sep="")
	ch2 <- strsplit(ch," ")[[1]]
	ex2a <- un <- un0 <- un1 <- NULL
	if(length(mem2)>0)for(i in 1:length(mem2)){
		ex1a <- NULL
		for(j in 1:length(ch2))
			if(mem2[i]==ch2[j]){
				if(j<length(ch2)&&length(grep("^\\[",ch2[j+1]))>0){
					ex1a <- c(ex1a,paste(ch2[j],ch2[j+1],sep=""))
					un1 <- c(un1,ch2[j])}
				else un0 <- c(un0,ch2[j])}
		if(!is.null(ex1a)){
			ex1a <- unique(ex1a)
			ex2a <- c(ex2a,length(ex1a))
			o <- gsub("(^[[:alnum:]]\\[)|(\\])","",ex1a)
			un <- if(length(grep("[[:alpha:]]",o))>0)c(un,ex1a)
				else c(un,ex1a[order(as.numeric(o))])}}
	if(length(un0)>0){
		un <- if(length(un1)>0&&length(grep(un1,un0))>0)
			c(un,unique(un0[-grep(un1,un0)]))
			else c(un,unique(un0))}
	.fn <- eval(parse(text=paste("function(",paste(mem2,collapse=","),")",paste("eval(attr(.fn,\"model\"))"))))
	attributes(.fn) <- list(model=parse(text=ch1),parameters=un,
		covariates=unique(mem[!is.na(ex2)&!fcn]),
		class="formulafn")
	rm(list=ls())
	return(.fn)}

print.formulafn <- function(z){
	if(!is.null(attr(z,"formula"))){
		cat("\nformula:\n")
		print.default(unclass(attr(z,"formula")))}
	if(!is.matrix(attr(z,"model"))){
		model <- deparse(attr(z,"model"))
		model[1] <- sub("expression\\(","",model[1])
		model[length(model)] <- sub("\\)$","",model[length(model)])
		cat("\nmodel function:\n")
		cat(model,sep="\n")}
	if(length(attr(z,"covariates"))>0){
		cat(paste("\ncovariates:\n"))
		for(i in 1:length(attr(z,"covariates")))
			cat(attr(z,"covariates")[i]," ")
		cat("\n")}
	if(length(attr(z,"parameters"))>0){
		cat(paste("\nparameters:\n"))
		for(i in 1:length(attr(z,"parameters")))
			cat(attr(z,"parameters")[i]," ")}
	cat("\n\n")}

model <- function(z, ...) UseMethod("model")

model.formulafn <- function(z) attr(z,"model")

formula.formulafn <- function(z) attr(z,"formula")

covariates.formulafn <- function(z) attr(z,"covariates")

parameters <- function(z, ...) UseMethod("parameters")

parameters.formulafn <- function(z) attr(z,"parameters")
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gettvc(response, times=NULL, tvcov=NULL, tvctimes=NULL,
#	oldtvcov=NULL, ties=TRUE)
#
#  DESCRIPTION
#
#    Function to find the most recent value of a time-varying
# covariate not recorded at the same time as the response.

gettvc <- function(response, times=NULL, tvcov=NULL, tvctimes=NULL,
	oldtvcov=NULL, ties=TRUE){
if(is.list(response)&&inherits(response,"response"))zr <- response
else zr <- restovec(response,times)
if(any(is.na(zr$y)))stop("NAs in response; matching cannot be done")
zt <- restovec(tvcov,tvctimes)
if(any(is.na(zt$y))){
	tmp <- NULL
	rna <- !is.na(zt$y)
	j <- c(0,cumsum(zt$nobs))
	for(i in 1:length(zt$nobs))tmp <- c(tmp,sum(rna[(j[i]+1):j[i+1]]))
	zt$nobs <- tmp
	zt$times <- zt$times[rna]
	zt$y <- zt$y[rna]}
if(length(zr$nobs)!=length(zt$nobs))stop("response and covariate do not have the same number of individuals")
nind <- length(zr$nobs)
nld <- max(c(zr$nobs,zt$nobs))
z2 <- .Fortran("gettvc",
	x=as.double(zr$times),
	y=as.double(zr$y),
	xtvc=as.double(zt$times),
	tvcov=as.double(zt$y),
	nobs=as.integer(zr$nobs),
	nind=as.integer(nind),
	nknt=as.integer(zt$nobs),
	ties=as.logical(ties),
	xu=matrix(0,nrow=nind,ncol=2*nld),
	ndelta=logical(2*nld*nind),
	tvcov2=matrix(0,nrow=nind,ncol=2*nld),
	nu=integer(nind),
	wu=double(2*nld),
	nld=as.integer(nld),
	tvcov3=double(length(zr$y)),
	DUP=F)
tvcov3 <- z2$tvcov3
z2 <- NULL
new <- missing(oldtvcov)
if(!new&!is.list(oldtvcov)){
	warning("oldtvcov must form a list - ignored")
	new <- T}
cname <- paste(deparse(substitute(tvcov)))
if(new)oldtvcov <- vector(mode="list",nind)
else if(!inherits(oldtvcov,"tvcov")){
	if(length(oldtvcov)!=nind)
		stop(paste("Previous time-varying covariate list must have length",nind))
	else if(!is.null(colnames(oldtvcov[[1]])))
		cname <- c(colnames(oldtvcov[[1]]),cname)
	else cname <- NULL}
else if(inherits(oldtvcov,"tvcov"))cname <- c(colnames(oldtvcov$tvcov),cname)
if(!inherits(oldtvcov,"tvcov")){
	nm <- 0
	for(i in 1:nind){
		oldtvcov[[i]] <- cbind(oldtvcov[[i]],tvcov3[(nm+1):(nm+zr$nobs[i])])
		nm <- nm+zr$nobs[i]}
	if(!is.null(cname))colnames(oldtvcov[[1]]) <- cname
	oldtvcov <- tvctomat(oldtvcov)}
else {
	oldtvcov$tvcov <- cbind(oldtvcov$tvcov,tvcov3)
	colnames(oldtvcov$tvcov) <- cname}
invisible(oldtvcov)}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gauss.hermite(points, iterlim=10)
#
#  DESCRIPTION
#
#    Function to compute points and weights for Gauss-Hermite integration

gauss.hermite <- function(points, iterlim=10){
	x <- w <- rep(0,points)
	m <- (points+1)/2
	for(i in 1:m){
		z <- if(i==1)sqrt(2*points+1)-2*(2*points+1)^(-1/6)
		else if(i==2)z-sqrt(points)/z
		else if(i==3||i==4)1.9*z-0.9*x[i-2]
		else 2.0*z-x[i-2]
		for(j in 1:iterlim){
			z1 <- z
			p <- hermite(points,z)
			z <- z1-p[1]/p[2]
			if(abs(z-z1)<=1e-15)break}
		if(j==iterlim)warning("iteration limit exceeded")
		x[points+1-i] <- -(x[i] <- z)
		w[i] <- w[points+1-i] <- 2/p[2]^2}
	r <- cbind(x*sqrt(2),w/sum(w))
	colnames(r) <- c("Points","Weights")
	r}

# orthonormal Hermite polynomials
hermite <- function(points, z){
	p1 <- 1/pi^0.4
	p2 <- 0
	for(j in 1:points){
		p3 <- p2
		p2 <- p1
		p1 <- z*sqrt(2.0/j)*p2-sqrt((j-1)/j)*p3}
	pp <- sqrt(2*points)*p2
	c(p1,pp)}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     int(f, a="-infty", b="infty", type="Romberg", eps=1.0e-6,
#	max, d, p=0)
#
#  DESCRIPTION
#
#    A function to perform vectorized Romberg integration

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

int <- function(f, a="-infty", b="infty", type="Romberg", eps=1.0e-6,
	max, d, p=0)
{
int1 <- function(ff, aa, bb){
	z <- .C("romberg",
		ff,
		as.double(aa),
		as.double(bb),
		len=as.integer(len),
		eps=as.double(eps),
		pts=as.integer(d),
		max=as.integer(max),
		err=integer(1),
		res=double(len))
	if(z$err==1)warning("Unable to allocate memory for int")
	if(z$err==2)warning("Division by zero in int")
	else if(z$err==3)warning("No convergence in int")
	z$res}
if(!missing(type))type <- match.arg(type,c("Romberg","TOMS614"))
if(missing(max)) max <- if(type=="Romberg") 16 else 100
if(missing(d)) d <- if(type=="Romberg") 5 else 1
if(is.numeric(a)){
	if(is.numeric(b)){
		if(any(a>=b))stop("Some a>=b")
		len <- length(f((a+b)/2))}
	else len <- length(f(a+1))}
else if(is.numeric(b))len <- length(f(b-1))
else len <- length(f(0))
if(is.numeric(a)&length(a)!=len){
	if(length(a)!=1)stop("a has incorrect length")
	else a <- rep(a,len)}
if(is.numeric(b)&length(b)!=len){
	if(length(b)!=1)stop("b has incorrect length")
	else b <- rep(b,len)}
if(len>1&type!="Romberg")stop("vector functions only allowed with Romberg")
if(type=="Romberg"){
	ff <- function(x) f(1/x)/(x*x)
	if(!is.numeric(b)){
		if(!is.numeric(a)) z <- int1(ff,rep(-1,len),rep(0,len)) +
			int1(f,rep(-1,len),rep(1,len)) +
			int1(ff,rep(0,len),rep(1,len))
		else {
			if(any(a>0)){
				if(any(a<=0))a1 <- ifelse(a>0,a,1)
				else a1 <- a
				z1 <- int1(ff,rep(0,len), 1/a1)}
			else z1 <- rep(0,len)
			if(any(a<=0)){
				if(any(a>0))a1 <- ifelse(a<=0,a,0)
				else a1 <- a
				z2 <- int1(f,a1,rep(1,len)) +
				   int1(ff,rep(0,len),rep(1,len))}
			else z2 <- rep(0,len)
			z <- z1*(a>0)+z2*(a<=0)}}
	else if(!is.numeric(a)){
		if(any(b<0)){
			if(any(b>=0))b1 <- ifelse(b<0,b,1)
			else b1 <- b
			z1 <- int1(ff, 1/b1,rep(0,len))}
		else z1 <- rep(0,len)
		if(any(b>=0)){
			if(any(b<0))b1 <- ifelse(b>=0,b,0)
			else b1 <- b
			z2 <- int1(f,rep(-1,len), b1) +
				int1(ff,rep(-1,len),rep(0,len))}
		else z2 <- rep(0,len)
		z <- z1*(b<0)+z2*(b>=0)}
	else z <- int1(f, a, b)
	z}
else {
	left <- !is.numeric(a)&&is.numeric(b)
	if(!is.numeric(b)){
		if(!is.numeric(a)){
			inf <- 1
			a <- b <- 1}
		else {
			inf <- 2
			b <- 1}}
	else if(!is.numeric(a)){
		a <- 1
		inf <- 1}
	else inf <- 4
	if(left){
		z2 <- .Fortran("inthp",
		a=as.double(b),
		b=as.double(b),
		d=as.double(d),
		f=f,
		m=as.integer(max),
		p=as.double(p),
		eps=as.double(eps),
		inf=as.integer(2),
		quadr=as.double(1),
		DUP=F)
		if(z2$inf==3||z2$inf==4)warning(paste("error",z2$inf,"- integration incomplete - try larger max"))
		else if(z2$inf>4)stop(paste("error",z2$inf,"- incorrect arguments"))}
	z1 <- .Fortran("inthp",
		a=as.double(a),
		b=as.double(b),
		d=as.double(d),
		f=f,
		m=as.integer(max),
		p=as.double(p),
		eps=as.double(eps),
		inf=as.integer(inf),
		quadr=as.double(1),
		DUP=F)
	if(z1$inf==3||z1$inf==4)warning(paste("error",z1$inf,"- integration incomplete - try larger max"))
	else if(z1$inf>4)stop(paste("error",z1$inf,"- incorrect arguments"))
	if(left)z1$quadr <- z1$quadr-z2$quadr
	z1$quadr}}

	
	#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     restovec(response, times=NULL, nest=NULL, coordinates=NULL,
#	 censor=NULL, totals=NULL, weights=NULL, delta=NULL)
#     tcctomat(ccov, names=NULL, oldtccov=NULL)
#     rmna(response, tvcov=NULL, ccov=NULL)
#     response(z, ...)
#     times(z, ...)
#     nesting(z, ...)
#     covariates(z, ...)
#     parameters(z, ...)
#     covind(z, ...)
#
#  DESCRIPTION
#
#    Utility functions for converting repeated measurements data to R objects

restovec <- function(response, times=NULL, nest=NULL, coordinates=NULL,
	censor=NULL, totals=NULL, weights=NULL, delta=NULL, type=NULL){
	if(missing(response))stop("A response must be supplied")
	nind <- 0
	tnest <- nobs <- y <- NULL
	ttime <- !is.logical(times)
	if(!ttime)times <- NULL
	if(is.vector(response,mode="numeric")){
		y <- response
		nobs <- if(is.null(times)) 1 else length(response)
		if(is.vector(censor,mode="numeric")){
			if(length(censor)!=length(y)){
				if(length(censor)==1)censor <- c(rep(1,length(y)-1),censor)
				else stop("Censoring vector must be the same length as the response")}}
		else if(!is.null(censor))stop("Censor must be a scalar or vector")
		if(!is.null(coordinates)&&(!is.matrix(coordinates)||(is.matrix(coordinates)&&length(dim(coordinates))!=2&&ncol(coordinates)!=2&&nrow(coordinates)!=length(y))))
			stop("coordinates must be a 2-dimensional matrix with two columns and the same number of rows as the length of response")
		if(is.vector(totals,mode="numeric")){
			if(length(totals)!=length(y)){
				if(length(totals)==1)totals <- rep(totals,length(y))
				else stop("Totals vector must be the same length as the response")}}
		else if(!is.null(totals)) stop("Totals must be a vector")
		if(is.vector(times,mode="numeric")){
			if(length(times)!=length(y))stop("Times vector must be the same length as the response")}
		else if(!is.null(times))stop("Times must be a vector")
		if(is.vector(weights,mode="numeric")){
			if(length(weights)!=length(y))stop("Weights vector must be the same length as the response")}
		else if(!is.null(weights))stop("Weights must be a vector")
		if(is.vector(delta,mode="numeric")){
			if(length(delta)!=length(y)){
				if(length(delta)==1)delta <- rep(delta,length(y))
				else stop("Delta vector must be the same length as the response")}}
		else if(!is.null(delta))stop("Delta must be a scalar or vector")}
	else if(is.matrix(response)||is.data.frame(response)){
		if(is.data.frame(response))response <- as.matrix(response)
		if(is.data.frame(totals))totals <- as.matrix(totals)
		if(is.vector(censor,mode="numeric")){
			if(length(censor)!=nrow(response))
				stop("Censoring vector must be the same length as the number of individuals")
			else {
				tmp <- matrix(1,nrow=nrow(response),ncol=ncol(response))
				tmp[,ncol(tmp)] <- censor
				censor <- tmp}}
		if(is.matrix(censor)){
			if(nrow(censor)!=nrow(response)||ncol(censor)!=ncol(response))
				stop("Censoring matrix must have the same dimensions as response")
			else censor <- as.vector(t(censor))}
		if(is.matrix(totals)){
			if(nrow(totals)!=nrow(response)||ncol(totals)!=ncol(response))
				stop("totals matrix must have the same dimensions as response")
			else totals <- as.vector(t(totals))}
		else if(!is.null(totals)&&is.vector(totals,mode="numeric")){
		     if(length(totals)!=nrow(response))stop("totals vector must have same length as number of individuals")
		     else totals <- rep(totals,rep(ncol(response),nrow(response)))}
		if(is.matrix(weights)){
			if(nrow(weights)!=nrow(response)||ncol(weights)!=ncol(response))
				stop("weights matrix must have the same dimensions as response")
			else weights <- as.vector(t(weights))}
		else if(!is.null(weights)&&is.vector(weights,mode="numeric")){
		     if(length(weights)!=nrow(response))stop("weights vector must have same length as number of individuals")
		     else weights <- rep(weights,rep(ncol(response),nrow(response)))}
		if(is.null(times)){
			if(is.null(censor)&&ttime)times <- as.double(rep(1:ncol(response),nrow(response)))}
		else if(is.vector(times,mode="numeric")) {
			if(is.null(nest)&&any(diff(times)<0,na.rm=T))stop("Times must be increasing")
			if(length(times)!=ncol(response))stop("Number of times must equal number of response columns")
			times <- rep(times,nrow(response))}
		else if(is.matrix(times)){
			if(ncol(times)!=ncol(response)|nrow(times)!=nrow(response))stop("Matrix of times must be the same size as matrix of responses")
			for(i in 1:nrow(response))
				if(any(diff(times[i,])<0,na.rm=T))
				stop(paste("Negative time step for individual ",i))
			times <- as.vector(t(times))}
		nobs <- rep(ncol(response),nrow(response))
		if(!is.null(nest)){
			if(is.vector(nest,mode="numeric")){
				if(length(nest)!=ncol(response))
					stop("Length of nest vector not equal to number of observations per individual")
				else if(any(diff(nest)!=0&diff(nest)!=1,na.rm=T))
					stop("Nest categories must be consecutive increasing integers")
				else tnest <- rep(nest,nrow(response))}
			else if(is.matrix(nest)){
				if(any(dim(nest)!=dim(response)))
					stop("Dimensions of nest not the same as response")
				for(i in nrow(nest))if(any(diff(nest[i,])!=0&diff(nest[i,])!=1,na.rm=T))
					stop("Nest categories must be consecutive increasing integers")
				tnest <- as.vector(t(nest))}
			else stop("nest must be a vector or matrix")}
		if(!is.null(delta)){
			if(is.data.frame(delta))delta <- as.matrix(delta)
			if(is.vector(delta,mode="numeric")){
				if(length(delta)>1){
					if(length(delta)!=ncol(response))
						stop("Length of delta not equal to number of observations per individual")
					else delta <- rep(delta,nrow(response))}}
			else if(is.matrix(delta)){
				if(any(dim(delta)!=dim(response)))
					stop("Dimensions of delta not the same as response")
				delta <- as.vector(t(delta))}
			else stop("delta must be a vector or matrix")}
		y <- as.vector(t(response))}
	else if(is.list(response)){
		if(!is.null(delta)&&!is.vector(delta,mode="numeric")||length(delta)>1)
			stop("delta must be a scalar when response is a list")
		if(!is.null(totals)){
			if(!is.vector(totals,mode="numeric"))stop("totals must be a scalar or vector when response is a list")
			else totv <- T}
		else totv <- F
		if(!is.null(weights)){
			if(is.list(weights))weights <- unlist(weights)
			else if(!is.vector(weights,mode="numeric"))stop("weights must be a list or vector when response is a list")}
		if(is.null(censor)){
			times <- NULL
			tot <- del <- cen <- nes <- 0
			ncols <- ncol(as.matrix(response[[1]]))
			nc <- ttime+1
			if(ncols<nc)stop("matrices must have at least 2 columns: responses and times")
			else if(ncols>nc)for(j in response){
				j <- as.matrix(j)
				for(k in (nc+1):ncols){
					if(is.null(censor)&&any(j[,k]<=0,na.rm=T))
						cen <- k
					else if(any(j[,k]>1,na.rm=T)&&all(j[,k]==trunc(j[,k]),na.rm=T)){
					     if(all(j[,k]>=j[,1],na.rm=T)&&any(diff(j[,k])<0))tot <- k
						else nes <- k}
					else if(is.null(delta)&&all(j[,k]>0,na.rm=T))del <- k}
				if((((ncols==2&&!ttime)||ncols==3)&&(nes>0||cen>0||del>0||tot>0))||(((ncols==3&&!ttime)||ncols==4)&&((nes>0&&cen>0)||(nes>0&&del>0)||(nes>0&&tot>0)||(cen>0&&del>0)))||(((ncols>=4&&!ttime)||ncols>=5)&&((nes>0&&cen>0&&del>0)||(nes>0&&tot>0))))break}
			for(i in response){
				i <- as.matrix(i)
				nind <- nind+1
				if(ncol(i)!=ncols)
					stop(paste("Individual ",nind,"does not have a",ncols,"column matrix"))
				if(nes==0&&ttime&&any(diff(i[,2])<0,na.rm=T))
					stop(paste("Negative time step for individual ",nind))
				nobs <- c(nobs,nrow(i))
				y <- c(y,i[,1])
				if(ttime)times <- c(times,i[,2])
				if(nes>0){
					if(any(diff(i[,nes])!=0&diff(i[,nes])!=1,na.rm=T))
						stop("nest categories for individual ",nind,"are not consecutive increasing integers")
					tnest <- c(tnest,i[,nes])}
				if(!totv&&tot>0)totals <- c(totals,i[,tot])
				if(cen>0)censor <- c(censor,i[,cen])
				if(del>0)delta <- c(delta,i[,del])}}
		else if(!is.vector(censor,mode="numeric"))
			stop("If response is a list, censor must be a vector")
		else {
			del <- nes <- 0
			ncols <- ncol(as.matrix(response[[1]]))
			if(ncols>1){
				for(j in response){
					j <- as.matrix(j)
					for(k in 2:ncols){
						if(is.null(censor)&&any(j[,k]<=0,na.rm=T))cen <- k
						else if(any(j[,k]>1,na.rm=T)&&all(j[,k]==trunc(j[,k]),na.rm=T))nes <- k
						else if(is.null(delta)&&all(j[,k]>0,na.rm=T))del <- k}
					if((ncols==3&&(nes>0||cen>0||del>0))||(ncols==4&&((nes>0&&cen>0)||(nes>0&&del>0)||(cen>0&&del>0)))||(ncols>=5&&((nes>0&&cen>0&&del>0))))break}
				tmp <- NULL
				j <- 0
				for(i in response){
					i <- as.matrix(i)
					nind <- nind+1
					if(ncol(i)!=ncols)stop(paste("Individual ",nind,"does not have a",ncols,"column matrix"))
					nobs <- c(nobs,nrow(i))
					y <- c(y,i[,1])
					tmp <- c(tmp,rep(1,length(i)-1),censor[j <- j+1])
					if(nes>0){
						if(any(diff(i[,nes])!=0&diff(i[,nes])!=1,na.rm=T))stop("nest categories for individual ",nind,"are not consecutive increasing integers")
						tnest <- c(tnest,i[,nes])}
					if(del>0)delta <- c(delta,i[,del])}
				censor <- tmp}
			else {
				tmp <- NULL
				j <- 0
				for(i in response){
					nind <- nind+1
					if(!is.vector(i,mode="numeric")&&!(is.matrix(i)&&ncol(i)==1))
						stop(paste("Individual ",nind,"does not have a vector or one column matrix"))
					tmp <- c(tmp,rep(1,length(i)-1),censor[j <- j+1])
					y <- c(y,i)
					nobs <- c(nobs,length(i))}
				censor <- tmp}}
		if(totv){
			if(length(totals)==1)totals <- rep(totals,length(y))
			else if(length(totals)!=length(y))
			     stop("totals must have one value per response")}}
	else
		stop("Responses must be supplied as a vector, matrix, dataframe, or list of matrices")
	if(!is.null(censor)){
		if(any(censor!=-1&censor!=0&censor!=1,na.rm=T))
			stop("censor must only contain -1, 0, and 1")
		if(is.null(times)){
			j <- 1
			na <- is.na(y)
			y[na] <- 0
			for(i in 1:length(nobs)){
				times <- c(times,cumsum(y[j:(j+nobs[i]-1)]))
				j <- j+nobs[i]}
			y[na] <- NA}
		if(all(censor==1,na.rm=T))censor <- NULL}
	if(!is.null(totals)){
		if(any(y<0,na.rm=T))stop("all responses must be non-negative")
		if(any(totals<y,na.rm=T)||any(totals<0,na.rm=T))
			stop("all totals must be non-negative and >= to responses")}
	if(!is.null(tnest)&&(any(tnest<1,na.rm=T)||any(tnest!=trunc(tnest),na.rm=T)))
		stop("nest must contain integers starting at 1")
	if(!is.null(delta)&&any(delta<=0,na.rm=T))
		stop("delta must be strictly positive")
	if(!is.null(weights)&&any(weights<0,na.rm=T))
		stop("weights must be non-negative")
	type <- if(!is.null(type))match.arg(type,c("nominal","ordinal","discrete","duration","continuous","unknown"))
	else if(!is.null(totals))"nominal"
	else if(!is.null(censor))"duration"
	else if(all(as.integer(y)==y,na.rm=T))"discrete"
	else "unknown"
	z <- list(y=y, nobs=nobs, times=times, nest=tnest,
		coordinates=coordinates, censor=censor, n=totals,
		wt=weights, delta=delta)
	attr(z,"type") <- type
	class(z) <- "response"
	z}

tcctomat <- function(ccov, names=NULL, oldccov=NULL, dataframe=TRUE){
	if(inherits(ccov,"tccov")&&inherits(oldccov,"tccov")){
		if(nrow(ccov$ccov)!=nrow(oldccov$ccov))stop("incompatible tccov objects")
		oldccov$ccov <- cbind(oldccov$ccov,ccov$ccov)
		oldccov$linear <- NULL
		return(oldccov)}
	linear <- NULL
	if(is.language(ccov)){
		linear <- ccov
		mt <- terms(ccov)
		mf <- model.frame(mt,sys.frame(sys.parent()))
		ccov <- model.matrix(mt,mf)[,-1,drop=F]}
	else if(is.factor(ccov)||is.vector(ccov,mode="character")){
		if(is.null(names))names <- paste(deparse(substitute(ccov)))
		ccov <- data.frame(ccov)
		colnames(ccov) <- names}
	if(is.vector(ccov,mode="numeric")){
		if(is.null(names))names <- paste(deparse(substitute(ccov)))
		ccov <- matrix(ccov,ncol=1)}
	else if(is.data.frame(ccov)){
		if(!dataframe){
	                rm(names)
	                tmp <- NULL
	                j <- 0
	                for(i in ccov){
	                	j <- j+1
	                	if(is.vector(i,mode="numeric")){
	                		tmp2 <- as.matrix(i)
	                		colnames(tmp2) <- names(ccov)[j]}
	                	else {
	                		mt <- terms(~i)
	                		tmp2 <- model.matrix(mt,model.frame(mt))[,-1,drop=F]
	                		colnames(tmp2) <- paste(names(ccov)[j],levels(i)[-1],sep="")}
	                	tmp <- cbind(tmp,tmp2)}
	                ccov <- tmp
	                rm(tmp,tmp2,mt)}}
	else if(!is.matrix(ccov))
		stop("Time-constant covariates must be a vector, matrix, dataframe, or model formula")
	if(is.null(colnames(ccov))){
		if(is.null(names))names <- paste(deparse(substitute(ccov)))
		if(length(names)==1&&ncol(ccov)>1)
			names <- paste(names,1:ncol(ccov),sep="")
		colnames(ccov) <- names}
	if(!is.null(oldccov)){
		if(!inherits(oldccov,"tccov"))
			stop("oldccov must have class, tccov")
		else if(nrow(oldccov$ccov)==nrow(ccov)){
			if(dataframe)oldccov$ccov <- data.frame(oldccov$ccov,ccov)
			else oldccov$ccov <- cbind(oldccov$ccov,ccov)}
		else stop("old and new covariates do not have the same number of individuals")}
	else {
		if(dataframe)ccov <- as.data.frame(ccov)
		oldccov <- list(ccov=ccov, linear=linear)
		class(oldccov) <- "tccov"}
	fac <- F
	for(i in 1:ncol(oldccov$ccov))if(!is.vector(oldccov$ccov[,i],mode="numeric")){
		fac <- T
		break}
	if(!fac)oldccov$ccov <- as.matrix(oldccov$ccov)
	oldccov}

tvctomat <- function(tvcov, names=NULL, interaction=NULL, ccov=NULL,
	oldtvcov=NULL, dataframe=TRUE){
	if(inherits(tvcov,"tvcov")&&inherits(oldtvcov,"tvcov")){
		if(length(tvcov$nobs)!=length(oldtvcov$nobs)||any(tvcov$nobs!=oldtvcov$nobs))stop("incompatible tvcov objects")
		oldtvcov$tvcov <- cbind(oldtvcov$tvcov,tvcov$tvcov)
		return(oldtvcov)}
	nbs <- tvcv <- NULL
	if(is.data.frame(tvcov)){
		if(is.null(names))names <- paste(deparse(substitute(tvcov)))
		if(dataframe){
			nbs <- rep(ncol(tvcov),nrow(tvcov))
			tvcv <- as.data.frame(as.vector(t(as.matrix(tvcov))))
			colnames(tvcv) <- names}
		else tvcov <- as.matrix(tvcov)}
	if(is.matrix(tvcov)&&is.character(tvcov)){
		nbs <- rep(ncol(tvcov),nrow(tvcov))
		if(is.null(names))names <- paste(deparse(substitute(tvcov)))
		if(length(names)!=1)stop("too many names")
		tvcv <- as.factor(as.vector(t(tvcov)))
		mt <- terms(~tvcv)
		names <- paste(names,levels(tvcv)[-1],sep="")
		tvcv <- model.matrix(mt,model.frame(mt))[,-1,drop=F]
		colnames(tvcv) <- names}
	else if(is.matrix(tvcov)){
		nbs <- rep(ncol(tvcov),nrow(tvcov))
		tvcv <- matrix(as.vector(t(tvcov)),ncol=1)
		if(!is.null(names)&&length(names)!=1)stop("too many names")
		colnames(tvcv) <- if(!is.null(names)) names
			else paste(deparse(substitute(tvcov)))}
	else if(is.list(tvcov)&&!is.data.frame(tvcov)){
		if(!inherits(tvcov,"tvcov")){
			if(is.null(names)){
				if(!is.null(colnames(tvcov[[1]])))names <- colnames(tvcov[[1]])
				else {
					names <- if(is.matrix(tvcov[[1]]))paste(paste(deparse(substitute(tvcov))),1:ncol(tvcov[[1]]),sep="")
					else paste(deparse(substitute(tvcov)))}}
			for(i in tvcov){
				i <- as.matrix(i)
				nbs <- c(nbs,dim(i)[1])
				tvcv <- rbind(tvcv,i)}
			if(is.character(tvcv)){
				tmp <- tmp2 <- NULL
				for(i in 1:ncol(tvcv)){
					mt <- terms(~as.factor(tvcv[,i]))
					tmp <- cbind(tmp,model.matrix(mt,model.frame(mt))[,-1,drop=F])
					tmp2 <- c(tmp2,paste(names[i],levels(as.factor(tvcv[,i]))[-1],sep=""))}
				tvcv <- tmp
				names <- tmp2
				rm(tmp,tmp2,mt)}
			if(is.null(colnames(tvcov[[1]]))){
				if(is.null(names))names <- paste(deparse(substitute(tvcov)))}
			else if(length(names)!=ncol(tvcv))names <- colnames(tvcov[[1]])
			if(length(names)==1&&ncol(tvcv)>1)
				names <- paste(names,1:ncol(tvcv),sep="")
			colnames(tvcv) <- names}
		else if(inherits(tvcov,"tvcov")){
			nbs <- tvcov$nobs
			tvcv <- tvcov$tvcov}}
	else if(!is.data.frame(tvcov))stop("The time-varying covariates must be a matrix, dataframe, or list")
	if(!is.null(interaction)){
		name <- colnames(tvcv)
		if(is.character(interaction)){
			mat <- match(interaction,name)
			if(any(is.na(mat)))
				stop(paste("Time-varying covariate(s)",ccov[is.na(mat)],"not found"))
			interaction <- mat}
		if(is.vector(interaction,mode="numeric")){
			if(length(interaction)>length(name))stop("too many interactions")
			if(!is.data.frame(tvcv))colnames(tvcv) <- NULL
			if(!is.null(ccov)){
				if(inherits(ccov,"tccov"))ccov <- ccov$ccov
				if(!is.matrix(ccov)&&!is.data.frame(ccov)){
					tmp <- paste(deparse(substitute(ccov)))
					ccov <- matrix(ccov)
					colnames(ccov) <- tmp}
				if(nrow(ccov)!=length(nbs))stop("ccov does not have one observation per individual")
				if(is.null(names))names <- colnames(ccov)
				mat <- match(names,colnames(ccov))
				if(any(is.na(mat)))stop(paste("covariates",names[is.na(mat)],"not found"))
				oldtvcov <- tvcv
				if(!is.data.frame(oldtvcov)&&!is.data.frame(ccov)){
					for(i in 1:length(interaction))for(j in 1:length(mat)){
						oldtvcov <- cbind(oldtvcov,tvcv[,interaction[i]]*rep(ccov[,mat[j]],nbs))
						name <-  c(name,paste(name[interaction[i]],".",names[j],sep=""))}}
				else {
					for(i in 1:length(interaction))for(j in 1:length(mat)){
						mt <- terms(~tvcv[,interaction[i]]:rep(ccov[,mat[j]],nbs))
						tmp <- model.matrix(mt,model.frame(mt))[,-1,drop=F]
				                if(!is.vector(tvcv[,interaction[i]],mode="numeric")){
				                	if(!is.vector(ccov[,mat[j]],mode="numeric")){
				                		nam <- NULL
				                		tmp2 <- paste(name[interaction[i]],levels(tvcv[,interaction[i]])[-1],".",sep="")
				                		for(k in 1:length(levels(ccov[,mat[j]])[-1]))
				                		nam <- c(nam,paste(tmp2,names[j],levels(ccov[,mat[j]])[-1][k],sep=""))
				                		tmp <- tmp[,-c(1:length(levels(tvcv[,interaction[i]])),seq(1,length(levels(tvcv[,interaction[i]]))*length(levels(ccov[,mat[j]])),by=length(levels(tvcv[,interaction[i]])))),drop=F]}
				                	else {
				                		nam <- paste(paste(name[interaction[i]],levels(tvcv[,interaction[i]])[-1],sep=""),".",names[j],sep="")
				                		tmp <- tmp[,-1,drop=F]}}
				                else {
				                	if(!is.vector(ccov[,mat[j]],mode="numeric")){
				                		nam <- paste(name[interaction[i]],".",paste(names[j],levels(ccov[,mat[j]])[-1],sep=""),sep="")
				                		tmp <- tmp[,-1,drop=F]}
				                	else nam <- paste(name[interaction[i]],".",names[j],sep="")}
				                colnames(tmp) <- nam
				                oldtvcov <- cbind(oldtvcov,tmp)}}
				oldtvcov <- list(tvcov=oldtvcov,nobs=nbs)
				if(!is.data.frame(oldtvcov$tvcov))colnames(oldtvcov$tvcov) <- name}
			else if(length(interaction)==2){
				if(is.data.frame(tvcv)){
					mt <- terms(~tvcv[,interaction[1]]:tvcv[,interaction[2]])
					tmp <- model.matrix(mt,model.frame(mt))[,-1,drop=F]
					if(!is.vector(tvcv[,interaction[1]],mode="numeric")){
						if(!is.vector(tvcv[,interaction[2]],mode="numeric")){
							names <- NULL
							tmp2 <- paste(name[interaction[1]],levels(tvcv[,interaction[1]])[-1],".",sep="")
							for(i in 1:length(levels(tvcv[,interaction[2]])[-1]))
							names <- c(names,paste(tmp2,name[interaction[2]],levels(tvcv[,interaction[2]])[-1][i],sep=""))
							tmp <- tmp[,-c(1:length(levels(tvcv[,interaction[1]])),seq(1,length(levels(tvcv[,interaction[1]]))*length(levels(tvcv[,interaction[2]])),by=length(levels(tvcv[,interaction[1]])))),drop=F]}
						else {
							names <- paste(paste(name[interaction[1]],levels(tvcv[,interaction[1]])[-1],sep=""),".",name[interaction[2]],sep="")
							tmp <- tmp[,-1,drop=F]}}
					else {
						if(!is.vector(tvcv[,interaction[2]],mode="numeric")){
							names <- paste(name[interaction[1]],".",paste(name[interaction[2]],levels(tvcv[,interaction[2]])[-1],sep=""),sep="")
							tmp <- tmp[,-1,drop=F]}
						else names <- paste(name[interaction[1]],".",name[interaction[2]],sep="")}
					colnames(tmp) <- names
					oldtvcov <- list(tvcov=cbind(tvcv,tmp),nobs=nbs)}
				else oldtvcov <- list(tvcov=cbind(tvcv,tvcv[,interaction[1]]*tvcv[,interaction[2]]),nobs=nbs)
				if(!is.data.frame(oldtvcov$tvcov))colnames(oldtvcov$tvcov) <- c(name,paste(name[interaction[1]],".",name[interaction[2]],sep=""))}
			else stop("interaction must be a vector containing column numbers or variable names")
			class(oldtvcov) <- "tvcov"}}
	else if(!is.null(oldtvcov)){
		if(!inherits(oldtvcov,"tvcov"))
			stop("oldtvcov must have class, tvcov")
		else if((nrow(oldtvcov$tvcov)==nrow(tvcv))&&
			all(oldtvcov$nobs==nbs)){
			if(dataframe)oldtvcov$tvcov <- data.frame(oldtvcov$tvcov,tvcv)
			else oldtvcov$tvcov <- cbind(oldtvcov$tvcov,tvcv)}
		else stop("old and new covariates do not have the same numbers of observations")}
	else {
		if(dataframe)tvcv <- as.data.frame(tvcv)
		oldtvcov <- list(tvcov=tvcv,nobs=nbs)
		class(oldtvcov) <- "tvcov"}
	fac <- F
	for(i in 1:ncol(oldtvcov$tvcov))if(!is.vector(oldtvcov$tvcov[,i],mode="numeric")){
		fac <- T
		break}
	if(!fac)oldtvcov$tvcov <- as.matrix(oldtvcov$tvcov)
	oldtvcov}

rmna <- function(response, ccov=NULL, tvcov=NULL){
	if(!inherits(response,"response"))response <- restovec(response)
	if(length(response$nobs)==1&&response$nobs==1)
		response$nobs <- rep(1,length(response$y))
	if(!is.null(ccov)){
		if(!inherits(ccov,"tccov"))ccov <- tcctomat(ccov)
		if(length(response$nobs)!=nrow(ccov$ccov))stop("Numbers of individuals for response and for time-constant covariates do not agree.")}
	if(!is.null(tvcov)){
		if(!inherits(tvcov,"tvcov"))tvcov <- tvctomat(tvcov)
		if(any(response$nobs!=tvcov$nobs))stop("Numbers of observations for response and time-varying covariates do not agree.")}
	rna <- !is.na(response$y)
	if(!is.null(response$times))rna <- rna&!is.na(response$times)
	if(!is.null(response$nest))rna <- rna&!is.na(response$nest)
	if(!is.null(response$coordinates))rna <- rna&!is.na(response$coordinates[,1])&!is.na(response$coordinates[,2])
	if(!is.null(response$n))rna <- rna&!is.na(response$n)
	for(i in 1:length(response$nobs))
		if(!is.null(ccov)&&any(is.na(ccov$ccov[i,])))rna[covind(response)==i] <- F
	if(!is.null(tvcov))
		for(i in 1:ncol(tvcov$tvcov))rna <- rna&!is.na(tvcov$tvcov[,i])
	response$y <- response$y[rna]
	if(!is.null(response$times))response$times <- response$times[rna]
	if(!is.null(response$nest))response$nest <- response$nest[rna]
	if(!is.null(response$coordinates))response$coordinates <- response$coordinates[rna,]
	if(!is.null(response$n))response$n <- response$n[rna]
	if(!is.null(response$censor)){
		response$censor <- response$censor[rna]
		if(all(response$censor==1))response$censor <- NULL}
	if(!is.null(response$delta)&&length(response$delta)>1)
		response$delta <- response$delta[rna]
	if(!is.null(tvcov))tvcov$tvcov <- tvcov$tvcov[rna,,drop=F]
	tmp <- NULL
	j <- c(0,cumsum(response$nobs))
	for(i in 1:length(response$nobs)){
		tmp <- c(tmp,sum(rna[(j[i]+1):j[i+1]]))
		if(tmp[i]==0)
			warning(paste("Individual",i,"has no observations"))}
	response$nobs <- tmp[tmp>0]
	if(!is.null(ccov)){
		ccov$ccov <- ccov$ccov[tmp>0,,drop=F]
		for(i in 1: ncol(ccov$ccov))
			if(length(unique(ccov$ccov[,i]))==1)
			warning(paste("covariate",colnames(ccov$ccov)[i],"has only one value\n"))}
	if(!is.null(tvcov)){
		tvcov$nobs <- response$nobs
		for(i in 1: ncol(tvcov$tvcov))
			if(length(unique(tvcov$tvcov[,i]))==1)
			warning(paste("covariate",colnames(tvcov$tvcov)[i],"has only one value\n"))}
	if(all(response$nobs==1))response$nobs <- 1
	z <- list(response=response,tvcov=tvcov,ccov=ccov)
	class(z) <- "repeated"
	z}

print.response <- function(z){
	if(length(z$nobs)>1||z$nobs>1)cat("Number of individuals:                ",length(z$nobs),"\n")
	cat("Number of observations:               ",length(z$y),"\n")
	if(length(z$nobs)>1)cat("Number of observations per individual:\n",z$nobs,"\n")
	if(is.null(z$n))y <- z$y
	else y <- z$y/z$n
	cat("Mean response:                        ",mean(y,na.rm=T),"\n")
	cat("Range of responses:                   ",range(y,na.rm=T),"\n")
	if(any(is.na(z$y)))
		cat("Number of NAs:                        ",sum(is.na(z$y)),"\n")
	if(!is.null(z$wt))
		cat("Number of positive weights:           ",sum(z$wt>0),"\n")
	if(!is.null(z$times)){
		cat("Mean time:                            ",mean(z$times,na.rm=T),"\n")
		cat("Range of times:                       ",range(z$times,na.rm=T),"\n")
		if(length(z$nobs)>1&&is.null(z$nest)){
			mn <- if(any(z$times<0))z$times[cumsum(c(1,z$nobs[1:(length(z$nobs)-1)]))]
				else 0
			cat("Mean total time:                      ",mean(z$times[cumsum(z$nobs)]-mn,na.rm=T),"\n")
			cat("Range of total times:                 ",range(z$times[cumsum(z$nobs)]-mn,na.rm=T),"\n")}}
	if(!is.null(z$nest))
		cat("Maximum number of clusters:           ",max(z$nest),"\n")
	if(!is.null(z$censor)) {
		if(sum(z$censor==0,na.rm=T)>0)cat("Number of right-censored observations:",sum(z$censor==0,na.rm=T),"\n")
		if(sum(z$censor==-1,na.rm=T)>0)cat("Number of left-censored observations: ",sum(z$censor==-1,na.rm=T),"\n")}
	if(!is.null(z$delta)&&length(z$delta)==1)
		cat("Unit of measurement:                  ",z$delta,"\n")}

print.tvcov <- function(z){
	if(is.function(z)){
		print.default(unclass(z))
		return()}
	cat("Number of individuals:            ",length(z$nobs),"\n")
	cat("Number of observations:           ",sum(z$nobs),"\n")
	cat("Number of observations per individual:\n",z$nobs,"\n")
	cat("Number of time-varying covariates:",ncol(z$tvcov),"\n")
	cat("Names of time-varying covariates:\n",colnames(z$tvcov),"\n")}

print.tccov <- function(z){
	if(is.function(z)){
		print.default(unclass(z))
		return()}
	cat("Number of individuals:             ",nrow(z$ccov),"\n")
	cat("Number of time-constant covariates:",ncol(z$ccov),"\n")
	cat("Names of time-constant covariates:\n",colnames(z$ccov),"\n")}

print.repeated <- function(z){
	if(is.function(z)){
		print.default(unclass(z))
		return()}
	cat("Response variable:\n\n")
	print.response(z$response)
	if(!is.null(z$ccov)){
		cat("\nTime-constant covariates:\n\n")
		print.tccov(z$ccov)}
	if(!is.null(z$tvcov)){
		cat("\nTime-varying covariates:\n\n")
		print.tvcov(z$tvcov)}}

plot.response <- function(z, nind=NULL, nest=1, add=F, lty=NULL,
	pch=NULL, main=NULL, ylim=range(z$y,na.rm=T),
	xlim=range(z$times,na.rm=T), xlab=NULL, ylab="Response", ...){
	if(length(z$nobs)==1&&z$nobs==1)z$nobs <- length(z$y)
	if(is.null(z$times)){
		z$times <- sequence(z$nobs)
		if(is.null(xlab)) xlab <- "Index number"}
	else if(is.null(xlab)) xlab <- "Time"
	tnest <- if(!is.null(z$nest)) z$nest
		else 1
	nm <- rep(1:length(z$nobs),z$nobs)
	j <- 1
	lt <- 0
	if(is.null(nind))nind <- 1:length(z$nobs)
	if(is.null(z$n))y <- z$y
	else y <- z$y/z$n
	if(!is.null(lty)){
		if(length(lty)==1)lty <- rep(lty,length(nind))
		else if(length(lty)!=length(nind))stop("lty must have one value for each item in nind")}
	if(!is.null(pch)){
		if(length(pch)==1)pch <- rep(pch,length(nind))
		else if(length(pch)!=length(nind))stop("pch must have one value for each item in nind")}
	for(i in 1:length(z$nobs))if(any(i==nind)){
		if(is.null(lty))lt <- lt%%4+1
		else lt <- lty[j]
		if(!add&&j==1)plot(z$times[nm==i&nest==tnest],
			y[nm==i&nest==tnest],lty=lt,type="l",
			ylim=ylim,xlim=xlim,main=main,
			ylab=ylab,xlab=xlab,...)
		else lines(z$times[nm==i&nest==tnest],
			y[nm==i&nest==tnest],lty=lt)
		if(!is.null(pch))points(z$times[nm==i&nest==tnest],
			y[nm==i&nest==tnest],pch=pch[j])
		j <- j+1}}

plot.repeated <- function(z, variable="response", number=1, nind=NULL,
	add=F, lty=NULL, main=NULL, ylim=range(z$response$y),
	xlim=range(z$response$times), xlab="Time", ylab="Response", ...){
	variable <- match.arg(variable,c("response","time-varying covariate"))
	if(inherits(z,"repeated")){
		if(variable=="response")
			plot.response(z$response, nind=nind,
				add=add, lty=lty, main=main, ylim=ylim,
				xlim=xlim, xlab=xlab, ylab=ylab, ...)
		else if(variable=="time-varying covariate"){
			if(number>ncol(z$tvcov$tvcov))
				stop("Less than",number,"covariates")
			if(missing(ylab))ylab <- colnames(z$tvcov$tvcov)[number]
			zz <- list()
			zz$times <- z$response$times
			zz$y <- z$tvcov$tvcov[,number]
			zz$nobs <- z$tvcov$nobs
			if(missing(ylim))ylim <- range(zz$y)
			class(zz) <- "response"
			plot.response(zz, nind=nind,
				add=add, lty=lty, main=main, ylim=ylim,
				xlim=xlim, xlab=xlab, ylab=ylab, ...)}}}

response <- function(z, ...) UseMethod("response")

response.response <- function(z, nind=NULL){
	if(is.null(nind))nind <- 1:length(z$y)
	else if(length(nind)>length(z$nobs)||any(nind>length(z$nobs)))
		stop("Individual not found")
	else nind <- !is.na(match(covind(z),nind))
	if(all(!nind))stop("No such individuals")
	if(!is.null(z$n)){
		z <- cbind(z$y,z$n-z$y)[nind,]
		colnames(z) <- c("y","n-y")
		return(z)}
	else if(!is.null(z$censor)){
		z <- cbind(z$y,z$censor)[nind,]
		colnames(z) <- c("Response","Censor")
		return(z)}
	else return(z$y[nind])}

response.repeated <- function(z, nind=NULL){
	if(is.null(nind))nind <- 1:length(z$response$y)
	else if(length(nind)>length(z$response$nobs)||any(nind>length(z$response$nobs)))
		stop("Individual not found")
	else nind <- !is.na(match(covind(z),nind))
	if(all(!nind))stop("No such individuals")
	if(!is.null(z$response$n)){
		z <- cbind(z$response$y,z$response$n-z$response$y)[nind,]
		colnames(z) <- c("y","n-y")
		return(z)}
	else if(!is.null(z$response$censor)){
		z <- cbind(z$response$y,z$response$censor)[nind,]
		colnames(z) <- c("Response","Censor")
		return(z)}
	else return(z$response$y[nind])}

covind <- function(z, ...) UseMethod("covind")

covind.response <- function(z) {
	if(length(z$nobs)==1&&z$nobs==1) return(1:length(z$y))
	else return(rep(1:length(z$nobs),z$nobs))}

covind.repeated <- function(z) {
	if(length(z$response$nobs)==1&&z$response$nobs==1)
		return(1:length(z$response$y))
	else return(rep(1:length(z$response$nobs),z$response$nobs))}

nobs <- function(z, ...) UseMethod("nobs")

nobs.response <- function(z) z$nobs

nobs.repeated <- function(z) z$response$nobs

times <- function(z, ...) UseMethod("times")

times.response <- function(z) z$times

times.repeated <- function(z) z$response$times

weights.response <- function(z) z$wt

weights.repeated <- function(z) z$response$wt

nesting <- function(z, ...) UseMethod("nesting")

nesting.response <- function(z){
	if(length(z$nobs)==1)return(NULL)
	else if(is.null(z$nest))return(covind(z))
	else {
		z <- cbind(covind(z),z$nest)
		colnames(z) <- c("Individual","Cluster")
		return(z)}}

nesting.repeated <- function(z){
	if(length(z$response$nobs)==1)return(NULL)
	else if(is.null(z$response$nest))return(covind(z))
	else {
		z <- cbind(covind(z),z$response$nest)
		colnames(z) <- c("Individual","Cluster")
		return(z)}}

covariates <- function(z, ...) UseMethod("covariates")

covariates.tccov <- function(z, names=NULL){
	if(is.null(names))return(z$ccov)
	else {
		mat <- match(names,colnames(z$ccov))
		if(any(is.na(mat)))
			stop(paste("covariate(s)",names[is.na(mat)],"not found"))
		return(z$ccov[,mat,drop=F])}}

covariates.tvcov <- function(z, names=NULL){
	if(is.null(names))return(z$tvcov)
	else {
		mat <- match(names,colnames(z$tvcov))
		if(any(is.na(mat)))
			stop(paste("covariate(s)",names[is.na(mat)],"not found"))
		return(z$tvcov[,mat,drop=F])}}

covariates.repeated <- function(z, names=NULL){
	if(is.null(names)){
		if(is.null(z$tvcov$tvcov))return(z$ccov$ccov)
		else if(is.null(z$ccov$ccov))return(z$tvcov$tvcov)
		else return(list(ccov=z$ccov$ccov,tvcov=z$tvcov$tvcov))}
	else {
		mat1 <- match(names,colnames(z$ccov$ccov))
		mat2 <- match(names,colnames(z$tvcov$tvcov))
		if(any(is.na(mat1)&is.na(mat2)))
			stop(paste("covariate(s)",names[is.na(mat1)&is.na(mat2)],"not found"))
		if(all(is.na(mat1)))return(z$tvcov$tvcov[,mat2,drop=F])
		else if(all(is.na(mat2)))return(z$ccov$ccov[,mat1,drop=F])
		else return(list(ccov=z$ccov$ccov[,mat1,drop=F],tvcov=z$tvcov$tvcov[,mat2,drop=F]))}}

names.tccov <- function(z) colnames(z$ccov)

names.tvcov <- function(z) colnames(z$tvcov)

names.repeated <- function(z)
	list(ccov=colnames(z$ccov$ccov),tvcov=colnames(z$tvcov$tvcov))

formula.tccov <- function(z) z$linear

formula.repeated <- function(z) z$ccov$linear

transform.response <- function(z, y=NULL, times=NULL){
	if(is.call(substitute(y)))y <- substitute(y)
	if(is.call(substitute(times)))times <- substitute(times)
	if(!is.null(y)){
		if(!is.null(z$n))stop("transformations do not make sense with binomial data")
		tran <- eval(deriv(y,"y"),z,NULL)
		z$y <- as.vector(tran)
		z$delta <- if(is.null(z$delta))as.vector(abs(attr(tran,"gradient")))
			else z$delta*as.vector(abs(attr(tran,"gradient")))
		if(all(z$delta==1))z$delta <- NULL}
	if(!is.null(times)){
		z$times <- eval(times,z,NULL)
		for(i in 1:length(z$nobs))if(any(diff(z$times[covind(z)==i])<0))stop("transformation produces negative time steps")}
	z}

transform.repeated <- function(z, y=NULL, times=NULL){
	if(is.call(substitute(y)))y <- substitute(y)
	if(is.call(substitute(times)))times <- substitute(times)
	z$response <- transform.response(z$response,y,times)
	z}

transform.tccov <- function(z, ...){
	isf <- is.data.frame(z$ccov)
	if(!isf)z$ccov <- as.data.frame(z$ccov)
	e <- eval(substitute(list(...)),z$ccov,NULL)
	tags <- names(e)
	for(i in 1:length(e))if(all(is.na(e[[i]])))stop(paste(tags[i],"defines an invalid tranformation\n or attempts to transform a factor variable"))
	inx <- match(tags,colnames(z$ccov))
	matched <- !is.na(inx)
	if(any(matched))z$ccov[inx[matched]] <- e[matched]
	if(!all(matched))z$ccov <- data.frame(z$ccov,e[!matched])
	if(!isf)z$ccov <- as.matrix(z$ccov)
	z}

transform.tvcov <- function(z, ...){
	isf <- is.data.frame(z$tvcov)
	if(!isf)z$tvcov <- as.data.frame(z$tvcov)
	e <- eval(substitute(list(...)),z$tvcov,NULL)
	tags <- names(e)
	for(i in 1:length(e))if(all(is.na(e[[i]])))stop(paste(tags[i],"defines an invalid tranformation\n or attempts to transform a factor variable"))
	inx <- match(tags,colnames(z$tvcov))
	matched <- !is.na(inx)
	if(any(matched))z$tvcov[inx[matched]] <- e[matched]
	if(!all(matched))z$tvcov <- data.frame(z$tvcov,e[!matched])
	if(!isf)z$tvcov <- as.matrix(z$tvcov)
	z}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     mu1.0o1c(p, times, dose=1, end=0.5)
#     mu1.1o1c(p, times, dose=1)
#     mu1.1o2c(p, times, dose=1)
#     mu1.1o2cl(p, times, dose=1)
#     mu1.1o2cc(p, times, dose=1)
#     mu2.0o1c(p, times, dose=1, ind, end=0.5)
#     mu2.0o2c1(p, times, dose=1, ind, end=0.5)
#     mu2.0o2c2(p, times, dose=1, ind, end=0.5)
#     mu2.1o1c(p, times, dose=1, ind)
#     mu2.0o1cfp(p, times, dose=1, ind, end=0.5)
#     mu2.0o2c1fp(p, times, dose=1, ind, end=0.5)
#     mu2.0o2c2fp(p, times, dose=1, ind, end=0.5)
#     mu2.1o1cfp(p, times, dose=1, ind)
#
#  DESCRIPTION
#
#    Functions giving nonlinear regressions models for various PKPD
#  compartment models

# standard pharmacokinetic models
#
# open zero-order one-compartment model
# p[1]: log volume (V)
# p[2]: log elimination rate (ke)
# end:  time when infusion stops
mu1.0o1c <- function(p, times, dose=1, end=0.5) {
	ke <- exp(p[2])
	dose/(exp(p[1])*ke)*((1-exp(-ke*times))*(times<=end)+
		(1-exp(-ke*end))*exp(-ke*(times-end))*(times>end))}
#
# open first-order one-compartment model
# p[1]: log volume (V)
# p[2]: log absorption rate (ka)
# p[3]: log elimination rate (ke)
mu1.1o1c <- function(p, times, dose=1) {
	ka <- exp(p[2])
	ke <- exp(p[3])
	exp(p[2]-p[1])*dose/(ka-ke)*(exp(-ke*times)-exp(-ka*times))}
#
# open first-order two-compartment model (ordered)
# p[1]: log volume (V)
# p[2]: log absorption rate (ka)
# p[3]: log elimination rate (ke)
# p[4]: log transfer rate between compartments (k12)
mu1.1o2c <- function(p, times, dose=1) {
	ka <- exp(p[2])
	ke <- exp(p[3])
	k12 <- exp(p[4])
	ka*k12*exp(-p[1])*dose/(k12-ka)*((exp(-ka*times)-exp(-ke*times))/
		(ke-ka)-(exp(-k12*times)-exp(-ke*times))/(ke-k12))}
#
# open first-order two-compartment model (ordered, absorption and transfer equal)
# p[1]: log volume (V)
# p[2]: log absorption rate (ka)
# p[3]: log elimination rate (ke)
mu1.1o2cl <- function(p, times, dose=1) {
	ka <- exp(p[2])
	ke <- exp(p[3])
	ka^2*exp(-p[1])*dose/(ka-ke)*((exp(-ka*times)-exp(-ke*times))/(ke-ka)
		-times*exp(-ka*times))}
#
# open first-order two-compartment model (circular)
# p[1]: log volume (V)
# p[2]: log absorption rate (ka)
# p[3]: log elimination rate (ke)
# p[4]: log rate to second compartment (k12)
# p[5]: log rate from second compartment (k21)
mu1.1o2cc <- function(p, times, dose=1) {
	ka <- exp(p[2])
	ke <- exp(p[3])
	k12 <- exp(p[4])
	k21 <- exp(p[5])
	beta <- 0.5*(k12+k21+ke-sqrt((k12+k21+ke)^2-4*k21*ke))
	alpha <- (k21*ke)/beta
	exp(p[2]-p[1])*dose*((k21-alpha)*exp(-alpha*times)/
		((ka-alpha)*(beta-alpha))+(k21-beta)*exp(-beta*times)/
		((ka-beta)*(alpha-beta))+(k21-ka)*exp(-ka*times)/
		((beta-ka)*(beta-ka)))}
#
# simultaneous models for parent drug and metabolite
#
# zero-order one-compartment model
# p[1]: log parent drug volume (Vp)
# p[2]: log parent drug direct elimination rate (kep)
# p[3]: log transformation rate from parent to metabolite (kpm)
# p[4]: log metabolite elimination rate (kem)
# p[5]: log metabolite volume (Vm)
# ind:  indicator vector: 1 for parent, 0 for metabolite
# end:  time when infusion stops
mu2.0o1c <- function(p, times, dose=1, ind, end=0.5) {
	Vp <- exp(p[1])
	kpm <- exp(p[3])
	kp <- exp(p[2])+kpm
	kem <- exp(p[4])
	Vm <- exp(p[5])
	kemp <- kem-kp
	tmp1 <- exp(-kp*times)
	tmp2 <- kpm/(kp*kem*Vm)
	g1 <- exp(-kp*end)
	g2 <- exp(-kem*end)
	cend <- (1-g1)/(Vp*kp)
	cexp <- exp(-kp*(times-end))*(times>end)
	cmend <- tmp2*(1+kp/kemp*g2-kem/kemp*g1)
	tmp3 <- cend*kpm*Vp/(kemp*Vm)
	dose*(ind*((1-tmp1)/(Vp*kp)*(times<=end)+cend*cexp)+
		(1-ind)*(tmp2*(1+kp/kemp*exp(-kem*times)-kem/kemp*
		tmp1)*(times<=end)+(g2/g1*cexp*tmp3+
		(cmend-tmp3)*exp(-kem*(times-end))/g2*(times>end))))}
#
# zero-order two-compartment for parent, one-compartment for metabolite, model
# p[1]: log parent drug volume (Vp)
# p[2]: log parent drug direct elimination rate (kep)
# p[3]: log parent drug rate to second compartment (k12)
# p[4]: log parent drug rate from second compartment (k21)
# p[5]: log transformation rate from parent to metabolite (kpm)
# p[6]: log metabolite elimination rate (kem)
# ind:  indicator vector: 1 for parent, 0 for metabolite
# end:  time when infusion stops
mu2.0o2c1 <- function(p, times, dose=1, ind, end=0.5) {
	Vp <- exp(p[1])
	kp12 <- exp(p[3])
	kp21 <- exp(p[4])
	kpm <- exp(p[5])
	kp <- exp(p[2])+kpm
	kem <- exp(p[6])
	tmp1 <- sqrt((kp+kp12+kp21)^2-4*kp21*kp)
	lamp1 <- 0.5*(kp+kp12+kp21+tmp1)
	lamp2 <- 0.5*(kp+kp12+kp21-tmp1)
	tmp10 <- exp(-kem*times)
	tmp13 <- exp(-kem*end)
	tmp2 <- (1-tmp10)/kem
	tmp3 <- (1-tmp13)/kem
	tmp4 <- lamp1-kp21
	tmp5 <- lamp2-kp21
	tmp6 <- exp(-lamp1*times)
	tmp7 <- exp(-lamp2*times)
	tmp8 <- exp(-lamp1*end)
 	tmp9 <- exp(-lamp2*end)
	tmp11 <- tmp6/tmp8
	tmp12 <- tmp7/tmp9
	tmp14 <- tmp10/tmp13
	dose/(Vp*tmp1)*(ind*((tmp4*(1-tmp6)/lamp1-tmp5*(1-tmp7)/lamp2)*
		(times<=end)+(tmp4*(1-tmp8)*tmp11/lamp1-tmp5*(1-tmp9)*
		tmp12/lamp2)*(times>end))+(1-ind)*kpm*((tmp4*(tmp2-
		(tmp6-tmp10)/(kem-lamp1))/lamp1-tmp5*(tmp2-(tmp7-tmp10)/
		(kem-lamp2))/lamp2)*(times<=end)+((tmp4*(tmp3-(tmp8-
		tmp13)/(kem-lamp1))/lamp1-tmp5*(tmp3-(tmp9-tmp13)/
		(kem-lamp2))/lamp2)*tmp14+tmp4*(1-tmp8)*
		(tmp14-tmp11)/(lamp1*(lamp1-kem))-tmp5*(1-tmp9)*
		(tmp14-tmp12)/(lamp2*(lamp2-kem)))*(times>end)))}
#
# zero-order two-compartment model for both parent and metabolite
# p[1]: log parent drug volume (Vp)
# p[2]: log parent drug direct elimination rate (kep)
# p[3]: log parent drug rate to second compartment (kp12)
# p[4]: log parent drug rate from second compartment (kp21)
# p[5]: log transformation rate from parent to metabolite (kpm)
# p[6]: log metabolite elimination rate (kem)
# p[7]: log metabolite drug rate to second compartment (km12)
# p[8]: log metabolite drug rate from second compartment (km21)
# ind:  indicator vector: 1 for parent, 0 for metabolite
# end:  time when infusion stops
mu2.0o2c2 <- function(p, times, dose=1, ind, end=0.5) {
        Vp <- exp(p[1])
	kp12 <- exp(p[3])
	kp21 <- exp(p[4])
	kpm <- exp(p[5])
	kp <- exp(p[2])+kpm
	kem <- exp(p[6])
	km12 <- exp(p[7])
	km21 <- exp(p[8])
	tmp1 <- sqrt((kp+kp12+kp21)^2-4*kp21*kp)
	lamp1 <- 0.5*(kp+kp12+kp21+tmp1)
	lamp2 <- 0.5*(kp+kp12+kp21-tmp1)
	tmp2 <- lamp1-kp21
	tmp3 <- lamp2-kp21
	tmp4 <- exp(-lamp1*times)
	tmp5 <- exp(-lamp2*times)
	tmp6 <- exp(-lamp1*end)
	tmp7 <- exp(-lamp2*end)
	tmp8 <- tmp4/tmp6
	tmp9 <- tmp5/tmp7
	tmp10 <- sqrt((kem+km12+km21)^2-4*km21*kem)
	lamm1 <- 0.5*(kem+km12+km21+tmp10)
	lamm2 <- 0.5*(kem+km12+km21-tmp10)
	tmp11 <- kem-lamm1
	tmp12 <- kem-lamm2
        tmp13 <- lamp1-lamm2
        tmp14 <- lamp1-lamm1
	tmp15 <- exp(-lamm1*times)
	tmp16 <- exp(-lamm2*times)
        tmp17 <- lamp1-km21
        tmp18 <- lamp2-km21
        tmp19 <- lamp2-lamm1
        tmp20 <- lamp2-lamm2
	tmp21 <- exp(-lamm1*end)
	tmp22 <- exp(-lamm2*end)
        tmp23 <- km21-lamp1
        tmp24 <- km21-lamp2
        tmp25 <- tmp15/tmp21
        tmp26 <- tmp16/tmp22
	dose/Vp*(ind*((tmp2*(1-tmp4)/(lamp1*tmp1)-tmp3*(1-tmp5)/
		(lamp2*tmp1))*(times<=end)+(tmp2*(1-tmp6)*tmp8/(lamp1*tmp1)-
		tmp3*(1-tmp7)* tmp9/(lamp2*tmp1))*(times>end))+(1-ind)*kpm* 
		((tmp2/tmp1*((tmp11*tmp16/tmp13-tmp12*tmp15/tmp14)/
		(kem*tmp10)+tmp17*tmp4/(lamp1*tmp14*tmp13)+1/(kem*lamp1))
		-tmp3/tmp1*((tmp12*tmp15/tmp19-tmp11*tmp16/tmp20)/
		(kem*(-tmp10))+tmp18*tmp5/(lamp2*tmp19*tmp20)+1/(kem*lamp2)))*
		(times<=end)+((-tmp2/(tmp1*tmp10)*(tmp12*tmp21/(kem*tmp14)+
		lamm2/(kem*lamp1)+tmp23/(lamp1*tmp14))+tmp3/(tmp1*tmp10)*
		(tmp12*tmp21/(kem*tmp19)+lamm2/(kem*lamp2)+tmp24/
		(lamp2*tmp19)))*tmp25+(tmp2/(tmp1*tmp10)*(tmp11*tmp22/
		(kem*tmp13)+lamm1/(kem*lamp1)+tmp23/(lamp1*tmp13))-
		tmp3/(tmp1*tmp10)*( tmp11*tmp22/(kem*tmp20)+lamm1/(kem*lamp2)+
		tmp24/(lamp2*tmp20)))*tmp26+tmp2*tmp23*(1-tmp6)*tmp8/
		(lamp1*tmp1*tmp14*tmp13)-tmp3*tmp24*(1-tmp7)*tmp9/
		(lamp2*tmp1*tmp19*tmp20))*(times>end)))}
#
# first-order one-compartment model
# p[1]: log volume (V)
# p[2]: log parent drug absorption rate (kap)
# p[3]: log parent drug direct elimination rate (kep)
# p[4]: log transformation rate from parent to metabolite (kpm)
# p[5]: log metabolite elimination rate (kem)
# ind:  indicator vector: 1 for parent, 0 for metabolite
mu2.1o1c <- function(p, times, dose=1, ind) {
	kap <- exp(p[2])
	kep <- exp(p[3])
	kem <- exp(p[5])
	kap*exp(p[1])*dose/(kap-kep)*(ind*(exp(-kep*times)-exp(-kap*times))+
	(1-ind)*exp(p[4])*(exp(-kap*times)/(kap-kem)-exp(-kep*times)/(kep-kem)+
	(1/(kep-kem)-1/(kap-kem))*exp(-kem*times)))}
#
# zero-order one-compartment first-pass model
# p[1]: log parent drug volume (Vp)
# p[2]: log parent drug direct elimination rate (kep)
# p[3]: log transformation rate from parent to metabolite (kpm)
# p[4]: log metabolite elimination rate (kem)
# p[5]: log metabolite volume (Vm)
# p[7]: logit of proportion going to first pass (pfp)
# ind:  indicator vector: 1 for parent, 0 for metabolite
# end:  time when infusion stops
mu2.0o1cfp <- function(p, times, dose=1, ind, end=0.5) {
	Vp <- exp(p[1])
	kpm <- exp(p[3])
	kp <- exp(p[2])+kpm
	kem <- exp(p[4])
	Vm <- exp(p[5])
	kemp <- kem-kp
	tmp1 <- exp(-kp*times)
	tmp2 <- exp(-kem*times)
	tmp3 <- kpm/(kp*kem*Vm)
	g1 <- exp(-kp*end)
	g2 <- exp(-kem*end)
	cend <- (1-g1)/(Vp*kp)
	cexp <- exp(-kp*(times-end))*(times>end)
	cmend <- tmp3*(1+kp/kemp*g2-kem/kemp*g1)
	tmp4 <- cend*kpm*Vp/(kemp*Vm)
	pfp <- exp(p[6])
	lpfp <- pfp/(1+pfp)
	dose*(ind*((1-tmp1)/(Vp*kp)*(times<=end)+cend*cexp)*lpfp+
		(1-ind)*(((1-tmp2)/(Vm*kem)*(times<=0.5)+(1-g2)/(Vm*kem)*
		exp(-kem*(times-0.5))*(times>0.5))/(1+pfp)+(tmp3*
		(1+kp/kemp*tmp2-kem/kemp*tmp1)*(times<=end)+(g2/g1*cexp*tmp4+
		(cmend-tmp4)*exp(-kem*(times-end))/g2*(times>end)))*lpfp))}
#
# zero-order two-compartment for parent, one-compartment for metabolite,
#   first-pass model
# p[1]: log parent drug volume (Vp)
# p[2]: log parent drug direct elimination rate (kep)
# p[3]: log parent drug rate to second compartment (k12)
# p[4]: log parent drug rate from second compartment (k21)
# p[5]: log transformation rate from parent to metabolite (kpm)
# p[6]: log metabolite elimination rate (kem)
# p[7]: logit of proportion going to first pass (pfp)
# ind:  indicator vector: 1 for parent, 0 for metabolite
# end:  time when infusion stops
mu2.0o2c1fp <- function(p, times, dose=1, ind, end=0.5) {
	Vp <- exp(p[1])
	kp12 <- exp(p[3])
	kp21 <- exp(p[4])
	kpm <- exp(p[5])
	kp <- exp(p[2])+kpm
	kem <- exp(p[6])
	tmp1 <- sqrt((kp+kp12+kp21)^2-4*kp21*kp)
	lamp1 <- 0.5*(kp+kp12+kp21+tmp1)
	lamp2 <- 0.5*(kp+kp12+kp21-tmp1)
	tmp10 <- exp(-kem*times)
	tmp13 <- exp(-kem*end)
	tmp2 <- (1-tmp10)/kem
	tmp3 <- (1-tmp13)/kem
	tmp4 <- lamp1-kp21
	tmp5 <- lamp2-kp21
	tmp6 <- exp(-lamp1*times)
	tmp7 <- exp(-lamp2*times)
	tmp8 <- exp(-lamp1*end)
 	tmp9 <- exp(-lamp2*end)
	tmp11 <- tmp6/tmp8
	tmp12 <- tmp7/tmp9
	tmp14 <- tmp10/tmp13
	pfp <- exp(p[7])
	lpfp <- pfp/(1+pfp)
	dose/(Vp*tmp1)*(ind*((tmp4*(1-tmp6)/lamp1-tmp5*(1-tmp7)/lamp2)*
		(times<=end)+(tmp4*(1-tmp8)*tmp11/lamp1-tmp5*(1-tmp9)*
		tmp12/lamp2)*(times>end))+(1-ind)*(((1-exp(-kem*times))/
		kem*(times<=end)+(1-exp(-kem*end))/kem*exp(-kem*(times-end))*
		(times>end))*tmp1/(1+pfp)+(kpm*((tmp4*(tmp2-(tmp6-tmp10)/
		(kem-lamp1))/lamp1-tmp5*(tmp2-(tmp7-tmp10)/(kem-lamp2))/
		lamp2)*(times<=end)+((tmp4*(tmp3-(tmp8-
		tmp13)/(kem-lamp1))/lamp1-tmp5*(tmp3-(tmp9-tmp13)/
		(kem-lamp2))/lamp2)*tmp14+tmp4*(1-tmp8)*
		(tmp14-tmp11)/(lamp1*(lamp1-kem))-tmp5*(1-tmp9)*
		(tmp14-tmp12)/(lamp2*(lamp2-kem)))*(times>end)))*lpfp))}
#
# zero-order two-compartment model for both parent and metabolite
#   first-pass model
# p[1]: log parent drug volume (Vp)
# p[2]: log parent drug direct elimination rate (kep)
# p[3]: log parent drug rate to second compartment (kp12)
# p[4]: log parent drug rate from second compartment (kp21)
# p[5]: log transformation rate from parent to metabolite (kpm)
# p[6]: log metabolite elimination rate (kem)
# p[7]: log metabolite drug rate to second compartment (km12)
# p[8]: log metabolite drug rate from second compartment (km21)
# ind:  indicator vector: 1 for parent, 0 for metabolite
# end:  time when infusion stops
mu2.0o2c2fp <- function(p, times, dose=1, ind, end=0.5) {
        Vp <- exp(p[1])
	kp12 <- exp(p[3])
	kp21 <- exp(p[4])
	kpm <- exp(p[5])
	kp <- exp(p[2])+kpm
	kem <- exp(p[6])
	km12 <- exp(p[7])
	km21 <- exp(p[8])
	tmp1 <- sqrt((kp+kp12+kp21)^2-4*kp21*kp)
	lamp1 <- 0.5*(kp+kp12+kp21+tmp1)
	lamp2 <- 0.5*(kp+kp12+kp21-tmp1)
	tmp2 <- lamp1-kp21
	tmp3 <- lamp2-kp21
	tmp4 <- exp(-lamp1*times)
	tmp5 <- exp(-lamp2*times)
	tmp6 <- exp(-lamp1*end)
	tmp7 <- exp(-lamp2*end)
	tmp8 <- tmp4/tmp6
	tmp9 <- tmp5/tmp7
	tmp10 <- sqrt((kem+km12+km21)^2-4*km21*kem)
	lamm1 <- 0.5*(kem+km12+km21+tmp10)
	lamm2 <- 0.5*(kem+km12+km21-tmp10)
	tmp11 <- kem-lamm1
	tmp12 <- kem-lamm2
        tmp13 <- lamp1-lamm2
        tmp14 <- lamp1-lamm1
	tmp15 <- exp(-lamm1*times)
	tmp16 <- exp(-lamm2*times)
        tmp17 <- lamp1-km21
        tmp18 <- lamp2-km21
        tmp19 <- lamp2-lamm1
        tmp20 <- lamp2-lamm2
	tmp21 <- exp(-lamm1*end)
	tmp22 <- exp(-lamm2*end)
        tmp23 <- km21-lamp1
        tmp24 <- km21-lamp2
        tmp25 <- tmp15/tmp21
        tmp26 <- tmp16/tmp22
	pfp <- exp(p[9])
	lpfp <- pfp/(1+pfp)
	dose/Vp*(ind*((tmp2*(1-tmp4)/(lamp1*tmp1)-tmp3*(1-tmp5)/(lamp2*tmp1))*
		(times<=end)+(tmp2*(1-tmp6)*tmp8/(lamp1*tmp1)-tmp3*(1-tmp7)*
		tmp9/(lamp2*tmp1))*(times>end))+(1-ind)*(((1-exp(-kem*times))/
		kem*(times<=end)+(1-exp(-kem*end))/kem*exp(-kem*(times-end))*
		(times>end))/(1+pfp)+(kpm*((tmp2/tmp1*((tmp11*tmp16/
		tmp13-tmp12*tmp15/tmp14)/(kem*tmp10)+tmp17*tmp4/
		(lamp1*tmp14*tmp13)+1/(kem*lamp1))-tmp3/tmp1*((tmp12*tmp15/
		tmp19-tmp11*tmp16/tmp20)/(kem*(-tmp10))+tmp18*tmp5/
		(lamp2*tmp19*tmp20)+1/(kem*lamp2)))*(times<=end)+((-tmp2/
		(tmp1*tmp10)*(tmp12*tmp21/(kem*tmp14)+lamm2/(kem*lamp1)+
		tmp23/(lamp1*tmp14))+tmp3/(tmp1*tmp10)*(tmp12*tmp21/
		(kem*tmp19)+lamm2/(kem*lamp2)+tmp24/(lamp2*tmp19)))*tmp25+
		(+tmp2/(tmp1*tmp10)*(tmp11*tmp22/(kem*tmp13)+lamm1/(kem*lamp1)+
		tmp23/(lamp1*tmp13))-tmp3/(tmp1*tmp10)*( tmp11*tmp22/
		(kem*tmp20)+lamm1/(kem*lamp2)+tmp24/(lamp2*tmp20)))*tmp26
		+tmp2*tmp23*(1-tmp6)*tmp8/(lamp1*tmp1*tmp14*tmp13)
		-tmp3*tmp24*(1-tmp7)*tmp9/(lamp2*tmp1*tmp19*tmp20))*
		(times>end)))*lpfp))}
#
# first-order one-compartment first-pass model
# p[1]: log volume (V)
# p[2]: log parent drug absorption rate (kap)
# p[3]: log parent drug direct elimination rate (kep)
# p[4]: log transformation rate from parent to metabolite (kpm)
# p[5]: log metabolite first-pass elimination rate (kefp)
# p[6]: log metabolite elimination rate (kem)
# p[7]: logit of proportion going to first pass (pfp)
# ind:  indicator vector: 1 for parent, 0 for metabolite
mu2.1o1cfp <- function(p, times, dose=1, ind) {
	kap <- exp(p[2])
	kep <- exp(p[3])
	kefp <- exp(p[5])
	kem <- exp(p[6])
	pfp <- exp(p[7])
	lpfp <- pfp/(1+pfp)
	exp(p[2]-p[1])*dose*(ind*(exp(-kep*times)-exp(-kap*times))/
		(kap-kep)*lpfp+(1-ind)*((exp(-kefp*times)-exp(-kap*times))/
		(kap-kefp)/(1+pfp)+exp(p[4])*(exp(-kap*times)/(kap-kem)-
		exp(-kep*times)/(kep-kem)+(1/(kep-kem)-1/(kap-kem))*
		exp(-kem*times))/(kap-kep)*lpfp))}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     plot(profile(z, ...))
#     plot(iprofile(z, ...))
#     plot(residuals(z, ...))
#
#  DESCRIPTION
#
#    Utility functions for plotting repeated measurements profiles
# and residuals

profile <- function(z, ...) UseMethod("profile")

profile.default <- function(z, times=NULL, mu=NULL){
	if(is.null(mu)||!is.function(mu)){
		if(is.null(z$pred))stop("Fitted values not available")
		if(!is.null(z$transform)){
			if(z$transform=="exp")z$pred <- log(z$pred)
			else if(z$transform=="square")z$pred  <- sqrt(z$pred)
			else if(z$transform=="sqrt")z$pred <- z$pred^2
			else if(z$transform=="log")z$pred <- exp(z$pred)}
		z$ptimes <- z$response$times}
	else {
		z$ptimes <- if(is.null(times))seq(min(z$response$times),
			max(z$response$times),length.out=25) else times
		z$pred <- mu(z$coef,z$ptimes)}
	class(z) <- c("profile",class(z))
	invisible(z)}

plot.profile <- function(z, nind=1, intensity=F, add=F,
	ylim=range(z$pred,na.rm=T), lty=NULL, ylab=NULL, xlab=NULL, ...){
	if(max(nind)>length(z$response$nobs))stop("no such individual")
	if(inherits(z,"kalsurv")){
		for(i in 1:length(z$response$y))if(z$response$y[i]==0)
			z$response$y[i] <- z$response$y[i-1]
		if(is.null(xlab))xlab <- "Chronological time"
		if(intensity){
			z$pred <- 1/z$pred
			if(is.null(ylab))ylab <- "Mean intensity"}
		else if(is.null(ylab))ylab <- "Time between events"}
	else {
		if(is.null(xlab))xlab <- "Time"
		if(is.null(ylab))ylab <- "Fitted value"}
	if(length(z$ptimes)==length(z$response$times)){
		ns <- length(nind)
		ii <- covind(z$response)
		if(!is.null(lty)){
			if(length(lty)!=1&&length(lty)!=ns)
				stop("lty must have a value for each observation")
			else if(length(lty)==1)lty <- rep(lty,ns)}
		first <- !add
		j <- 0
		lt <- 0
		for(i in nind){
			if(is.null(z$response$nest)) kk <- nest <- 1
			else {
				nest <- unique(z$response$nest)
				kk <- z$response$nest}
			for(k in nest){
				j <- j+1
				if(is.null(lty)) lt <- (lt%%4)+1
				else lt <- lty[j]
				if(first){
					plot(z$ptimes[ii==i&kk==k],z$pred[ii==i&kk==k],type="l",ylim=ylim,lty=lt,xlab=xlab,ylab=ylab,...)
					first <- FALSE}
				else lines(z$ptimes[ii==i&kk==k],z$pred[ii==i&kk==k],lty=lt)}}}
	else {
		if(is.null(ylim))ylim <- c(min(z$pred),max(z$pred))
		if(is.null(lty))lty <- 1
		if(!add)plot(z$ptimes, z$pred, type="l", ylim=ylim, lty=lty,
			xlab=xlab, ylab=ylab, ...)
		else lines(z$ptimes, z$pred, lty=lty)}
	if(!is.null(z$pse)){
		lines(z$ptimes, z$pse[,1], lty=3)
		lines(z$ptimes, z$pse[,2], lty=3)}}

iprofile <- function(z, ...) UseMethod("iprofile")

iprofile.default <- function(z, plotsd=F){
	if(!inherits(z,"recursive"))
		stop("The object must have class, recursive")
	else if(is.null(z$rpred))stop("Individual profiles not available")
	if(!is.null(z$transform)){
                if(z$transform=="exp"){
                	if(plotsd){
                		sd1 <- log(z$rpred+2*z$sdr)
                		sd2 <- log(z$rpred-2*z$sdr)}
                	z$rpred <- log(z$rpred)}
                else if(z$transform=="square"){
                	if(plotsd){
                		sd1 <- sqrt(z$rpred+2*z$sdr)
                		sd2 <- sqrt(z$rpred-2*z$sdr)}
                	z$rpred  <- sqrt(z$rpred)}
                else if(z$transform=="sqrt"){
                	if(plotsd){
                		sd1 <- (z$rpred+2*z$sdr)^2
                		sd2 <- (z$rpred-2*z$sdr)^2}
                	z$rpred <- z$rpred^2}
                else if(z$transform=="log"){
                	if(plotsd){
                		sd1 <- exp(z$rpred+2*z$sdr)
                		sd2 <- exp(z$rpred-2*z$sdr)}
                	z$rpred <- exp(z$rpred)}
		else {
			sd1 <- z$rpred+2*z$sdr
			sd2 <- z$rpred-2*z$sdr}
		if(plotsd)z$psd <- cbind(sd1,sd2)}
	class(z) <- c("iprofile",class(z))
	invisible(z)}

plot.iprofile <- function(z, nind=1, observed=T, intensity=F, add=F, lty=NULL,
	pch=NULL, ylab=NULL, xlab=NULL, main=NULL, ylim=NULL, xlim=NULL, ...){
	if(max(nind)>length(z$response$nobs))stop("no such individual")
	if(inherits(z,"kalsurv")){
		for(i in 1:length(z$response$y))if(z$response$y[i]==0)
			z$response$y[i] <- z$response$y[i-1]
		if(is.null(xlab))xlab <- "Chronological time"
		if(intensity){
			z$rpred <- 1/z$rpred
			z$response$y <- 1/z$response$y
			if(is.null(ylab))ylab <- "Mean intensity"}
		else if(is.null(ylab))ylab <- "Time between events"}
	else {
		if(is.null(xlab))xlab <- "Time"
		if(is.null(ylab))ylab <- "Recursive fitted value"}
	if(is.null(ylim)&&!is.null(z$sdr)&&z$transform=="identity")
		ylim <- c(min(z$rpred-3*z$sdr,na.rm=T),max(z$rpred+3*z$sdr,na.rm=T))
	ns <- length(nind)
	ii <- covind(z$response)
	pc <- -1
	lt <- 0
	first <- !add
	if(is.null(main))
		main <- ifelse(ns==1,paste("Individual ",nind),"")
	if(is.null(ylim))ylim <- c(min(c(z$rpred,z$response$y),na.rm=T),
		max(c(z$rpred,z$response$y),na.rm=T))
	if(is.null(xlim))xlim <- c(min(z$resp$times),max(z$resp$times))
	if(!is.null(lty)){
		if(length(lty)!=1&&length(lty)!=ns)
			stop("lty must have a value for each observation")
		else if(length(lty)==1)lty <- rep(lty,ns)}
	if(!is.null(pch)){
		if(length(pch)!=1&&length(pch)!=ns)
			stop("pch must have a value for each observation")
		else if(length(pch)==1)pch <- rep(pch,ns)}
	na <- !is.na(z$rpred)
	j <- 0
	for(i in nind){
		if(is.null(z$response$nest)) kk <- nest <- 1
		else {
			nest <- unique(z$response$nest)
			kk <- z$response$nest}
		for(k in nest){
			j <- j+1
			if(is.null(pch))pc <- (pc+1)%%4
			else pc <- pch[j]
			if(is.null(lty)) lt <- (lt%%4)+1
			else lt <- lty[j]
			if(first){
				plot(z$resp$times[ii==i&kk==k&na],z$rpred[ii==i&kk==k&na],type="l",lty=lt,ylab=ylab,xlab=xlab,main=main,ylim=ylim,xlim=xlim,...)
				first <- F}
			else {
				if(k==1)lines(z$resp$times[ii==i&kk==k&na],z$rpred[ii==i&kk==k&na],lty=lt)
				else lines(z$resp$times[ii==i&kk==k&na],c(z$pred[ii==i&kk==k&na][1],z$rpred[ii==i&kk==k&na][-1]),lty=lt)}
			if(observed)points(z$resp$times[ii==i&kk==k],z$resp$y[ii==i&kk==k],pch=pc)
			if(!is.null(z$psd)){
				lines(z$resp$times[ii==i&kk==k&na],z$psd[ii==i&kk==k&na,1],lty=3)
				lines(z$resp$times[ii==i&kk==k&na],z$psd[ii==i&kk==k&na,2],lty=3)}}}}

plot.residuals <- function(z, x=NULL, subset=NULL, ccov=NULL,
	nind=NULL, recursive=TRUE, pch=20, ylab="Residual",
	xlab=NULL, main=NULL, ...){
	na <- TRUE
	reps <- !is.null(z$response$y)
	if(!reps){
		nind <- ccov <- NULL
		recursive <- FALSE}
	if(is.character(x))x <- match.arg(x,c("response","fitted"))
	if(reps){
		n <- length(z$response$y)
		res <- if(inherits(z,"recursive"))
			residuals(z, recursive=recursive) else residuals(z)
		if(inherits(z,"kalsurv"))for(i in 1:length(z$response$y))
			if(z$response$y[i]==0)
				z$response$y[i] <- z$response$y[i-1]}
	else {
		res <- residuals(z)
		n <- length(res)}
	if(is.null(subset))subset <- rep(TRUE,n)
	else {
		tmp <- rep(FALSE,n)
		tmp[subset] <- TRUE
		subset <- tmp}
	if(reps&&!is.null(nind)){
		if(is.null(subset))subset <- rep(FALSE,n)
		for(i in nind)subset <- subset|covind(z)==i}
	if(is.null(x)){
		x <- z$response$times
		if(is.null(x))stop("x must be specified")
		if(is.null(xlab))xlab <- "Time"}
	else if(is.numeric(x)){
		if(length(x)!=n)
			stop("x variable must have same length as residuals")
		if(is.null(xlab))xlab <- paste(deparse(substitute(x)))}
	else if(x=="response"){
		x <- if(reps)z$response$y else z$y
		if(is.null(x))stop("response variable not found")
		if(is.null(xlab))xlab <- "Response"}
	else if(x=="fitted"){
		x <- if(reps) fitted(z, recursive=recursive) else fitted(z)
		na <- !is.na(x)
		if(is.null(xlab))xlab <- "Fitted values"}
	if(is.null(ccov))
		plot(x[subset&na], res[subset&na], pch=pch, ylab=ylab,
			xlab=xlab, main=main, ...)
	else if(length(ccov)>1)stop("Only one covariate can be specified")
	else {
		mat <- match(ccov,colnames(z$response$ccov))
		if(is.na(mat))stop("covariate not found")
		un <- unique(z$response$ccov[,mat])
		tmp <- par()$mfg[3:4]
		ss <- ceiling(sqrt(length(un)))
		if(length(un)==ss*(ss-1))ss1 <- ss-1
		else ss1 <- ss
		par(mfrow=c(ss,ss1))
		for(i in un){
			ind <- (1:sum(z$response$nobs))[rep(z$response$ccov[,ccov],z$resp$nobs)==i]
			main <- paste("Covariate ",cov,"=",i)
			plot(x[subset&ind&na],res[subset&ind&na],
				pch=pch,ylab=ylab,xlab=xlab,main=main,...)}
		par(mfrow=tmp)}}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  DESCRIPTION
#
#    Utility functions for printing repeated measurements results

residuals.gnlr <- function(z) z$residuals
fitted.values.gnlr <- function(z) z$fitted.values
coefficients.gnlr <- function(z) z$coefficients
weights.gnlr <- function(z) z$prior.weights
df.residual.gnlr <- function(z) z$df
deviance.gnlr <- function(z) 2*z$maxlike

print.gnlr <- function(z) {
	sht <- z$nps>0||!is.null(z$shape)
	mix <- z$npm>0||!is.null(z$mix)
	gnlmm <- !is.null(z$points)
	censor <- if(mix)!is.null(z$censor) else z$censor
	npl <- z$npl-gnlmm
	np1 <- z$npl+1
	np1a <- z$npl+z$npm+1
	np2 <- z$npl+z$npm+z$nps
	np3 <- np2+1
	np <- z$npl+z$npm+z$nps+z$npf
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	if(mix&&censor)cat(z$censor,"")
	if(censor)cat("censored ")
	if(z$npf>0&(z$dist=="inverse Gauss"|z$dist=="logistic"|z$dist=="gamma"|z$dist=="Weibull"|z$dist=="extreme value"))
		cat("generalized ")
	cat(z$dist,"distribution\n\n")
	if(gnlmm){
		cat(" with normal mixing distribution on",z$scale,"scale\n")
		cat(" (",z$points," point Gauss-Hermite integration)\n\n",sep="")}
	t <- deparse(z$likefn)
	cat("Log likelihood function:",t[2:length(t)],"",sep="\n")
	if(z$npl>0){
		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(inherits(z$linear[[1]],"formulafn"))
			cat("Linear part: ",deparse(attr(z$linear[[1]],"formula")),sep="\n")}
	if(mix){
		cat("\nMixture function:\n")
		if(!is.null(attr(z$mix,"formula")))cat(deparse(attr(z$mix,"formula")),sep="\n")
		else if(!is.null(attr(z$mix,"model"))){
			t <- deparse(attr(z$mix,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		if(inherits(z$linear[[2]],"formulafn"))
			cat("Linear part: ",deparse(attr(z$linear[[2]],"formula")),sep="\n")}
	if(sht){
		if(!mix){
			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(inherits(z$linear[[2]],"formulafn"))
				cat("Linear part: ",deparse(attr(z$linear[[2]],"formula")),sep="\n")}
		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(inherits(z$linear[[3]],"formulafn"))
				cat("Linear part: ",deparse(attr(z$linear[[3]],"formula")),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")
	if(npl>0){
		if(z$common)cat("Common parameters:\n")
		else cat("Location parameters:\n")
		cname <- if(is.matrix(attr(z$mu,"model")))colnames(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$linear[[1]])&&!is.null(attr(z$linear[[1]],"parameters")))cname <- c(cname,colnames(attr(z$linear[[1]],"model")))
		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 <- NULL}}
	if(z$npm>0){
		if(!z$common)cat("\nMixture parameters:\n")
		cname <- c(cname,if(is.matrix(attr(z$mix,"model")))colnames(attr(z$mix,"model"))
			else if(length(grep("linear",attr(z$mix,"parameters")))>0)
			attr(z$mix,"parameters")[grep("\\[",attr(z$mix,"parameters"))]
			else attr(z$mix,"parameters"))
		if(!is.null(z$linear[[2]])&&!is.null(attr(z$linear[[2]],"parameters")))cname <- c(cname,colnames(attr(z$linear[[2]],"model")))
		if(!z$common)coef.table <- cbind(z$coefficients[np1:(np-sht)],z$se[np1:(np-sht)])
		dimnames(coef.table) <- list(cname, c("estimate", "se"))
		print.default(coef.table,digits=4,print.gap=2)}
	if(z$common||z$nps>0){
		cname <- c(cname,if(z$npm>0)" "
			else if(is.matrix(attr(z$shape,"model")))colnames(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$linear[[2]])&&!is.null(attr(z$linear[[2]],"parameters")))cname <- c(cname,colnames(attr(z$linear[[2]],"model")))
		if(!z$common)coef.table <- cbind(z$coefficients[np1a:np2],z$se[np1a:np2])
		if(z$common){
			dimnames(coef.table) <- list(unique(cname), c("estimate", "se"))
			print.default(coef.table,digits=4,print.gap=2)}}
	if(gnlmm){
		cat("\nMixing standard deviation:\n")
		coef.table <- cbind(z$coefficients[z$npl],z$se[z$npl])
		dimnames(coef.table) <- list(" ", c("estimate", "se"))
		print.default(coef.table, digits=4, print.gap=2)}
	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(z$npf>0||!is.null(z$family)){
		if(!z$common)cat("\nFamily parameters:\n")
		cname <- c(cname,if(is.matrix(attr(z$family,"model")))colnames(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$linear[[3]])&&!is.null(attr(z$linear[[3]],"parameters")))cname <- c(cname,colnames(attr(z$linear[[3]],"model")))
		if(z$common)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(np>1){
		cat("\nCorrelations:\n")
		dimnames(z$corr) <- list(seq(1,np),seq(1,np))
		print.default(z$corr, digits=4)}
	invisible(z)}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     read.list(file="", skip=0, nlines=2, order=NULL)
#     read.surv(file="", skip=0, nlines=1, cumulative=T, all=T)
#
#  DESCRIPTION
#
#    Utility functions for reading repeated measurements data

read.list <- function(file="", skip=0, nlines=2, order=NULL){
	if(!is.null(order)){
		if(length(order)!=nlines)
			stop("order must have length",nlines,"\n")
		else if(range(order)!=c(1,nlines))
			stop("order must have values in",1:nlines,"\n")}
	continue <- T
	result <- list()
	while(continue){
		x <- scan(file,skip=skip,nlines=nlines,quiet=T)
		skip <- skip+nlines
		if(length(x)==0)continue <- F
		else {
			tmp <- matrix(x,ncol=nlines)
			if(!is.null(order))tmp <- tmp[,order]
			result <- c(result,list(tmp))}}
	invisible(result)}

read.surv <- function(file="", skip=0, nlines=1, cumulative=T, all=T){
	continue <- T
	result <- list()
	censor <- NULL
	while(continue){
		x <- scan(file,skip=skip,nlines=nlines,quiet=T)
		skip <- skip+nlines
		if(length(x)==0)continue <- F
		else {
			if(all)mm <- matrix(x,ncol=2,byrow=T)[,1]
			else mm <- x[1:(length(x)-1)]
			if(cumulative)mm <- c(mm[1],diff(mm))
			result <- c(result,list(mm))
			censor <- c(censor,x[length(x)])}}
	invisible(list(result,censor))}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     wr(formula)
#     det(x)
#     collapse(x,index,fcn=sum)
#     mexp(x, t=1, n=20, k=3)
#
#  DESCRIPTION
#
#    Utility functions for repeated measurements

wr <- function(formula){
	mt <- terms(formula)
	mf <- model.frame(mt, sys.frame(sys.parent()), na.action=na.fail)
	list(response=model.response(mf, "numeric"),
		design=model.matrix(mt, mf))}

# det <- function(x) abs(Re(prod(eigen(x,only.values=T)$values)))
det <- function(x) abs(prod(diag(qr(x)$qr)))

collapse <- function(x,index,fcn=sum){
	ans <- NULL
	for(i in split(x,index))ans <- c(ans,fcn(i))
	ans}

mexp <- function(x, type="spectral decomposition", t=1, n=20, k=3){
	if(!is.matrix(x))stop("x must be a matrix")
	if(length(dim(x))!=2)stop("x must be a two dimensional matrix")
	if(dim(x)[1]!=dim(x)[2])stop("x must be a square matrix")
	type <- match.arg(type,c("spectral decomposition","series approximation"))
	d <- ncol(x)
	if(type=="spectral decomposition"){
		z <- eigen(t*x,sym=F)
		p <- z$vectors%*%diag(exp(z$values))%*%solve(z$vectors)}
	else {
		xx <- x*t/2^k
		p <- diag(d)
		q <- p
		for(r in 1:n){
			q <- xx%*%q/r
			p <- p+q}
		for(i in 1:k) p <- p%*%p}
	p}
