.packageName <- "rmutil"
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     contr.mean(n, contrasts=TRUE)
#
#  DESCRIPTION
#
#    A function to provide correct constraints about the mean
#  (correcting contr.sum)

contr.mean <- function(n, contrasts=TRUE){
	if(length(n) <= 1){
		if(is.numeric(n)&&length(n)==1&&n>1)levels <- 1:n
		else stop("Not enough degrees of freedom to define contrasts")}
	else levels <- n
	lenglev <- length(levels)
	if(contrasts){
		cont <- array(0,c(lenglev,lenglev-1),
			list(levels,levels[1:(lenglev-1)]))
		cont[col(cont)==row(cont)] <- 1
		cont[lenglev,] <- -1}
	else {
		cont <- array(0,c(lenglev,lenglev),list(levels,levels))
		cont[col(cont) == row(cont)] <- 1}
	cont}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     runge.kutta(f, initial, x)
#     lin.diff.eqn(A, initial, t=1)
#
#  DESCRIPTION
#
#	Functions for solving differential equations

###    Runge-Kutta method for solving a differential equation
###
runge.kutta <- function(f, initial, x){
if(!is.function(f))stop("f must be a function")
if(!is.numeric(initial)||length(initial)!=1)stop("initial must be a scalar")
if(!is.vector(x,mode="numeric"))stop("x must be a numeric vector")
y <- initial
for(i in 1:(length(x)-1)){
	stepsize <- x[i+1]-x[i]
	f1 <- stepsize*f(y[i],x[i])
	f2 <- stepsize*f(y[i]+f1/2,x[i]+stepsize/2)
	f3 <- stepsize*f(y[i]+f2/2,x[i]+stepsize/2)
	f4 <- stepsize*f(y[i]+f3,x[i]+stepsize)
	y <- c(y,y[i]+(f1+2*f2+2*f3+f4)/6)}
y
}

### autonomous linear differential equations
###
lin.diff.eqn <- function(A, initial, t=1){
if(!is.matrix(A)||dim(A)[1]!=dim(A)[2])stop("A must be a square matrix")
if(!is.vector(initial,mode="numeric")||length(initial)!=dim(A)[1])
	stop("initial must be a numeric vector with length equal to the dimensions of A")
if(!is.vector(t,mode="numeric"))stop("t must be a numeric scalar or vector")
z <- NULL
for(i in 1:length(t))z <- cbind(z,mexp(A,t=t[i])%*%initial)
t(z)
}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     pinvgauss(q, m, s)
#     dinvgauss(y, m, s, log=FALSE)
#     qinvgauss(p, m, s)
#     rinvgauss(n, m, s)
#     plaplace(q, m=0, s=1)
#     dlaplace(y, m=0, s=1)
#     qlaplace(p, m=0, s=1)
#     rlaplace(n, m=0, s=1)
#     plevy(q, m=0, s=1)
#     dlevy(y, m=0, s=1)
#     qlevy(p, m=0, s=1)
#     rlevy(n, m=0, s=1)
#     ppareto(q, m, s)
#     dpareto(y, m, s)
#     qpareto(p, m, s)
#     rpareto(n, m, s)
#     psimplex(q, m, s)
#     dsimplex(y, m, s)
#     qsimplex(p, m, s)
#     rsimplex(n, m, s)
#     ptwosidedpower(q, m, s=2)
#     dtwosidedpower(y, m, s=2)
#     qtwosidedpower(p, m, s=2)
#     rtwosidedpower(n, m, s=2)
#
#     pboxcox(q, m=0, s=1, f=1)
#     dboxcox(y, m=0, s=1, f=1)
#     qboxcox(p, m=0, s=1, f=1)
#     rboxcox(n, m=0, s=1, f=1)
#     pburr(q, m, s, f)
#     dburr(y, m, s, f)
#     qburr(p, m, s, f)
#     rburr(n, m, s, f)
#     pgextval(q, s, m, f)
#     dgextval(y, s, m, f)
#     qgextval(p, s, m, f)
#     rgextval(n, s, m, f)
#     pggamma(q, s, m, f)
#     dggamma(y, s, m, f)
#     qggamma(p, s, m, f)
#     rggamma(n, s, m, f)
#     pginvgauss(q, m, s, f)
#     dginvgauss(y, m, s, f)
#     qginvgauss(p, m, s, f)
#     rginvgauss(n, m, s, f)
#     pglogis(q, m=0, s=1, f=1)
#     dglogis(y, m=0, s=1, f=1)
#     qglogis(p, m=0, s=1, f=1)
#     rglogis(n, m=0, s=1, f=1)
#     pgweibull(q, s, m, f)
#     dgweibull(y, s, m, f)
#     qgweibull(p, s, m, f)
#     rgweibull(n, s, m, f)
#     phjorth(q, m, s, f)
#     dhjorth(y, m, s, f)
#     qhjorth(p, m, s, f)
#     rhjorth(n, m, s, f)
#     ppowexp(q, m=0, s=1, f=1)
#     dpowexp(y, m=0, s=1, f=1)
#     qpowexp(p, m=0, s=1, f=1)
#     rpowexp(n, m=0, s=1, f=1)
#     pskewlaplace(q, m=0, s=1, f=1)
#     dskewlaplace(y, m=0, s=1, f=1)
#     qskewlaplace(p, m=0, s=1, f=1)
#     rskewlaplace(n, m=0, s=1, f=1)
#
#     pbetabinom(q, size, m, s)
#     dbetabinom(y, size, m, s)
#     qbetabinom(p, size, m, s)
#     rbetabinom(n, size, m, s)
#     pdoublebinom(q, size, m, s)
#     ddoublebinom(y, size, m, s)
#     qdoublebinom(p, size, m, s)
#     rdoublebinom(n, size, m, s)
#     pmultbinom(q, size, m, s)
#     dmultbinom(y, size, m, s)
#     qmultbinom(p, size, m, s)
#     rmultbinom(n, size, m, s)
#     pdoublepois(q, m, s)
#     ddoublepois(y, m, s)
#     qdoublepois(p, m, s)
#     rdoublepois(n, m, s)
#     pmultpois(q, m, s)
#     dmultpois(y, m, s)
#     qmultpois(p, m, s)
#     rmultpois(n, m, s)
#     ppvfpois(q, m, s, f)
#     dpvfpois(y, m, s, f)
#     qpvfpois(p, m, s, f)
#     rpvfpois(n, m, s, f)
#     pgammacount(q, m, s)
#     dgammacount(y, m, s)
#     qgammacount(p, m, s)
#     rgammacount(n, m, s)
#     pconsul(q, m, s)
#     dconsul(y, m, s)
#     qconsul(p, m, s)
#     rconsul(n, m, s)
#
#  DESCRIPTION
#
#    Functions to compute the probability and cumulative probability
# functions for
# continuous two parameter distributions:
#  inverse Gaussian, Laplace, Levy, Pareto, simplex
# continuous three parameter distributions:
#  Box-Cox, Burr, generalized extreme value, generalized gamma, generalized
#  inverse Gaussian, generalized logistic, generalized Weibull, Hjorth,
#  power exponential, skew Laplace
# discrete two parameter distributions:
#  double Poisson, multiplicative Poisson, double binomial, Consul,
#  multiplicative binomial, beta binomial 

### continuous two-parameter distributions
###
### inverse Gaussian distribution
###
pinvgauss <- function(q, m, s){
if(any(q<=0))stop("q must contain positive 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, log=FALSE){
if(any(y<=0))stop("y must contain positive values")
if(any(m<=0))stop("m must be positive")
if(any(s<=0))stop("s must be positive")
tmp <- -(y-m)^2/(2*y*s*m^2)-(log(2*pi*s)+3*log(y))/2
if(!log)tmp <- exp(tmp)
tmp}

qinvgauss <- function(p, m, s){
h <- function(y){
	t <- y/m[i]
	v <- sqrt(y*s[i])
	pnorm((t-1)/v)+exp(2/(m[i]*s[i]))*pnorm(-(t+1)/v)-p[i]}
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0.001,20)
	while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
	tmp[i] <- uniroot(h,interval)$root}
tmp}

rinvgauss <- function(n=1, m, s) qinvgauss(runif(n),m=m,s=s)

### Laplace distribution
###
plaplace <- function(q, m=0, s=1){
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, log=FALSE){
if(any(s<=0))stop("s must be positive")
tmp <- -abs(y-m)/s-log(2*s)
if(!log)tmp <- exp(tmp)
tmp}

qlaplace <- function(p, m=0, s=1){
h <- function(y){
	u <- (y-m[i])/s[i]
	t <- exp(-abs(u))/2
	ifelse(u<0,t,1-t)-p[i]}
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
ifelse(p<0.5,s*log(2*p)+m,-s*log(2*(1-p))+m)}

rlaplace <- function(n=1, m, s){
if(any(s<0))stop("s must be positive")
q <- runif(n)
ifelse(q<0.5,s*log(2*q)+m,-s*log(2*(1-q))+m)}

### Levy distribution
###
plevy <- function(q, m=0, s=1){
if(any(q<=m))stop("some y <= m")
if(any(s<=0))stop("s must be positive")
2*(1-pnorm(1/sqrt((q-m)/s)))}

dlevy <- function(y, m=0, s=1, log=FALSE){
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)))}
tmp <- log(s/(2*pi))/2-3*log(y-m)/2-s/(2*(y-m))
if(!log)tmp <- exp(tmp)
tmp}

qlevy <- function(p, m=0, s=1){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
s/qnorm(1-p/2)^2+m}

rlevy <- function(n=1, m=0, s=1) {
if(any(s<0))stop("s must be positive")
s/qnorm(1-runif(n)/2)^2+m}

### Pareto distribution
###
ppareto <- function(q, m, s){
if(any(q<0))stop("q must be >= 0")
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, log=FALSE){
if(any(y<0))stop("y must be >= 0")
if(any(m<=0))stop("m must be positive")
if(any(s<=1))stop("s must be > 1")
m <- m*(s-1)
tmp <- log(s)-(s+1)*log(1+y/m)-log(m)
if(!log)tmp <- exp(tmp)
tmp}

qpareto <- function(p, m, s){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<=1))stop("s must be >1")
((1-p)^(-1/s)-1)*m*(s-1)}

rpareto <- function(n=1, m, s){
if(any(m<=0))stop("m must be positive")
if(any(s<=1))stop("s must be >1")
((1-runif(n))^(-1/s)-1)*m*(s-1)}

### simplex distribution
###
psimplex <- function(q, m, s){
if(any(q<=0)||any(q>=1))stop("q must contain values between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must contain values between 0 and 1")
if(any(s<=0))stop("s must be positive")
len <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
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("psimplex",
	as.double(q),
	as.double(m),
	as.double(s),
	as.double(1),
	len=as.integer(len),
	eps=as.double(1.0e-6),
	pts=as.integer(5),
	max=as.integer(16),
	err=integer(1),
	res=double(len),
	DUP=FALSE,
	PACKAGE="rmutil")
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}

dsimplex <- function(y, m, s, log=FALSE){
if(any(y<=0)||any(y>=1))stop("y must contain values between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must contain values between 0 and 1")
if(any(s<=0))stop("s must be positive")
tmp <- -((y-m)/(m*(1-m)))^2/(2*y*(1-y)*s)-(log(2*pi*s)+3*(log(y)+log(1-y)))/2
if(!log)tmp <- exp(tmp)
tmp}

qsimplex <- function(p, m, s){
h <- function(y).C("psimplex",
	as.double(y),
	as.double(m[i]),
	as.double(s[i]),
	as.double(1),
	len=as.integer(1),
	eps=as.double(1.0e-6),
	pts=as.integer(5),
	max=as.integer(16),
	err=integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must contain values between 0 and 1")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0.001,0.999)
	while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
	tmp[i] <- uniroot(h,interval)$root}
tmp}

rsimplex <- function(n=1, m, s) qsimplex(runif(n),m=m,s=s)

### two-sided power distribution
###
ptwosidedpower <- function(q, m, s=2){
if(any(q<=0)||any(q>=1))stop("q must contain values between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must contain values between 0 and 1")
if(any(s<=0))stop("s must be positive")
ifelse(q<m,m*(q/m)^s,1-(1-m)*((1-q)/(1-m))^s)}

dtwosidedpower <- function(y, m, s=2, log=FALSE){
if(any(y<=0)||any(y>=1))stop("y must contain values between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must contain values between 0 and 1")
if(any(s<=0))stop("s must be positive")
tmp <- log(s)+(s-1)*ifelse(y<m,log(y)-log(m),log(1-y)-log(1-m))
if(!log)tmp <- exp(tmp)
tmp}

qtwosidedpower <- function(p, m, s=2){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must contain values between 0 and 1")
if(any(s<0))stop("s must be positive")
ifelse(p<m,m*(p/m)^(1/s),1-(1-m)*((1-p)/(1-m))^(1/s))}

rtwosidedpower <- function(n, m, s=2) qtwosidedpower(runif(n),m=m,s=s)

### continuous three-parameter distributions
###
### Box-Cox distribution
### normed to make it a real distribution with y > 0
###
pboxcox <- function(q, m, s=1, f=1){
if(any(q<=0))stop("q must contain positive 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))
(pnorm(q^f/f,m,sqrt(s))-(f>0)*norm)/(1-(f<0)-norm)}

dboxcox <- function(y, m, s=1, f=1, log=FALSE){
if(any(y<=0))stop("y must contain positive 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))
tmp <- (f-1)*log(y)+dnorm(y^f/f,m,sqrt(s),log=TRUE)-log(1-(f<0)-norm)
if(!log)tmp <- exp(tmp)
tmp}

qboxcox <- function(p, m, s=1, f=1){
h <- function(y){
	norm <- sign(f[i])*pnorm(0,m[i],sqrt(s[i]))
	(pnorm(y^f[i]/f[i],m[i],sqrt(s[i]))-(f[i]>0)*norm)/
		(1-(f[i]<0)-norm)-p[i]}
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s),length(f))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
if(length(f)!=len){
	if(length(f)==1)f <- rep(f,len)
	else stop("length of f incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0.001,20)
	while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
	tmp[i] <- uniroot(h,interval)$root}
tmp}

rboxcox <- function(n=1, m, s=1, f=1) qboxcox(runif(n),m=m,s=s,f=f)

### Burr distribution
###
pburr <- function(q, m, s, f){
if(any(q<=0))stop("q must contain positive 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}

dburr <- function(y, m, s, f, log=FALSE){
if(any(y<=0))stop("y must contain positive 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
tmp <- log(f*s)+(s-1)*log(y1)-log(m)-(f+1)*log(1+y1^s)
if(!log)tmp <- exp(tmp)
tmp}

qburr <- function(p, m, s, f){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
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-p)^(-1/f)-1)^(1/s)*m}

rburr <- function(n=1, m, s, f){
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-runif(n))^(-1/f)-1)^(1/s)*m}

### generalized extreme value distribution
### normed to make it a real distribution with y > 0
###
pgextval <- function(q, s, m, f){
if(any(q<=0))stop("q must contain positive 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+ind*norm)/(1-ind+norm)}

dgextval <- function(y, s, m, f, log=FALSE){
if(any(y<=0))stop("y must contain positive 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)
y1 <- exp(y^f/f)
tmp <- (f-1)*log(y)+log(y1)+dweibull(y1,s,m,log=TRUE)-log(1-(f>0)+norm)
if(!log)tmp <- exp(tmp)
tmp}

qgextval <- function(p, s, m, f){
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
(f*log(qweibull(p*(1-ind+norm)+ind-ind*norm,s,m)))^(1/f)}

rgextval <- function(n=1, s, m, f){
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
(f*log(qweibull(runif(n)*(1-ind+norm)+ind-ind*norm,s,m)))^(1/f)}

### generalized gamma distribution
###
pggamma <- function(q, s, m, f){
if(any(q<=0))stop("q must contain positive 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,scale=(m/s)^f)}

dggamma <- function(y, s, m, f, log=FALSE){
if(any(y<=0))stop("y must contain positive 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")
tmp <- log(f)+(f-1)*log(y)+dgamma(y^f,s,scale=(m/s)^f,log=TRUE)
if(!log)tmp <- exp(tmp)
tmp}

qggamma <- function(p, s, m, f) {
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")
qgamma(p,s,scale=(m/s)^f)^(1/f)}

rggamma <- function(n=1, s, m, f){
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")
qgamma(runif(n),s,scale=(m/s)^f)^(1/f)}

### generalized inverse Gaussian distribution
###
pginvgauss <- function(q, m, s, f){
if(any(q<=0))stop("q must contain positive values")
if(any(m<=0))stop("m must be positive")
if(any(s<=0))stop("s must be positive")
len <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
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=FALSE,
	PACKAGE="rmutil")
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, log=FALSE){
if(any(y<=0))stop("y must contain positive values")
if(any(m<=0))stop("m must be positive")
if(any(s<=0))stop("s must be positive")
tmp <- (f-1)*log(y)-(1/y+y/m^2)/(2*s)-f*log(m)-log(2*besselK(1/(s*m),abs(f)))
if(!log)tmp <- exp(tmp)
tmp}

qginvgauss <- function(p, m, s, f){
h <- function(y).C("pginvgauss",
	as.double(y),
	as.double(m[i]),
	as.double(s[i]),
	as.double(f[i]),
	len=as.integer(1),
	eps=as.double(1.0e-6),
	pts=as.integer(5),
	max=as.integer(16),
	err=integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<=0))stop("s must be positive")
len <- max(length(p),length(m),length(s),length(f))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
if(length(f)!=len){
	if(length(f)==1)f <- rep(f,len)
	else stop("length of f incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0.001,20)
	while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
	tmp[i] <- uniroot(h,interval)$root}
tmp}

rginvgauss <- function(n=1, m, s, f) qginvgauss(runif(n),m=m,s=s,f=f)

### generalized logistic distribution
###
pglogis <- 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")
(1+exp(-sqrt(3)*(q-m)/(s*pi)))^-f}

dglogis <- function(y, m=0, s=1, f=1, log=FALSE) {
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))
tmp <- log(3)/2+log(f*y1)-log(pi*s)-(f+1)*log(1+y1)
if(!log)tmp <- exp(tmp)
tmp}

qglogis <- function(p, m=0, s=1, f=1){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(s<=0))stop("s must be positive")
if(any(f<=0))stop("f must be positive")
-log(p^(-1/f)-1)*s*pi/sqrt(3)+m}

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

### generalized Weibull distribution
###
pgweibull <- function(q, s, m, f){
if(any(q<=0))stop("q must contain positive 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, log=FALSE){
if(any(y<=0))stop("y must contain positive 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)
tmp <- log(s*f)+(s-1)*log(y)+(f-1)*log(1-y1)+log(y1)-s*log(m)
if(!log)tmp <- exp(tmp)
tmp}

qgweibull <- function(p, s, m, f){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
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")
m*(-log(1-p^(1/f)))^(1/s)}

rgweibull <- function(n=1, s, m, f){
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")
m*(-log(1-runif(n)^(1/f)))^(1/s)}

### Hjorth distribution
###
phjorth <- function(q, m, s, f){
if(any(q<=0))stop("q must contain positive 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, log=FALSE){
if(any(y<=0))stop("y must contain positive values")
if(any(m<=0))stop("m must be positive")
if(any(s<=0))stop("s must be positive")
tmp <- -(f/s)*log(1+s*y)-(y/m)^2/2+log(y/m^2+f/(1+s*y))
if(!log)tmp <- exp(tmp)
tmp}

qhjorth <- function(p, m, s, f){
h <- function(y) 1-(1+s[i]*y)^(-f[i]/s[i])*exp(-(y/m[i])^2/2)-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s),length(f))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
if(length(f)!=len){
	if(length(f)==1)f <- rep(f,len)
	else stop("length of f incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0.001,20)
	while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
	tmp[i] <- uniroot(h,interval)$root}
tmp}

rhjorth <- function(n=1, m, s, f) qhjorth(runif(n),m=m,s=s,f=f)

### power exponential distribution
###
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 <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
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=FALSE,
	PACKAGE="rmutil")
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, log=FALSE){
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)
tmp <- -(abs(y-m)/s)^(2*f)/2-log(s)-lgamma(b)-b*log(2)
if(!log)tmp <- exp(tmp)
tmp}

qpowexp <- function(p, m=0, s=1, f=1){
h <- function(y) {
	z <- .C("ppowexp",
	        as.double(y),
	        as.double(m[i]),
	        as.double(s[i]),
	        as.double(f[i]),
	        len=as.integer(1),
	        eps=as.double(1.0e-6),
	        pts=as.integer(5),
	        max=as.integer(16),
	        err=integer(1),
	        res=double(1),
	        DUP=FALSE,
		PACKAGE="rmutil")$res
	if(y-m[i]>0) 0.5+z-p[i] else 0.5-z-p[i]}
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
if(any(f<=0))stop("f must be positive")
len <- max(length(p),length(m),length(s),length(f))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
if(length(f)!=len){
	if(length(f)==1)f <- rep(f,len)
	else stop("length of f incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- m[i]+s[i]*c(-2,2)
	while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
	tmp[i] <- uniroot(h,interval)$root}
tmp}

rpowexp <- function(n=1, m=0, s=1, f=1) qpowexp(runif(n),m=m,s=s,f=f)

### skew Laplace distribution
###
pskewlaplace <- 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")
u <- (q-m)/s
ifelse(u>0,1-exp(-f*abs(u))/(1+f^2),f^2*exp(-abs(u)/f)/(1+f^2))}

dskewlaplace <- function(y, m=0, s=1, f=1, log=FALSE){
if(any(s<=0))stop("s must be positive")
if(any(f<=0))stop("f must be positive")
tmp <- log(f)+ifelse(y>m,-f*(y-m),(y-m)/f)/s-log((1+f^2)*s)
if(!log)tmp <- exp(tmp)
tmp}

qskewlaplace <- function(p, m=0, s=1, f=1){
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
if(any(f<=0))stop("f must be positive")
ifelse(p<0.5,f*s*log((1+f^2)*p/f^2)+m,-s*log((1+f^2)*(1-p))/f+m)}

rskewlaplace <- function(n=1, m=0, s=1, f=1){
if(any(s<0))stop("s must be positive")
if(any(f<=0))stop("f must be positive")
q <- runif(n)
ifelse(q<0.5,f*s*log((1+f^2)*q/f^2)+m,-s*log((1+f^2)*(1-q))/f+m)}

### discrete (overdispersed) two-parameter distributions
###
### beta-binomial distribution
###
pbetabinom <- function(q, size, m, s){
if(any(q<0))stop("q must contain non-negative values")
if(any(size<0))stop("size must contain non-negative values")
if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
if(any(s<=0))stop("s must be positive")
len <- max(length(q),length(m),length(s),length(size))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
if(length(size)!=len){
	if(length(size)==1)size <- rep(size,len)
	else stop("size must be the same length as q")}
if(any(q>size))stop("q must be <= size")
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("m and q must have the same length")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("s and q must have the same length")}
t <- s*m
u <- s*(1-m)
res <- vector("numeric",length(q))
for(i in 1:length(q)){
	qq <- 0:q[i]
	res[i] <- sum(exp(lbeta(qq+t[i],size[i]-qq+u[i])-
		lbeta(t[i],u[i])+lchoose(size[i],qq)))}
res}

dbetabinom <- function(y, size, m, s, log=FALSE){
if(any(y<0))stop("y must contain non-negative values")
if(any(size<0))stop("size must contain non-negative values")
if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
if(any(s<=0))stop("s must be positive")
ly <- max(length(y),length(m),length(s),length(size))
if(length(y)!=ly){
	if(length(y)==1)y <- rep(y,ly)
	else stop("length of y incorrect")}
if(length(size)!=ly){
	if(length(size)==1)size <- rep(size,ly)
	else stop("size must be the same length as y")}
if(any(y>size))stop("y must be <= size")
if(length(m)!=ly){
	if(length(m)==1)m <- rep(m,ly)
	else stop("m and y must have the same length")}
if(length(s)!=ly){
	if(length(s)==1)s <- rep(s,ly)
	else stop("s and y must have the same length")}
t <- s*m
u <- s*(1-m)
tmp <- lbeta(y+t,size-y+u)-lbeta(t,u)+lchoose(size,y)
if(!log)tmp <- exp(tmp)
tmp}

qbetabinom <- function(p, size, m, s){
h <- function(y){
	t <- s[i]*m[i]
	u <- s[i]*(1-m[i])
	pp <- 0:y
	sum(exp(lbeta(pp+t,size[i]-pp+u)-
		lbeta(t,u)+lchoose(size[i],pp)))-p[i]}
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s),length(size))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(size)!=len){
	if(length(size)==1)size <- rep(size,len)
	else stop("length of size incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,size[i])
	tmp[i] <- if(h(interval[1])*h(interval[2])>0)0
		else uniroot(h,interval)$root}
trunc(tmp)}

rbetabinom <- function(n=1, size, m, s) qbetabinom(runif(n),size=size,m=m,s=s)

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

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

qdoublebinom <- function(p, size, m, s){
h <- function(y) .C("pdb",
	as.integer(y),
	as.integer(size[i]),
	as.double(m[i]),
	as.double(s[i]),
	as.integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s),length(size))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(size)!=len){
	if(length(size)==1)size <- rep(size,len)
	else stop("length of size incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,size[i])
	tmp[i] <- if(h(interval[1])*h(interval[2])>0)0
		else uniroot(h,interval)$root}
trunc(tmp)}

rdoublebinom <- function(n=1, size, m, s)
	qdoublebinom(runif(n),size=size,m=m,s=s)

### multiplicative binomial distribution
###
pmultbinom <- function(q, size, m, s){
if(any(q<0))stop("q must contain non-negative values")
if(any(size<0))stop("size must contain non-negative values")
if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
if(any(s<=0))stop("s must be positive")
len <- max(length(q),length(m),length(s),length(size))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
if(length(size)!=len){
	if(length(size)==1)size <- rep(size,len)
	else stop("size must be the same length as q")}
if(any(q>size))stop("q must be <= size")
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("m and q must have the same length")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("s and q must have the same length")}
.C("pmb",
	as.integer(q),
	as.integer(size),
	as.double(m),
	as.double(s),
	as.integer(length(q)),
	res=double(length(q)),
	DUP=FALSE,
	PACKAGE="rmutil")$res}

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

qmultbinom <- function(p, size, m, s){
h <- function(y).C("pmb",
	as.integer(y),
	as.integer(size[i]),
	as.double(m[i]),
	as.double(s[i]),
	as.integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0)||any(m>=1))stop("m must lie between 0 and 1")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s),length(size))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(size)!=len){
	if(length(size)==1)size <- rep(size,len)
	else stop("length of size incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,size[i])
	tmp[i] <- if(h(interval[1])*h(interval[2])>0)0
		else uniroot(h,interval)$root}
trunc(tmp)}

rmultbinom <- function(n=1, size, m, s)
	qmultbinom(runif(n),size=size,m=m,s=s)

### double Poisson distribution
###
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")
len <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("m and q must have the same length")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	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=FALSE,
	PACKAGE="rmutil")$res}

ddoublepois <- function(y, m, s, log=FALSE){
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")
ly <- max(length(y),length(m),length(s))
if(length(y)!=ly){
	if(length(y)==1)y <- rep(y,ly)
	else stop("length of y incorrect")}
if(length(m)!=ly){
	if(length(m)==1)m <- rep(m,ly)
	else stop("m and y must have the same length")}
if(length(s)!=ly){
	if(length(s)==1)s <- rep(s,ly)
	else stop("s and y must have the same length")}
tmp <- .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=FALSE,
	PACKAGE="rmutil")$res
if(!log)tmp <- exp(tmp)
tmp}

qdoublepois <- function(p, m, s){
h <- function(y).C("pdp",
	as.integer(y),
	as.integer(3*max(c(y,100))),
	as.double(m[i]),
	as.double(s[i]),
	as.integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,20)
	if(h(interval[1])*h(interval[2])>0&&h(interval[1])>0)tmp[i] <- 0
	else {
		while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
		tmp[i] <- uniroot(h,interval)$root}}
trunc(tmp)}

rdoublepois <- function(n=1, m, s) qdoublepois(runif(n),m=m,s=s)

### multiplicative Poisson distribution
###
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|s>1))stop("s must be positive and <= 1")
len <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("m and q must have the same length")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	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=FALSE,
	PACKAGE="rmutil")$res}

dmultpois <- function(y, m, s, log=FALSE){
if(any(y<0))stop("y must contain non-negative values")
if(any(m<=0))stop("m must be positive")
if(any(s<=0|s>1))stop("s must be positive and <= 1")
ly <- max(length(y),length(m),length(s))
if(length(y)!=ly){
	if(length(y)==1)y <- rep(y,ly)
	else stop("length of y incorrect")}
if(length(m)!=ly){
	if(length(m)==1)m <- rep(m,ly)
	else stop("m and y must have the same length")}
if(length(s)!=ly){
	if(length(s)==1)s <- rep(s,ly)
	else stop("s and y must have the same length")}
tmp <- .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=FALSE,
	PACKAGE="rmutil")$res
if(!log)tmp <- exp(tmp)
tmp}

qmultpois <- function(p, m, s){
h <- function(y).C("pmp",
	as.integer(y),
	as.integer(3*max(c(y,100))),
	as.double(m[i]),
	as.double(s[i]),
	as.integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<0))stop("m must be positive")
if(any(s<=0|s>1))stop("s must be positive and <= 1")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,20)
	if(h(interval[1])*h(interval[2])>0&&h(interval[1])>0)tmp[i] <- 0
	else {
		while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
		tmp[i] <- uniroot(h,interval)$root}}
trunc(tmp)}

rmultpois <- function(n=1, m, s) qmultpois(runif(n),m=m,s=s)

### power variance function Poisson distribution
###
ppvfpois <- 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 <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("m and q must have the same length")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("s and q must have the same length")}
if(length(f)!=len){
	if(length(f)==1)f <- rep(f,len)
	else stop("f and q must have the same length")}
.C("ppvfp",
	as.integer(q),
	as.double(m),
	as.double(s),
	as.double(f),
	as.integer(length(q)),
	res=double(length(q)),
	DUP=FALSE,
	PACKAGE="rmutil")$res}

dpvfpois <- function(y, m, s, f, log=FALSE){
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>=1))stop("f must be < 1")
ly <- max(length(y),length(m),length(s))
if(length(y)!=ly){
	if(length(y)==1)y <- rep(y,ly)
	else stop("length of y incorrect")}
if(length(m)!=ly){
	if(length(m)==1)m <- rep(m,ly)
	else stop("m and y must have the same length")}
if(length(s)!=ly){
	if(length(s)==1)s <- rep(s,ly)
	else stop("s and y must have the same length")}
if(length(f)!=ly){
	if(length(f)==1)f <- rep(f,ly)
	else stop("f and y must have the same length")}
tmp <- log(.C("dpvfp",
	as.integer(y),
	as.double(m),
	as.double(s),
	as.double(f),
	as.integer(length(y)),
	as.double(rep(1,length(y))),
	res=double(length(y)),
	DUP=FALSE,
	PACKAGE="rmutil")$res)
if(!log)tmp <- exp(tmp)
tmp}

qpvfpois <- function(p, m, s, f){
h <- function(y).C("ppvfp",
	as.integer(y),
	as.double(m[i]),
	as.double(s[i]),
	as.double(f[i]),
	as.integer(1),
	res=double(1),
	DUP=FALSE,
	PACKAGE="rmutil")$res-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
if(length(f)!=len){
	if(length(f)==1)f <- rep(f,len)
	else stop("f and p must have the same length")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	if(f[i]==0)tmp[i] <- qnbinom(p[i],s[i],m[i]/(m[i]+s[i]))
	else {
		interval <- c(0,20)
		if(h(interval[1])*h(interval[2])>0&&h(interval[1])>0)
			tmp[i] <- 0
		else {
			while(h(interval[1])*h(interval[2])>0)
				interval <- 2*interval
			tmp[i] <- uniroot(h,interval)$root}}}
trunc(tmp)}

rpvfpois <- function(n=1, m, s, f) qpvfpois(runif(n),m=m,s=s,f=f)

### gamma count distribution
###
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, log=FALSE){
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")
tmp <- ifelse(y==0,pgamma(m*s,(y+1)*s,1,log=TRUE,lower=FALSE),
	log(pgamma(m*s,y*s+(y==0),1)-pgamma(m*s,(y+1)*s,1)))
if(!log)tmp <- exp(tmp)
tmp}

qgammacount <- function(p, m, s){
h <- function(y) 1-pgamma(m[i]*s[i],(y+1)*s[i],1)-p[i]
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,20)
	if(h(interval[1])*h(interval[2])>0&&h(interval[1])>0)tmp[i] <- 0
	else {
		while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
		tmp[i] <- uniroot(h,interval)$root}}
trunc(tmp)}

rgammacount <- function(n=1, m, s) qgammacount(runif(n),m=m,s=s)

### Consul generalized Poisson distribution
###
pconsul <- 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")
len <- max(length(q),length(m),length(s))
if(length(q)!=len){
	if(length(q)==1)q <- rep(q,len)
	else stop("length of q incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(any(s<0))stop("s must be positive")
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
res <- vector("numeric",length(q))
for(i in 1:length(q)){
	qq <- 0:q[i]
	res[i] <- sum(m[i]*exp(-(m[i]+qq*(s[i]-1))/s[i])*
		(m[i]+qq*(s[i]-1))^(qq-1)/(s[i]^qq*gamma(qq+1)))}
res}

dconsul <- function(y, m, s, log=FALSE){
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")
tmp <- log(m)-(m+y*(s-1))/s+(y-1)*log(m+y*(s-1))-y*log(s)-lgamma(y+1)
if(!log)tmp <- exp(tmp)
tmp}

qconsul <- function(p, m, s){
h <- function(y) {
	pp <- 0:y
	sum(m[i]*exp(-(m[i]+pp*(s[i]-1))/s[i])*(m[i]+pp*(s[i]-1))^(pp-1)/
		(s[i]^pp*gamma(pp+1)))-p[i]}
if(any(p<0|p>1))stop("p must lie between 0 and 1")
if(any(m<=0))stop("m must be positive")
if(any(s<0))stop("s must be positive")
len <- max(length(p),length(m),length(s))
if(length(p)!=len){
	if(length(p)==1)p <- rep(p,len)
	else stop("length of p incorrect")}
if(length(m)!=len){
	if(length(m)==1)m <- rep(m,len)
	else stop("length of m incorrect")}
if(length(s)!=len){
	if(length(s)==1)s <- rep(s,len)
	else stop("length of s incorrect")}
tmp <- vector(mode="numeric",len)
for (i in 1:len){
	interval <- c(0,20)
	if(h(interval[1])*h(interval[2])>0&&h(interval[1])>0)tmp[i] <- 0
	else {
		while(h(interval[1])*h(interval[2])>0)interval <- 2*interval
		tmp[i] <- uniroot(h,interval)$root}}
trunc(tmp)}

rconsul <- function(n=1, m, s) qconsul(runif(n),m=m,s=s)
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#   fmobj(z, envir=parent.frame()))
#   finterp(.z, .envir=parent.frame(),
#	.formula=FALSE, .vector=TRUE, .args=NULL, .start=1, .name=NULL,
#	.expand=TRUE, .intercept=TRUE, .old=NULL){
#   fnenvir(.z, .envir=parent.frame(), .name=NULL, .expand=TRUE)
#
#  DESCRIPTION
#
#    Functions to translate a model formula with unknown parameters
#  into a function and to modify a function to read from a data object.

###
### function to find objects specified in a formula, returning
###indicators of which are parameters, covariates, factors, and functions
###
fmobj <- function(z, envir=parent.frame()){
if(!inherits(z,"formula"))return(NULL)
#
# transform formula to one character string
#
local <- fac <- cov <- ch <- NULL
ch1 <- deparse(z[[length(z)]])
for(j in 1:length(ch1))ch <- paste(ch,ch1[j],collapse=" ",sep="\n")
#
# put extra spaces in character string so that substitutions can be made
#
ch <- gsub("\n"," \n ",gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [ ",ch))))
ch <- gsub("/"," / ",gsub(","," ,",gsub("\\("," ( ",gsub(":"," : ",ch))))
ch <- paste(" ",gsub(" -"," - ",gsub(" \\+"," + ",ch))," ",sep="")
#
# find names of variables and parameters
# removing names of functions that are arguments of other functions
# except times and response
#
mem <- all.vars(z)
fcn <- all.names(z)
fcn <- fcn[!(fcn%in%mem)]
if(length(mem)>0){
	tmp <- vector(length=length(mem))
	for(i in 1:length(mem))
		tmp[i] <- exists(mem[i],envir=envir)&&is.function(eval(parse(text=mem[i]),envir=envir))&&(length(grep(paste(mem[i],","),ch))>0||length(grep(paste(",",mem[i]),ch))>0||length(grep(paste("=",mem[i]),ch))>0||length(grep(paste("\\(",mem[i],"\\)"),ch))>0)&&mem[i]!="times"&&mem[i]!="response"
	fcn <- unique(c(fcn,mem[tmp]))
	mem <- mem[!tmp]}
#
# Create indicators for numeric covariates (cov) and for factor
# variables (fac) that exist in the given environment.
# Everything else in mem is an unknown parameter.
#
if(length(mem)>0){
	for(j in 1:length(mem)){
		local <- c(local,length(grep(paste(mem[j],"<-"),ch))>0)
		cov <- c(cov,exists(mem[j],envir=envir)&&
			is.numeric(eval(parse(text=mem[j]),envir=envir)))
		fac <- c(fac,exists(mem[j],envir=envir)&&!cov[j]&&
			is.factor(eval(parse(text=mem[j]),envir=envir)))}
	zz <- list(formula=ch,objects=mem,functions=fcn,
		parameters=!cov&!fac&!local,covariates=cov,factors=fac,
		local=local)}
else zz <- list(formula=ch,objects=mem,functions=fcn)
class(zz) <- "fmobj"
zz}

###
### functions to translate model formulae into functions,
### perhaps transforming them to read from a data object
###
finterp <- function(.z, ...) UseMethod("finterp")

### default method
###
finterp.default <- function(.z, .envir=parent.frame(),
	.formula=FALSE, .vector=TRUE, .args=NULL, .start=1, .name=NULL,
	.expand=TRUE, .intercept=TRUE, .old=NULL, .response=FALSE){
if(!inherits(.z,"formula"))return(NULL)
#
# find the appropriate environment if its name is supplied
#
if(is.name(.envir)){
	if(is.null(.name)).name <- as.character(.envir)
	.envir <- eval(.envir)}
#
# call appropriate special method if it exists
#
if(!is.environment(.envir)){
	if(is.null(.name)).name <- paste(deparse(substitute(.envir)))
	if(inherits(.envir,"repeated"))
		return(finterp.repeated(.z,.envir,.formula,.vector,.args,.start,.name,.expand,.intercept,.old,.response))
	if(inherits(.envir,"tccov"))
		return(finterp.tccov(.z,.envir,.formula,.vector,.args,.start,.name,.expand,.intercept,.old))
	if(inherits(.envir,"tvcov"))
		return(finterp.tvcov(.z,.envir,.formula,.vector,.args,.start,.name,.expand,.intercept,.old))
	if(inherits(.envir,"data.frame"))
		return(finterp.data.frame(.z,.envir,.formula,.vector,.args,.start,.name,.expand,.intercept,.old))}
#
# check for common parameters
#
.pars <- .range <- NULL
if(!is.null(.old)){
	if(!is.list(.old)).old <- list(.old)
	for(.j in .old){
		if(!inherits(.j,"formulafn"))
			stop("objects in .old must have class, formulafn")
		.pars <- c(.pars,attr(.j,"parameters"))
		.range <- c(.range,attr(.j,"range")[1]:attr(.j,"range")[2])}
	if(.start<=max(.range))
		warning("possible conflict in vector indexing - check .start")}
if(!is.null(.args)&&!is.character(.args))
	stop(".args must be a character string")
#
# create indicators for covariates that exist in the given environment (.ex)
# and for factor variables (.fac), and a vector of unique parameter names (.un)
#
.zz <- fmobj(.z)
.ch <- .zz$formula
.mem <- .zz$objects
.fcn <- .zz$functions
if("$"%in%.fcn)stop("sublists not allowed (attach dataframes and use variable names)")
.ex <- .zz$covariates
.fac <- .zz$factors
.local <- .zz$local
rm(.zz)
if(length(.mem)>0){
	.un <- unique(.mem[!.ex&!.fac&!.local])
	if(length(unique(.mem[.ex|.fac|.local]))==0&&length(.un)==0)
		warning("finterp.default: no variables found")}
#
# handle W&R formulae
#
if(length(.mem)==0||all(.ex|.fac|.local)){
	if(.formula)return(.z)
	else {
	# create model matrix and return as attribute of function
		if(any("offset"%in%.fcn))stop("offset not allowed")
		.mt <- terms(.z)
		if(is.numeric(.mt[[2]])){
			.dm <- matrix(1)
			colnames(.dm) <- "(Intercept)"}
		else {
			.dm <- model.matrix(.mt,model.frame(.mt,.envir))
			if(!.intercept).dm <- .dm[,-1,drop=FALSE]}
		.fna <- function(.p) as.vector(.dm%*%
			.p[attr(.fna,"range")[1]:attr(.fna,"range")[2]])
		attributes(.fna) <- list(formula=.z,model=colnames(.dm),
			covariates=if(length(.mem)>0)
				unique(.mem[.ex|.fac]) else NULL,
			parameters=paste("p[",1:dim(.dm)[2],"]",sep=""),
			range=c(.start,.start+dim(.dm)[2]-1),
			class="formulafn")
		.obj <- ls(all.names=TRUE)
		rm(list=.obj[.obj!=".fna"&.obj!=".dm"])
		rm(.obj)
		return(.fna)}}
#
# create function for formulae with unknowns making sure there are no
# factor variables present
#
if(!is.null(.fac)&&any(.fac))stop(paste("covariates in formulae with unknowns must not be factors\ncheck",.mem[.fac]))
.fna <- function(.p) eval(attr(.fna,"model"))
if(.vector){
#
# return a function with all parameters as one vector
#
	# check if some parameters are not to be put in the vector
	if(!is.null(.args)){
		.tmp <- match(.args,.un)
		if(!is.na(.tmp)).un <- .un[-.tmp]
		.par <- "alist(.p="
		for(.j in 1:length(.args)){
			.par <- paste(.par,",",collapse="")
			.par <- paste(.par,.args[.j],"=",collapse="")}
		.par <- paste(.par,")",collapse="")
		formals(.fna) <- eval(parse(text=.par))}
	# check if some parameters are common to another formula
	if(!is.null(.old)){
		.j <- match(.pars,.un)
		.un <- .un[-.j]
		.pars <- .pars[!is.na(.j)]
		.range <- .range[!is.na(.j)]
		for(.j in 1:length(.pars))
			.ch <- gsub(paste(" ",.pars[.j]," ",sep=""),
				paste(" .p[",.range[.j],"] ",sep=""),.ch)}
	if(length(.un)>0)for(.j in 1:length(.un))
		.ch <- gsub(paste(" ",.un[.j]," ",sep=""),
			paste(" .p[",.start+.j-1,"] ",sep=""),.ch)}
else {
#
# return a function with parameters having their original names
#
	.par <- "alist("
	for(.j in 1:length(.un)){
		if(.j>1).par <- paste(.par,",",collapse="")
		.par <- paste(.par,.un[.j],"=",collapse="")}
# bug reported in 0.63.0
#	if(length(.un)==1).par <- paste(.par,",...=",collapse="")
	.par <- paste(.par,")",collapse="")
	formals(.fna) <- eval(parse(text=.par))}
attributes(.fna) <- list(formula=.z,model=parse(text=.ch),parameters=.un,
	common=.pars,covariates=unique(.mem[.ex]),
	range=c(.start,.start+length(.un)-1),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fna"])
rm(.obj)
return(.fna)}

### method for repeated objects
###
finterp.repeated <- function(.z, .envir=NULL, .formula=FALSE, .vector=TRUE,
	.args=NULL, .start=1, .name=NULL, .expand=TRUE, .intercept=TRUE,
	.old=NULL, .response=FALSE){
if(!inherits(.z,"formula"))return(NULL)
#
# check for common parameters
#
.pars <- .range <- NULL
if(!is.null(.old)){
	if(!is.list(.old)).old <- list(.old)
	for(.j in .old){
		if(!inherits(.j,"formulafn"))
			stop("objects in .old must have class, formulafn")
		.pars <- c(.pars,attr(.j,"parameters"))
		.range <- c(.range,attr(.j,"range")[1]:attr(.j,"range")[2])}
	if(.start<=max(.range))
		warning("possible conflict in vector indexing - check .start")}
if(!is.null(.args)&&!is.character(.args))
	stop(".args must be a character string")
#
# find the appropriate environment if its name is supplied
#
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
#
# dissect formula
#
.ex1 <- .ex2 <- .ex3 <- .ex4 <- .ex5 <- .ex6 <- NULL
.zz <- fmobj(.z)
.ch <- .zz$formula
.mem <- .zz$objects
.fcn <- .zz$functions
.local <- .zz$local
rm(.zz)
#
# create indicators for variables that exist in the repeated object (.ex) and
# a vector of unique parameter names (.un)
#
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(nobs(.envir))==1)
		stop("these are not repeated measurements")
	.ex5 <- match(.mem,"nesting")
	if(any(!is.na(.ex5))&&is.null(.envir$response$nest))
		stop("no nesting variable available")
	.ex6 <- match(.mem,colnames(.envir$response$y))
	if(any(!is.na(.ex2))&&!.expand)
		stop("time-varying covariates present - time-constant ones must be expanded")
	.un <- unique(.mem[is.na(.ex1)&is.na(.ex2)&is.na(.ex3)&is.na(.ex4)&is.na(.ex5)&is.na(.ex6)&!.local])
	if(length(unique(.mem[!is.na(.ex1)|!is.na(.ex2)|!is.na(.ex3)|!is.na(.ex4)|!is.na(.ex5)|!is.na(.ex6)]))==0&&length(.un)==0)
		warning("finterp.repeated: no variables found")}
#
# replace time-constant covariate names by location in data object,
# expanding to the proper length, if required
#
if(.expand).i <- covind(.envir)
.ex1a <- if(is.null(.ex1)) NULL else .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
	.ch <- if(.expand)gsub(paste(" ",colnames(.envir$ccov$ccov)[.ex1a[.j]],
		" ",sep=""),paste(" ",.ndata,"$ccov$ccov[,",
		.ex1a[.j],"][.i] ",sep=""),.ch)
		else gsub(paste(" ",colnames(.envir$ccov$ccov)[.ex1a[.j]],
		" ",sep=""),paste(" ",.ndata,"$ccov$ccov[,",
		.ex1a[.j],"] ",sep=""),.ch)
#
# replace time-varying covariate names by location in data object
#
.ex2a <- if(is.null(.ex2)) NULL else .ex2[!is.na(.ex2)]
if(length(.ex2a)>0)for(.j in 1:length(.ex2a))
	.ch <- gsub(paste(" ",colnames(.envir$tvcov$tvcov)[.ex2a[.j]],
		" ",sep=""),paste(" ",.ndata,"$tvcov$tvcov[,",
		.ex2a[.j],"] ",sep=""),.ch)
#
# replace special name, times, by location in data object
#
.ex3a <- if(is.null(.ex3)) NULL else .ex3[!is.na(.ex3)]
if(length(.ex3a)>0)
	.ch <- gsub(" times ",paste(" ",.ndata,"$response$times ",sep=""),.ch)
#
# replace special name, individuals, by location in data object
#
.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)
#
# replace special name, nesting, by location in data object
#
.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)
#
# replace response variable names by location in data object
#
.ex6a <- if(is.null(.ex6)) NULL else .ex6[!is.na(.ex6)]
if(length(.ex6a)>0){
	if(dim(.envir$response$y)[2]==1&&!.response)
		stop(paste(colnames(.envir$response$y)[.ex6a]," is the response and cannot be a covariate"))
	for(.j in 1:length(.ex6a)){
		if(!is.null(.envir$response$n)&&!all(is.na(.envir$response$n[.ex6a[.j]])))
			stop(paste(colnames(.envir$response$y)[.ex6a[.j]]," is binomial and cannot be a covariate"))
		if(!is.null(.envir$response$censor)&&!all(is.na(.envir$response$censor[.ex6a[.j]]))&&!all(.envir$response$censor[.ex6a[.j]]==1))
			stop(paste(colnames(.envir$response$y)[.ex6a[.j]]," is censored and cannot be a covariate"))
		.ch <- gsub(paste(" ",colnames(.envir$response$y)[.ex6a[.j]],
			" ",sep=""),paste(" ",.ndata,"$response$y[,",
			.ex6a[.j],"] ",sep=""),.ch)}}
#
# handle W&R formulae
#
if((is.null(.ex1)&&is.null(.ex2)&&is.null(.ex3)&&is.null(.ex4)&&is.null(.ex5)&&is.null(.ex6))||all(!is.na(.ex1)|!is.na(.ex2)|!is.na(.ex3)|!is.na(.ex4)|!is.na(.ex5)|!is.na(.ex6))){
	if(.formula)return(.z)
	else {
	# create model matrix, change column names, and return as
	# attribute of function
		if(any("offset"%in%.fcn))stop("offset not allowed")
		.ch <- as.formula(paste("~",.ch))
		.mt <- terms(.ch)
		if(is.numeric(.mt[[2]])){
			if(!.intercept)return(NULL)
			.n <- if(.expand||is.null(.envir$ccov$ccov))
					dim(.envir$response$y)[1]
				else dim(.envir$ccov$ccov)[1]
			.dm <- matrix(1)
			colnames(.dm) <- "(Intercept)"
			.fna <- function(.p) rep(.p[attr(.fna,"range")[1]],.n)}
		else {
			.dm <- model.matrix(.mt,model.frame(.mt))
			if(!.intercept).dm <- .dm[,-1,drop=FALSE]
			if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
				colnames(.dm) <- gsub(paste(.ndata,"\\$ccov\\$ccov\\[, ",.ex1a[.j],"\\]",sep=""),paste(colnames(.envir$ccov$ccov)[.ex1a[.j]],sep=""),colnames(.dm))
			if(length(.ex2a)>0)for(.j in 1:length(.ex2a))
				colnames(.dm) <- gsub(paste(.ndata,"\\$tvcov\\$tvcov\\[, ",.ex2a[.j],"\\]",sep=""),paste(colnames(.envir$tvcov$tvcov)[.ex2a[.j]],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))
			if(length(.ex6a)>0)for(.j in 1:length(.ex6a))
				colnames(.dm) <- gsub(paste(.ndata,"\\$response\\$y\\[, ",.ex6a[.j],"\\]",sep=""),paste(colnames(.envir$response$y)[.ex6a[.j]],sep=""),colnames(.dm))
			.fna <- function(.p) as.vector(.dm%*%
				.p[attr(.fna,"range")[1]:attr(.fna,"range")[2]])}
		attributes(.fna) <- list(formula=.z,model=colnames(.dm),
			covariates=if(length(.mem)>0)
				unique(.mem[(!is.na(.ex1)|!is.na(.ex2)|!is.na(.ex3)|!is.na(.ex4)|!is.na(.ex5)|!is.na(.ex6))]) else NULL,
			parameters=paste("p[",1:dim(.dm)[2],"]",sep=""),
			range=c(.start,.start+dim(.dm)[2]-1),
			class="formulafn")
		.obj <- ls(all.names=TRUE)
		rm(list=.obj[.obj!=".i"&.obj!=".fna"&.obj!=".dm"&.obj!=".n"])
		rm(.obj)
		return(.fna)}}
#
# make sure there are no factor variables present
#
if(length(.ex1a)>0)for(.j in 1:length(.ex1a))if(is.factor(.envir$ccov$ccov[,.ex1a[.j]]))stop(paste(colnames(.envir$ccov$ccov)[.ex1a[.j]],"is a factor variable"))
if(length(.ex2a)>0)for(.j in 1:length(.ex2a))if(is.factor(.envir$tvcov$tvcov[,.ex2a[.j]]))stop(paste(colnames(.envir$tvcov$tvcov)[.ex2a[.j]],"is a factor variable"))
if(length(.ex4a)>0)stop("index for individuals cannot be used in formulae with unknowns")
if(length(.ex5a)>0)stop("index for nesting cannot be used in formulae with unknowns")
#
# create and return the function
#
.fna <- function(.p) eval(attr(.fna,"model"))
#
# check if some parameters are not to be put in the vector
#
if(!is.null(.args)){
	.tmp <- match(.args,.un)
	if(!is.na(.tmp)).un <- .un[-.tmp]
	.par <- "alist(.p="
	for(.j in 1:length(.args)){
		.par <- paste(.par,",",collapse="")
		.par <- paste(.par,.args[.j],"=",collapse="")}
	.par <- paste(.par,")",collapse="")
	formals(.fna) <- eval(parse(text=.par))}
#
# check if some parameters are common to another formula
#
if(!is.null(.old)){
	.j <- match(.pars,.un)
	.un <- .un[-.j]
	.pars <- .pars[!is.na(.j)]
	.range <- .range[!is.na(.j)]
	for(.j in 1:length(.pars)).ch <- gsub(paste(" ",.pars[.j]," ",sep=""),
		paste(" .p[",.range[.j],"] ",sep=""),.ch)}
if(length(.un)>0)for(.j in 1:length(.un))
	.ch <- gsub(paste(" ",.un[.j]," ",sep=""),
		paste(" .p[",.start+.j-1,"] ",sep=""),.ch)
attributes(.fna) <- 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)|!is.na(.ex6))]),
	common=.pars,range=c(.start,.start+length(.un)-1),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".i"&.obj!=".fna"])
rm(.obj)
return(.fna)}

### method for tccov objects
###
finterp.tccov <- function(.z, .envir=NULL, .formula=FALSE, .vector=TRUE,
	.args=NULL, .start=1, .name=NULL, .expand=NULL, .intercept=TRUE,
	.old=NULL){
if(!inherits(.z,"formula"))return(NULL)
#
# check for common parameters
#
.pars <- .range <- NULL
if(!is.null(.old)){
	if(!is.list(.old)).old <- list(.old)
	for(.j in .old){
		if(!inherits(.j,"formulafn"))
			stop("objects in .old must have class, formulafn")
		.pars <- c(.pars,attr(.j,"parameters"))
		.range <- c(.range,attr(.j,"range")[1]:attr(.j,"range")[2])}
	if(.start<=max(.range))
		warning("possible conflict in vector indexing - check .start")}
if(!is.null(.args)&&!is.character(.args))
	stop(".args must be a character string")
#
# find the appropriate environment if its name is supplied
#
if(is.name(.envir)){
	if(is.null(.name)).name <- as.character(.envir)
	.envir <- eval(.envir)}
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
#
# create appropriate names for search in data object
#
if(inherits(.envir,"repeated")){
	.cn <- colnames(.envir$ccov$ccov)
	.cc <- "$ccov"
	.cc2 <- "\\$ccov"}
else {
	.cn <- colnames(.envir$ccov)
	.cc2 <- .cc <- ""}
#
# dissect formula
#
.ex1 <- NULL
.zz <- fmobj(.z)
.ch <- .zz$formula
.mem <- .zz$objects
.fcn <- .zz$functions
.local <- .zz$local
rm(.zz)
#
# create indicator for variables that exist in the tccov object (.ex1)
# and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	.ex1 <- match(.mem,.cn)
	.un <- unique(.mem[is.na(.ex1)&!.local])
	if(length(unique(.mem[!is.na(.ex1)]))==0&&length(.un)==0)
		warning("finterp.tccov: no variables found")}
#
# replace time-constant covariate names by location in data object,
# expanding to the proper length, if required
#
.ex1a <- if(is.null(.ex1)) NULL else .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
	.ch <- gsub(paste(" ",.cn[.ex1a[.j]]," ",sep=""),
		paste(" ",.ndata,.cc,"$ccov[,",
		.ex1a[.j],"] ",sep=""),.ch)
#
# handle W&R formulae
#
if(is.null(.ex1)||all(!is.na(.ex1))){
	if(.formula)return(.z)
	else {
	# create model matrix, change column names, and return as
	# attribute of function
		if(any("offset"%in%.fcn))stop("offset not allowed")
		.ch <- as.formula(paste("~",.ch))
		.mt <- terms(.ch)
		if(is.numeric(.mt[[2]])){
			if(!.intercept)return(NULL)
			.n <- dim(.envir$ccov)[1]
			.dm <- matrix(1)
			colnames(.dm) <- "(Intercept)"
			.fna <- function(.p) rep(.p[attr(.fna,"range")[1]],.n)}
		else {
			.dm <- model.matrix(.mt,model.frame(.mt))
			if(!.intercept).dm <- .dm[,-1,drop=FALSE]
			if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
				colnames(.dm) <- gsub(paste(.ndata,.cc2,"\\$ccov\\[, ",.ex1a[.j],"\\]",sep=""),paste(.cn[.ex1a[.j]],sep=""),colnames(.dm))
			.fna <- function(.p) as.vector(.dm%*%
				.p[attr(.fna,"range")[1]:attr(.fna,"range")[2]])}
		attributes(.fna) <- list(formula=.z,model=colnames(.dm),
			covariates=if(length(.mem)>0)
				unique(.mem[!is.na(.ex1)]) else NULL,
			parameters=paste("p[",1:dim(.dm)[2],"]",sep=""),
			range=c(.start,.start+dim(.dm)[2]-1),
			class="formulafn")
		.obj <- ls(all.names=TRUE)
		rm(list=.obj[.obj!=".i"&.obj!=".fna"&.obj!=".dm"&.obj!=".n"])
		rm(.obj)
		return(.fna)}}
#
# create function for formulae with unknowns making sure there are no
# factor variables present
#
if(inherits(.envir,"repeated")){
	if(length(.ex1a)>0)for(.j in 1:length(.ex1a))if(is.factor(.envir$ccov$ccov[,.ex1a[.j]]))stop(paste(colnames(.envir$ccov$ccov)[.ex1a[.j]],"is a factor variable"))}
else {
	if(length(.ex1a)>0)for(.j in 1:length(.ex1a))if(is.factor(.envir$ccov[,.ex1a[.j]]))stop(paste(colnames(.envir$ccov)[.ex1a[.j]],"is a factor variable"))}
#
# create and return the function
#
.fna <- function(.p) eval(attr(.fna,"model"))
#
# check if some parameters are not to be put in the vector
#
if(!is.null(.args)){
	.tmp <- match(.args,.un)
	if(!is.na(.tmp)).un <- .un[-.tmp]
	.par <- "alist(.p="
	for(.j in 1:length(.args)){
		.par <- paste(.par,",",collapse="")
		.par <- paste(.par,.args[.j],"=",collapse="")}
	.par <- paste(.par,")",collapse="")
	formals(.fna) <- eval(parse(text=.par))}
#
# check if some parameters are common to another formula
#
if(!is.null(.old)){
	.j <- match(.pars,.un)
	.un <- .un[-.j]
	.pars <- .pars[!is.na(.j)]
	.range <- .range[!is.na(.j)]
	for(.j in 1:length(.pars)).ch <- gsub(paste(" ",.pars[.j]," ",sep=""),
		paste(" .p[",.range[.j],"] ",sep=""),.ch)}
if(length(.un)>0)for(.j in 1:length(.un))
	.ch <- gsub(paste(" ",.un[.j]," ",sep=""),
		paste(" .p[",.start+.j-1,"] ",sep=""),.ch)
attributes(.fna) <- list(formula=.z,model=parse(text=.ch),parameters=.un,
	common=.pars,covariates=unique(.mem[!is.na(.ex1)]),
	range=c(.start,.start+length(.un)-1),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fna"])
rm(.obj)
return(.fna)}

### method for tvcov objects
###
finterp.tvcov <- function(.z, .envir=NULL, .formula=FALSE, .vector=TRUE,
	.args=NULL, .start=1, .name=NULL, .expand=NULL, .intercept=TRUE,
	.old=NULL){
if(!inherits(.z,"formula"))return(NULL)
#
# check for common parameters
#
.pars <- .range <- NULL
if(!is.null(.old)){
	if(!is.list(.old)).old <- list(.old)
	for(.j in .old){
		if(!inherits(.j,"formulafn"))
			stop("objects in .old must have class, formulafn")
		.pars <- c(.pars,attr(.j,"parameters"))
		.range <- c(.range,attr(.j,"range")[1]:attr(.j,"range")[2])}
	if(.start<=max(.range))
		warning("possible conflict in vector indexing - check .start")}
if(!is.null(.args)&&!is.character(.args))
	stop(".args must be a character string")
#
# find the appropriate environment if its name is supplied
#
if(is.name(.envir)){
	if(is.null(.name)).name <- as.character(.envir)
	.envir <- eval(.envir)}
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
#
# create appropriate names for search in data object
#
if(inherits(.envir,"repeated")){
	.cn <- colnames(.envir$tvcov$tvcov)
	.cc <- "$tvcov"
	.cc2 <- "\\$tvcov"}
else {
	.cn <- colnames(.envir$tvcov)
	.cc2 <- .cc <- ""}
#
# dissect formula
#
.ex1 <- NULL
.zz <- fmobj(.z)
.ch <- .zz$formula
.mem <- .zz$objects
.fcn <- .zz$functions
.local <- .zz$local
rm(.zz)
#
# create indicator for variables that exist in the tvcov object (.ex1)
# and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	.ex1 <- match(.mem,.cn)
	.un <- unique(.mem[is.na(.ex1)&!.local])
	if(length(unique(.mem[!is.na(.ex1)]))==0&&length(.un)==0)
		warning("finterp.tvcov: no variables found")}
#
# replace time-varying covariate names by location in data object
#
.ex1a <- if(is.null(.ex1)) NULL else .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
	.ch <- gsub(paste(" ",.cn[.ex1a[.j]]," ",sep=""),
		paste(" ",.ndata,.cc,"$tvcov[,",
		.ex1a[.j],"] ",sep=""),.ch)
#
# handle W&R formulae
#
if(is.null(.ex1)||all(!is.na(.ex1))){
	if(.formula)return(.z)
	else {
	# create model matrix, change column names, and return as
	# attribute of function
		if(any("offset"%in%.fcn))stop("offset not allowed")
		.ch <- as.formula(paste("~",.ch))
		.mt <- terms(.ch)
		if(is.numeric(.mt[[2]])){
			if(!.intercept)return(NULL)
			.n <- dim(.envir$tvcov)[1]
			.dm <- matrix(1)
			colnames(.dm) <- "(Intercept)"
			.fna <- function(.p) rep(.p[attr(.fna,"range")[1]],.n)}
		else {
			.dm <- model.matrix(.mt,model.frame(.mt))
			if(!.intercept).dm <- .dm[,-1,drop=FALSE]
			if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
				colnames(.dm) <- gsub(paste(.ndata,.cc2,"\\$ccov\\[, ",.ex1a[.j],"\\]",sep=""),paste(.cn[.ex1a[.j]],sep=""),colnames(.dm))
			.fna <- function(.p) as.vector(.dm%*%
				.p[attr(.fna,"range")[1]:attr(.fna,"range")[2]])}
		attributes(.fna) <- list(formula=.z,model=colnames(.dm),
			covariates=if(length(.mem)>0)
				unique(.mem[!is.na(.ex1)]) else NULL,
			parameters=paste("p[",1:dim(.dm)[2],"]",sep=""),
			range=c(.start,.start+dim(.dm)[2]-1),
			class="formulafn")
		.obj <- ls(all.names=TRUE)
		rm(list=.obj[.obj!=".fna"&.obj!=".dm"&.obj!=".n"])
		rm(.obj)
		return(.fna)}}
#
# create function for formulae with unknowns making sure there are no
# factor variables present
#
if(inherits(.envir,"repeated")){
	if(length(.ex1a)>0)for(.j in 1:length(.ex1a))if(is.factor(.envir$tvcov$tvcov[,.ex1a[.j]]))stop(paste(colnames(.envir$tvcov$tvcov)[.ex1a[.j]],"is a factor variable"))}
else {
	if(length(.ex1a)>0)for(.j in 1:length(.ex1a))if(is.factor(.envir$tvcov[,.ex1a[.j]]))stop(paste(colnames(.envir$tvcov)[.ex1a[.j]],"is a factor variable"))}
#
# create and return the function
#
.fna <- function(.p) eval(attr(.fna,"model"))
#
# check if some parameters are not to be put in the vector
#
if(!is.null(.args)){
	.tmp <- match(.args,.un)
	if(!is.na(.tmp)).un <- .un[-.tmp]
	.par <- "alist(.p="
	for(.j in 1:length(.args)){
		.par <- paste(.par,",",collapse="")
		.par <- paste(.par,.args[.j],"=",collapse="")}
	.par <- paste(.par,")",collapse="")
	formals(.fna) <- eval(parse(text=.par))}
#
# check if some parameters are common to another formula
#
if(!is.null(.old)){
	.j <- match(.pars,.un)
	.un <- .un[-.j]
	.pars <- .pars[!is.na(.j)]
	.range <- .range[!is.na(.j)]
	for(.j in 1:length(.pars)).ch <- gsub(paste(" ",.pars[.j]," ",sep=""),
		paste(" .p[",.range[.j],"] ",sep=""),.ch)}
if(length(.un)>0)for(.j in 1:length(.un))
	.ch <- gsub(paste(" ",.un[.j]," ",sep=""),
		paste(" .p[",.start+.j-1,"] ",sep=""),.ch)
attributes(.fna) <- list(formula=.z,model=parse(text=.ch),parameters=.un,
	common=.pars,covariates=unique(.mem[!is.na(.ex1)]),
	range=c(.start,.start+length(.un)-1),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fna"])
rm(.obj)
return(.fna)}

### method for dataframes
###
finterp.data.frame <- function(.z, .envir=NULL, .formula=FALSE, .vector=TRUE,
	.args=NULL, .start=1, .name=NULL, .expand=NULL, .intercept=TRUE,
	.old=NULL){
if(!inherits(.z,"formula"))return(NULL)
#
# check for common parameters
#
.pars <- .range <- NULL
if(!is.null(.old)){
	if(!is.list(.old)).old <- list(.old)
	for(.j in .old){
		if(!inherits(.j,"formulafn"))
			stop("objects in .old must have class, formulafn")
		.pars <- c(.pars,attr(.j,"parameters"))
		.range <- c(.range,attr(.j,"range")[1]:attr(.j,"range")[2])}
	if(.start<=max(.range))
		warning("possible conflict in vector indexing - check .start")}
if(!is.null(.args)&&!is.character(.args))
	stop(".args must be a character string")
#
# find the appropriate environment if its name is supplied
#
if(is.name(.envir)){
	if(is.null(.name)).name <- as.character(.envir)
	.envir <- eval(.envir)}
.ndata <- if(is.null(.name))paste(deparse(substitute(.envir))) else .name
#
# create appropriate names for search in data object
#
.cn <- colnames(.envir)
#
# dissect formula
#
.ex1 <- NULL
.zz <- fmobj(.z)
.ch <- .zz$formula
.mem <- .zz$objects
.fcn <- .zz$functions
.local <- .zz$local
rm(.zz)
#
# create indicator for variables that exist in the dataframe (.ex1)
# and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	.ex1 <- match(.mem,.cn)
	.un <- unique(.mem[is.na(.ex1)&!.local])
	if(length(unique(.mem[!is.na(.ex1)]))==0&&length(.un)==0)
		warning("finterp.data.frame: no variables found")}
#
# replace covariate names by location in data object
#
.ex1a <- if(is.null(.ex1)) NULL else .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a))
	.ch <- gsub(paste(" ",.cn[.ex1a[.j]]," ",sep=""),
		paste(" ",.ndata,"$",.cn[.ex1a[.j]],sep=""),.ch)
#
# handle W&R formulae
#
if(is.null(.ex1)||all(!is.na(.ex1))){
	if(.formula)return(.z)
	else {
	# create model matrix, change column names, and return as
	# attribute of function
		if(any("offset"%in%.fcn))stop("offset not allowed")
		.ch <- as.formula(paste("~",.ch))
		.mt <- terms(.ch)
		if(is.numeric(.mt[[2]])){
			if(!.intercept)return(NULL)
			.n <- dim(.envir)[1]
			.dm <- matrix(1)
			colnames(.dm) <- "(Intercept)"
			.fna <- function(.p) rep(.p[attr(.fna,"range")[1]],.n)}
		else {
			.dm <- model.matrix(.mt,model.frame(.mt,data=.envir))
			if(!.intercept).dm <- .dm[,-1,drop=FALSE]
			.fna <- function(.p) as.vector(.dm%*%
				.p[attr(.fna,"range")[1]:attr(.fna,"range")[2]])}
		attributes(.fna) <- list(formula=.z,model=colnames(.dm),
			covariates=if(length(.mem)>0)
				unique(.mem[!is.na(.ex1)]) else NULL,
			parameters=paste("p[",1:dim(.dm)[2],"]",sep=""),
			range=c(.start,.start+dim(.dm)[2]-1),
			class="formulafn")
		.obj <- ls(all.names=TRUE)
		rm(list=.obj[.obj!=".i"&.obj!=".fna"&.obj!=".dm"&.obj!=".n"])
		rm(.obj)
		return(.fna)}}
#
# create function for formulae with unknowns making sure there are no
# factor variables present
#
if(length(.ex1a)>0)for(.j in 1:length(.ex1a))if(is.factor(.envir[,.ex1a[.j]]))
	stop(paste(colnames(.envir)[.ex1a[.j]],"is a factor variable"))
#
# create and return the function
#
.fna <- function(.p) eval(attr(.fna,"model"))
#
# check if some parameters are not to be put in the vector
#
if(!is.null(.args)){
	.tmp <- match(.args,.un)
	if(!is.na(.tmp)).un <- .un[-.tmp]
	.par <- "alist(.p="
	for(.j in 1:length(.args)){
		.par <- paste(.par,",",collapse="")
		.par <- paste(.par,.args[.j],"=",collapse="")}
	.par <- paste(.par,")",collapse="")
	formals(.fna) <- eval(parse(text=.par))}
#
# check if some parameters are common to another formula
#
if(!is.null(.old)){
	.j <- match(.pars,.un)
	.un <- .un[-.j]
	.pars <- .pars[!is.na(.j)]
	.range <- .range[!is.na(.j)]
	for(.j in 1:length(.pars)).ch <- gsub(paste(" ",.pars[.j]," ",sep=""),
		paste(" .p[",.range[.j],"] ",sep=""),.ch)}
if(length(.un)>0)for(.j in 1:length(.un))
	.ch <- gsub(paste(" ",.un[.j]," ",sep=""),
		paste(" .p[",.start+.j-1,"] ",sep=""),.ch)
attributes(.fna) <- list(formula=.z,model=parse(text=.ch),parameters=.un,
	common=.pars,covariates=unique(.mem[!is.na(.ex1)]),
	range=c(.start,.start+length(.un)-1),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fna"])
rm(.obj)
return(.fna)}

### functions to find the variables and parameters in functions,
### perhaps transforming them to read from a data object
###
fnenvir <- function(.z, ...) UseMethod("fnenvir")

### default method
###
fnenvir.default <- function(.z, .envir=parent.frame(), .name=NULL,
	.expand=TRUE, .response=FALSE){
if(!is.function(.z))return(NULL)
#
# find the appropriate environment if its name is supplied
#
if(is.name(.envir)){
	if(is.null(.name)).name <- as.character(.envir)
	.envir <- eval(.envir)}
#
# call appropriate special method if it exists
#
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,.response))
	if(inherits(.envir,"tccov"))return(fnenvir.tccov(.z,.envir,.name=.name,.expand))
	if(inherits(.envir,"tvcov"))return(fnenvir.tvcov(.z,.envir,.name=.name,.expand))
	if(inherits(.envir,"data.frame"))return(fnenvir.data.frame(.z,.envir,.name=.name,.expand))}
#
# transform function to a character string
#
.ch1 <- deparse(.z,width=500)
.ch2 <- .ch1[1]
.ch1 <- .ch1[-1]
#
# find arguments of function
#
.mem2 <- strsplit(gsub("[(),]"," ",.ch2)," ")[[1]]
if(length(.mem2)>0).mem2 <- .mem2[.mem2!=""]
if(length(.mem2)>1).mem2 <- .mem2[2:length(.mem2)]
else .mem2 <- NULL
#
# find body of function
#
.fcn <- .ex <- .ch <- NULL
for(.j in 1:length(.ch1)).ch <- paste(.ch,.ch1[.j],collapse=" ")
#
# remove punctuation from function body
#
.mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(\\.[0-9]+)|(^[0-9]+)"," ",.ch)," ")[[1]]
if(length(.mem)>0).mem <- .mem[.mem!=""]
#
# create indicators for variables that exist in the given environment (.ex)
# and for functions (.fcn) and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	for(.j in 1:length(.mem)){
		.ex <- c(.ex,exists(.mem[.j],envir=.envir))
		.fcn <- c(.fcn,if(exists(.mem[.j])){
			if(.mem[.j]=="function"||.mem[.j]=="if"||
				.mem[.j]=="else"||.mem[.j]=="for"||
				.mem[.j]=="while"||.mem[.j]=="repeat") TRUE
			else is.function(eval(parse(text=.mem[.j])))}
			else FALSE)}
	for(.j in 1:length(.mem)){
		if(!.fcn[.j]&&.ex[.j]&&is.factor(eval(parse(text=.mem[.j]),envir=.envir)))stop(paste(.mem[.j],"is a factor variable"))}
	.un <- unique(.mem[!.ex])
	if(length(unique(.mem[.ex&!.fcn]))==0&&length(.un)==0)
		warning("fnenvir.default: no variables found")}
#
# put extra spaces in character string so that substitutions can be made
#
.ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch)))
.ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",.ch))))
.ch <- paste(" ",gsub("\\("," ( ",gsub(":"," : ",.ch))," ",sep="")
.ch2 <- strsplit(.ch," ")[[1]]
#
# find arguments in body with (.un) and without (.un0) subscripts
#
.un <- .un0 <- .un1 <- NULL
if(length(.mem2)>0)for(.j in 1:length(.mem2)){
	.ex1a <- NULL
	for(.k in 1:length(.ch2))if(.mem2[.j]==.ch2[.k]){
		if(.k<length(.ch2)&&length(grep("^\\[",.ch2[.k+1]))>0){
			.ex1a <- c(.ex1a,paste(.ch2[.k],.ch2[.k+1],sep=""))
			.un1 <- c(.un1,.ch2[.k])}
		else .un0 <- c(.un0,.ch2[.k])}
	if(!is.null(.ex1a)){
		.ex1a <- unique(.ex1a)
		.o <- gsub("(^[[:alnum:]]\\[)|(\\])","",.ex1a)
		.un <- if(length(grep("[[:alpha:]]",.o))>0)c(.un,.ex1a)
			else c(.un,.ex1a[order(as.numeric(.o))])}}
#
# find unique arguments without subscripts and add to .un
#
if(length(.un0)>0){
	if(length(.un1)>0){
		.tmp <- NULL
		for(.k in 1:length(.un1))
			if(length(grep(.un1[.k],.un0))>0)
				.tmp <- c(.tmp,grep(.un1[.k],.un0))
		.un <- c(.un,unique(.un0[-.tmp]))}
	else .un <- c(.un,unique(.un0))}
#
# create the new function that evaluates its model attribute
#
.fnb <- eval(parse(text=paste("function(",paste(.mem2,collapse=","),")",paste("eval(attr(.fnb,\"model\"))"))))
.ex <- if(length(.fcn)>0&&!is.null(.ex)).ex&!.fcn else NULL
attributes(.fnb) <- list(model=parse(text=.ch1),parameters=.un,
	covariates=unique(.mem[.ex]),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fnb"])
rm(.obj)
return(.fnb)}

### method for repeated objects
###
fnenvir.repeated <- function(.z, .envir=NULL, .name=NULL, .expand=TRUE,
	.response=FALSE){
if(!is.function(.z))return(NULL)
#
# find the appropriate environment if its name is supplied
#
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
#
# transform function to a character string
#
.ch1 <- deparse(.z,width=500)
.ch2 <- .ch1[1]
.ch1 <- .ch1[-1]
#
# find arguments of function
#
.mem2 <- strsplit(gsub("[(),]"," ",.ch2)," ")[[1]]
if(length(.mem2)>0).mem2 <- .mem2[.mem2!=""]
if(length(.mem2)>1).mem2 <- .mem2[2:length(.mem2)]
else .mem2 <- NULL
#
# find body of function
#
.fcn <- .ex1 <- .ex2 <- .ex3 <- .ex4 <- .ch <- NULL
for(.j in 1:length(.ch1)).ch <- paste(.ch,.ch1[.j],collapse=" ")
#
# remove punctuation from function body
#
.mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(\\.[0-9]+)|(^[0-9]+)"," ",.ch)," ")[[1]]
if(length(.mem)>0).mem <- .mem[.mem!=""]
#
# create indicators for variables that exist in the repeated environment (.ex)
# and for functions (.fcn) and a vector of unique parameter names (.un)
#
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,colnames(.envir$response$y))
	if(any(!is.na(.ex2))&&!.expand)stop("time-varying covariates present - time-constant ones must be expanded")
	for(.j in 1:length(.mem)){
		.fcn <- c(.fcn,if(exists(.mem[.j])){
			if(.mem[.j]=="function"||.mem[.j]=="if"||
				.mem[.j]=="else"||.mem[.j]=="for"||
				.mem[.j]=="while"||.mem[.j]=="repeat") TRUE
			else is.function(eval(parse(text=.mem[.j])))&&is.na(.ex1[.j])&&is.na(.ex2[.j])&&is.na(.ex3[.j])&&is.na(.ex4[.j])}
			else FALSE)}
	.un <- unique(.mem[is.na(.ex1)&is.na(.ex2)&is.na(.ex3)&is.na(.ex4)&!.fcn])
	if(length(unique(.mem[(!is.na(.ex1)|!is.na(.ex2)|!is.na(.ex3)|!is.na(.ex4))&!.fcn]))==0&&length(.un)==0)
		warning("fnenvir.repeated: no variables found")}
#
# put extra spaces in character string so that substitutions can be made
#
for(.j in 1:length(.ch1)){
	.ch1[.j] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch1[.j])))
	.ch1[.j] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",.ch1[.j])))
	.ch1[.j] <- paste(" ",gsub("\\("," ( ",.ch1[.j])," ",sep="")}
#
# replace time-constant covariate names by location in data object,
# expanding to the proper length, if required
#
if(.expand).i <- covind(.envir)
.ex1a <- .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a)){
	if(is.factor(.envir$ccov$ccov[,.ex1a[.j]]))stop(paste(colnames(.envir$ccov$ccov)[.ex1a[.j]],"is a factor variable"))
	for(.k in 1:length(.ch1))
	.ch1[.k] <- if(.expand)gsub(paste(" ",colnames(.envir$ccov$ccov)[.ex1a[.j]],
		" ",sep=""),paste(" ",.ndata,"$ccov$ccov[,",
		.ex1a[.j],"][.i] ",sep=""),.ch1[.k])
		else gsub(paste(" ",colnames(.envir$ccov$ccov)[.ex1a[.j]],
		" ",sep=""),paste(" ",.ndata,"$ccov$ccov[,",
		.ex1a[.j],"] ",sep=""),.ch1[.k])}
#
# replace time-varying covariate names by location in data object
#
.ex2a <- .ex2[!is.na(.ex2)]
if(length(.ex2a)>0)for(.j in 1:length(.ex2a)){
	if(is.factor(.envir$tvcov$tvcov[,.ex2a[.j]]))stop(paste(colnames(.envir$tvcov$tvcov)[.ex2a[.j]],"is a factor variable"))
	for(.k in 1:length(.ch1))
		.ch1[.k] <- gsub(paste(" ",colnames(.envir$tvcov$tvcov)[.ex2a[.j]],
			" ",sep=""),paste(" ",.ndata,"$tvcov$tvcov[,",
			.ex2a[.j],"] ",sep=""),.ch1[.k])}
#
# replace special name, times, by location in data object
#
.ex3a <- if(is.null(.ex3)) NULL else .ex3[!is.na(.ex3)]
if(length(.ex3a)>0)for(.k in 1:length(.ch1))
	.ch1[.k] <- gsub(" times ",paste(" ",.ndata,"$response$times ",sep=""),.ch1[.k])
#
# replace response by location in data object
#
.ex4a <- .ex4[!is.na(.ex4)]
if(length(.ex4a)>0){
	if(dim(.envir$response$y)[2]==1&&!.response)
		stop(paste(colnames(.envir$response$y)[.ex4a]," is the response and cannot be a covariate"))
	for(.k in 1:length(.ch1))
		.ch1[.k] <- gsub(paste(" ",colnames(.envir$response$y)[.ex4a[.j]],
			" ",sep=""),paste(" ",.ndata,"$response$y[,",
			.ex4a[.j],"] ",sep=""),.ch1[.k])}
#
# put extra spaces in character string so that substitutions can be made
#
.ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch)))
.ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",.ch))))
.ch <- paste(" ",gsub("\\("," ( ",gsub(":"," : ",.ch))," ",sep="")
.ch2 <- strsplit(.ch," ")[[1]]
#
# find arguments in body with (.un) and without (.un0) subscripts
#
.un <- .un0 <- .un1 <- NULL
if(length(.mem2)>0)for(.j in 1:length(.mem2)){
	.ex1a <- NULL
	for(.k in 1:length(.ch2))if(.mem2[.j]==.ch2[.k]){
		if(.k<length(.ch2)&&length(grep("^\\[",.ch2[.k+1]))>0){
			.ex1a <- c(.ex1a,paste(.ch2[.k],.ch2[.k+1],sep=""))
			.un1 <- c(.un1,.ch2[.k])}
		else .un0 <- c(.un0,.ch2[.k])}
	if(!is.null(.ex1a)){
		.ex1a <- unique(.ex1a)
		.o <- gsub("(^[[:alnum:]]\\[)|(\\])","",.ex1a)
		.un <- if(length(grep("[[:alpha:]]",.o))>0)c(.un,.ex1a)
			else c(.un,.ex1a[order(as.numeric(.o))])}}
#
# find unique arguments without subscripts and add to .un
#
if(length(.un0)>0){
	if(length(.un1)>0){
		.tmp <- NULL
		for(.k in 1:length(.un1))
			if(length(grep(.un1[.k],.un0))>0)
				.tmp <- c(.tmp,grep(.un1[.k],.un0))
		.un <- c(.un,unique(.un0[-.tmp]))}
	else .un <- c(.un,unique(.un0))}
#
# create the new function that evaluates its model attribute
#
.fnb <- eval(parse(text=paste("function(",paste(.mem2,collapse=","),")",paste("eval(attr(.fnb,\"model\"))"))))
.ex1 <- if(!is.null(.ex1)&&!is.null(.ex2)&&!is.null(.ex3)&&length(.fcn)>0)
	(!is.na(.ex1)|!is.na(.ex2)|!is.na(.ex3))&!.fcn else NULL
attributes(.fnb) <- list(model=parse(text=.ch1),parameters=.un,
	covariates=unique(.mem[.ex1]),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".i"&.obj!=".fnb"])
rm(.obj)
return(.fnb)}

### method for tccov objects
###
fnenvir.tccov <- function(.z, .envir=NULL, .name=NULL, .expand=TRUE){
if(!is.function(.z))return(NULL)
#
# find the appropriate environment if its name is supplied
#
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
#
# transform function to a character string
#
.ch1 <- deparse(.z,width=500)
.ch2 <- .ch1[1]
.ch1 <- .ch1[-1]
#
# find arguments of function
#
.mem2 <- strsplit(gsub("[(),]"," ",.ch2)," ")[[1]]
if(length(.mem2)>0).mem2 <- .mem2[.mem2!=""]
if(length(.mem2)>1).mem2 <- .mem2[2:length(.mem2)]
else .mem2 <- NULL
#
# find body of function
#
.fcn <- .ex1 <- .ch <- NULL
for(.j in 1:length(.ch1)).ch <- paste(.ch,.ch1[.j],collapse=" ")
#
# remove punctuation from function body
#
.mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(\\.[0-9]+)|(^[0-9]+)"," ",.ch)," ")[[1]]
if(length(.mem)>0).mem <- .mem[.mem!=""]
#
# create appropriate names for search in data object
#
if(inherits(.envir,"repeated")){
	.cn <- colnames(.envir$ccov$ccov)
	.cc <- "$ccov"}
else {
	.cn <- colnames(.envir$ccov)
	.cc <- ""}
#
# create indicators for variables that exist in the tccov environment (.ex)
# and for functions (.fcn) and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	.ex1 <- match(.mem,.cn)
	for(.j in 1:length(.mem)){
		.fcn <- c(.fcn,if(exists(.mem[.j])){
			if(.mem[.j]=="function"||.mem[.j]=="if"||
				.mem[.j]=="else"||.mem[.j]=="for"||
				.mem[.j]=="while"||.mem[.j]=="repeat") TRUE
			else is.function(eval(parse(text=.mem[.j])))&&is.na(.ex1[.j])}
			else FALSE)}
	.un <- unique(.mem[is.na(.ex1)&!.fcn])
	if(length(unique(.mem[!is.na(.ex1)&!.fcn]))==0&&length(.un)==0)
		warning("fnenvir.tccov: no variables found")}
#
# put extra spaces in character string so that substitutions can be made
#
for(.j in 1:length(.ch1)){
	.ch1[.j] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch1[.j])))
	.ch1[.j] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",.ch1[.j])))
	.ch1[.j] <- paste(" ",gsub("\\("," ( ",.ch1[.j])," ",sep="")}
#
# replace time-constant covariate names by location in data object,
# expanding to the proper length, if required
#
.ex1a <- .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a)){
	if(inherits(.envir,"repeated")){
		if(is.factor(.envir$ccov$ccov[,.ex1a[.j]]))stop(paste(colnames(.envir$ccov$ccov)[.ex1a[.j]],"is a factor variable"))}
	else if(is.factor(.envir$ccov[,.ex1a[.j]]))stop(paste(colnames(.envir$ccov)[.ex1a[.j]],"is a factor variable"))
	for(.k in 1:length(.ch1)).ch1[.k] <- gsub(paste(" ",.cn[.ex1a[.j]],
		" ",sep=""),paste(" ",.ndata,.cc,"$ccov[,",
		.ex1a[.j],"] ",sep=""),.ch1[.k])}
#
# put extra spaces in character string so that substitutions can be made
#
.ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch)))
.ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",.ch))))
.ch <- paste(" ",gsub("\\("," ( ",gsub(":"," : ",.ch))," ",sep="")
.ch2 <- strsplit(.ch," ")[[1]]
#
# find arguments in body with (.un) and without (.un0) subscripts
#
.un <- .un0 <- .un1 <- NULL
if(length(.mem2)>0)for(.j in 1:length(.mem2)){
	.ex1a <- NULL
	for(.k in 1:length(.ch2))if(.mem2[.j]==.ch2[.k]){
		if(.k<length(.ch2)&&length(grep("^\\[",.ch2[.k+1]))>0){
			.ex1a <- c(.ex1a,paste(.ch2[.k],.ch2[.k+1],sep=""))
			.un1 <- c(.un1,.ch2[.k])}
		else .un0 <- c(.un0,.ch2[.k])}
	if(!is.null(.ex1a)){
		.ex1a <- unique(.ex1a)
		.o <- gsub("(^[[:alnum:]]\\[)|(\\])","",.ex1a)
		.un <- if(length(grep("[[:alpha:]]",.o))>0)c(.un,.ex1a)
			else c(.un,.ex1a[order(as.numeric(.o))])}}
#
# find unique arguments without subscripts and add to .un
#
if(length(.un0)>0){
	if(length(.un1)>0){
		.tmp <- NULL
		for(.k in 1:length(.un1))
			if(length(grep(.un1[.k],.un0))>0)
				.tmp <- c(.tmp,grep(.un1[.k],.un0))
		.un <- c(.un,unique(.un0[-.tmp]))}
	else .un <- c(.un,unique(.un0))}
#
# create the new function that evaluates its model attribute
#
.fnb <- eval(parse(text=paste("function(",paste(.mem2,collapse=","),")",paste("eval(attr(.fnb,\"model\"))"))))
.ex1 <- if(!is.null(.ex1)&&length(.fcn)>0)!is.na(.ex1)&!.fcn else NULL
attributes(.fnb) <- list(model=parse(text=.ch1),parameters=.un,
	covariates=unique(.mem[.ex1]),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fnb"])
rm(.obj)
return(.fnb)}

### method for tvcov objects
###
fnenvir.tvcov <- function(.z, .envir=NULL, .name=NULL, .expand=TRUE){
if(!is.function(.z))return(NULL)
#
# find the appropriate environment if its name is supplied
#
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
#
# transform function to a character string
#
.ch1 <- deparse(.z,width=500)
.ch2 <- .ch1[1]
.ch1 <- .ch1[-1]
#
# find arguments of function
#
.mem2 <- strsplit(gsub("[(),]"," ",.ch2)," ")[[1]]
if(length(.mem2)>0).mem2 <- .mem2[.mem2!=""]
if(length(.mem2)>1).mem2 <- .mem2[2:length(.mem2)]
else .mem2 <- NULL
#
# find body of function
#
.fcn <- .ex2 <- .ch <- NULL
for(.j in 1:length(.ch1)).ch <- paste(.ch,.ch1[.j],collapse=" ")
#
# remove punctuation from function body
#
.mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(\\.[0-9]+)|(^[0-9]+)"," ",.ch)," ")[[1]]
if(length(.mem)>0).mem <- .mem[.mem!=""]
#
# create appropriate names for search in data object
#
if(inherits(.envir,"repeated")){
	.cn <- colnames(.envir$tvcov$tvcov)
	.cc <- "$tvcov"}
else {
	.cn <- colnames(.envir$tvcov)
	.cc <- ""}
#
# create indicators for variables that exist in the tccov environment (.ex)
# and for functions (.fcn) and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	.ex2 <- match(.mem,.cn)
	for(.j in 1:length(.mem)){
		.fcn <- c(.fcn,if(exists(.mem[.j])){
			if(.mem[.j]=="function"||.mem[.j]=="if"||
				.mem[.j]=="else"||.mem[.j]=="for"||
				.mem[.j]=="while"||.mem[.j]=="repeat") TRUE
			else is.function(eval(parse(text=.mem[.j])))&&is.na(.ex1[.j])}
			else FALSE)}
	.un <- unique(.mem[is.na(.ex2)&!.fcn])
	if(length(unique(.mem[!is.na(.ex2)&!.fcn]))==0&&length(.un)==0)
		warning("fnenvir.tvcov: no variables found")}
#
# put extra spaces in character string so that substitutions can be made
#
for(.j in 1:length(.ch1)){
	.ch1[.j] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch1[.j])))
	.ch1[.j] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",.ch1[.j])))
	.ch1[.j] <- paste(" ",gsub("\\("," ( ",.ch1[.j])," ",sep="")}
#
# replace time-varying covariate names by location in data object,
# expanding to the proper length, if required
#
.ex2a <- .ex2[!is.na(.ex2)]
if(length(.ex2a)>0)for(.j in 1:length(.ex2a)){
	if(inherits(.envir,"repeated")){
		if(is.factor(.envir$tvcov$tvcov[,.ex2a[.j]]))stop(paste(colnames(.envir$tvcov$tvcov)[.ex2a[.j]],"is a factor variable"))}
	else if(is.factor(.envir$tvcov[,.ex2a[.j]]))stop(paste(colnames(.envir$tvcov)[.ex2a[.j]],"is a factor variable"))
	for(.k in 1:length(.ch1)).ch1[.k] <- gsub(paste(" ",.cn[.ex2a[.j]],
		" ",sep=""),paste(" ",.ndata,.cc,"$tvcov[,",
		.ex2a[.j],"] ",sep=""),.ch1[.k])}
#
# put extra spaces in character string so that substitutions can be made
#
.ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch)))
.ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",.ch))))
.ch <- paste(" ",gsub("\\("," ( ",gsub(":"," : ",.ch))," ",sep="")
.ch2 <- strsplit(.ch," ")[[1]]
#
# find arguments in body with (.un) and without (.un0) subscripts
#
.un <- .un0 <- .un1 <- NULL
if(length(.mem2)>0)for(.j in 1:length(.mem2)){
	.ex1a <- NULL
	for(.k in 1:length(.ch2))if(.mem2[.j]==.ch2[.k]){
		if(.k<length(.ch2)&&length(grep("^\\[",.ch2[.k+1]))>0){
			.ex1a <- c(.ex1a,paste(.ch2[.k],.ch2[.k+1],sep=""))
			.un1 <- c(.un1,.ch2[.k])}
		else .un0 <- c(.un0,.ch2[.k])}
	if(!is.null(.ex1a)){
		.ex1a <- unique(.ex1a)
		.o <- gsub("(^[[:alnum:]]\\[)|(\\])","",.ex1a)
		.un <- if(length(grep("[[:alpha:]]",.o))>0)c(.un,.ex1a)
			else c(.un,.ex1a[order(as.numeric(.o))])}}
#
# find unique arguments without subscripts and add to .un
#
if(length(.un0)>0){
	if(length(.un1)>0){
		.tmp <- NULL
		for(.k in 1:length(.un1))
			if(length(grep(.un1[.k],.un0))>0)
				.tmp <- c(.tmp,grep(.un1[.k],.un0))
		.un <- c(.un,unique(.un0[-.tmp]))}
	else .un <- c(.un,unique(.un0))}
#
# create the new function that evaluates its model attribute
#
.fnb <- eval(parse(text=paste("function(",paste(.mem2,collapse=","),")",paste("eval(attr(.fnb,\"model\"))"))))
.ex2 <- if(!is.null(.ex2)&&length(.fcn)>0)!is.na(.ex2)&!.fcn else NULL
attributes(.fnb) <- list(model=parse(text=.ch1),parameters=.un,
	covariates=unique(.mem[.ex2]),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fnb"])
rm(.obj)
return(.fnb)}

### method for dataframes
###
fnenvir.data.frame <- function(.z, .envir=NULL, .name=NULL, .expand=TRUE){
if(!is.function(.z))return(NULL)
#
# find the appropriate environment if its name is supplied
#
.ndata <- if(is.null(.name))paste(deparse(substitute(.envir)))
else .name
#
# transform function to a character string
#
.ch1 <- deparse(.z,width=500)
.ch2 <- .ch1[1]
.ch1 <- .ch1[-1]
#
# find arguments of function
#
.mem2 <- strsplit(gsub("[(),]"," ",.ch2)," ")[[1]]
if(length(.mem2)>0).mem2 <- .mem2[.mem2!=""]
if(length(.mem2)>1).mem2 <- .mem2[2:length(.mem2)]
else .mem2 <- NULL
#
# find body of function
#
.fcn <- .ex1 <- .ch <- NULL
for(.j in 1:length(.ch1)).ch <- paste(.ch,.ch1[.j],collapse=" ")
#
# remove punctuation from function body
#
.mem <- strsplit(gsub("(\\[(0|1|2|3|4|5|6|7|8|9|:|,)+\\])|([][+*/^():!<>%&|~,{}\"\\\=-])|( [0-9]+)|(\\.[0-9]+)|(^[0-9]+)"," ",.ch)," ")[[1]]
if(length(.mem)>0).mem <- .mem[.mem!=""]
#
# create appropriate names for search in data object
#
.cn <- colnames(.envir)
#
# create indicators for variables that exist in the dataframe (.ex)
# and for functions (.fcn) and a vector of unique parameter names (.un)
#
if(length(.mem)>0){
	.ex1 <- match(.mem,.cn)
	for(.j in 1:length(.mem)){
		.fcn <- c(.fcn,if(exists(.mem[.j])){
			if(.mem[.j]=="function"||.mem[.j]=="if"||
				.mem[.j]=="else"||.mem[.j]=="for"||
				.mem[.j]=="while"||.mem[.j]=="repeat") TRUE
			else is.function(eval(parse(text=.mem[.j])))&&is.na(.ex1[.j])}
			else FALSE)}
	.un <- unique(.mem[is.na(.ex1)&!.fcn])
	if(length(unique(.mem[!is.na(.ex1)&!.fcn]))==0&&length(.un)==0)
		warning("fnenvir.data.frame: no variables found")}
#
# put extra spaces in character string so that substitutions can be made
#
for(.j in 1:length(.ch1)){
	.ch1[.j] <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch1[.j])))
	.ch1[.j] <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",.ch1[.j])))
	.ch1[.j] <- paste(" ",gsub("\\("," ( ",.ch1[.j])," ",sep="")}
#
# replace covariate names by location in data object
#
.ex1a <- .ex1[!is.na(.ex1)]
if(length(.ex1a)>0)for(.j in 1:length(.ex1a)){
	if(is.factor(.envir[,.ex1a[.j]]))stop(paste(colnames(.envir)[.ex1a[.j]],"is a factor variable"))
	for(.k in 1:length(.ch1)).ch1[.k] <- gsub(paste(" ",.cn[.ex1a[.j]],
		" ",sep=""),paste(" ",.ndata,"$",.cn[.ex1a[.j]],
		sep=""),.ch1[.k])}
#
# put extra spaces in character string so that substitutions can be made
#
.ch <- gsub("\\^"," ^ ",gsub("\\)"," )",gsub("\\["," [",.ch)))
.ch <- gsub("-","- ",gsub("/"," / ",gsub(","," ,",gsub("\\+","+ ",.ch))))
.ch <- paste(" ",gsub("\\("," ( ",gsub(":"," : ",.ch))," ",sep="")
.ch2 <- strsplit(.ch," ")[[1]]
#
# find arguments in body with (.un) and without (.un0) subscripts
#
.un <- .un0 <- .un1 <- NULL
if(length(.mem2)>0)for(.j in 1:length(.mem2)){
	.ex1a <- NULL
	for(.k in 1:length(.ch2))if(.mem2[.j]==.ch2[.k]){
		if(.k<length(.ch2)&&length(grep("^\\[",.ch2[.k+1]))>0){
			.ex1a <- c(.ex1a,paste(.ch2[.k],.ch2[.k+1],sep=""))
			.un1 <- c(.un1,.ch2[.k])}
		else .un0 <- c(.un0,.ch2[.k])}
	if(!is.null(.ex1a)){
		.ex1a <- unique(.ex1a)
		.o <- gsub("(^[[:alnum:]]\\[)|(\\])","",.ex1a)
		.un <- if(length(grep("[[:alpha:]]",.o))>0)c(.un,.ex1a)
			else c(.un,.ex1a[order(as.numeric(.o))])}}
#
# find unique arguments without subscripts and add to .un
#
if(length(.un0)>0){
	if(length(.un1)>0){
		.tmp <- NULL
		for(.k in 1:length(.un1))
			if(length(grep(.un1[.k],.un0))>0)
				.tmp <- c(.tmp,grep(.un1[.k],.un0))
		.un <- c(.un,unique(.un0[-.tmp]))}
	else .un <- c(.un,unique(.un0))}
#
# create the new function that evaluates its model attribute
#
.fnb <- eval(parse(text=paste("function(",paste(.mem2,collapse=","),")",paste("eval(attr(.fnb,\"model\"))"))))
.ex1 <- if(!is.null(.ex1)&&length(.fcn)>0)!is.na(.ex1)&!.fcn else NULL
attributes(.fnb) <- list(model=parse(text=.ch1),parameters=.un,
	covariates=unique(.mem[.ex1]),class="formulafn")
.obj <- ls(all.names=TRUE)
rm(list=.obj[.obj!=".fnb"])
rm(.obj)
return(.fnb)}

### print methods
###
print.formulafn <- function(z){
if(!is.null(attr(z,"formula"))){
	cat("\nformula:\n")
	print.default(unclass(attr(z,"formula")))}
if(!is.character(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){
	if(length(attr(z,"common"))>0)cat(paste("\nnew parameters:\n"))
	else cat(paste("\nparameters:\n"))
	for(i in 1:length(attr(z,"parameters")))
		cat(attr(z,"parameters")[i]," ")
	cat("\n")}
if(length(attr(z,"common"))>0){
	cat(paste("\ncommon parameters:\n"))
	for(i in 1:length(attr(z,"common")))
		cat(attr(z,"common")[i]," ")
	cat("\n")}
cat("\n")}

print.fmobj <- function(z){
if(any(z$parameters)){
	tmp <- unique(z$objects[z$parameters])
	cat(paste("\nparameters:\n"))
	for(i in 1:length(tmp))
		cat(tmp[i]," ")
	cat("\n")}
if(any(z$covariates)){
	tmp <- unique(z$objects[z$covariates])
	cat(paste("\ncovariates:\n"))
	for(i in 1:length(tmp))
		cat(tmp[i]," ")
	cat("\n")}
if(any(z$factors)){
	tmp <- unique(z$objects[z$factors])
	cat(paste("\nfactors:\n"))
	for(i in 1:length(tmp))
		cat(tmp[i]," ")
	cat("\n")}
if(!is.null(z$functions)){
	cat(paste("\nfunctions:\n"))
	for(i in 1:length(z$functions))
		cat(z$functions[i]," ")
	cat("\n")}
cat("\n")
}

### miscellaneous methods
###
### extract the model
###
model <- function(z, ...) UseMethod("model")

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

### extract the original formula
###
formula.formulafn <- function(z) attr(z,"formula")

### extract the covariate names
###
covariates.formulafn <- function(z, ...) attr(z,"covariates")

### extract the parameter names
###
parameters <- function(z, ...) UseMethod("parameters")

parameters.formulafn <- function(z) attr(z,"parameters")
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     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 necessary, make into response object and remove NAs
#
if(inherits(response,"response"))izr <- response
else izr <- restovec(response,times)
if(any(is.na(izr$y))){
	isna <- TRUE
	nna <- length(izr$y)
	tmp <- NULL
	rna <- !is.na(izr$y)
	irna <- (1:nna)*rna
	j <- c(0,cumsum(nobs(izr)))
	for(i in 1:length(nobs(izr)))tmp <- c(tmp,sum(rna[(j[i]+1):j[i+1]]))
	zr <- list()
	zr$nobs <- tmp
	zr$times <- izr$times[rna]
	zr$y <- izr$y[rna]
	class(zr) <- "response"}
else {
	isna <- FALSE
	zr <- izr}
#
# remove NAs from time-varying covariate
#
zt <- restovec(tvcov,tvctimes)
if(any(is.na(zt$y))){
	tmp <- NULL
	rna <- !is.na(zt$y)
	j <- c(0,cumsum(nobs(zt)))
	for(i in 1:length(nobs(zt)))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(nobs(izr))!=length(nobs(zt)))
	stop("response and covariate do not have the same number of individuals")
#
# obtain new aligned times
#
nind <- length(nobs(zr))
nld <- max(c(nobs(zr),nobs(zt)))
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(nobs(zr)),
	nind=as.integer(nind),
	nknt=as.integer(nobs(zt)),
	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=FALSE,
	PACKAGE="rmutil")
if(isna){
	tvcov3 <- rep(NA,nna)
	tvcov3[irna] <- z2$tvcov3}
else tvcov3 <- z2$tvcov3
rm(z2)
#
# check if new covariate or to be combined with others
#
new <- missing(oldtvcov)
if(!new&!is.list(oldtvcov)){
	warning("oldtvcov must form a list - ignored")
	new <- TRUE}
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")){
#
# combine tvcov objects
#
	oldtvcov$tvcov <- cbind(oldtvcov$tvcov,tvcov3)
	colnames(oldtvcov$tvcov) <- cname}
else {
#
# create a new tvcov object
#
	nm <- 0
	for(i in 1:nind){
		oldtvcov[[i]] <- cbind(oldtvcov[[i]],tvcov3[(nm+1):
			(nm+nobs(izr)[i])])
		nm <- nm+nobs(izr)[i]
		if(!is.null(cname))colnames(oldtvcov[[i]]) <- cname}
	oldtvcov <- tvctomat(oldtvcov)}
invisible(oldtvcov)}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     int(f, a=-Inf, b=Inf, type="Romberg", eps=0.0001,
#	max=NULL, d=NULL, p=0)
#
#  DESCRIPTION
#
#    A function to perform vectorized Romberg integration

.First.lib <- function(lib, pkg)
	library.dynam("rmutil", pkg, lib)
###
### vectorized one-dimensional integration
###
int <- function(f, a=-Inf, b=Inf, type="Romberg", eps=0.0001,
	max=NULL, d=NULL, p=0){
#
# function to call the C code
#
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),
		PACKAGE="rmutil")
	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}
#
# check algorithm to be used and initialize parameters
#
type <- match.arg(type,c("Romberg","TOMS614"))
if(is.null(max))max <- if(type=="Romberg") 16 else 100
if(is.null(d))d <- if(type=="Romberg") 5 else 1
#
# check function and integration limits
#
if(length(formals(f))!=1)stop("f must have one argument")
if(any(a==Inf))stop("lower bound cannot be Inf")
if(any(b==-Inf))stop("upper bound cannot be -Inf")
if((length(a)>1&&any(a==-Inf)&&all(a!=-Inf))||(length(b)>1&&any(b==Inf)&&all(b!=Inf)))stop("int cannot be vectorized with some limits infinite")
#
# determine length of vector to be integrated
#
if(all(a!=-Inf)){
	if(all(b!=Inf)){
		if(any(a>=b))stop("some a>=b")
		len <- length(f((a+b)/2))}
	else len <- length(f(a+1))}
else if(all(b!=Inf))len <- length(f(b-1))
else len <- length(f(0))
if(len>1&&type!="Romberg")stop("vector functions only allowed with Romberg")
#
# if a vector and there are infinite limits, check that all limits are infinite
#
if(all(a!=-Inf)&&length(a)!=len){
	if(length(a)!=1)stop("a has incorrect length")
	else a <- rep(a,len)}
if(all(b!=Inf)&&length(b)!=len){
	if(length(b)!=1)stop("b has incorrect length")
	else b <- rep(b,len)}
if(type=="Romberg"){
	# invert function for infinite limits
	ff <- function(x) f(1/x)/(x*x)
	if(b==Inf){
		if(all(a==-Inf))
		# both limits infinite
			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 {
		# only upper limit infinite, cut in 2 pieces about 0
			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(all(a==-Inf)){
	# only lower limit infinite, cut in 2 pieces about 0
		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 {
#
# TOMS614
#
	left <- a==-Inf&&b!=Inf
	if(b==Inf){
		if(all(a==-Inf)){
		# both limits infinite
			inf <- 1
			a <- b <- 1}
		else {
		# only upper limit is infinite
			inf <- 2
			b <- 1}}
	else if(all(a==-Inf)){
	# only lower limit is infinite
		a <- 1
		inf <- 1}
	else inf <- 4
	if(left){
	# lower limit infinite, upper limit numeric: calculate for
	# whole real line first
		z2 <- .C("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=FALSE,
		PACKAGE="rmutil")
		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"))}
	# integrate either for both limits finite or with upper limit infinite
	z1 <- .C("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=FALSE,
		PACKAGE="rmutil")
	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 lower limit infinite, upper limit numeric, subtract upper
	# part from that for whole real line
	if(left)z1$quadr <- z1$quadr-z2$quadr
	z1$quadr}}
###
### vectorized two-dimensional integration
###
int2 <- function(f, a=c(-Inf,-Inf), b=c(Inf,Inf), eps=1.0e-6, max=16, d=5){
#
# function adapted from Gentleman and Ihaka (2000)
#    Jr Comp Graph Stat 9, 491-508
#
g <- function(y){
	fx <- function(x) f(x,y)
	romberg(fx,a[,2],b[,2])}
#
# function to call the C code
#
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),
		PACKAGE="rmutil")
	if(z$err==1)warning("Unable to allocate memory for int2")
	if(z$err==2)warning("Division by zero in int2")
	else if(z$err==3)warning("No convergence in int2")
	z$res}
#
# function for Romberg integration
#
romberg <- function(f, a=-Inf, b=Inf){
	# invert function for infinite limits
        ff <- function(x) f(1/x)/(x*x)
        if(b==Inf){
        	if(all(a==-Inf))
        	# both limits infinite
        		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 {
        	# only upper limit infinite, cut in 2 pieces about 0
        		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(all(a==-Inf)){
        # only lower limit infinite, cut in 2 pieces about 0
        	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}
#
# check dimensions of limits
#
if(is.vector(a,mode="numeric")&&length(a)==2)a <- matrix(a,ncol=2)
else if(is.matrix(a)){
	if(dim(a)[2]!=2)stop("a must be 2-column matrix")}
else stop("a must be a 2-element vector or a 2-column matrix")
if(is.vector(b,mode="numeric")&&length(b)==2)b <- matrix(b,ncol=2)
else if(is.matrix(b)){
	if(dim(b)[2]!=2)stop("b must be 2-column matrix")}
else stop("b must be a 2-element vector or a 2-column matrix")
if((dim(a)[1]>1&&((any(a[,1]==-Inf)&&all(a[,1]!=-Inf))||(any(a[,2]==-Inf)&&all(a[,1]!=-Inf))))||(dim(b)[1]>1&&((any(b[,1]==Inf)&&all(b[,1]!=Inf))||(any(b[,2]==Inf)&&all(b[,1]!=Inf)))))stop("int2 cannot have only some limits infinite")
if(length(formals(f))!=2)stop("f must have two arguments")
#
# determine length of vectors to be integrated
#
if(all(a!=-Inf)){
	if(all(b!=Inf)){
		if(any(a[,1]>=b[,1])||any(a[,2]>=b[,2]))stop("some a>=b")
		len <- length(f((a[,1]+b[,1])/2,(a[,2]+b[,2])/2))}
	else len <- length(f(a[,1]+1,a[,2]+1))}
else if(all(b!=Inf))len <- length(f(b[,1]-1,b[,2]-1))
else len <- length(f(0,0))
#
# if a matrix and there are infinite limits, check that all limits are infinite
#
if(any(a!=-Inf)&&dim(a)[1]!=len){
	if(dim(a)[1]!=1)stop("a has incorrect size")
	else a <- matrix(rep(a,len),ncol=2,byrow=TRUE)}
if(any(b!=Inf)&&dim(b)[1]!=len){
	if(dim(b)[1]!=1)stop("b has incorrect size")
	else b <- matrix(rep(b,len),ncol=2,byrow=TRUE)}
#
# integrate
#
romberg(g,a[,1],b[,1])}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     restovec(response, times=NULL, nest=NULL, coordinates=NULL,
#	censor=NULL, totals=NULL, weights=NULL, delta=NULL, type=NULL,
#	names=NULL, units=NULL, oldresponse=NULL, description=NULL)
#     tcctomat(ccov, names=NULL, units=NULL, oldtccov=NULL, dataframe=TRUE,
#     description=NULL)
#     tvctomat(tvcov, names=NULL, units=NULL, interaction=NULL, ccov=NULL,
#	oldtvcov=NULL, dataframe=TRUE, description=NULL)
#     rmna(response, tvcov=NULL, ccov=NULL)
#     lvna(response, tvcov=NULL, ccov=NULL)
#     dftorep(dataframe, response, id=NULL, times=NULL, censor=NULL,
#	totals=NULL, weights=NULL, nest=NULL, delta=NULL,
#	coordinates=NULL, type=NULL, ccov=NULL, tvcov=NULL, na.rm=TRUE)
#     as.data.frame(z)
#     as.matrix(z)
#     covariates(z, nind=NULL, names=NULL)
#     covind(z)
#     delta(z, nind=NULL, names=NULL)
#     formula(z)
#     names(z)
#     nesting(z, nind=NULL)
#     nobs(z)
#     plot.response(z, nind=NULL, name=NULL, nest=1, ccov=NULL, add=FALSE,
#	lty=NULL, pch=NULL, main=NULL, ylim=NULL, xlim=NULL, xlab=NULL,
#	ylab=NULL, ...)
#     plot.repeated(z, name=NULL, nind=NULL, ccov=NULL, add=FALSE, lty=NULL,
#	main=NULL, ylim=NULL, xlim=NULL, xlab=NULL, ylab=NULL, ...)
#     print(z)
#     response(z, nind=NULL, names=NULL)
#     times(z, nind=NULL)
#     transform(z, ...)
#     weights(z, nind=NULL)
#
#  DESCRIPTION
#
#    Utility functions for converting repeated measurements data to R objects

### function to create a response object
###
restovec <- function(response=NULL, times=NULL, nest=NULL, coordinates=NULL,
	censor=NULL, totals=NULL, weights=NULL, delta=NULL, type=NULL,
	names=NULL, units=NULL, oldresponse=NULL, description=NULL){
if(is.null(response))stop("A response must be supplied")
#
# check type
#
mvr <- length(names)>1
if(!is.null(type)){
	tmp <- NULL
	for(i in 1:length(type))
		tmp <- c(tmp,match.arg(type[i],
			c("nominal","ordinal","discrete","duration","continuous","unknown")))
	type <- tmp
	if(!mvr)mvr <- length(type)>1}
#
# initial values
#
nind <- 0
tnest <- nobs <- y <- NULL
#
# check if times are required
#
ttime <- !is.logical(times)||times
if((ttime&&is.logical(times))||!ttime)times <- NULL
#
# handle various forms of response
#
if(is.null(names))names <- paste(deparse(substitute(response)))
if(is.vector(response,mode="numeric")){
#
# numerical vector supplied: either univariate independent
#   observations or one time series
#
	y <- response
	# check if independent observations or one time series
	nobs <- if(is.null(times)) 1 else length(response)
	# check times
	if(is.vector(times,mode="numeric")){
		if(length(times)!=length(y))
			stop("times must be the same length as the response")}
	else if(!is.null(times))stop("times must be a vector")
	# check censor indicator
	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("censor must be the same length as the response")}}
	else if(!is.null(censor))stop("censor must be a scalar or vector")
	# check coordinates
	if(!is.null(coordinates)&&(!is.matrix(coordinates)||(is.matrix(coordinates)&&length(dim(coordinates))!=2&&dim(coordinates)[2]!=2&&dim(coordinates)[1]!=length(y))))
		stop("coordinates must be a matrix with two columns and the same number of rows as the length of response")
	# check totals
	if(is.vector(totals,mode="numeric")){
		if(length(totals)!=length(y)){
			if(length(totals)==1)totals <- rep(totals,length(y))
			else stop("totals must be the same length as the response")}}
	else if(!is.null(totals)) stop("totals must be a vector")
	# check weights
	if(is.vector(weights,mode="numeric")){
		if(length(weights)!=length(y))
		stop("weights must be the same length as the response")}
	else if(!is.null(weights))stop("weights must be a vector")
	# check delta
	if(is.vector(delta,mode="numeric")){
		if(length(delta)!=length(y)){
			if(length(delta)==1)delta <- rep(delta,length(y))
			else stop("delta must be the same length as the response")}}
	else if(!is.null(delta))stop("delta must be a scalar or vector")}
else if(is.array(response)&&length(dim(response))==3){
#
# one multivariate 3-dim array of balanced repeated measurements supplied
#
	nobs <- rep(dim(response)[2],dim(response)[1])
	if(length(names)==1)names <- paste(names,1:dim(response)[3],sep="")
	# check times
	if(is.null(times)){
		if(is.null(censor)&&ttime)
			times <- as.double(rep(1:dim(response)[2],dim(response)[1]))}
	else if(is.matrix(times)){
		if(dim(times)[2]!=dim(response)[2]||dim(times)[1]!=dim(response)[1])
			stop("times matrix must be the same size as first two dimensions of array of responses")
		# time steps can be 0 but not negative
		for(i in 1:dim(response)[1])
			if(any(diff(times[i,])<0,na.rm=TRUE))
			stop(paste("negative time step for individual ",i))
		times <- as.vector(t(times))}
	else if(is.vector(times,mode="numeric")) {
		if(is.null(nest)&&any(diff(times)<0,na.rm=TRUE))
			stop("times must be increasing")
		if(length(times)!=dim(response)[2])
			stop("number of times must equal number of response columns")
		times <- rep(times,dim(response)[1])}
	else stop("times must be a vector or matrix")
	# check weights
	if(is.matrix(weights)){
		if(dim(weights)[1]!=dim(response)[1]||dim(weights)[2]!=dim(response)[2])
			stop("weights matrix must be the same size as first two dimensions of array of responses")
		else weights <- as.vector(t(weights))}
	else if(is.vector(weights,mode="numeric")){
		if(length(weights)!=dim(response)[1])
			stop("weights vector must have same length as number of individuals")
		else weights <- rep(weights,rep(dim(response)[2],dim(response)[1]))}
	else if(!is.null(weights))stop("weights must be a vector or matrix")
	# check nesting
	if(is.matrix(nest)){
		if(dim(weights)[1]!=dim(response)[1]||dim(weights)[2]!=dim(response)[2])
			stop("nest matrix must be the same size as first two dimensions of array of responses")
		for(i in 1:dim(nest)[1])
			if(any(diff(nest[i,])!=0&diff(nest[i,])!=1,na.rm=TRUE))
				stop("nest categories must be consecutive increasing integers")
		tnest <- as.vector(t(nest))}
	else if(is.vector(nest,mode="numeric")){
		if(length(nest)!=dim(response)[2])
			stop("nest vector must have same length as number of individuals")
		if(any(diff(nest)!=0&diff(nest)!=1,na.rm=TRUE))
			stop("nest categories must be consecutive increasing integers")
		tnest <- rep(nest,dim(response)[1])}
	else if(!is.null(nest))stop("nest must be a vector or matrix")
	# check censor indicator
	if(is.array(censor)&&length(dim(censor))==3){
		if(any(dim(censor)!=dim(response)))
			stop("censor array must be the same size as array of responses")
		tmp <- NULL
		for(i in 1:dim(response)[3])
			tmp <- cbind(tmp,as.vector(t(censor[,,i])))
		censor <- tmp
		rm(tmp)}
	else if(is.matrix(censor)){
	# if a matrix, corresponds to last observation of each subject
		if(dim(censor)[1]!=dim(response)[1]||dim(censor)[2]!=dim(response)[3])
			stop("censor matrix must have dimensions, number of individuals by number of variables")
		tmp <- array(1,dim(response))
		for(i in 1:dim(response)[3])
			tmp[,dim(tmp)[2],i] <- censor[,i]
		censor <- NULL
		for(i in 1:dim(response)[3])
			censor <- cbind(censor,as.vector(t(tmp[,,i])))
		rm(tmp)}
	else if(!is.null(censor))stop("censor must be a matrix or array")
	# check totals
	if(is.array(totals)&&length(dim(totals))==3){
		if(any(dim(totals)!=dim(response)))
			stop("totals array must be the same size as array of responses")
		tmp <- NULL
		for(i in 1:dim(response)[3])
			tmp <- cbind(tmp,as.vector(t(totals[,,i])))
		totals <- tmp
		rm(tmp)}
	else if(is.matrix(totals)){
		if(dim(totals)[1]!=dim(response)[1]||dim(totals)[2]!=dim(response)[3])
			stop("totals matrix must have dimensions, number of individuals by number of variables")
		for(i in 1:dim(response)[3])
		tmp <- NULL
		for(i in 1:dim(response)[3])
			tmp <- cbind(tmp,rep(totals[,i],rep(dim(response)[2],dim(response)[1])))
		totals <- tmp
		rm(tmp)}
	else if(!is.null(totals))stop("totals must be a matrix or array")
	# check delta
	if(is.array(delta)&&length(dim(delta))==3){
		if(any(dim(delta)!=dim(response)))
			stop("delta array must be the same size as array of responses")
		tmp <- NULL
		for(i in 1:dim(response)[3])
			tmp <- cbind(tmp,as.vector(t(delta[,,i])))
		delta <- tmp
		rm(tmp)}
	else if(is.matrix(delta)){
		if(dim(delta)[1]!=dim(response)[1]||dim(delta)[2]!=dim(response)[3])
			stop("delta matrix must have dimensions, number of individuals by number of variables")
		for(i in 1:dim(response)[3])
		tmp <- NULL
		for(i in 1:dim(response)[3])
			tmp <- cbind(tmp,rep(delta[,i],rep(dim(response)[2],dim(response)[1])))
		delta <- tmp
		rm(tmp)}
	else if(!is.null(delta))stop("delta must be a matrix or array")
	y <- NULL
	for(i in 1:dim(response)[3])y <- cbind(y,as.vector(t(response[,,i])))
	mvr <- TRUE}
else if(mvr&&(is.matrix(response)||is.data.frame(response))){
#
# multivariate matrix or dataframe of independent observations or time
#   series supplied
#
	y <- as.matrix(response)
	# check if independent observations or one time series
	nobs <- if(is.null(times)) 1 else dim(response)[1]
	# check times
	if(is.vector(times,mode="numeric")){
		if(length(times)!=dim(y)[1])
			stop("times must be the same length as the number of responses/variable")}
	else if(!is.null(times))stop("times must be a vector")
	# check weights
	if(is.vector(weights,mode="numeric")){
		if(length(weights)!=dim(y)[1])
		stop("weights must be the same length as the number of responses/variable")}
	else if(!is.null(weights))stop("weights must be a vector")
	# check censor indicator
	if(is.vector(censor,mode="numeric")){
		if(is.null(times))stop("censor must be a matrix")
		if(length(censor)!=dim(y)[2])
			stop("censor must be the same length as the number of variables")
		censor <- rbind(matrix(1,ncol=dim(y)[2],nrow=dim(y)[1]-1),censor)}
	else if(is.matrix(censor)){
		if(any(dim(censor)!=dim(y)))stop("censor and response must have the same dimensions")}
	else if(!is.null(censor))stop("censor must be a vector or matrix")
	# check totals
	if(is.vector(totals,mode="numeric")){
		if(length(totals)!=dim(y)[2])
			stop("totals must be the same length as the number of variables")
		totals <- matrix(rep(totals,dim(y)[1]),ncol=dim(y)[2],byrow=TRUE)}
	else if(is.matrix(totals)){
		if(any(dim(totals)!=dim(y)))stop("totals and response must have the same dimensions")}
	else if(!is.null(totals)) stop("totals must be a vector or matrix")
	# check delta
	if(is.vector(delta,mode="numeric")){
		if(length(delta)!=dim(y)[2]){
			if(length(delta)==1)
				delta <- matrix(delta,nrow=dim(y)[1],ncol=dim(y)[2])
			else if(length(delta)==dim(y)[2])
				delta <- matrix(rep(delta,dim(y)[1]),ncol=dim(y)[2],byrow=TRUE)
			else stop("delta must be the same length as the number of variables")}}
	else if(is.matrix(delta)){
		if(any(dim(delta)!=dim(y)))stop("delta and response must have the same dimensions")}
	else if(!is.null(delta))stop("delta must be a scalar, vector, or matrix")}
else if(is.matrix(response)||is.data.frame(response)){
#
# one matrix or dataframe with independent observations or several time
#   series supplied
#
	# transform to a matrix
	if(is.data.frame(response))response <- as.matrix(response)
	if(is.data.frame(totals))totals <- as.matrix(totals)
	if(is.data.frame(delta))delta <- as.matrix(delta)
	# create vector of observations/individual
	nobs <- rep(dim(response)[2],dim(response)[1])
	# check times
	if(is.null(times)){
		if(is.null(censor)&&ttime)
			times <- as.double(rep(1:dim(response)[2],dim(response)[1]))}
	else if(is.matrix(times)){
		if(any(dim(times)!=dim(response)))
			stop("times matrix must have the same dimensions as response")
		# time steps can be 0 but not negative
		for(i in 1:dim(response)[1])
			if(any(diff(times[i,])<0,na.rm=TRUE))
			stop(paste("negative time step for individual ",i))
		times <- as.vector(t(times))}
	else if(is.vector(times,mode="numeric")) {
		if(is.null(nest)&&any(diff(times)<0,na.rm=TRUE))
			stop("times must be increasing")
		if(length(times)!=dim(response)[2])
			stop("number of times must equal number of response columns")
		times <- rep(times,dim(response)[1])}
	else stop("times must be a vector or matrix")
	# check weights
	if(is.matrix(weights)){
		if(any(dim(weights)!=dim(response)))
			stop("weights matrix must have the same dimensions as response")
		else weights <- as.vector(t(weights))}
	else if(is.vector(weights,mode="numeric")){
		if(length(weights)!=dim(response)[1])
			stop("weights vector must have same length as number of individuals")
		else weights <- rep(weights,rep(dim(response)[2],dim(response)[1]))}
	else if(!is.null(weights))stop("weights must be a vector or matrix")
	# check nesting
	if(is.matrix(nest)){
		if(any(dim(nest)!=dim(response)))
			stop("nest matrix must have the same dimensions as response")
		for(i in 1:dim(nest)[1])
			if(any(diff(nest[i,])!=0&diff(nest[i,])!=1,na.rm=TRUE))
				stop("nest categories must be consecutive increasing integers")
		tnest <- as.vector(t(nest))}
	else if(is.vector(nest,mode="numeric")){
		if(length(nest)!=dim(response)[2])
			stop("nest vector must have same length as number of individuals")
		if(any(diff(nest)!=0&diff(nest)!=1,na.rm=TRUE))
			stop("nest categories must be consecutive increasing integers")
		tnest <- rep(nest,dim(response)[1])}
	else if(!is.null(nest))stop("nest must be a vector or matrix")
	# check censor indicator
	if(is.matrix(censor)){
		if(any(dim(censor)!=dim(response)))
			stop("censor matrix must have the same dimensions as response")
		censor <- as.vector(t(censor))}
	else if(is.vector(censor,mode="numeric")){
	# if a vector, corresponds to last observation of each subject
		if(length(censor)!=dim(response)[1])
			stop("censor must be the same length as the number of individuals")
		else {
			tmp <- matrix(1,nrow=dim(response)[1],ncol=dim(response)[2])
			tmp[,dim(tmp)[2]] <- censor
			censor <- tmp}}
	else if(!is.null(censor))stop("censor must be a vector or matrix")
	# check totals
	if(is.matrix(totals)){
		if(any(dim(totals)!=dim(response)))
			stop("totals matrix must have the same dimensions as response")
		totals <- as.vector(t(totals))}
	else if(is.vector(totals,mode="numeric")){
		if(length(totals)!=dim(response)[1])
			stop("totals vector must have same length as number of individuals")
		else totals <- rep(totals,rep(dim(response)[2],dim(response)[1]))}
	else if(!is.null(totals))stop("totals must be a vector or matrix")
	# check delta
	if(is.matrix(delta)){
		if(any(dim(delta)!=dim(response)))
			stop("delta matrix must have the same dimensions as response")
		delta <- as.vector(t(delta))}
	else if(is.vector(delta,mode="numeric")){
		if(length(delta)>1){
			if(length(delta)!=dim(response)[2])
				stop("delta vector must have same length as number of individuals")
			else delta <- rep(delta,dim(response)[1])}}
	else if(!is.null(delta))stop("delta must be a vector or matrix")
	y <- as.vector(t(response))}
else if(mvr&&is.list(response)){
#
# a list of unbalanced multivariate repeated measurements supplied
#
	# obtain responses and possibly times
	y <- times <- nobs <- NULL
	nind <- 0
	nmv <- dim(as.matrix(response[[1]]))[2]
	for(i in response){
		nind <- nind+1
		if(!is.matrix(i))stop("response must be a list of matrices")
		nobs <- c(nobs,dim(i)[1])
		if(dim(i)[2]!=nmv)
			stop("all matrices must have the same number of columns")
		if(ttime){
			y <- rbind(y,i[,1:(nmv-1)])
			if(is.null(nest)&&any(diff(i[,nmv])<0,na.rm=TRUE))
				stop(paste("negative time step for individual ",nind))
			times <- c(times,i[,nmv])}
		else y <- rbind(y,i)}
	if(ttime)nmv <- nmv-1
	if(!is.null(nest)){
	# obtain nesting
		nind <- 0
		nes <- NULL
		if(!is.list(nest))stop("nest must be a list")
		for(i in nest){
			if(!is.vector(i,mode="numeric")&&!(is.matrix(i)&&dim(i)[2]==1))
				stop("nest must be a list of vectors")
			if(any(diff(i)!=0&diff(i)!=1,na.rm=TRUE))
				stop("nest categories must be consecutive increasing integers")
			nind <- nind+1
			if(length(i)!=nobs[nind])
				stop(paste("nest for individual",nind,"should have length",nobs[nind]))
			nes <- c(nes,i)}
		tnest <- nes
		rm(nes)}
	if(!is.null(weights)){
	# obtain weights
		nind <- 0
		wt <- NULL
		if(!is.list(weights))stop("weights must be a list")
		for(i in weights){
			if(!is.vector(i,mode="numeric")&&!is.vector(i,mode="logical")&&!(is.matrix(i)&&dim(i)[2]==1))
				stop("weights must be a list of vectors")
			nind <- nind+1
			if(length(i)!=nobs[nind])
				stop(paste("weights for individual",nind,"should have length",nobs[nind]))
			wt <- c(wt,i)}
		weights <- wt
		rm(wt)}
	if(!is.null(censor)){
	# obtain censoring
		nind <- 0
		cen <- NULL
		if(!is.list(censor))stop("censor must be a list")
		for(i in censor){
			if(!is.matrix(i))
				stop("censor must be a list of matrices")
			nind <- nind+1
			if(any(dim(i)!=c(nobs[nind],nmv)))
				stop(paste("censor for individual",nind,"should be",nobs[nind],"x",nmv,"matrix"))
			cen <- rbind(cen,i)}
		censor <- cen
		rm(cen)}
	if(!is.null(totals)){
	# obtain totals
		nind <- 0
		tot <- NULL
		if(!is.list(totals))stop("totals must be a list")
		for(i in totals){
			if(!is.matrix(i))
				stop("totals must be a list of matrices")
			nind <- nind+1
			if(any(dim(i)!=c(nobs[nind],nmv)))
				stop(paste("totals for individual",nind,"should be",nobs[nind],"x",nmv,"matrix"))
			tot <- rbind(tot,i)}
		totals <- tot
		rm(tot)}
	if(!is.null(delta)){
	# obtain delta
		nind <- 0
		del <- NULL
		if(!is.list(delta))stop("delta must be a list")
		for(i in delta){
			if(!is.matrix(i))
				stop("delta must be a list of matrices")
			nind <- nind+1
			if(any(dim(i)!=c(nobs[nind],nmv)))
				stop(paste("delta for individual",nind,"should be",nobs[nind],"x",nmv,"matrix"))
			del <- rbind(del,i)}
		delta <- del
		rm(del)}}
else if(is.list(response)){
#
# a list of unbalanced repeated measurements supplied
#
	# check if nest, delta, and/or totals are supplied
	# separately
	delv <- !is.null(delta)
	totv <- !is.null(totals)
	nestv <- !is.null(nest)
	if(is.null(censor)){
		# initialize
		times <- NULL
		tot <- del <- cen <- nes <- 0
		ncols <- dim(as.matrix(response[[1]]))[2]
		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){
			# find columns for censor, totals, delta, nest
			j <- as.matrix(j)
			for(k in (nc+1):ncols){
				if(any(j[,k]<=0,na.rm=TRUE))cen <- k
				else if(any(j[,k]>1,na.rm=TRUE)&&all(j[,k]==trunc(j[,k]),na.rm=TRUE)){
					if(all(j[,1]>=0,na.rm=TRUE)&&all(j[,1]==trunc(j[,1]),na.rm=TRUE)&&all(j[,k]>=j[,1],na.rm=TRUE)&&any(diff(j[,k])<0,na.rm=TRUE)&&!totv)tot <- k
					else if(all(diff(j[,k])==0|diff(j[,k])==1,na.rm=TRUE)&&!nestv)nes <- k
					else stop(paste("column",k,"of unknown type"))}
				else if(!delv&&all(j[,k]>0,na.rm=TRUE))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){
			# obtain responses and times
			i <- as.matrix(i)
			nind <- nind+1
			if(dim(i)[2]!=ncols)
				stop(paste("Individual ",nind,"does not have a",ncols,"column matrix"))
			if(!nestv&&nes==0&&ttime&&any(diff(i[,2])<0,na.rm=TRUE))
				stop(paste("negative time step for individual ",nind))
			nobs <- c(nobs,dim(i)[1])
			y <- c(y,i[,1])
			if(ttime)times <- c(times,i[,2])
			# obtain censor, totals, delta, nest
			# from their columns
			if(nes>0){
				if(any(diff(i[,nes])!=0&diff(i[,nes])!=1,na.rm=TRUE))
					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(!delv&&del>0)delta <- c(delta,i[,del])}}
	else if(is.vector(censor,mode="numeric")){
		# initialize (cannot be totals and censor available)
		del <- nes <- 0
		ncols <- dim(as.matrix(response[[1]]))[2]
		if(ncols>1){
			for(j in response){
			# find columns for delta, nest
				j <- as.matrix(j)
				for(k in 2:ncols){
					if(is.null(censor)&&any(j[,k]<=0,na.rm=TRUE))cen <- k
					else if(any(j[,k]>1,na.rm=TRUE)&&all(j[,k]==trunc(j[,k]),na.rm=TRUE))nes <- k
					else if(is.null(delta)&&all(j[,k]>0,na.rm=TRUE))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){
			# obtain responses
				i <- as.matrix(i)
				nind <- nind+1
				if(dim(i)[2]!=ncols)stop(paste("Individual ",nind,"does not have a",ncols,"column matrix"))
				nobs <- c(nobs,dim(i)[1])
				y <- c(y,i[,1])
				# construct censor
				tmp <- c(tmp,rep(1,dim(i)[1]-1),censor[j <- j+1])
				# obtain delta, nest from their columns
				if(nes>0){
					if(any(diff(i[,nes])!=0&diff(i[,nes])!=1,na.rm=TRUE))
					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){
			# obtain responses
				nind <- nind+1
				if(!is.vector(i,mode="numeric")&&!(is.matrix(i)&&dim(i)[2]==1))
					stop(paste("Individual ",nind,"does not have a vector or one column matrix"))
				# construct censor
				tmp <- c(tmp,rep(1,length(i)-1),censor[j <- j+1])
				y <- c(y,i)
				nobs <- c(nobs,length(i))}
			censor <- tmp}}
	else stop("If response is a list, censor must be a vector")
	if(nestv){
	# obtain nesting
		nind <- 0
		nes <- NULL
		if(!is.list(nest))stop("nest must be a list")
		for(i in nest){
			if(!is.vector(i,mode="numeric")&&!(is.matrix(i)&&dim(i)[2]==1))
				stop("nest must be a list of vectors")
			if(any(diff(i)!=0&diff(i)!=1,na.rm=TRUE))
				stop("nest categories must be consecutive increasing integers")
			nind <- nind+1
			if(length(i)!=nobs[nind])
				stop(paste("nest for individual",nind,"should have length",nobs[nind]))
			nes <- c(nes,i)}
		tnest <- nes
		rm(nes)}
	if(totv){
	# obtain totals
		nind <- 0
		tot <- NULL
		if(!is.list(totals))stop("totals must be a list")
		for(i in totals){
			if(!is.vector(i,mode="numeric")&&!(is.matrix(i)&&dim(i)[2]==1))
				stop("totals must be a list of vectors")
			nind <- nind+1
			if(length(i)!=nobs[nind])
				stop(paste("totals for individual",nind,"should have length",nobs[nind]))
			tot <- rbind(tot,i)}
		totals <- tot
		rm(tot)}
	if(delv){
	# obtain delta
		if(is.vector(delta)&&length(delta)==1)
			delta <-  rep(delta,length(y))
		else {
			nind <- 0
			del <- NULL
			if(!is.list(delta))stop("delta must be a list")
			for(i in delta){
				if(!is.vector(i,mode="numeric")&&!(is.matrix(i)&&dim(i)[2]==1))
					stop("delta must be a list of vectors")
				nind <- nind+1
				if(length(i)!=nobs[nind])
					stop(paste("delta for individual",nind,"should have length",nobs[nind]))
				del <- c(del,i)}
			delta <- del
			rm(del)}}
	if(!is.null(weights)){
	# obtain weights
		nind <- 0
		wt <- NULL
		if(!is.list(weights))stop("weights must be a list")
		for(i in weights){
			if(!is.vector(i,mode="numeric")&&!is.vector(i,mode="logical")&&!(is.matrix(i)&&dim(i)[2]==1))
				stop("weights must be a list of vectors")
			nind <- nind+1
			if(length(i)!=nobs[nind])
				stop(paste("weights for individual",nind,"should have length",nobs[nind]))
			wt <- c(wt,i)}
		weights <- wt
		rm(wt)}
	# check that totals, delta, and weights are now
	# correct if supplied separately
	if(totv){
		if(length(totals)==1)totals <- rep(totals,length(y))
		else if(length(totals)==length(nobs))
			totals <- totals[rep(1:length(nobs),nobs)]
		else if(length(totals)!=length(y))
			stop("totals must have one value per response")}
	if(delv&&length(delta)>1&&length(delta)!=length(y))
		stop("delta must have one value per response")
	if(!is.null(weights)&&length(y)!=length(weights))stop("weights must have one value per response")}
else stop("Responses must be supplied as a vector, matrix, dataframe, array, or list of matrices")
#
# make sure that the response is a matrix
#
if(!is.numeric(y))stop("response must be numeric")
if(is.matrix(y)){
	if(is.null(colnames(y)))colnames(y) <- if(length(names)==1)
		paste(names,1:dim(y)[2],sep="")
		else if(length(names)==dim(y)[2]) names
		else stop("incorrect number of names")}
else {
	y <- matrix(y,ncol=1)
	colnames(y) <- if(length(names)==1)names else "y"}
rownames(y) <- 1:dim(y)[1]
if(!is.null(units)){
	if(!is.character(units))stop("units must be a character vector")
	if(length(units)!=dim(y)[2])
		stop("units must be given for all responses")}
#
# check that type has the right length
#
if(is.null(type))type <- rep("unknown",dim(y)[2])
else {
	if(length(type)!=dim(y)[2])
		stop("a type must be supplied for each response")
	if(length(type)==1)type <- rep(type,dim(y)[2])
	if(any(is.na(type)))type[is.na(type)] <- "unknown"}
if(!is.null(censor)){
#
# check that censor has correct values
#
	if(!is.numeric(censor))stop("censor must be numeric")
	if(any(censor!=-1&censor!=0&censor!=1,na.rm=TRUE))
		stop("censor must only contain -1, 0, and 1")
	if(!is.null(censor)&&!is.matrix(censor))censor <- matrix(censor,ncol=1)
	# construct (cumulative) times from responses if univariate
	if(!mvr&&length(nobs)>1&&is.null(times)&&type=="duration"){
		j <- 1
		na <- is.na(y[,1])
		y[na,1] <- 0
		for(i in 1:length(nobs)){
			times <- c(times,cumsum(y[j:(j+nobs[i]-1),1]))
			j <- j+nobs[i]}
		y[na,1] <- NA}
	for(i in 1:dim(y)[2])
		if(type[i]=="unknown"&&any(!is.na(censor[,i])))
			type[i] <- "duration"
	# remove censor if unnecessary
	if(all(censor==1,na.rm=TRUE))censor <- NULL}
if(!is.null(totals)){
#
# check that totals has correct values
#
	if(!is.numeric(totals))stop("totals must be numeric")
	if(!is.matrix(totals))totals <- matrix(totals,ncol=1)
	for(i in 1:dim(y)[2])if(any(!is.na(totals[,i]))){
		if(any(y[,i]<0,na.rm=TRUE))
			stop("all responses must be non-negative for binomial data")
		if(any(totals[,i]<y[,i],na.rm=TRUE)||any(totals[,i]<0,na.rm=TRUE))
			stop("all totals must be non-negative and >= to responses")
		if(type[i]=="unknown"&&any(!is.na(totals[,i])))
			type[i] <- "nominal"}}
#
# check that nest, delta, weights have correct values
#
if(!is.null(tnest)){
	if(!is.numeric(tnest))stop("tnest must be numeric")
	if((any(tnest<1,na.rm=TRUE)||any(tnest!=trunc(tnest),na.rm=TRUE)))
		stop("nest must contain integers starting at 1")}
if(!is.null(delta)){
	if(!is.numeric(delta))stop("delta must be numeric")
	if(any(delta<=0,na.rm=TRUE))stop("delta must be strictly positive")
	if(!is.matrix(delta))delta <- matrix(delta,ncol=1)
	for(i in 1:dim(y)[2])
		if(type[i]=="unknown"&&any(!is.na(delta[,i])))
			type[i] <- "continuous"}
if(!is.null(weights)){
	if(!is.numeric(weights)&&!is.logical(weights))stop("weights must be numeric or logical")
	if(any(weights<0,na.rm=TRUE))stop("weights must be non-negative")}
#
# check that ordinal data have correct values
#
if(!is.na(match("ordinal",type))){
	for(i in 1:dim(y)[2])if(!is.na(match("ordinal",type[i]))){
		if(min(y[,i],na.rm=TRUE)!=0)
			stop("ordinal responses must be indexed from zero")
		if(any(as.integer(y[!is.na(y[,i]),i])!=y[!is.na(y[,i]),i]))
			stop("ordinal responses must be integers")}}
#
# combine with old object, if provided
#
if(!is.null(oldresponse)){
	if(any(nobs!=oldresponse$nobs))
		stop("old and new objects do not have the same number of observations per individual")
	if(dim(y)[1]!=dim(oldresponse$y)[1])
		stop("old and new objects do not have the same number of observations")
	if((!is.null(times)&&(is.null(oldresponse$times)||any(times!=oldresponse$times,na.rm=TRUE)))||(is.null(times)&&!is.null(oldresponse$times)))
		stop("old and new objects do not have the same times")
	if((!is.null(tnest)&&(is.null(oldresponse$tnest)||any(tnest!=oldresponse$tnest,na.rm=TRUE)))||(is.null(tnest)&&!is.null(oldresponse$tnest)))
		stop("old and new objects do not have the same nesting")
	if((!is.null(weights)&&(is.null(oldresponse$wt)||any(weights!=oldresponse$wt,na.rm=TRUE)))||(is.null(weights)&&!is.null(oldresponse$wt)))
		stop("old and new objects do not have the same weights")
	y <- cbind(oldresponse$y,y)
	if(!is.null(censor)){
		if(is.null(oldresponse$censor))
			censor <- cbind(matrix(NA,nrow=dim(oldresponse$y)[1],ncol=dim(oldresponse$y)[2]),censor)
		else censor <- cbind(oldresponse$censor,censor)}
	else if(!is.null(oldresponse$censor))
		censor <- cbind(oldresponse$censor,matrix(NA,nrow=dim(y)[1],ncol=dim(y)[2]))
	if(!is.null(totals)){
		if(is.null(oldresponse$n))
			totals <- cbind(matrix(NA,nrow=dim(oldresponse$y)[1],ncol=dim(oldresponse$y)[2]),totals)
		else totals <- cbind(oldresponse$n,totals)}
	else if(!is.null(oldresponse$n))
		totals <- cbind(oldresponse$n,matrix(NA,nrow=dim(y)[1],ncol=dim(y)[2]))
	if(!is.null(delta)){
		if(is.null(oldresponse$delta))
			delta <- cbind(matrix(1,nrow=dim(oldresponse$y)[1],ncol=dim(oldresponse$y)[2]),delta)
		else delta <- cbind(oldresponse$delta,delta)}
	else if(!is.null(oldresponse$delta))
		delta <- cbind(oldresponse$delta,matrix(1,nrow=dim(y)[1],ncol=dim(y)[2]))
	if(!is.null(units)){
		if(is.null(oldresponse$units))
			units <- c(rep(NA,dim(oldresponse$y)[2]),units)
		else units <- c(oldresponse$units,units)}
	else if(!is.null(oldresponse$units))
		units <- c(oldresponse$units,rep(NA,dim(y)[2]))
	type <- c(oldresponse$type,type)}
#
# put names on matrices
#
if(!is.null(totals)&&is.null(colnames(totals)))colnames(totals) <- colnames(y)
if(!is.null(censor)&&is.null(colnames(censor)))colnames(censor) <- colnames(y)
if(!is.null(delta)&&is.null(colnames(delta)))colnames(delta) <- colnames(y)
if(!is.null(units))names(units) <- colnames(y)
names(type) <- colnames(y)
#
# check for variable descriptions
#
if(!is.null(description)){
	if(!is.list(description))stop("description must be a list")
	if(!all(tmp <- names(description)%in%colnames(y)))
		stop(paste("variable(s)",names(description)[!tmp],"not found"))
	for(i in description)if(!is.character(i))
		stop("description list must contain character vectors")
	if(!is.null(oldresponse))
		description <- c(oldresponse$description,description)}
z <- list(y=y, nobs=nobs, times=times, nest=tnest, censor=censor, n=totals,
	coordinates=coordinates, wt=weights, delta=delta, units=units,
	type=type, description=description)
class(z) <- "response"
z}

### function to create a time-constant covariate (tccov) object
###
tcctomat <- function(ccov, names=NULL, units=NULL, oldccov=NULL,
	dataframe=TRUE, description=NULL){
if(inherits(ccov,"tccov")&&inherits(oldccov,"tccov")){
#
# check for compatibility
#
	if(dim(ccov$ccov)[1]!=dim(oldccov$ccov)[1])
		stop("incompatible tccov objects")
	if(!is.null(oldccov$units)||!is.null(ccov$units)){
		if(is.null(oldccov$units))
			oldccov$units <- rep(NA,dim(oldccov$ccov)[2])
		if(is.null(ccov$units))ccov$units <- rep(NA,dim(ccov$ccov)[2])
		oldccov$units <- c(oldccov$units,ccov$units)}
	oldccov$ccov <- cbind(oldccov$ccov,ccov$ccov)
	oldccov$linear <- NULL
	return(oldccov)}
linear <- NULL
if(is.language(ccov)){
#
# if provided as a formula, transform to a matrix
#
	linear <- ccov
	mt <- terms(ccov)
	mf <- model.frame(mt,parent.frame())
	ccov <- model.matrix(mt,mf)[,-1,drop=FALSE]}
else if(is.factor(ccov)||is.vector(ccov,mode="character")){
#
# if provided as factor variables, make a dataframe
#
	if(is.null(names))names <- paste(deparse(substitute(ccov)))
	ccov <- data.frame(ccov)
	colnames(ccov) <- names}
if(is.vector(ccov,mode="numeric")){
#
# if a vector, get a name
#
	if(is.null(names))names <- paste(deparse(substitute(ccov)))
	ccov <- matrix(ccov,ncol=1)}
else if(is.data.frame(ccov)){
	if(!dataframe){
	# if a dataframe supplied, but should not be stored as one
                rm(names)
                tmp <- NULL
                j <- 0
		units2 <- NULL
                for(i in ccov){
                	j <- j+1
                	if(is.vector(i,mode="numeric")){
			# handle numeric vectors
                		tmp2 <- as.matrix(i)
				units2 <- c(units2,units[j])
                		colnames(tmp2) <- names(ccov)[j]}
                	else {
			# handle factor variables
                		mt <- terms(~i)
                		tmp2 <- model.matrix(mt,model.frame(mt))[,-1,drop=FALSE]
				units2 <- c(units2,rep(units[j],length(levels(i)[-1])))
				tmp3 <- dimnames(get(getOption("contrasts")[[if(is.ordered(i))2 else 1]])(levels(i),contrasts =TRUE))[[2]]
				if(is.null(tmp3))tmp3 <- 1:(length(levels(i))-1)
                		colnames(tmp2) <- paste(names(ccov)[j],tmp3,sep="")}
#                		colnames(tmp2) <- paste(names(ccov)[j],levels(i)[-1],sep="")}
                	tmp <- cbind(tmp,tmp2)}
		units <- units2
                ccov <- tmp
                rm(tmp,tmp2,mt)}}
else if(!is.matrix(ccov))
	stop("Inter-unit (time-constant) covariates must be a vector, matrix, dataframe, or model formula")
if(is.null(colnames(ccov))){
#
# create names if not available
#
	if(is.null(names))names <- paste(deparse(substitute(ccov)))
	if(length(names)==1&&dim(ccov)[2]>1)
		names <- paste(names,1:dim(ccov)[2],sep="")
	colnames(ccov) <- names}
#
# check units
#
if(!is.null(units)){
	if(!is.character(units))stop("units must be a character vector")
	if(length(units)!=dim(ccov)[2])
		stop("units must be supplied for all covariates")}
#
# check for variable descriptions
#
if(!is.null(description)){
	if(!is.list(description))stop("description must be a list")
	if(!all(tmp <- names(description)%in%colnames(ccov)))
		stop(paste("variable(s)",names(description)[!tmp],"not found"))
	for(i in description)if(!is.character(i))
		stop("description list must contain character vectors")}
if(!is.null(oldccov)){
#
# combine new data with old data when available
#
	if(!inherits(oldccov,"tccov"))
		stop("oldccov must have class, tccov")
	oldccov$description <- c(oldccov$description,description)
	if(!is.null(oldccov$units)||!is.null(units)){
		if(is.null(oldccov$units))
			oldccov$units <- rep(NA,dim(oldccov$ccov)[2])
		if(is.null(units))units <- rep(NA,dim(ccov)[2])
		oldccov$units <- c(oldccov$units,units)}
	else if(dim(oldccov$ccov)[1]==dim(ccov)[1]){
		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,units=units,description=description)
	class(oldccov) <- "tccov"}
if(!is.null(oldccov$units))names(oldccov$units) <- colnames(oldccov$ccov)
if(is.data.frame(oldccov$ccov)){
#
# if no factor variables, store as a matrix anyway
#
	fac <- FALSE
	for(i in 1:dim(oldccov$ccov)[2])if(!is.vector(oldccov$ccov[,i],mode="numeric")){
		fac <- TRUE
		break}
	if(!fac)oldccov$ccov <- as.matrix(oldccov$ccov)}
oldccov}

### function to create a time-varying covariate (tvcov) object
###
tvctomat <- function(tvcov, names=NULL, units=NULL, interaction=NULL,
	ccov=NULL, oldtvcov=NULL, dataframe=TRUE, description=NULL){
#
# check for compatibility
#
if(inherits(tvcov,"tvcov")&&inherits(oldtvcov,"tvcov")){
	if(length(tvcov$nobs)!=length(oldtvcov$nobs)||
		any(tvcov$nobs!=oldtvcov$nobs))
		stop("incompatible tvcov objects")
	if(!is.null(oldtvcov$units)||!is.null(tvcov$units)){
		if(is.null(oldtvcov$units))
			oldtvcov$units <- rep(NA,dim(oldtvcov$tvcov)[2])
		if(is.null(tvcov$units))
			tvcov$units <- rep(NA,dim(tvcov$tvcov)[2])
		oldtvcov$units <- c(oldtvcov$units,tvcov$units)}
	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(length(names)!=1)stop("too many names")
	if(dataframe){
	# make new one-column dataframe
		nbs <- rep(dim(tvcov)[2],dim(tvcov)[1])
		tvcv <- as.data.frame(as.vector(t(as.matrix(tvcov))))
		colnames(tvcv) <- names}
	# if factors, as.matrix transforms to character for next step
	else tvcov <- as.matrix(tvcov)}
if(is.matrix(tvcov)&&is.character(tvcov)){
	nbs <- rep(dim(tvcov)[2],dim(tvcov)[1])
	if(is.null(names))names <- paste(deparse(substitute(tvcov)))
	if(length(names)!=1)stop("too many names")
	tvcv <- as.factor(as.vector(t(tvcov)))
	if(dataframe){
	# make new one-column dataframe
		tvcv <- as.data.frame(as.vector(t(as.matrix(tvcov))))
		colnames(tvcv) <- names}
	else {
	# make indicator matrix from factor
		mt <- terms(~tvcv)
		tmp3 <- dimnames(get(getOption("contrasts")[[if(is.ordered(tvcv))2 else 1]])(levels(tvcv),contrasts =TRUE))[[2]]
		if(is.null(tmp3))tmp3 <- 1:(length(levels(tvcv))-1)
		names <- paste(names,tmp3,sep="")
#		names <- paste(names,levels(tvcv)[-1],sep="")
		tvcv <- model.matrix(mt,model.frame(mt))[,-1,drop=FALSE]
		colnames(tvcv) <- names
		if(!is.null(units))units <- rep(units,dim(tvcv)[2])}}
else if(is.matrix(tvcov)){
#
# transform to a vector
#
	nbs <- rep(dim(tvcov)[2],dim(tvcov)[1])
	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")){
		nbs <- tvcov$nobs
		tvcv <- tvcov$tvcov}
	else {
		ncols <- dim(as.data.frame(tvcov[[1]]))[2]
		# create names
		if(is.null(names)){
			if(is.null(colnames(tvcov[[1]]))){
				names <- if(is.matrix(tvcov[[1]]))paste(paste(deparse(substitute(tvcov))),1:ncols,sep="")
				else paste(deparse(substitute(tvcov)))}
			else names <- colnames(tvcov[[1]])}
		# concatenate list elements into a matrix
		ff <- TRUE
		for(i in tvcov){
		# create one big dataframe
			i <- as.data.frame(i)
			if(dim(i)[2]!=ncols)
				stop("all elements of the list must have the same number of columns")
			nbs <- c(nbs,dim(i)[1])
			if(ff){
				tvcv <- i
				ff <- FALSE}
			else tvcv <- rbind(tvcv,i)}
		if(is.character(tvcv)||!dataframe){
		# if necessary, transform to indicator matrix
			tmp <- tmp2 <- NULL
			for(i in 1:ncols){
				if(is.numeric(tvcv[,i])){
					tmp <- cbind(tmp,tvcv[,i])
					tmp2 <- c(tmp2,names[i])}
				else {
					mt <- terms(~tvcv[,i])
					tmp <- cbind(tmp,model.matrix(mt,model.frame(mt))[,-1,drop=FALSE])
					tmp3 <- dimnames(get(getOption("contrasts")[[if(is.ordered(tvcv[,i]))2 else 1]])(levels(tvcv[,i]),contrasts =TRUE))[[2]]
					if(is.null(tmp3))tmp3 <- 1:(length(levels(tvcv[,i]))-1)
					tmp2 <- c(tmp2,paste(names[i],tmp3,sep=""))}}
#					tmp2 <- c(tmp2,paste(names[i],levels(as.factor(tvcv[,i]))[-1],sep=""))}}
			tvcv <- tmp
			names <- tmp2
			ncols <- length(names)
			rm(tmp,tmp2,mt)}
		# create colnames if necessary
		if(is.null(colnames(tvcov[[1]]))){
			if(is.null(names))names <- paste(deparse(substitute(tvcov)))}
		else if(length(names)!=ncols)names <- colnames(tvcov[[1]])
		if((length(names)==1&&ncols>1))
			names <- paste(names,1:ncols,sep="")
		if(length(names)!=ncols)
			stop(paste(ncols,"variable names required"))
		colnames(tvcv) <- names}}
else if(!is.data.frame(tvcov))
	stop("Intra-unit (time-varying) covariates must be a matrix, dataframe, or list")
if(!is.null(interaction)){
#
# if necessary, create interactions
#
	name <- colnames(tvcv)
	units <- tvcov$units
	if(is.character(interaction)){
	# if names supplied, find corresponding columns
		mat <- match(interaction,name)
		if(any(is.na(mat)))
			stop(paste("Intra-unit (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 interactions with time-constant covariates
			if(inherits(ccov,"tccov")){
				ccov <- ccov$ccov
				units2 <- ccov$units
				if(!is.null(units)&&is.null(units2))
					units2 <- rep("NA",dim(ccov)[2])
				if(is.null(units)&&!is.null(units2))
					units <- rep("NA",dim(tvcov$tvcov)[2])}
			if(!is.matrix(ccov)&&!is.data.frame(ccov)){
			# if a vector, transform to matrix
				tmp <- paste(deparse(substitute(ccov)))
				ccov <- matrix(ccov)
				colnames(ccov) <- tmp}
			if(dim(ccov)[1]!=length(nbs))
				stop("ccov does not have one observation per individual")
			# find desired covariates
			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))colnames(oldtvcov) <- name
			if(!is.data.frame(oldtvcov)&&!is.data.frame(ccov)){
			# calculate interactions for ordinary matrices
				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=""))
					if(!is.null(units))units <- c(units,paste(units[interaction[i]],".",units2[j],sep=""))}}
			else {
			# calculate interactions when expansion required
				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=FALSE]
			                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=FALSE]}
			                	else {
			                		nam <- paste(paste(name[interaction[i]],levels(tvcv[,interaction[i]])[-1],sep=""),".",names[j],sep="")
			                		tmp <- tmp[,-1,drop=FALSE]}
							if(!is.null(units))units <- c(units,rep(units2[j],length(levels(tvcv[,interaction[i]])[-1])))}
			                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=FALSE]
							if(!is.null(units))units <- c(units,rep(units[interaction[i]],length(levels(ccov[,mat[j]])[-1])))}
			                	else {
							nam <- paste(name[interaction[i]],".",names[j],sep="")
							if(!is.null(units))units <- c(units,paste(units[interaction[i]],".",units2[j],sep=""))}}
			                colnames(tmp) <- nam
					name <- c(name,nam)
					oldtvcov <- cbind(oldtvcov,tmp)}}
			if(!is.data.frame(oldtvcov))colnames(oldtvcov) <- name
			oldtvcov <- list(tvcov=oldtvcov,nobs=nbs,units=units)}
		else if(length(interaction)==2){
		# one pair of interactions
			if(is.data.frame(tvcv)){
			# expand dataframe
				mt <- terms(~tvcv[,interaction[1]]:tvcv[,interaction[2]])
				tmp <- model.matrix(mt,model.frame(mt))[,-1,drop=FALSE]
				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=FALSE]}
					else {
						names <- paste(paste(name[interaction[1]],levels(tvcv[,interaction[1]])[-1],sep=""),".",name[interaction[2]],sep="")
						tmp <- tmp[,-1,drop=FALSE]
						if(!is.null(units))units <- c(units,paste(rep(units[interaction[1]],length(levels(tvcv[,interaction[1]])[-1])),".",units[interaction[2]],sep=""))}}
				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=FALSE]
						if(!is.null(units))units <- c(units,paste(units[interaction[1]],".",rep(units[interaction[2]],length(levels(tvcv[,interaction[2]])[-1])),sep=""))}
					else {
						names <- paste(name[interaction[1]],".",name[interaction[2]],sep="")
						if(!is.null(units))units <- c(units,paste(units[interaction[1]],".",units[interaction[2]],sep=""))}}
				colnames(tmp) <- names
				oldtvcov <- list(tvcov=cbind(tvcv,tmp),nobs=nbs,units=units)}
			else {
				units <- if(is.null(tvcov$units))NULL else c(tvcov$units,paste(tvcov$units[interaction[1]],".",tvcov$units[interaction[2]],sep=""))
				oldtvcov <- list(tvcov=cbind(tvcv,tvcv[,interaction[1]]*tvcv[,interaction[2]]),nobs=nbs,units=units)}
			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)){
#
# check for variable descriptions
#
if(!is.null(description)){
	if(!is.list(description))stop("description must be a list")
	if(!all(tmp <- names(description)%in%colnames(tvcv)))
		stop(paste("variable(s)",names(description)[!tmp],"not found"))
	for(i in description)if(!is.character(i))
		stop("description list must contain character vectors")}
#
# if old tvcov, combine with new one
#
	if(!inherits(oldtvcov,"tvcov"))
		stop("oldtvcov must have class, tvcov")
	oldtvcov$description <- c(oldtvcov$description,description)
	if(!is.null(oldtvcov$units)||!is.null(units)){
		if(is.null(oldtvcov$units))
			oldtvcov$units <- rep(NA,dim(oldtvcov$tvcov)[2])
		if(is.null(units))units <- rep(NA,dim(tvcv)[2])
		oldtvcov$units <- c(oldtvcov$units,units)}
	if((dim(oldtvcov$tvcov)[1]==dim(tvcv)[1])&&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 {
	# check units
	if(!is.null(units)){
		if(!is.character(units))
			stop("units must be a character vector")
		if(length(units)!=dim(tvcv)[2])
			stop("units must be supplied for all covariates")}
	if(dataframe)tvcv <- as.data.frame(tvcv)
	oldtvcov <- list(tvcov=tvcv,nobs=nbs,units=units,description=description)
	class(oldtvcov) <- "tvcov"}
if(!is.null(oldtvcov$units))names(oldtvcov$units) <- colnames(oldtvcov$tvcov)
#
# if no factor variables present, return a matrix anyway
#
if(is.data.frame(oldtvcov$tvcov)){
	fac <- FALSE
	for(i in 1:dim(oldtvcov$tvcov)[2])if(!is.vector(oldtvcov$tvcov[,i],mode="numeric")){
		fac <- TRUE
		break}
	if(!fac)oldtvcov$tvcov <- as.matrix(oldtvcov$tvcov)}
oldtvcov}

### functions to create a repeated object
###
### method to create repeated object removing NAs
###
rmna <- function(response, ccov=NULL, tvcov=NULL){
#
# if necessary, convert response
#
if(!inherits(response,"response"))response <- restovec(response)
#
# if necessary, expand nobs
#
if(length(response$nobs)==1&&response$nobs==1)
	response$nobs <- rep(1,length(response$y))
#
# if necessary, convert ccov
#
if(!is.null(ccov)){
	if(!inherits(ccov,"tccov"))ccov <- tcctomat(ccov)
	if(length(response$nobs)!=dim(ccov$ccov)[1])
		stop("Numbers of individuals for response and for inter-unit (time-constant) covariates do not agree.")}
#
# if necessary, convert tvcov
#
if(!is.null(tvcov)){
	if(!inherits(tvcov,"tvcov"))tvcov <- tvctomat(tvcov)
	if(length(response$nobs)!=length(tvcov$nobs)||
		any(response$nobs!=tvcov$nobs))
		stop("Numbers of observations for response and intra-unit (time-varying) covariates do not agree.")}
#
# create NA indicators
#
rna <- rep(TRUE,dim(response$y)[1])
for(i in 1:dim(response$y)[2])rna <- rna&!is.na(response$y[,i])
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$wt))rna <- rna&!is.na(response$wt)
if(!is.null(response$coordinates))
	rna <- rna&!is.na(response$coordinates[,1])&!is.na(response$coordinates[,2])
if(!is.null(response$n)){
	for(i in 1:dim(response$y)[2])if(any(!is.na(response$n[,i])))
		rna <- rna&!is.na(response$n[,i])}
for(i in 1:length(response$nobs))
	if(!is.null(ccov)&&any(is.na(ccov$ccov[i,])))
		rna[covind(response)==i] <- FALSE
if(!is.null(tvcov))
	for(i in 1:dim(tvcov$tvcov)[2])rna <- rna&!is.na(tvcov$tvcov[,i])
#
# remove NAs
#
if(any(!rna)){
	# remove NAs from variables associated with response
        response$y <- response$y[rna,,drop=FALSE]
        if(!is.null(response$times))response$times <- response$times[rna]
        if(!is.null(response$nest))response$nest <- response$nest[rna]
        if(!is.null(response$wt))response$wt <- response$wt[rna]
        if(!is.null(response$coordinates))
        	response$coordinates <- response$coordinates[rna,]
        if(!is.null(response$n))response$n <- response$n[rna,,drop=FALSE]
        if(!is.null(response$censor)){
        	response$censor <- response$censor[rna,,drop=FALSE]
        	if(all(response$censor==1))response$censor <- NULL}
        if(!is.null(response$delta)&&length(response$delta)>1)
        	response$delta <- response$delta[rna,,drop=FALSE]
        if(!is.null(tvcov))tvcov$tvcov <- tvcov$tvcov[rna,,drop=FALSE]
        # correct nobs
        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]
        # remove NAs from ccov
        if(!is.null(ccov)){
        	ccov$ccov <- ccov$ccov[tmp>0,,drop=FALSE]
        	for(i in 1: dim(ccov$ccov)[2])
        		if(length(unique(ccov$ccov[,i]))==1)
        			warning(paste("covariate",colnames(ccov$ccov)[i],"has only one value\n"))}
        # remove NAs from tvcov
	if(!is.null(tvcov)){
		tvcov$nobs <- response$nobs
		for(i in 1: dim(tvcov$tvcov)[2])
			if(length(unique(tvcov$tvcov[,i]))==1)
			warning(paste("covariate",colnames(tvcov$tvcov)[i],"has only one value\n"))}}
#
# if independent observations, reset nobs
#
if(all(response$nobs==1))response$nobs <- 1
z <- list(response=response,tvcov=tvcov,ccov=ccov)
class(z) <- "repeated"
z}

### method to create repeated object leaving NAs
###
lvna <- function(response, ccov=NULL, tvcov=NULL){
#
# if necessary, convert response
#
if(!inherits(response,"response"))response <- restovec(response)
#
# if necessary, expand nobs
#
if(length(response$nobs)==1&&response$nobs==1)
	response$nobs <- rep(1,length(response$y))
#
# if necessary, convert ccov
#
if(!is.null(ccov)){
	if(!inherits(ccov,"tccov"))ccov <- tcctomat(ccov)
	if(length(response$nobs)!=dim(ccov$ccov)[1])
		stop("Numbers of individuals for response and for intra-unit (time-constant) covariates do not agree.")}
#
# if necessary, convert tvcov
#
if(!is.null(tvcov)){
	if(!inherits(tvcov,"tvcov"))tvcov <- tvctomat(tvcov)
	if(any(response$nobs!=tvcov$nobs))
		stop("Numbers of observations for response and intra-unit (time-varying) covariates do not agree.")}
#
# create NA indicators
#
rna <- rep(TRUE,dim(response$y)[1])
for(i in 1:dim(response$y)[2])rna <- rna&!is.na(response$y[,i])
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)){
	for(i in 1:dim(response$y)[2])if(any(!is.na(response$n[,i])))
		rna <- rna&!is.na(response$n[,i])}
for(i in 1:length(response$nobs))
	if(!is.null(ccov)&&any(is.na(ccov$ccov[i,])))rna[covind(response)==i] <- FALSE
if(!is.null(tvcov))
	for(i in 1:dim(tvcov$tvcov)[2])rna <- rna&!is.na(tvcov$tvcov[,i])
#
# if independent observations, reset nobs
#
if(all(response$nobs==1))response$nobs <- 1
z <- list(response=response,tvcov=tvcov,ccov=ccov,
	NAs=if(any(!rna))!rna else NULL)
class(z) <- "repeated"
z}

### method to create repeated object from a dataframe
###
dftorep <- function(dataframe, response, id=NULL, times=NULL, censor=NULL,
	totals=NULL, weights=NULL, nest=NULL, delta=NULL,
	coordinates=NULL, type=NULL, ccov=NULL, tvcov=NULL, na.rm=TRUE){
if(missing(dataframe)||!is.data.frame(dataframe))
	stop("a dataframe must be supplied")
if(missing(response)||!is.character(response))
	stop("name(s) of response variables must be supplied")
#
# find response information and construct object
#
cn <- colnames(dataframe)
nc <- match(response,cn)
if(any(is.na(nc)))stop(paste("response",response[is.na(nc)],"not found"))
tot <- matrix(NA,ncol=nc,nrow=dim(dataframe)[1])
for(i in nc)if(is.matrix(dataframe[[i]])&&dim(dataframe[[i]])[2]==2){
		tot[,i] <- dataframe[[i]][,1]+dataframe[[i]][,2]
		dataframe[[i]] <- dataframe[[i]][,1]}
if(all(is.na(tot)))tot <- NULL
if(!is.numeric(z <- as.matrix(dataframe[,nc,drop=FALSE])))
	stop("response must be numeric")
z <- list(response=list(y=z,nobs=NULL,times=NULL,nest=NULL,coordinates=NULL,
	censor=NULL,n=tot,wt=NULL,delta=NULL,units=NULL,type=NULL),
	ccov=NULL,tvcov=NULL)
class(z) <- "repeated"
class(z$response) <- "response"
tobs <- dim(z$response$y)[1]
nrcol <- dim(z$response$y)[2]
if(is.null(type))z$response$type <- rep("unknown",nrcol)
else if(length(type)!=nrcol)stop("a type must be supplied for each response")
else {
	for(i in 1:length(type))
		z$response$type[i] <- match.arg(type[i],
			c("nominal","ordinal","discrete","duration","continuous","unknown"))
	if(any(is.na(z$response$type)))
		z$response$type[is.na(z$response$type)] <- "unknown"}
rna <- rep(TRUE,tobs)
for(i in 1:nrcol)rna <- rna&!is.na(z$response$y[,i])
if(is.null(id))
	z$response$nobs <- if(is.null(times)) rep(1,tobs) else tobs
else {
	if(!is.character(id)||length(id)>1)
		stop("id must be the name of one variable")
	nc <- match(id,cn)
	if(is.na(nc))stop("id not found")
	id <- as.vector(dataframe[,nc])
	if(is.character(id)||is.factor(id))id <- as.numeric(as.factor(id))
	else if(any(diff(id)!=0&diff(id)!=1,na.rm=TRUE))
		warning("id not consecutively numbered")
	nobs <- table(id)
	z$response$nobs <- as.vector(nobs[match(unique(id),names(nobs))])}
if(any(z$response$nobs!=1)&&length(z$response$nobs)>1)for(i in unique(id)){
	if(any(diff((1:tobs)[id==i])>1,na.rm=TRUE))
		stop(paste("observations for individual",i,"not together in table"))}
if(!is.null(nest)){
	if(all(z$response$nobs==1))
		stop("these are not repeated measurements - nest not valid")
	if(!is.character(nest)||length(nest)>1)
		stop("nest must be the name of one variable")
	nc <- match(nest,cn)
	if(is.na(nc))stop("nest not found")
	z$response$nest <- as.vector(dataframe[,nc])
	if(is.character(z$response$nest))
		z$response$nest <- as.numeric(as.factor(z$response$nest))
	else if(!is.numeric(z$response$nest))stop("nest must be numeric")
	rna <- rna&!is.na(z$response$nest)}
if(!is.null(times)){
	if(!is.character(times)||length(times)>1)
		stop("times must be the name of one variable")
	nc <- match(times,cn)
	if(is.na(nc))stop("times not found")
	z$response$times <- as.vector(dataframe[,nc])
	if(!is.numeric(z$response$times))stop("times must be numeric")
	rna <- rna&!is.na(z$response$times)}
if(!is.null(times))for(i in unique(id))
	if(!is.null(nest))for(j in unique(z$response$nest)){
		if(any(diff(z$response$times[id==i&z$response$nest==j])<0,na.rm=TRUE))
			stop(paste("negative time step for individual",i))}
	else
		if(any(diff(z$response$times[id==i])<0,na.rm=TRUE))
			stop(paste("negative time step for individual",i))
if(!is.null(nest))for(i in unique(id))
	if(any(diff(z$response$nest[id==i])!=0&
		diff(z$response$nest[id==i])!=1,na.rm=TRUE))
		stop(paste("nest for individual",i,"not consecutively numbered"))
if(!is.null(censor)){
	if(!is.character(censor)||length(censor)!=nrcol)
		stop("censor must have one name per response variable")
	nc <- match(censor,cn)
	if(any(is.na(nc)))stop("censor",censor[is.na(nc)],"not found")
	z$response$censor <- as.matrix(dataframe[,nc,drop=FALSE])
	if(!is.numeric(z$response$censor))stop("censor must be numeric")
	if(any(z$response$censor!=1&z$response$censor!=0&
		z$response$censor!=-1,na.rm=TRUE))
		stop("censor indicator can only have values, -1, 0, 1")
	for(i in 1:nrcol)if(!all(is.na(z$response$censor[,i]))){
		rna <- rna&!is.na(z$response$censor[,i])
		if(z$response$type[i]=="unknown")
			z$response$type[i] <- "duration"}}
if(!is.null(totals)){
	if(!is.character(totals)||length(totals)!=nrcol)
		stop("totals must have one name per response variable")
	nc <- match(totals,cn)
	if(any(is.na(nc)))stop("totals",totals[is.na(nc)],"not found")
	z$response$n <- as.matrix(dataframe[,nc,drop=FALSE])
	if(!is.numeric(z$response$n))stop("totals must be numeric")
	if(any(z$response$y<0|z$response$n<z$response$y,na.rm=TRUE))
		stop("responses must lie between 0 and totals")
	for(i in 1:nrcol)if(!all(is.na(z$response$n[,i]))){
		rna <- rna&!is.na(z$response$n[,i])
		if(z$response$type[i]=="unknown")
			z$response$type[i] <- "nominal"}}
if(!is.null(delta)){
	if(is.numeric(delta)){
		if(length(delta)==1)
			z$response$delta <- matrix(delta,ncol=nrcol,nrow=tobs)
		else if(length(delta)==nrcol)
			z$response$delta <- matrix(rep(delta,tobs),ncol=nrcol,nrow=tobs,byrow=TRUE)
		else stop("delta must contain one value for each response")
		if(any(z$response$type=="unknown"))for(i in 1:nrcol)
			if(z$response$type[i]=="unknown")
				z$response$type[i] <- "continuous"}
	else {
		if(!is.character(delta)||length(delta)!=nrcol)
			stop("delta must have one name per response variable")
		nc <- match(delta,cn)
		if(any(is.na(nc)))stop("delta",delta[is.na(nc)],"not found")
		z$response$delta <- as.matrix(dataframe[,nc,drop=FALSE])
		if(!is.numeric(z$response$delta))stop("delta must be numeric")
		if(any(z$response$y<=0,na.rm=TRUE))
			stop("delta must be strictly positive")
		for(i in 1:nrcol)if(!all(is.na(z$response$delta[,i]))){
			rna <- rna&!is.na(z$response$delta[,i])
			if(z$response$type[i]=="unknown")
				z$response$type[i] <- "continuous"}}}
if(!is.null(weights)){
	if(!is.character(weights)||length(times)>1)
		stop("weights must be the name of one variable")
	nc <- match(weights,cn)
	if(is.na(nc))stop("weights not found")
	z$response$wt <- as.vector(dataframe[,nc])
	if(!is.numeric(z$response$wt))stop("weights must be numeric")
	rna <- rna&!is.na(z$response$wt)}
if(!is.null(coordinates)){
	if(!is.character(coordinates)||(length(coordinates)!=2&&
		length(coordinates)!=3))
		stop("coordinates must be the name of 2 or 3 variables")
	nc <- match(coordinates,cn)
	if(any(is.na(nc)))
		stop("coordinates",coordinates[is.na(nc)],"not found")
	z$response$coordinates <- as.matrix(dataframe[,nc,drop=FALSE])
	if(!is.numeric(z$response$coordinates))
		stop("coordinates must be numeric")
	for(i in 1:length(coordinates))
		rna <- rna&!is.na(z$response$coordinates[,i])}
#
# find time-varying covariates
#
if(!is.null(tvcov)){
	if(all(z$response$nobs==1))
		stop("these are not repeated measurements - tvcov not valid")
	z$tvcov <- list(tvcov=NULL,nobs=z$response$nobs)
	class(z$tvcov) <- "tvcov"
	nc <- match(tvcov,cn)
	if(any(is.na(nc)))stop("tvcov",tvcov[is.na(nc)],"not found")
	z$tvcov$tvcov <- dataframe[,nc,drop=FALSE]
	for(i in 1:length(tvcov))rna <- rna&!is.na(z$tvcov$tvcov[,i])
	# if no factor variables present, return a matrix anyway
	fac <- FALSE
	for(i in 1:dim(z$tvcov$tvcov)[2])
		if(!is.vector(z$tvcov$tvcov[,i],mode="numeric")){
		fac <- TRUE
		break}
	if(!fac)z$tvcov$tvcov <- as.matrix(z$tvcov$tvcov)}
#
# find time-constant covariates
#
if(!is.null(ccov)){
	z$ccov <- list(ccov=NULL)
	class(z$ccov) <- "tccov"
	nc <- match(ccov,cn)
	if(any(is.na(nc)))stop("ccov",ccov[is.na(nc)],"not found")
	z$ccov$ccov <- dataframe[,nc,drop=FALSE]
	for(i in unique(id))for(j in 1:length(ccov))
		if(sum(!is.na(unique(z$ccov$ccov[id==i,j])))>1)
		stop(paste("ccov",ccov[j],"for individual",i,"not constant"))
	for(i in 1:length(ccov))rna <- rna&!is.na(z$ccov$ccov[,i])
	j <- c(0,cumsum(z$response$nobs)[-length(z$response$nobs)])+1
	z$ccov$ccov <- z$ccov$ccov[j,,drop=FALSE]
	# if no factor variables present, return a matrix anyway
	fac <- FALSE
	for(i in 1:dim(z$ccov$ccov)[2])
		if(!is.vector(z$ccov$ccov[,i],mode="numeric")){
		fac <- TRUE
		break}
	if(!fac)z$ccov$ccov <- as.matrix(z$ccov$ccov)}
#
# remove NAs
#
if(na.rm&&any(!rna)){
	# remove NAs from variables associated with response
	z$response$y <- z$response$y[rna,,drop=FALSE]
	if(!is.null(z$response$times))z$response$times <- z$response$times[rna]
	if(!is.null(z$response$nest))z$response$nest <- z$response$nest[rna]
	if(!is.null(z$response$coordinates))
		z$response$coordinates <- z$response$coordinates[rna,]
	if(!is.null(z$response$n))z$response$n <- z$response$n[rna,,drop=FALSE]
	if(!is.null(z$response$censor)){
		z$response$censor <- z$response$censor[rna,,drop=FALSE]
		if(all(z$response$censor==1))z$response$censor <- NULL}
	if(!is.null(z$response$delta)&&length(z$response$delta)>1)
		z$response$delta <- z$response$delta[rna,,drop=FALSE]
	if(!is.null(z$tvcov))z$tvcov$tvcov <- z$tvcov$tvcov[rna,,drop=FALSE]
	# correct nobs
	tmp <- NULL
	j <- c(0,cumsum(z$response$nobs))
	for(i in 1:length(z$response$nobs)){
		tmp <- c(tmp,sum(rna[(j[i]+1):j[i+1]]))
		if(tmp[i]==0)
			warning(paste("Individual",i,"has no observations"))}
	z$response$nobs <- tmp[tmp>0]
	# remove NAs from ccov
	if(!is.null(z$ccov)){
		z$ccov$ccov <- z$ccov$ccov[tmp>0,,drop=FALSE]
		for(i in 1: dim(z$ccov$ccov)[2])
			if(length(unique(z$ccov$ccov[,i]))==1)
			warning(paste("covariate",colnames(z$ccov$ccov)[i],"has only one value\n"))}
	# remove NAs from tvcov
	if(!is.null(z$tvcov)){
		z$tvcov$nobs <- z$response$nobs
		for(i in 1: dim(z$tvcov$tvcov)[2])
			if(length(unique(z$tvcov$tvcov[,i]))==1)
			warning(paste("covariate",colnames(z$tvcov$tvcov)[i],"has only one value\n"))}}
if(!na.rm&&any(!rna))z$NAs <- !rna
#
# if independent observations, reset nobs
#
if(all(z$response$nobs==1))z$response$nobs <- 1
z}

### methods for objects created by these functions

### print methods
###
print.response <- function(z, nindmax=50){
nobs <- nobs(z)
nind <- length(nobs)
cn <- colnames(z$y)
tmp <- rbind(colnames(z$y),z$type)
rntmp <- c(if(length(cn)>1)"Names:" else "Name: ","Type:")
if(!is.null(z$units)){
	tmp <- rbind(tmp,z$units)
	rntmp <- c(rntmp,"Units:")}
rownames(tmp) <- rntmp
colnames(tmp) <- rep("",length(cn))
print(tmp,quote=FALSE)
if(any(nobs>1))cat("Number of individuals:                ",nind,"\n")
cat("Total number of observations:         ",dim(z$y)[1],"\n")
if(nind>1&&any(nobs>1)){
	if(all(diff(nobs)==0))
		cat("Number of observations per individual:",nobs[1],"\n")
 	else {
		if(nind>nindmax)cat("Range of observations per individual: ",
			range(nobs),"\n")
		else cat("Number of observations per individual:\n",
			nobs,"\n")}}
av <- rg <- NULL
for(i in 1:dim(z$y)[2]){
      y <- if(is.null(z$n)||all(is.na(z$n[,i])))z$y[,i] else z$y[,i]/z$n[,i]
      av <- c(av,if((z$type[i]=="nominal"&&(is.null(z$n)||all(is.na(z$n[,i]))))
	||z$type[i]=="ordinal")NA else mean(y,na.rm=TRUE))
      rg <- c(rg,range(y,na.rm=TRUE))}
names(av) <- cn
rg <- matrix(rg,nrow=2)
dimnames(rg) <- list(c("lower","upper"),cn)
if(!all(is.na(av))){
	cat("Mean response:")
	if(dim(z$y)[2]>1){
		cat("\n")
		print(av)
		cat("\n")}
	else cat("                        ",av,"\n")}
cat("Range of responses:")
if(dim(z$y)[2]>1){
	cat("\n")
	print(rg)
	cat("\n")}
else cat("                   ",rg,"\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=TRUE),"\n")
	cat("Range of times:                       ",range(z$times,na.rm=TRUE),"\n")
	if(nind>1&&is.null(z$nest)){
		mn <- if(any(z$times<0,na.rm=TRUE))z$times[cumsum(c(1,nobs[1:(nind-1)]))]
			else 0
		cat("Mean total time:                      ",mean(z$times[cumsum(nobs)]-mn,na.rm=TRUE),"\n")
		cat("Range of total times:                 ",range(z$times[cumsum(nobs)]-mn,na.rm=TRUE),"\n")}}
if(!is.null(z$nest))
	cat("Maximum number of clusters:           ",max(z$nest),"\n")
if(!is.null(z$censor)){
	cens0 <- cens1 <- n0 <- n1 <- NULL
	for(i in 1:dim(z$y)[2]){
		if(sum(z$censor[,i]==0,na.rm=TRUE)>0){
			cens0 <- c(cens0,sum(z$censor[,i]==0,na.rm=TRUE))
			n0 <- c(n0,cn[i])}
		if(sum(z$censor[,i]==-1,na.rm=TRUE)>0){
			cens1 <- c(cens1,sum(z$censor[,i]==-1,na.rm=TRUE))
			n1 <- c(n1,cn[i])}}
	names(cens0) <- n0
	names(cens1) <- n1
	if(!is.null(cens0)){
		cat("Number of right-censored observations:")
		if(length(cens0)>1){
			cat("\n")
			print(cens0)
			cat("\n")}
		else cat(" ",cens0," (",n0,")\n",sep="")}
	if(!is.null(cens1)){
		cat("Number of left-censored observations:")
		if(length(cens1)>1){
			cat("\n")
			print(cens1)
			cat("\n")}
		else cat("  ",cens1," (",n1,")\n",sep="")}}
if(!is.null(z$delta)&&length(z$delta)==1)
	cat("Unit of measurement:                  ",z$delta,"\n")
if(!is.null(z$description))for(i in 1:length(z$description)){
	cat(names(z$description)[i],": ",sep="")
	cat(z$description[[i]],"\n")}}

print.tccov <- function(z){
if(is.function(z))print.default(unclass(z))
else {
	tmp <- matrix(colnames(z$ccov),nrow=1)
	rn <- "Names:"
	if(!is.null(z$units)){
		tmp <- rbind(tmp,z$units)
		rn <- c(rn,"Units:")}
	dimnames(tmp) <- list(rn,rep("",dim(z$ccov)[2]))
	print(tmp,quote=FALSE)
	cat("Number of individuals:             ",dim(z$ccov)[1],"\n")
	if(!is.null(z$description))for(i in 1:length(z$description)){
		cat(names(z$description)[i],": ",sep="")
		cat(z$description[[i]],"\n")}}}

print.tvcov <- function(z, nindmax=50){
if(is.function(z))print.default(unclass(z))
else {
	tmp <- matrix(colnames(z$tvcov),nrow=1)
	rn <- "Names:"
	if(!is.null(z$units)){
		tmp <- rbind(tmp,z$units)
		rn <- c(rn,"Units:")}
	dimnames(tmp) <- list(rn,rep("",dim(z$tvcov)[2]))
	print(tmp,quote=FALSE)
	cat("Number of individuals:               ",length(nobs(z)),"\n")
	cat("Number of observations:              ",sum(nobs(z)),"\n")
	if(length(nobs(z))>nindmax)cat("Range of observations per individual:",
		range(nobs(z)),"\n")
	else cat("Number of observations per individual:\n",
		nobs(z),"\n")
	if(!is.null(z$description))for(i in 1:length(z$description)){
		cat(names(z$description)[i],": ",sep="")
		cat(z$description[[i]],"\n")}}}

print.repeated <- function(z, nindmax=50){
if(is.function(z))print.default(unclass(z))
else {
	cat("\nResponse variable:\n")
	print.response(z$response,nindmax=nindmax)
	if(!is.null(z$ccov)){
		cat("\nInter-unit (time-constant) covariates:\n")
		print.tccov(z$ccov)}
	if(!is.null(z$tvcov)){
		cat("\nIntra-unit (time-varying) covariates:\n")
		print.tvcov(z$tvcov,nindmax=nindmax)}}}

### plot methods
###
plot.response <- function(z, name=NULL, nind=NULL, nest=1, ccov=NULL,
	add=FALSE, lty=NULL, pch=NULL, main=NULL, ylim=NULL, xlim=NULL,
	xlab=NULL, ylab=NULL, ...){
if(is.null(name)){
	if(dim(z$y)[2]>1)stop("please specify which variable to plot")
	name <- colnames(z$y)}
else if(length(name)>1)stop("only one variable can be plotted")
col <- match(name,colnames(z$y))
if(is.na(col))stop(paste(name,"not found"))
if(z$type[col]=="ordinal"){
	# special case: ordinal response
	return(plot.ordinal(z=z,ccov=ccov,main=main,xlab=xlab,ylab=ylab,
		xlim=xlim,ylim=ylim,lty=lty,add=add,...))}
if(is.null(ylab))ylab <- name
if(is.null(z$times)){
#
# when no times, set up for index plot
#
	if(all(nobs(z)==1)){
		z$times <- 1:length(nobs(z))
		# set to value different from 1 so not time series
		z$nobs <- 5}
	else z$times <- sequence(nobs(z))
	if(is.null(xlab)) xlab <- "Index number"}
else if(is.null(xlab)) xlab <- "Time"
if(is.null(ylim))ylim <- range(z$y[,col],na.rm=TRUE)
if(is.null(xlim))xlim <- range(z$times,na.rm=TRUE)
tnest <- if(!is.null(z$nest)) z$nest else 1
#
# initialize
#
nm <- covind(z)
j <- 1
lt <- 0
#
# if no individuals chosen, plot them all
#
if(is.null(nind))nind <- 1:length(nobs(z))
#
# if binomial, plot proportions
#
y <- if(is.null(z$n)||all(is.na(z$n[,col])))z$y[,col] else z$y[,col]/z$n[,col]
if(!is.null(lty)){
#
# set up line types
#
	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)){
#
# set up symbol types
#
	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(nobs(z)))if(any(i==nind))for(k in nest){
	lt <- if(is.null(lty))lt%%6+1 else lty[j]
	if(!add&&j==1)plot(z$times[nm==i&k==tnest],y[nm==i&k==tnest],lty=lt,
		type="l",ylim=ylim,xlim=xlim,main=main,ylab=ylab,xlab=xlab,...)
	else lines(z$times[nm==i&k==tnest],y[nm==i&k==tnest],lty=lt)
	if(!is.null(pch))points(z$times[nm==i&k==tnest],
		y[nm==i&k==tnest],pch=pch[j])
	j <- j+1}}

plot.repeated <- function(z, name=NULL, nind=NULL, nest=1, ccov=NULL,
	add=FALSE, lty=NULL, pch=NULL, main=NULL, ylim=NULL, xlim=NULL,
	xlab=NULL, ylab=NULL, ...){
if(is.null(name)){
	if(dim(z$response$y)[2]>1)stop("please specify which variable to plot")
	name <- colnames(z$response$y)}
else if(length(name)>1)stop("only one variable name can be supplied")
col <- match(name,colnames(z$response$y))
if(is.na(col)){
	col <- match(name,colnames(z$tvcov$tvcov))
	if(is.na(col))stop(paste(name,"not found"))
	variable <- "tvc"}
else variable <- "response"
#
# check individuals to plot
# if no individuals chosen, plot them all
#
uncov <- NULL
if(!is.null(nind)&&!is.null(ccov))
	stop("only one of nind and ccov can be specified")
if(is.null(nind)&&is.null(ccov))nind <- 1:length(nobs(z))
else if(!is.null(ccov)&&z$response$type[col]!="ordinal"){
	if(is.numeric(ccov)){
		if(length(ccov)!=dim(z$ccov$ccov)[2])
			stop("a covariate value must be given for each covariate")
	        tccov <- z$ccov$ccov
	        if(is.data.frame(tccov))for(i in 1:length(ccov)){
	        	if(is.factor(tccov[[i]]))
	        		tccov[[i]] <- as.numeric(tccov[[i]])}
	        tccov <- as.matrix(tccov)
		nind <- NULL
		for(i in 1:length(nobs(z)))
			if(all(ccov==tccov[i,]))nind <- c(nind,i)}
	else if(is.character(ccov)){
		if(is.null(z$ccov$ccov))stop("no covariates found")
		if(length(ccov)>1)
			stop("only one variable name can be given in ccov")
		col2 <- match(ccov,colnames(z$ccov$ccov))
		if(is.na(col2))stop(paste("covariate",ccov,"not found"))
		uncov <- unique(z$ccov$ccov[,col2])
		if(is.factor(uncov))uncov <- as.character(uncov)
		if(length(uncov)>6)
			stop(paste(ccov,"has too many distinct values to plot"))
		if(length(uncov)==1)uncov <- NULL}
	else stop("ccov must be a vector of covariate values or a covariate name")}
if(variable=="response"){
	# special case: ordinal response
	if(z$response$type[col]=="ordinal")
		plot.ordinal(z=z,ccov=ccov,main=main,xlab=xlab,ylab=ylab,
			xlim=xlim,ylim=ylim,lty=lty,add=add,...)
	else {
		if(is.null(uncov))plot.response(z$response,name=name,nind=nind,
			nest=nest,add=add,lty=lty,pch=pch,main=main,
			ylim=ylim,xlim=xlim,xlab=xlab,ylab=ylab,...)
		else {
			mfrow <- if(length(uncov)==2)c(2,1)
				else if(length(uncov)<5)c(2,2) else c(3,2)
			oldpar <- par(mfrow=mfrow,no.readonly=TRUE)
			for(i in uncov){
				nind <- NULL
				main <- paste(ccov,"=",i)
				for(j in 1:length(nobs(z)))
					if(i==z$ccov$ccov[j,col2])
					nind <- c(nind,j)
				plot.response(z$response,name=name,nind=nind,
				nest=nest,add=add,lty=lty,pch=pch,main=main,
				ylim=ylim,xlim=xlim,xlab=xlab,ylab=ylab,...)}
			par(oldpar)}}}
else if(variable=="tvc"){
	# set up covariate as a "response"
	if(is.null(ylab))ylab <- colnames(z$tvcov$tvcov)[col]
	zz <- list(times=z$response$times,y=z$tvcov$tvcov[,col,drop=FALSE],
		nobs=z$tvcov$nobs,n=NULL,type="unknown")
	class(zz) <- "response"
	if(is.null(uncov))plot.response(zz,name=name,nind=nind,nest=nest,
		add=add,lty=lty,pch=pch,main=main,ylim=ylim,xlim=xlim,
		xlab=xlab,ylab=ylab,...)
	else {
		mfrow <- if(length(uncov)==2)c(2,1)
			else if(length(uncov)<5)c(2,2) else c(3,2)
		oldpar <- par(mfrow=mfrow,no.readonly=TRUE)
		for(i in uncov){
			nind <- NULL
			main <- paste(ccov,"=",i)
			for(j in 1:length(nobs(z)))
				if(i==z$ccov$ccov[j,col2])
				nind <- c(nind,j)
			plot.response(zz,name=name,nind=nind,nest=nest,add=add,
			lty=lty,pch=pch,main=main,ylim=ylim,xlim=xlim,
			xlab=xlab,ylab=ylab,...)}
		par(oldpar)}}}

### methods to find the response variable
###
response <- function(z, ...) UseMethod("response")

response.response <- function(z, nind=NULL, names=NULL){
if(is.null(nind))nind <- 1:dim(z$y)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
if(is.null(names))col <- 1:dim(z$y)[2]
else {
	col <- match(names,colnames(z$y))
	if(any(is.na(col)))stop(paste(names[is.na(col)],"not found"))}
cn <- tmp <- NULL
for(i in col){
	if(!is.null(z$n)&&!any(is.na(z$n[,i]))){
	# binomial response
		tmp <- cbind(tmp,z$y[,i],z$n[,i]-z$y[,i])
		cn <- c(cn,colnames(z$y)[i],paste("n-",colnames(z$y)[i],sep=""))}
	else if(!is.null(z$censor)&&!any(is.na(z$censor[,i]))){
	# censored response with indicator
		tmp <- cbind(tmp,z$y[,i],z$censor[,i])
		cn <- c(cn,colnames(z$y)[i],paste(colnames(z$y)[i],".cens",sep=""))}
	else {
		tmp <- cbind(tmp,z$y[,i])
		cn <- c(cn,colnames(z$y)[i])}}
colnames(tmp) <- cn
tmp[nind,]}

response.repeated <- function(z, nind=NULL, names=NULL){
if(is.null(nind))nind <- 1:dim(z$response$y)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
if(is.null(names))col <- 1:dim(z$response$y)[2]
else {
	col <- match(names,colnames(z$response$y))
	if(any(is.na(col)))stop(paste(names[is.na(col)],"not found"))}
cn <- tmp <- NULL
for(i in col){
	if(!is.null(z$response$n)&&!any(is.na(z$response$n[,i]))){
	# binomial response
		tmp <- cbind(tmp,z$response$y[,i],z$response$n[,i]-z$response$y[,i])
		cn <- c(cn,colnames(z$response$y)[i],paste("n-",colnames(z$response$y)[i],sep=""))}
	else if(!is.null(z$response$censor)&&!any(is.na(z$response$censor[,i]))){
	# censored response with indicator
		tmp <- cbind(tmp,z$response$y[,i],z$response$censor[,i])
		cn <- c(cn,colnames(z$response$y)[i],paste(colnames(z$response$y)[i],".cens",sep=""))}
	else {
		tmp <- cbind(tmp,z$response$y[,i])
		cn <- c(cn,colnames(z$response$y)[i])}}
colnames(tmp) <- cn
tmp[nind,]}

### methods for indexing of time-constant covariates for individuals
###
covind <- function(z, ...) UseMethod("covind")

covind.default <- function(z) rep(1:length(nobs(z)),nobs(z))

### methods to find numbers of observations/individual
###
nobs <- function(z, ...) UseMethod("nobs")

nobs.default <- function(z) {
if(is.null(z$response)||is.null(z$response$nobs))return(NULL)
if(length(z$response$nobs)>1||z$response$nobs>1)z$response$nobs
else rep(1,dim(z$response$y)[1])}

nobs.response <- function(z) {
if(length(z$nobs)>1||z$nobs>1)z$nobs
else rep(1,length(z$y))}

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

nobs.data.frame <- function(z) rep(1,dim(z)[1])

### methods to find times
###
times <- function(z, ...) UseMethod("times")

times.default <- function(z, nind=NULL){
if(is.null(nind)||is.null(z$response$times))return(z$response$times)
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
z$response$times[nind]}

times.response <- function(z, nind=NULL){
if(is.null(nind)||is.null(z$times))return(z$times)
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
z$times[nind]}

### methods to find unit of measurement/Jacobian
###
delta <- function(z, ...) UseMethod("delta")

delta.response <- function(z, nind=NULL, names=NULL){
#
# find individuals
#
if(is.null(z$delta))return(NULL)
if(is.null(nind))nind <- 1:dim(z$y)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
#
# find variables
#
col <- if(is.null(names))1:dim(z$y)[2] else match(names,colnames(z$y))
if(any(is.na(col)))stop(paste(names[is.na(col)],"not found"))
z$delta[nind,col]}

delta.repeated <- function(z, nind=NULL, names=NULL){
#
# find individuals
#
if(is.null(z$response$delta))return(NULL)
if(is.null(nind))nind <- 1:dim(z$response$y)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
#
# find variables
#
col <- if(is.null(names))1:dim(z$response$y)[2]
	else match(names,colnames(z$response$y))
print(col)
if(any(is.na(col)))stop(paste(names[is.na(col)],"not found"))
z$response$delta[nind,col]}

### methods to find weights
###
weights.response <- function(z, nind=NULL){
if(is.null(nind)||is.null(z$wt))return(z$wt)
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
z$wt[nind]}

weights.repeated <- function(z, nind=NULL){
if(is.null(nind)||is.null(z$response$wt))return(z$response$wt)
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
z$response$wt[nind]}

### methods to find nesting indicators
###
nesting <- function(z, ...) UseMethod("nesting")

nesting.response <- function(z, nind=NULL){
if(is.null(nind))nind <- 1:length(z$y)
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
#
# if nest is NULL, return individual index otherwise both
#
if(length(nobs(z))==1||all(nobs(z)==1))return(NULL)
else if(is.null(z$nest))return(covind(z)[nind])
else {
	z <- cbind(covind(z),z$nest)
	colnames(z) <- c("Individual","Cluster")
	return(z)[nind,,drop=FALSE]}}

nesting.repeated <- function(z, nind=NULL){
if(is.null(nind))nind <- 1:dim(z$response$y)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
#
# if nest is NULL, return individual index otherwise both
#
if(length(nobs(z))==1||all(nobs(z)==1))return(NULL)
else if(is.null(z$response$nest))return(covind(z)[nind])
else {
	z <- cbind(covind(z),z$response$nest)
	colnames(z) <- c("Individual","Cluster")
	return(z[nind,,drop=FALSE])}}

### methods to find covariates
###
covariates <- function(z, ...) UseMethod("covariates")

covariates.tccov <- function(z, nind=NULL, names=NULL, expand=FALSE){
if(is.null(nind))nind <- 1:dim(z$ccov)[1]
else if(length(nind)>dim(z$ccov)[1]||any(nind>dim(z$ccov)[1])||any(nind<1))
	stop("Individual not found")
if(is.null(names))return(z$ccov[nind,])
else {
	col <- match(names,colnames(z$ccov))
	if(any(is.na(col)))
		stop(paste("covariate(s)",names[is.na(col)],"not found"))
	return(z$ccov[nind,col])}}

covariates.tvcov <- function(z, nind=NULL, names=NULL, expand=FALSE){
if(is.null(nind))nind <- 1:dim(z$tvcov)[1]
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nind <- !is.na(match(covind(z),nind))
if(all(!nind))stop("No such individuals")
if(is.null(names))return(z$tvcov[nind,])
else {
	col <- match(names,colnames(z$tvcov))
	if(any(is.na(col)))
		stop(paste("covariate(s)",names[is.na(col)],"not found"))
	return(z$tvcov[nind,col])}}

covariates.repeated <- function(z, nind=NULL, names=NULL, expand=FALSE){
if(expand&&!is.null(nind))stop("can only expand for all individuals")
ind <- covind(z)
if(is.null(nind)){
	nindv <- 1:dim(z$response$y)[1]
	nind <- if(expand)ind else 1:length(nobs(z))}
else if(length(nind)>length(nobs(z))||any(nind>length(nobs(z))))
	stop("Individual not found")
else nindv <- !is.na(match(ind,nind))
if(all(!nindv))stop("No such individuals")
if(is.null(names)){
	if(is.null(z$tvcov$tvcov))return(z$ccov$ccov[nind,])
	else if(is.null(z$ccov$ccov))return(z$tvcov$tvcov[nindv,])
	else {
		if(expand)return(cbind(z$ccov$ccov[nind,],
			z$tvcov$tvcov[nindv,]))
		else return(list(ccov=z$ccov$ccov[nind,],
			tvcov=z$tvcov$tvcov[nindv,]))}}
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[nindv,mat2])
	else if(all(is.na(mat2)))return(z$ccov$ccov[nind,mat1])
	else {
		if(expand)return(cbind(z$ccov$ccov[nind,mat1],
			z$tvcov$tvcov[nindv,mat2]))
		else return(list(ccov=z$ccov$ccov[nind,mat1],
			tvcov=z$tvcov$tvcov[nindv,mat2]))}}}

### methods to find names
###
names.response <- function(z) colnames(z$y)

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

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

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

### methods to find units of measurements
###
units <- function(z, ...) UseMethod("units")

units.default <- function(z) z$units

units.repeated <- function(z)
	list(response=units(z$response),ccov=units(z$ccov),
		tvcov=units(z$tvcov))

### methods to find description of variables
###
description <- function(z, ...) UseMethod("description")

description.default <- function(z) z$description

description.repeated <- function(z)
	list(response=description(z$response),ccov=description(z$ccov),
		tvcov=description(z$tvcov))

### methods to find response type(s)
###
resptype <- function(z, ...) UseMethod("resptype")

resptype.response <- function(z) z$type

resptype.repeated <- function(z) z$response$type

### methods to find formula used in tccov
###
formula.tccov <- function(z) z$linear

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

### methods to transform response, times, or covariates
###
transform.response <- function(z, times=NULL, units=NULL, ...){
if(is.call(substitute(times)))times <- substitute(times)
tran <- as.list(substitute(list(...)))[-1]
if(!is.null(tran)){
#
# transform response
#
	if(is.null(z$delta))
		z$delta <- matrix(1,nrow=dim(z$y)[1],ncol=dim(z$y)[2])
	else if(length(delta)==1)
		z$delta <- matrix(z$delta,nrow=dim(z$y)[1],ncol=dim(z$y)[2])
	cn <- colnames(z$y)
	cn2 <- names(tran)
	col <- match(cn2,cn)
	col2 <- NULL
	if(!is.null(units)){
		if(length(units)!=length(tran))
			stop(paste(length(tran),"units required"))
		if(!is.character(units))
			stop("units must be a character vector")}
	for(i in tran){
		tmp <- NULL
		for(j in 1:length(cn)){
			if(length(grep(cn[j],as.character(i)))>0){
				tmp <- j
				break}}
		if(is.null(tmp))stop("variable to transform not found")
		col2 <- c(col2,tmp)}
	j <- 0
	for(i in tran){
		j <- j+1
		if(z$type[col2[j]]!="continuous"&&z$type[col2[j]]!="duration"&&z$type[col2[j]]!="unknown")
			stop(paste("transformations do not make sense with",z$type[col2[j]],"responses"))
		# transform
		tran <- eval(deriv(i,cn[col2[j]]),as.data.frame(z$y),NULL)
		# calculate Jacobian
		jacob <- as.vector(abs(attr(tran,"gradient")))
		if(any(is.na(jacob)&!is.na(tran)))
			stop("NAs in jacobian - invalid transformation")
		if(any(abs(jacob)==Inf,na.rm=TRUE))
			stop("infinite jacobian - invalid transformation")
		if(any(jacob<=0,na.rm=TRUE))
			stop("nonpositive value in jacobian - invalid transformation")
		# store in the response object, updating delta, units, type
		if(is.na(col[j])){
			if(any(is.na(tran)&!is.na(z$y[,col2[j]]),na.rm=TRUE))
				stop("NAs created by transformation")
			tran <- as.matrix(tran)
			colnames(tran) <- cn2[j]
			z$y <- cbind(z$y,tran)
			z$delta <- if(all(is.na(z$delta[,col2[j]])))
				cbind(z$delta,jacob)
				else cbind(z$delta,z$delta[,col2[j]]*jacob)
			colnames(z$delta) <- colnames(z$y)
			if(!is.null(z$n)){
				z$n <- cbind(z$n,rep(NA,dim(z$n)[1]))
				colnames(z$n) <- colnames(z$y)}
			if(!is.null(z$censor)){
				z$censor <- cbind(z$censor,z$censor[,col2[j]])
				colnames(z$censor) <- colnames(z$y)}
			z$type <- c(z$type,z$type[col2[j]])
			names(z$type) <- colnames(z$y)
			if(!is.null(z$units)){
				z$units <- c(z$units,if(is.null(units))NA else
					units[j])
				names(z$units) <- colnames(z$y)}}
		else {
			if(any(is.na(tran)&!is.na(z$y[,col[j]]),na.rm=TRUE))
				stop("NAs created by transformation")
			z$y[,col[j]] <- as.vector(tran)
			z$delta[,col[j]] <- if(all(is.na(z$delta[,col[j]])))
				jacob else z$delta[,col[j]]*jacob
			if(!is.null(z$units))
				z$units[col[j]] <- if(is.null(units))NA
					else units[j]}}}
if(!is.null(z$units)&&all(is.na(z$units)))z$units <- NULL
if(!is.null(times)){
#
# transform times
#
	z$times <- eval(times,z,NULL)
	for(i in 1:length(nobs(z)))if(any(diff(z$times[covind(z)==i])<0))
		stop("transformation produces negative time steps")}
z}

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

transform.tccov <- function(z, ...){
isf <- is.data.frame(z$ccov)
if(!isf)z$ccov <- as.data.frame(z$ccov)
#
# find transformations
#
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"))
#
# find covariates to transform
#
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)
#
# find transformations
#
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"))
#
# find covariates to transform
#
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}

### as.data.frame methods
###
as.data.frame.response <- function(z,row.names=NULL,optional=FALSE){
	tmp <- data.frame(z$y)
	if(!is.null(z$n))for(i in 1:dim(z$y)[2])if(any(!is.na(z$n[,i])))
		tmp[[i]] <- I(cbind(z$y[,i],z$n[,i]-z$y[,i]))
	if(!is.null(z$censor))for(i in 1:dim(z$y)[2])
		if(any(!is.na(z$censor[,i])))
			tmp[[i]] <- I(cbind(z$y[,i],z$censor[,i]))
	cn <- colnames(z$y)
	if(length(z$nobs)!=1){
		cn <- c(cn,"individuals")
		tmp <- data.frame(tmp,as.factor(rep(1:length(z$nobs),z$nobs)))}
	if(!is.null(z$nest)){
		cn <- c(cn,"nesting")
		tmp <- data.frame(tmp,as.factor(z$nest))}
	if(!is.null(z$times)){
		cn <- c(cn,"times")
		tmp <- data.frame(tmp,z$times)}
	colnames(tmp) <- cn
	data.frame(tmp)}

as.data.frame.tccov <- function(z,row.names=NULL,optional=FALSE)
	as.data.frame(z$ccov)

as.data.frame.tvcov <- function(z,row.names=NULL,optional=FALSE)
	as.data.frame(z$tvcov)

as.data.frame.repeated <- function(z,row.names=NULL,optional=FALSE){
	tmp <- data.frame(z$response$y)
	if(!is.null(z$response$n))for(i in 1:dim(z$response$y)[2])
		if(any(!is.na(z$response$n[,i])))
			tmp[[i]] <- I(cbind(z$response$y[,i],z$response$n[,i]-z$response$y[,i]))
	if(!is.null(z$response$censor))for(i in 1:dim(z$response$y)[2])
		if(any(!is.na(z$response$censor[,i])))
			tmp[[i]] <- I(cbind(z$response$y[,i],z$response$censor[,i]))
	cn <- colnames(z$response$y)
	if(!(length(z$response$nobs)==1)){
		cn <- c(cn,"individuals")
		tmp <- data.frame(tmp,as.factor(rep(1:length(z$response$nobs),
			z$response$nobs)))}
	if(!is.null(z$response$nest)){
		cn <- c(cn,"nesting")
		tmp <- data.frame(tmp,as.factor(z$response$nest))}
	if(!is.null(z$response$times)){
		cn <- c(cn,"times")
		tmp <- data.frame(tmp,z$response$times)}
	tmp <- data.frame(tmp)
	colnames(tmp) <- cn
	if(!is.null(z$ccov$ccov))
		tmp <- data.frame(tmp,z$ccov$ccov[covind(z),,drop=FALSE])
	if(!is.null(z$tvcov$tvcov))
		tmp <- data.frame(tmp,z$tvcov$tvcov)
	tmp}

### as.matrix methods
###
as.matrix.response <- function(z){
	tmp <- z$y
	cn <- colnames(z$y)
	if(!is.null(z$times)){
		cn <- c(cn,"times")
		tmp <- cbind(tmp,z$times)}
	colnames(tmp) <- cn
	tmp}

as.matrix.tccov <- function(z) as.matrix(z$ccov)

as.matrix.tvcov <- function(z) as.matrix(z$tvcov)

as.matrix.repeated <- function(z){
	tmp <- z$response$y
	cn <- colnames(z$response$y)
	if(!is.null(z$response$times)){
		cn <- c(cn,"times")
		tmp <- cbind(tmp,z$response$times)}
	colnames(tmp) <- cn
	if(!is.null(z$ccov$ccov))
		tmp <- cbind(tmp,z$ccov$ccov[covind(z),,drop=FALSE])
	if(!is.null(z$tvcov$tvcov))
		tmp <- cbind(tmp,z$tvcov$tvcov)
	tmp}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     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 compartment 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 (lpfp)
# 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)
	lpfp <- exp(p[6])
	lpfp <- lpfp/(1+lpfp)
	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-lpfp)+(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 (lpfp)
# 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
	lpfp <- exp(p[7])
	lpfp <- lpfp/(1+lpfp)
	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))*lpfp+(1-ind)*(((1-exp(-kem*times))/
		kem*(times<=end)+(1-exp(-kem*end))/kem*exp(-kem*(times-end))*
		(times>end))*tmp1*(1-lpfp)+(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)
# p[9]: logit of proportion going to first pass (lpfp)
# 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
	lpfp <- exp(p[9])
	lpfp <- lpfp/(1+lpfp)
	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))*lpfp+(1-ind)*
		(((1-exp(-kem*times))/kem*(times<=end)+(1-exp(-kem*end))/
		kem*exp(-kem*(times-end))*(times>end))*(1-lpfp)+
		(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 (ked)
#	(kep: total parent drug elimination)
# p[4]: log transformation rate from parent to metabolite (kpm)
# p[5]: log metabolite first-pass formation rate (kmfp)
# p[6]: log metabolite elimination rate (kem)
# p[7]: logit of proportion going to first pass (lpfp)
# ind:  indicator vector: 1 for parent, 0 for metabolite
mu2.1o1cfp <- function(p, times, dose=1, ind) {
	kap <- exp(p[2])
	kf <- exp(p[4])
	kep <- exp(p[3])+kf
	kmfp <- exp(p[5])
	kem <- exp(p[6])
	lpfp <- exp(p[7])
	lpfp <- lpfp/(1+lpfp)
	exp(-p[1])*dose*(ind*(exp(-kep*times)-exp(-kap*times))/
		(kap-kep)*lpfp+(1-ind)*((exp(-kmfp*times)-exp(-kap*times))/
		(kap-kmfp)*(1-lpfp)+kf*(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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     plot(mprofile(z, ...))
#     plot(iprofile(z, ...))
#     plot.residuals(z, ...)
#
#  DESCRIPTION
#
#    Utility functions for plotting repeated measurements profiles
# and residuals

### functions to create information for plotting marginal profiles
###   from dynamic models
mprofile <- function(z, ...) UseMethod("mprofile")

mprofile.default <- function(z, times=NULL, mu=NULL){
if(is.null(mu)||!is.function(mu)){
#
# use fitted values from model
#
	if(is.null(z$pred))stop("Fitted values not available")
	# if response is transformed, transform predicted values
	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)}
	# store times corresponding to predicted values
	if(inherits(z,"kalsurv")){
		z$ptimes <- vector("double",length(z$response$y))
		tmp1 <- 1
		for(i in 1:length(nobs(z))){
			tmp2 <- sum(nobs(z)[1:i])
			z$ptimes[tmp1:tmp2] <- cumsum(z$response$y[tmp1:tmp2])
			tmp1 <- tmp2+1}
		z$response$times <- z$ptimes}
	else z$ptimes <- z$response$times}
else {
#
# if a function is supplied, calculate predicted values
#
	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("mprofile",class(z))
invisible(z)}

### function to plot marginal profiles
###
plot.mprofile <- function(z, nind=1, intensity=FALSE, add=FALSE,
	ylim=range(z$pred,na.rm=TRUE), lty=NULL, ylab=NULL, xlab=NULL, ...){
if(max(nind)>length(nobs(z)))stop("no such individual")
if(inherits(z,"kalsurv")){
#
# event history data may have ties
#
	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){
	# modify predicted values, if intensity wanted
		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)){
#
# use fitted values from model
#
	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){
	# plot separately for each individual chosen
		if(is.null(z$response$nest)) kk <- nest <- 1
		else {
 nest <- unique(z$response$nest)
			kk <- z$response$nest}
		for(k in nest){
		# if nesting, start lines over in each cluster
			j <- j+1
			if(is.null(lty)) lt <- (lt%%6)+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 {
#
# a function was supplied to calculate predicted values
#
	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)){
#
# plot standard errors if available (carma only)
#
	lines(z$ptimes, z$pse[,1], lty=3)
	lines(z$ptimes, z$pse[,2], lty=3)}}

### functions to create information for plotting individual profiles
### from dynamic models
###
iprofile <- function(z, ...) UseMethod("iprofile")

iprofile.default <- function(z, plotsd=FALSE){
if(!inherits(z,"recursive"))
	stop("The object must have class, recursive")
else if(is.null(z$rpred))stop("Individual profiles not available")
#
# if response is transformed, transform predicted values
# and standard deviations
#
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)}
if(inherits(z,"kalsurv")){
	z$response$times <- vector("double",length(z$response$y))
	tmp1 <- 1
	for(i in 1:length(nobs(z))){
		tmp2 <- sum(nobs(z)[1:i])
		z$response$times[tmp1:tmp2] <- cumsum(z$response$y[tmp1:tmp2])
		tmp1 <- tmp2+1}}
class(z) <- c("iprofile",class(z))
invisible(z)}

### function to plot individual profiles
###
plot.iprofile <- function(z, nind=1, observed=TRUE, intensity=FALSE, add=FALSE,
	lty=NULL, pch=NULL, ylab=NULL, xlab=NULL, main=NULL, ylim=NULL,
	xlim=NULL, ...){
if(max(nind)>length(nobs(z)))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=TRUE),max(z$rpred+3*z$sdr,na.rm=TRUE))
ns <- length(nind)
ii <- covind(z$response)
pc <- -1
lt <- 0
first <- !add
#
# set up plotting controls
#
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=TRUE),
	max(c(z$rpred,z$response$y),na.rm=TRUE))
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
#
# plot separately for each individual chosen
#
if(is.null(z$response$nest)) kk <- nest <- 1
else {
	nest <- unique(z$response$nest)
	kk <- z$response$nest}
for(i in nind){
	for(k in nest){
	# if nesting, start lines over in each cluster
		j <- j+1
		if(is.null(pch))pc <- (pc+1)%%6
		else pc <- pch[j]
		if(is.null(lty)) lt <- (lt%%6)+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 <- FALSE}
		else lines(z$resp$times[ii==i&kk==k&na],z$rpred[ii==i&kk==k&na],lty=lt)
		# if required, plot data points
		if(observed)points(z$resp$times[ii==i&kk==k],z$resp$y[ii==i&kk==k],pch=pc)
		# if required, plot standard deviations
		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)}}}}

### function to plot residuals
###
plot.residuals <- function(z, x=NULL, subset=NULL, ccov=NULL,
	nind=NULL, recursive=TRUE, pch=20, ylab="Residual",
	xlab=NULL, main=NULL, ...){
na <- TRUE
#
# check if model produced by a function in one of my libraries
#
resp <- !is.null(z$response$y)
if(!resp){
	nind <- ccov <- NULL
	recursive <- FALSE}
if(is.character(x))x <- match.arg(x,c("response","fitted"))
#
# find residuals to be plotted
#
if(resp){
	n <- length(z$response$y)
	res <- if(inherits(z,"recursive"))
		residuals(z, recursive=recursive) else residuals(z)
	# handle ties in event histories
	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)}
#
# indicator of subset to be plotted
#
if(is.null(subset))subset <- rep(TRUE,n)
else {
	tmp <- rep(FALSE,n)
	tmp[subset] <- TRUE
	subset <- tmp}
#
# find individuals and subset to be plotted
#
if(resp&&!is.null(nind)){
	if(is.null(subset))subset <- rep(FALSE,n)
	for(i in nind)subset <- subset&covind(z)==i}
#
# find values for x axis
#
if(is.null(x)){
	# plot by times if possible
	x <- z$response$times
	if(is.null(x))stop("x must be specified")
	if(is.null(xlab))xlab <- "Time"}
else if(is.numeric(x)){
	# plot against vector supplied if possible
	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"){
	# plot against response if possible
	x <- if(resp)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"){
	# plot against fitted values if possible
	x <- if(resp)fitted(z, recursive=recursive) else fitted(z)
	na <- !is.na(x)
	if(is.null(xlab))xlab <- "Fitted values"}
#
# plot
#
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$ccov$ccov))
	if(is.na(mat))stop("covariate not found")
	un <- unique(z$ccov$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(nobs(z))
		ind[rep(z$ccov$ccov[,mat],nobs(z))!=i] <- NA
		main <- paste("Covariate ",ccov,"=",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, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  DESCRIPTION
#
#    Utility functions for printing nonlinear model results

### standard methods for gnlm models
###

weights.gnlm <- function(z) z$prior.weights

df.residual.gnlm <- function(z) z$df

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

### print function for bnlr, gnlr, gnlr3, gnlmm, and fmr
###
print.gnlm <- function(z,digits=max(4,.Options$digits-3),correlation=TRUE) {
sht <- z$nps>0||!is.null(z$shape)
mix <- z$npm>0||!is.null(z$mix)
gnlmm <- !is.null(z$points)
gnlmix <- z$npm>0&&is.null(z$mix)
censor <- if(mix)!is.null(z$censor) else z$censor
npl <- z$npl-gnlmm
np1 <- z$npl+1
np1a <- z$npl+z$npm*(!gnlmix)+1
np2 <- z$npl+z$npm*(!gnlmix)+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&&!is.logical(z$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 ")
if(!is.null(z$dist))cat(z$dist,"distribution\n\n")
else if(!is.null(z$link))cat(z$link,"link\n\n")
if(!is.null(z$mixture))cat(z$mixture,"mixing 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="")}
cat("Log likelihood function:\n")
if(z$distribution=="own"){
	if(!is.null(attr(z$likefn,"formula")))
		cat(deparse(attr(z$likefn,"formula")),sep="\n")
	else if(!is.null(attr(z$likefn,"model"))){
		t <- deparse(attr(z$likefn,"model"))
		t[1] <- sub("expression\\(","",t[1])
		t[length(t)] <- sub("\\)$","",t[length(t)])
		cat(t,sep="\n")}}
else {
	t <- deparse(z$likefn)
	cat(t[2:length(t)],"",sep="\n")}
if((z$npl>0||!is.null(z$mu))&&z$distribution!="own"){
	cat("Location function:\n")
	if(!is.null(attr(z$mu,"formula")))
		cat(deparse(attr(z$mu,"formula")),sep="\n")
	else if(!is.null(attr(z$mu,"model"))){
		t <- deparse(attr(z$mu,"model"))
		t[1] <- sub("expression\\(","",t[1])
		t[length(t)] <- sub("\\)$","",t[length(t)])
		cat(t,sep="\n")}
	if(!is.null(z$linear[[1]])){
		cat("Linear part:\n")
		print(z$linear[[1]])}}
if(mix){
	if(!is.null(z$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(!is.null(z$linear[[2]])){
		cat("Linear part:\n")
		print(z$linear[[2]])}}
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(!is.null(z$linear[[2]])){
			cat("Linear part:\n")
			print(z$linear[[2]])}}
	if(!is.null(z$family)){
		cat("\n(Log) family function:\n")
		if(!is.null(attr(z$family,"formula")))
			cat(deparse(attr(z$family,"formula")),sep="\n")
		else if(!is.null(attr(z$family,"model"))){
			t <- deparse(attr(z$family,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		if(!is.null(z$linear[[3]])){
			cat("Linear part:\n")
			print(z$linear[[3]])}}}
cat("\n-Log likelihood   ",z$maxlike,"\n")
cat("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 if(z$distribution=="own")cat("Model parameters:\n")
	else cat("Location parameters:\n")
	if(z$distribution=="own"){
		cname <- if(is.character(attr(z$likefn,"model")))
			attr(z$likefn,"model")
		else if(length(grep("linear",attr(z$likefn,"parameters")))>0)
		attr(z$likefn,"parameters")[grep("\\[",attr(z$likefn,"parameters"))]
		else attr(z$likefn,"parameters")}
	else {
		cname <- if(is.character(attr(z$mu,"model")))attr(z$mu,"model")
		else if(length(grep("linear",attr(z$mu,"parameters")))>0)
		attr(z$mu,"parameters")[grep("\\[",attr(z$mu,"parameters"))]
		else attr(z$mu,"parameters")}
	if(!is.null(z$linmodel[[1]]))cname <- c(cname,z$linmodel[[1]])
	coef.table <- cbind(z$coefficients[1:npl],z$se[1:npl])
	if(!z$common){
		dimnames(coef.table) <- list(cname, c("estimate", "se"))
		print.default(coef.table,digits=digits,print.gap=2)
		cname <- coef.table <- NULL}}
if(z$npm>0&&!is.null(z$mix)){
	if(!z$common)cat("\nMixture parameters:\n")
	cname <- c(cname,if(is.character(attr(z$mix,"model")))
		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$linmodel[[2]]))cname <- c(cname,z$linmodel[[2]])
	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=digits,print.gap=2)
	cname <- coef.table <- NULL}
if(z$common||z$nps>0){
	if(!is.null(z$shape))cname <- c(cname,if(mix&&!gnlmix)" "
		else if(is.character(attr(z$shape,"model")))
			attr(z$shape,"model")
		else if(length(grep("linear",attr(z$shape,"parameters")))>0||
		length(grep("mu",attr(z$shape,"parameters")))>0)
		attr(z$shape,"parameters")[grep("\\[",attr(z$shape,"parameters"))]
		else attr(z$shape,"parameters"))
	if(!is.null(z$linmodel[[2]]))cname <- c(cname,z$linmodel[[2]])
	if(!z$common)coef.table <- cbind(z$coefficients[np1a:np2],
		z$se[np1a:np2])
	if(z$common&&is.null(z$family)){
		dimnames(coef.table) <- list(unique(cname),c("estimate","se"))
		print.default(coef.table,digits=digits,print.gap=2)}
	if(is.null(z$shape)&&z$nps==1){
		coef.table <- cbind(z$coefficients[np2],z$se[np2])
		cname <- " "}}
if(gnlmm){
	cat("\nMixing standard deviation:\n")
	coef.table2 <- cbind(z$coefficients[z$npl],z$se[z$npl])
	dimnames(coef.table2) <- list(" ", c("estimate", "se"))
	print.default(coef.table2,digits=digits,print.gap=2)}
if(z$nps>0&&(!z$common||mix)){
	cat("\nShape parameters:\n")
	dimnames(coef.table) <- list(cname,c("estimate","se"))
	print.default(coef.table,digits=digits,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.character(attr(z$family,"model")))
		attr(z$family,"model")
		else if(length(grep("linear",attr(z$family,"parameters")))>0)
		attr(z$family,"parameters")[grep("\\[",attr(z$family,"parameters"))]
		else attr(z$family,"parameters"))
	if(!is.null(z$linmodel[[3]]))cname <- c(cname,z$linmodel[[3]])
	if(z$common){
		dimnames(coef.table) <- list(unique(cname),c("estimate","se"))
		print.default(coef.table,digits=digits,print.gap=2)}
	else {
		coef.table <- cbind(z$coefficients[np3:np],z$se[np3:np])
		dimnames(coef.table) <- list(cname,c("estimate","se"))
		print.default(coef.table,digits=digits,print.gap=2)}}
if(z$npm>0&&is.null(z$mix)){
	cat("\nMixing dispersion parameter:\n")
	coef.table <- cbind(z$coefficients[np],z$se[np])
	dimnames(coef.table) <- list(" ", c("estimate", "se"))
	print.default(coef.table,digits=digits,print.gap=2)}
if(np>1&&correlation){
	cat("\nCorrelations:\n")
	dimnames(z$corr) <- list(seq(1,np),seq(1,np))
	print.default(z$corr,digits=digits)}
invisible(z)}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     read.list(file="", skip=0, nlines=2, order=NULL)
#     read.surv(file="", skip=0, nlines=1, cumulative=T, all=T)
#     read.rep(file, header=TRUE, skip=0, col.names=NULL,
#	response, id=NULL, times=NULL, censor=NULL,
#	totals=NULL, weights=NULL, nest=NULL, delta=NULL,
#	coordinates=NULL, type=NULL, ccov=NULL, tvcov=NULL, na.rm=T)
#
#  DESCRIPTION
#
#    Utility functions for reading repeated measurements data

### read unbalanced repeated measurements from a file into a list
###
read.list <- function(file="", skip=0, nlines=2, order=NULL){
#
# check if order of columns is to be changed
if(!is.null(order)){
	if(length(order)!=nlines)stop("order must have length",nlines,"\n")
	else if(any(range(order)!=c(1,nlines)))
		stop("order must have values in (",c(1,nlines),")\n")}
#
# scan in the data until EOF
#
continue <- TRUE
result <- list()
while(continue){
	x <- scan(file,skip=skip,nlines=nlines,quiet=TRUE)
	skip <- skip+nlines
	if(length(x)==0)continue <- FALSE
	else {
		tmp <- matrix(x,ncol=nlines)
		if(!is.null(order))tmp <- tmp[,order]
		result <- c(result,list(tmp))}}
invisible(result)}

### read unbalanced event history data from a file into a list
###
read.surv <- function(file="", skip=0, nlines=1, cumulative=TRUE, all=TRUE){
#
# scan in the data until EOF
#
continue <- TRUE
result <- list()
censor <- NULL
while(continue){
	x <- scan(file,skip=skip,nlines=nlines,quiet=TRUE)
	skip <- skip+nlines
	if(length(x)==0)continue <- FALSE
	else {
		# find response times (if all==TRUE, times and censor
		# indicator alternate on the line
		if(all)mm <- matrix(x,ncol=2,byrow=TRUE)[,1]
		else mm <- x[1:(length(x)-1)]
		# if cumulative times, find times between events
		if(cumulative)mm <- c(mm[1],diff(mm))
		result <- c(result,list(mm))
		# create vector of censor indicators for last time of
		# each individual only
		censor <- c(censor,x[length(x)])}}
invisible(list(result,censor))}

### read a rectangular data set from a file and create a repeated data object
###
read.rep <- function(file, header=TRUE, skip=0, sep = "",
	na.strings="NA", response, id=NULL, times=NULL, censor=NULL,
	totals=NULL, weights=NULL, nest=NULL, delta=NULL,
	coordinates=NULL, type=NULL, ccov=NULL, tvcov=NULL, na.rm=TRUE){
if(missing(response)||!is.character(response))
	stop("name(s) of response variables must be supplied")
if(missing(file)||!is.character(file))
	stop("a file name must be supplied")
dataframe <- read.table(file,header=header,skip=skip,
	na.strings=na.strings,sep=sep)
#
# find response information and construct object
#
cn <- colnames(dataframe)
nc <- match(response,cn)
if(any(is.na(nc)))stop(paste("response",response[is.na(nc)],"not found"))
if(!is.numeric(z <- as.matrix(dataframe[,nc,drop=FALSE])))
	stop("response must be numeric")
z <- list(response=list(y=z,nobs=NULL,times=NULL,nest=NULL,coordinates=NULL,
	censor=NULL,n=NULL,wt=NULL,delta=NULL,units=NULL,type=NULL),
	ccov=NULL,tvcov=NULL)
class(z) <- "repeated"
class(z$response) <- "response"
tobs <- dim(z$response$y)[1]
nrcol <- dim(z$response$y)[2]
if(is.null(type))z$response$type <- rep("unknown",nrcol)
else if(length(type)!=nrcol)stop("a type must be supplied for each response")
else {
	for(i in 1:length(type))
		z$response$type[i] <- match.arg(type[i],
			c("nominal","ordinal","discrete","duration","continuous","unknown"))
	if(any(is.na(z$response$type)))
		z$response$type[is.na(z$response$type)] <- "unknown"}
rna <- rep(TRUE,tobs)
for(i in 1:nrcol)rna <- rna&!is.na(z$response$y[,i])
if(is.null(id))
	z$response$nobs <- if(is.null(times)) rep(1,tobs) else tobs
else {
	if(!is.character(id)||length(id)>1)
		stop("id must be the name of one variable")
	nc <- match(id,cn)
	if(is.na(nc))stop("id not found")
	id <- as.vector(dataframe[,nc])
	if(is.character(id)||is.factor(id))id <- as.numeric(as.factor(id))
	else if(any(diff(id)!=0&diff(id)!=1,na.rm=TRUE))
		warning("id not consecutively numbered")
	nobs <- table(id)
	z$response$nobs <- as.vector(nobs[match(unique(id),names(nobs))])}
if(any(z$response$nobs!=1)&&length(z$response$nobs)>1)for(i in unique(id)){
	if(any(diff((1:tobs)[id==i])>1,na.rm=TRUE))
		stop(paste("observations for individual",i,"not together in table"))}
if(!is.null(nest)){
	if(all(z$response$nobs==1))
		stop("these are not repeated measurements - nest not valid")
	if(!is.character(nest)||length(nest)>1)
		stop("nest must be the name of one variable")
	nc <- match(nest,cn)
	if(is.na(nc))stop("nest not found")
	z$response$nest <- as.vector(dataframe[,nc])
	if(is.character(z$response$nest))
		z$response$nest <- as.numeric(as.factor(z$response$nest))
	else if(!is.numeric(z$response$nest))stop("nest must be numeric")
	rna <- rna&!is.na(z$response$nest)}
if(!is.null(times)){
	if(!is.character(times)||length(times)>1)
		stop("times must be the name of one variable")
	nc <- match(times,cn)
	if(is.na(nc))stop("times not found")
	z$response$times <- as.vector(dataframe[,nc])
	if(!is.numeric(z$response$times))stop("times must be numeric")
	rna <- rna&!is.na(z$response$times)}
if(!is.null(times)||!is.null(nest))for(i in unique(id)){
	if(!is.null(times)&&any(diff(z$response$times[id==i])<0,na.rm=TRUE))
		stop(paste("negative time step for individual",i))
	if(!is.null(nest)&&any(diff(z$response$nest[id==i])!=0&
		diff(z$response$nest[id==i])!=1,na.rm=TRUE))
		stop(paste("nest for individual",i,"not consecutively numbered"))}
if(!is.null(censor)){
	if(!is.character(censor)||length(censor)!=nrcol)
		stop("censor must have one name per response variable")
	nc <- match(censor,cn)
	if(any(is.na(nc)))stop("censor",censor[is.na(nc)],"not found")
	z$response$censor <- as.matrix(dataframe[,nc,drop=FALSE])
	if(!is.numeric(z$response$censor))stop("censor must be numeric")
	if(any(z$response$censor!=1&z$response$censor!=0&
		z$response$censor!=-1,na.rm=TRUE))
		stop("censor can only have values, -1, 0, 1")
	for(i in 1:nrcol)if(!all(is.na(z$response$censor[,i]))){
		rna <- rna&!is.na(z$response$censor[,i])
		if(z$response$type[i]=="unknown")
			z$response$type[i] <- "duration"}}
if(!is.null(totals)){
	if(!is.character(totals)||length(totals)!=nrcol)
		stop("totals must have one name per response variable")
	nc <- match(totals,cn)
	if(any(is.na(nc)))stop("totals",totals[is.na(nc)],"not found")
	z$response$n <- as.matrix(dataframe[,nc,drop=FALSE])
	if(!is.numeric(z$response$n))stop("totals must be numeric")
	if(any(z$response$y<0|z$response$n<z$response$y,na.rm=TRUE))
		stop("responses must lie between 0 and totals")
	for(i in 1:nrcol)if(!all(is.na(z$response$n[,i]))){
		rna <- rna&!is.na(z$response$n[,i])
		if(z$response$type[i]=="unknown")
			z$response$type[i] <- "nominal"}}
if(!is.null(delta)){
	if(is.numeric(delta)){
		if(length(delta)==1)
			z$response$delta <- matrix(delta,ncol=nrcol,nrow=tobs)
		else if(length(delta)==nrcol)
			z$response$delta <- matrix(rep(delta,tobs),ncol=nrcol,nrow=tobs,byrow=TRUE)
		else stop("delta must contain one value for each response")
		if(any(z$response$type=="unknown"))for(i in 1:nrcol)
			if(z$response$type[i]=="unknown")
				z$response$type[i] <- "continuous"}
	else {
		if(!is.character(delta)||length(delta)!=nrcol)
			stop("delta must have one name per response variable")
		nc <- match(delta,cn)
		if(any(is.na(nc)))stop("delta",delta[is.na(nc)],"not found")
		z$response$delta <- as.matrix(dataframe[,nc,drop=FALSE])
		if(!is.numeric(z$response$delta))stop("delta must be numeric")
		if(any(z$response$y<=0,na.rm=TRUE))
			stop("delta must be strictly positive")
		for(i in 1:nrcol)if(!all(is.na(z$response$delta[,i]))){
			rna <- rna&!is.na(z$response$delta[,i])
			if(z$response$type[i]=="unknown")
				z$response$type[i] <- "continuous"}}}
if(!is.null(weights)){
	if(!is.character(weights)||length(times)>1)
		stop("weights must be the name of one variable")
	nc <- match(weights,cn)
	if(is.na(nc))stop("weights not found")
	z$response$wt <- as.vector(dataframe[,nc])
	if(!is.numeric(z$response$wt))stop("weights must be numeric")
	rna <- rna&!is.na(z$response$wt)}
if(!is.null(coordinates)){
	if(!is.character(coordinates)||(length(coordinates)!=2&&
		length(coordinates)!=3))
		stop("coordinates must be the name of 2 or 3 variables")
	nc <- match(coordinates,cn)
	if(any(is.na(nc)))
		stop("coordinates",coordinates[is.na(nc)],"not found")
	z$response$coordinates <- as.matrix(dataframe[,nc,drop=FALSE])
	if(!is.numeric(z$response$coordinates))
		stop("coordinates must be numeric")
	for(i in 1:length(coordinates))
		rna <- rna&!is.na(z$response$coordinates[,i])}
#
# find time-varying covariates
#
if(!is.null(tvcov)){
	if(all(z$response$nobs==1))
		stop("these are not repeated measurements - tvcov not valid")
	z$tvcov <- list(tvcov=NULL,nobs=z$response$nobs)
	class(z$tvcov) <- "tvcov"
	nc <- match(tvcov,cn)
	if(any(is.na(nc)))stop("tvcov",tvcov[is.na(nc)],"not found")
	z$tvcov$tvcov <- dataframe[,nc,drop=FALSE]
	for(i in 1:length(tvcov))rna <- rna&!is.na(z$tvcov$tvcov[,i])
	# if no factor variables present, return a matrix anyway
	fac <- FALSE
	for(i in 1:dim(z$tvcov$tvcov)[2])
		if(!is.vector(z$tvcov$tvcov[,i],mode="numeric")){
		fac <- TRUE
		break}
	if(!fac)z$tvcov$tvcov <- as.matrix(z$tvcov$tvcov)}
#
# find time-constant covariates
#
if(!is.null(ccov)){
	z$ccov <- list(ccov=NULL)
	class(z$ccov) <- "tccov"
	nc <- match(ccov,cn)
	if(any(is.na(nc)))stop("ccov",ccov[is.na(nc)],"not found")
	z$ccov$ccov <- dataframe[,nc,drop=FALSE]
	for(i in unique(id))for(j in 1:length(ccov))
		if(sum(!is.na(unique(z$ccov$ccov[id==i,j])))>1)
		stop(paste("ccov",ccov[j],"for individual",i,"not constant"))
	for(i in 1:length(ccov))rna <- rna&!is.na(z$ccov$ccov[,i])
	j <- c(0,cumsum(z$response$nobs)[-length(z$response$nobs)])+1
	z$ccov$ccov <- z$ccov$ccov[j,,drop=FALSE]
	# if no factor variables present, return a matrix anyway
	fac <- FALSE
	for(i in 1:dim(z$ccov$ccov)[2])
		if(!is.vector(z$ccov$ccov[,i],mode="numeric")){
		fac <- TRUE
		break}
	if(!fac)z$ccov$ccov <- as.matrix(z$ccov$ccov)}
#
# remove NAs
#
if(na.rm&&any(!rna)){
	# remove NAs from variables associated with response
	z$response$y <- z$response$y[rna,,drop=FALSE]
	if(!is.null(z$response$times))z$response$times <- z$response$times[rna]
	if(!is.null(z$response$nest))z$response$nest <- z$response$nest[rna]
	if(!is.null(z$response$coordinates))
		z$response$coordinates <- z$response$coordinates[rna,]
	if(!is.null(z$response$n))z$response$n <- z$response$n[rna,,drop=FALSE]
	if(!is.null(z$response$censor)){
		z$response$censor <- z$response$censor[rna,,drop=FALSE]
		if(all(z$response$censor==1))z$response$censor <- NULL}
	if(!is.null(z$response$delta)&&length(z$response$delta)>1)
		z$response$delta <- z$response$delta[rna,,drop=FALSE]
	if(!is.null(z$tvcov))z$tvcov$tvcov <- z$tvcov$tvcov[rna,,drop=FALSE]
	# correct nobs
	tmp <- NULL
	j <- c(0,cumsum(z$response$nobs))
	for(i in 1:length(z$response$nobs)){
		tmp <- c(tmp,sum(rna[(j[i]+1):j[i+1]]))
		if(tmp[i]==0)
			warning(paste("Individual",i,"has no observations"))}
	z$response$nobs <- tmp[tmp>0]
	# remove NAs from ccov
	if(!is.null(z$ccov)){
		z$ccov$ccov <- z$ccov$ccov[tmp>0,,drop=FALSE]
		for(i in 1: dim(z$ccov$ccov)[2])
			if(length(unique(z$ccov$ccov[,i]))==1)
			warning(paste("covariate",colnames(z$ccov$ccov)[i],"has only one value\n"))}
	# remove NAs from tvcov
	if(!is.null(z$tvcov)){
		z$tvcov$nobs <- z$response$nobs
		for(i in 1: dim(z$tvcov$tvcov)[2])
			if(length(unique(z$tvcov$tvcov[,i]))==1)
			warning(paste("covariate",colnames(z$tvcov$tvcov)[i],"has only one value\n"))}}
if(!na.rm&&any(!rna))z$NAs <- !rna
#
# if independent observations, reset nobs
#
if(all(z$response$nobs==1))z$response$nobs <- 1
z}
#
#  rmutil : A Library of Special Functions for Repeated Measurements
#  Copyright (C) 1998, 1999, 2000, 2001 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public Licence as published by
#  the Free Software Foundation; either version 2 of the Licence, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public Licence for more details.
#
#  You should have received a copy of the GNU General Public Licence
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     wr(formula, data=NULL, expand=T))
#     det(x)
#     capply(x, index, fcn=sum)
#     mexp(x, t=1, n=20, k=3)
#     contr.mean(n, contrasts=TRUE)
#
#  DESCRIPTION
#
#    Utility functions for repeated measurements

### function to find the response vector and design matrix from a W&R formula
###
wr <- function(formula, data=NULL, expand=TRUE){
if(is.null(data))data <- parent.frame()
else if(!is.data.frame(data)&&!is.environment(data))
	data <- if(expand||inherits(data,"tccov"))as.data.frame(data)
		else as.data.frame(data$ccov)
mt <- terms(formula)
mf <- model.frame(mt,data=data,na.action=na.fail)
list(response=model.response(mf,"numeric"), design=model.matrix(mt,mf))}

### a fast simplified version of tapply
###
capply <- function(x, index, fcn=sum){
ans <- NULL
for(i in split(x,index))ans <- c(ans,fcn(i))
ans}

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

### matrix power
###
"%^%" <- function(x, p){
if(!is.matrix(x))stop("x must be a matrix")
if(dim(x)[1]!=dim(x)[2])stop("x must be a square matrix")
z <- eigen(x,sym=FALSE)
z$vectors%*%diag(z$values^p)%*%solve(z$vectors)}

#    A function to provide correct constraints about the mean
#  (correcting contr.sum)

contr.mean <- function(n, contrasts=TRUE){
if(length(n) <= 1){
	if(is.numeric(n)&&length(n)==1&&n>1)levels <- 1:n
	else stop("Not enough degrees of freedom to define contrasts")}
else levels <- n
lenglev <- length(levels)
if(contrasts){
	cont <- array(0,c(lenglev,lenglev-1),
		list(levels,levels[1:(lenglev-1)]))
	cont[col(cont)==row(cont)] <- 1
	cont[lenglev,] <- -1}
else {
	cont <- array(0,c(lenglev,lenglev),list(levels,levels))
	cont[col(cont) == row(cont)] <- 1}
cont}
