#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     fit.dist(y, ni, dist="normal", breaks=F, delta=1, censor=F,
#	exact=T, plot=F, add=F, main, xlab, ...)
#
#  DESCRIPTION
#
#    A function to fit common distributions to frequency data and to
# plot the resulting curve along with the histogram

fit.dist <- function(y, ni, dist="normal", breaks=F, delta=1, censor=F,
	exact=T, plot=F, add=F, main, xlab, ...)
{
	if(!missing(dist))dist <- match.arg(dist,c("binomial","Poisson",
		"negative binomial","geometric","zeta","normal","log normal",
		"inverse Gauss","logistic","exponential","Pareto","gamma",
		"Weibull"))
	if(missing(main))main <- paste("Histogram of", deparse(substitute(y)))
	if(missing(xlab))xlab <- paste(deparse(substitute(y)))
	n <- length(ni)
	if (length(delta)==1) delta <- rep(delta,n)
	if (breaks){
		if(length(y)!=n+1)
			stop("Breaks vector must be one longer than frequency vector")
		yi <- (y[1:n]+y[2:(n+1)])/2
		delta <- diff(y)}
	else yi <- y
	pi.hat <- ni/sum(ni)
        ybar <- weighted.mean(yi,ni)
	s2 <- weighted.mean((yi-ybar)^2,ni)
	if (dist=="binomial"){
		m <- length(yi)-1
		nu <- ybar/m
		pi.tilde <- gamma(m+1)/gamma(yi+1)/gamma(m-yi+1)*
			nu^yi*(1-nu)^(m-yi)
		param <- nu
		names(param) <- "nu.hat"
		p <- 1}
	else if (dist=="Poisson"){
		pi.tilde <- exp(-ybar)*ybar^yi/gamma(yi+1)
		param <- ybar
		names(param) <- "mu.hat"
		p <- 1}
	else if (dist=="geometric"){
		nu <- 1/(1+ybar)
		pi.tilde <- nu*(1-nu)^yi
		param <- nu
		names(param) <- "nu.hat"
		p <- 1}
	else if (dist=="negative binomial"){
		nu <- ybar/s2
		gam <- ybar^2/(s2-ybar)
		if(exact){
			nu <- log(nu/(1-nu))
			fcn <- function(p)
				-sum(ni*(lgamma(yi+p[2])-lgamma(p[2])+
				p[2]*p[1]-(yi+p[2])*log(1+exp(p[1]))))
#				p[2]*log(p[1])+yi*log(1-p[1])))
			z <- nlm(fcn, p=c(nu, gam), stepmax=sqrt(nu^2+gam^2)/2)
			nu <- exp(z$estimate[1])
			nu <- nu/(1+nu)
			gam <- z$estimate[2]}
		pi.tilde <- gamma(yi+gam)/gamma(yi+1)/gamma(gam)*
			nu^gam*(1-nu)^yi
		param <- c(nu, gam)
		names(param) <- c("nu.hat","gamma.hat")
		p <- 2}
	else if (dist=="zeta"){
		pi.tilde <- 1/yi
		nu <- sum(pi.tilde)
		pi.tilde <- pi.tilde/nu
		rho <- round(pi.hat[1]/pi.tilde[1]+0.1)
		if(exact){
			fcn <- function(p) {
				if(censor) const <- sum(yi^(-p[1]))
				else const <- sum(seq(1,30)^(-p[1]))
				sum(ni*(p[1]*log(yi)+log(const)))}
			z <- nlm(fcn, p=rho, stepmax=1)
			rho <- z$estimate[1]}
		pi.tilde <- yi^(-rho)
		nu <- sum(pi.tilde)
		pi.tilde <- pi.tilde/nu
		param <- rho
		names(param) <- "rho.hat"
		p <- 1}
        else if (dist=="normal"){
		mu.hat <- ybar
		sigma2.hat <- s2
		pi.tilde <- exp(-(yi-mu.hat)^2/(2*sigma2.hat))/
			sqrt(2*pi*sigma2.hat)
		param <- c(mu.hat,sigma2.hat)
		names(param) <- c("mu.hat","sigma2.hat")
		p <- 2}
        else if (dist=="log normal"){
		mu.hat <- weighted.mean(log(yi),ni)
		sigma2.hat <- weighted.mean((log(yi)-mu.hat)^2,ni)
		pi.tilde <- exp(-(log(yi)-mu.hat)^2/(2*sigma2.hat))/
			(yi*sqrt(2*pi*sigma2.hat))
		param <- c(mu.hat,sigma2.hat)
		names(param) <- c("mu.hat","sigma2.hat")
		p <- 2}
        else if (dist=="inverse Gauss"){
		mu.hat <- ybar
		sigma2.hat <- weighted.mean(1/yi,ni)-(1/ybar)
		pi.tilde <- exp(-(yi-mu.hat)^2/(2*yi*sigma2.hat*mu.hat^2))/
			sqrt(2*pi*yi^3*sigma2.hat)
		param <- c(mu.hat,sigma2.hat)
		names(param) <- c("mu.hat","sigma2.hat")
		p <- 2}
	else if (dist=="logistic"){
		mu.hat <- ybar
		sigma <- sqrt(s2)
		if(exact){
			fcn <- function(p)
				sum(ni*(pi*(yi-p[1])/p[2]/sqrt(3)+log(p[2])
				+2*log(1+exp(-pi*(yi-p[1])/p[2]/sqrt(3)))))
			z <- nlm(fcn, p=c(mu.hat,sigma), stepmax=10)
			mu.hat <- z$estimate[1]
			sigma <- z$estimate[2]}
		pi.tilde <- exp(-pi*(yi-mu.hat)/(sigma*sqrt(3)))
		pi.tilde <- pi*pi.tilde/(sigma*sqrt(3)*(1+pi.tilde)^2)
		param <- c(mu.hat,sigma)
		names(param) <- c("mu.hat","sigma.hat")
		p <- 2}
        else if (dist=="exponential"){
		pi.tilde <- (1/ybar)*exp(-yi/ybar)
		param <- ybar
		names(param) <- "mu.hat"
		p <- 1}
        else if (dist=="Pareto"){
		delta.hat <- yi[1]-delta[1]/2
		alpha.hat <- sum(ni)/sum(ni*log(yi/delta.hat))
		pi.tilde <- alpha.hat*delta.hat^alpha.hat/(yi^(alpha.hat+1))
		param <- c(alpha.hat,delta.hat)
		names(param) <- c("alpha.hat","delta.hat")
		p <- 2}
        else if (dist=="gamma"){
		alpha.hat <- ybar^2/s2
		mu.hat <- ybar
		if(exact){
			fcn <- function(p)
				-sum(ni*(p[2]*log(p[2])
				+(p[2]-1)*log(yi)-p[2]*log(p[1])
				-p[2]*yi/p[1]-lgamma(p[2])))
			z <- nlm(fcn, p=c(mu.hat,alpha.hat), stepmax=10)
			mu.hat <- z$estimate[1]
			alpha.hat <- z$estimate[2]}
		pi.tilde <- (alpha.hat^alpha.hat)*(yi^(alpha.hat-1))/
			(mu.hat^alpha.hat)*exp(-alpha.hat*yi/mu.hat)/
			gamma(alpha.hat)
		param <- c(alpha.hat,mu.hat)
		names(param) <- c("alpha.hat","mu.hat")
		p <- 2}
        else if (dist=="Weibull"){
		tamp <- ybar^2/(s2+ybar^2)
		Alpha.Weibull.fn <- function(y){
			alpha.trans.fn <- function(al)
				gamma(1+1/al)*gamma(1+1/al)/gamma(1+2/al)
			tol <- 0.001
			al.start <- 0.0001
			al.end <- 50
			al.mid <- 0.5*(al.start+al.end)
			y.tamp <- alpha.trans.fn(al.mid)
			while (abs(y.tamp-y)>tol){
				if ((y.tamp-y)>0) al.end <- al.mid
				else al.start <- al.mid
				al.mid <- 0.5*(al.start+al.end)
				y.tamp <- alpha.trans.fn(al.mid)}
			al.mid}
		alpha.hat <- Alpha.Weibull.fn(tamp)
		mu.hat <- weighted.mean(yi^alpha.hat,ni)
		if(exact){
			fcn <- function(p)
				-sum(ni*(log(p[2])+(p[2]-1)*log(yi)
				-log(p[1])-yi^p[2]/p[1]))
			z <- nlm(fcn, p=c(mu.hat,alpha.hat), stepmax=10)
			mu.hat <- z$estimate[1]
			alpha.hat <- z$estimate[2]}
		pi.tilde <- alpha.hat*yi^(alpha.hat-1)/mu.hat*
			exp(-yi^alpha.hat/mu.hat)
		param <- c(alpha.hat,mu.hat)
		names(param) <- c("alpha.hat","mu.hat")
		p <- 2}
	pi.tilde <- pi.tilde*delta
        if (censor)
		pi.tilde[length(pi.tilde)] <- 1-sum(pi.tilde[1:(length(pi.tilde)-1)])
	dev.comp <- rep(0,length(pi.tilde))
	dev.comp[ni>0] <- -2*ni[ni>0]*log(pi.tilde[ni>0]/pi.hat[ni>0])
	deviance <- sum(dev.comp)
	AIC <- deviance+2*p
	resid <- (ni-sum(ni)*pi.tilde)/sqrt(sum(ni)*pi.tilde)
	result.output <- c(ybar,s2,param,deviance,AIC)
	names(result.output) <- c("mean","variance",names(param),"deviance","AIC")
	cat(dist," distribution,","  n = ",sum(ni),"\n",sep="")
	print(result.output)
        cat("\n")
	if(censor)nn <- n-1
	else nn <- n
	if (plot){
		if (!add){
			cum.histo (c(yi-delta/2, yi[n]+delta[n]/2), ni, prob=T,
				ylab="Probability", main, xlab, ...)
			lines(yi[1:nn], pi.tilde[1:nn]/delta[1:nn])}
		else lines(yi[1:nn], pi.tilde[1:nn]/delta[1:nn], add=T, ...)}
	if(length(unique(delta))==1)
		df <- data.frame(yi,ni,pi.hat,pi.tilde,dev.comp,resid)
	else
		df <- data.frame(yi,ni,delta,pi.hat,pi.tilde,dev.comp,resid)
#	list(parameters=result.output,df=df)
	df}

cum.histo <- function (breaks, freq, prob = F,
	main = paste("Histogram of", deparse(substitute(breaks))),
	xlab = deparse(substitute(breaks)), ylab,
        xlim = range(breaks), ...)
{
	if (prob) {
                freq <- freq/(sum(freq) * diff(breaks))
                if (missing(ylab)) 
                        ylab <- "Relative Frequency"
        }
        else if (missing(ylab)) 
                ylab <- "Frequency"
	plot(breaks, c(freq, 0), type = "n", main = main,
		xlab = xlab, ylab = ylab, ...)
	rect(breaks[-length(breaks)], 0, breaks[-1], freq, border = par("fg"))}
#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     fmr(y, distribution="normal", mu=NULL, mix=NULL, linear=NULL,
#	pmu=NULL, pmix=NULL, pshape=NULL, censor="right", exact=F,
#	wt=1, delta=1, common=F, envir=sys.frame(sys.parent()),
#	print.level=0, typsiz=abs(p), ndigit=10, gradtol=0.00001,
#	stepmax=10*sqrt(p%*%p), steptol=0.00001, iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models with a variety of
# distributions and a mixture in the tail(s).

fmr <- function(y, distribution="normal", mu=NULL, mix=NULL, linear=NULL,
	pmu=NULL, pmix=NULL, pshape=NULL, censor="right", exact=F,
	wt=1, delta=1, common=F, envir=sys.frame(sys.parent()), print.level=0,
	typsiz=abs(p), ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p),
	steptol=0.00001, iterlim=100, fscale=1){

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

call <- sys.call()
if(!missing(distribution)&&!is.function(distribution)){
	distribution <- match.arg(distribution,c("binomial","beta binomial",
	"double binomial","mult binomial","Poisson","negative binomial",
	"double Poisson","mult Poisson","gamma count","Consul","geometric",
	"normal","inverse Gauss","logistic","exponential","gamma","Weibull",
	"extreme value","Pareto","Cauchy","Student t","Laplace","Levy"))}
if(common){
	if(!is.function(mu))stop("with common parameters, mu must be a function")
	if(!is.function(mix))stop("with common parameters, mix must be a function")
	if(!is.null(linear))stop("linear cannot be used with common parameters")}
if(!missing(pmu))npl <- length(pmu)
else npl <- 0
if(!missing(pmix))npm <- length(pmix)
else npm <- 0
sht <- distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"
if(sht&&missing(pshape))
	stop("An estimate of the shape parameter must be given")
np <- npl+npm+sht
if(is.function(distribution)){
	fcn <- distribution
	distribution <- "own"}
respenv <- inherits(y,"repeated")
envname <- if(respenv)paste(deparse(substitute(y)))
	else NULL
lin1 <- lin2 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]}
else lin1 <- linear
if(inherits(mu,"formula"))lin1 <- mu
if(inherits(mix,"formula"))lin2 <- mix
lin1a <- lin2a <- mu2 <- mixt2 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else "tccov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(lin1,"formula")){
		if(is.function(mu)){
			lin1a <- if(respenv)finterp(lin1,envir=y,name=envname)
			else finterp(lin1,envir=envir,name=envname)}
		class(lin1) <- c(class(lin1),type)}
	if(inherits(lin2,"formula")){
		if(is.function(mix)){
			lin2a <- if(respenv)finterp(lin2,envir=y,name=envname)
			else finterp(lin2,envir=envir,name=envname)}
		class(lin2) <- c(class(lin2),type)}
	if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=y,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu2 <- mu
		if(respenv)attr(mu2,"model") <- tmp}
	if(is.function(mix)){
		tmp <- parse(text=paste(deparse(mix))[-1])
		class(mix) <- type
		mix <- if(respenv)fnenvir(mix,envir=y,name=envname)
			else fnenvir(mix,envir=envir,name=envname)
		mixt2 <- mix
		if(respenv)attr(mixt2,"model") <- tmp}}
if(inherits(lin1,"formula")){
	mu1 <- if(respenv)finterp(lin1,envir=y,name=envname)
		else finterp(lin1,envir=envir,name=envname)
	npt1 <- length(attr(mu1,"parameters"))
	if(is.matrix(attr(mu1,"model"))){
		if(all(dim(attr(mu1,"model"))==1)){
			if(is.function(mu)){
				lin1 <- mu1
				mu1 <- function(p) mu(p,p[npl]*rep(1,n))}
			else {
				tmp <- attributes(mu1)
				mu1 <- function(p) p[1]*rep(1,n)
				attributes(mu1) <- tmp}}
		else {
			if(is.function(mu)){
				lf <- if(inherits(mu,"formulafn"))length(attr(mu,"parameters"))
					else length(if(respenv)attr(fnenvir(mu,envir=y),"parameters")
						else attr(fnenvir(mu,envir=envir),"parameters"))
				dm1 <- attr(mu1,"model")
				lin1 <- mu1
				mu1 <- function(p) mu(p,dm1%*%p[lf:(lf+npt1-1)])}}}
	else {
		if(is.function(mu)){
			warning("ignoring mu function\n")
			mu <- mu2 <- NULL}
		if(npl!=npt1){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu1,"parameters"),names(pmu))
				pmu <- unlist(pmu)[o]
				if(sum(!is.na(o))!=length(pmu))stop("invalid estimates for mu - probably wrong names")}
			else pmu <- unlist(pmu)}}
	if(npl<npt1)stop("Not enough initial estimates for mu")}
else if(!is.function(mu)){
	mu1 <- function(p) p[1]*rep(1,n)
	npt1 <- 1}
else {
	mu1 <- mu
	if(length(mu1(pmu))==1)mu1 <- function(p) mu(p)*rep(1,n)}
if(is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=y))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=y))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu)){
		if(is.null(lin1))length(attr(mu1,"parameters"))
		else length(attr(mu1,"parameters"))-1+npt1}
       else npt1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl1 <- if(common) 1 else npl+1
if(inherits(lin2,"formula")){
	mixt1 <- if(respenv)finterp(lin2,envir=y,start=npl1,name=envname)
		else finterp(lin2,envir=envir,start=npl1,name=envname)
	npt2 <- length(attr(mixt1,"parameters"))
	if(is.matrix(attr(mixt1,"model"))){
		if(all(dim(attr(mixt1,"model"))==1)){
			if(is.function(mix)){
				lin2 <- mixt1
				mixt <- function(p) {
					mf <- mix(p[npl1:np],p[np]*rep(1,n))
					exp(mf)/(1+exp(mf))}}
			else {
				mixt <- function(p) {
					mf <- p[npl1]*rep(1,n)
					exp(mf)/(1+exp(mf))}
				mixt2 <- fnenvir(function(p) {
					mf <- p[1]*rep(1,n)
					exp(mf)/(1+exp(mf))})
				attributes(mixt) <- attributes(mixt1)}
			rm(mixt1)}
		else {
			dm2 <- attr(mixt1,"model")
			if(is.function(mix))mixt <- function(p) {
				lfm <- if(inherits(mix,"formulafn"))length(attr(mix,"parameters"))
					else length(if(respenv)attr(fnenvir(mix,envir=y),"parameters")
						else attr(fnenvir(mix,envir=envir),"parameters"))
				lin2 <- mixt1
				mf <- mix(p[npl1:np],dm2%*%p[(npl+lfm):np])
				exp(mf)/(1+exp(mf))}
			else {
				mixt <- function(p) {
					mf <- dm2%*%p[npl1:(npl1+npt2-1)]
					exp(mf)/(1+exp(mf))}
				attributes(mixt) <- attributes(mixt1)}}}
	else {
		if(is.function(mix)){
			warning("ignoring mix function\n")
			mix <- mixt2 <- NULL}
		if(npm!=npt2){
			cat("\nParameters are ")
			cat(attr(mixt1,"parameters"),"\n")
			stop(paste("pmix should have",npt2,"estimates"))}
		mixt <- function(p) {
			mf <- mixt1(p)
			exp(mf)/(1+exp(mf))}
		attributes(mixt) <- attributes(mixt1)
		if(is.list(pmix)){
			if(!is.null(names(pmix))){
				o <- match(attr(mixt,"parameters"),names(pmix))
				pmix <- unlist(pmix)[o]
				if(sum(!is.na(o))!=length(pmix))stop("invalid estimates for mix - probably wrong names")}
			else pmix <- unlist(pmix)}}}
else if(!is.function(mix)){
	mixt <- function(p) exp(p[npl1])/(1+exp(p[npl1]))*rep(1,n)
	mixt2 <- fnenvir(function(p) exp(p[1])/(1+exp(p[1]))*rep(1,n))
	npt2 <- 1}
else mixt <- function(p) {
	mf <- mix(p[npl1:np])
	exp(mf)/(1+exp(mf))}
if(is.null(attributes(mixt))){
	attributes(mixt) <- if(is.function(mix)){
		if(!inherits(mix,"formulafn")){
			if(respenv)attributes(fnenvir(mix,envir=y))
			else attributes(fnenvir(mix,envir=envir))}
		else attributes(mix)}
		else {
			if(respenv)attributes(fnenvir(mixt,envir=y))
			else attributes(fnenvir(mixt,envir=envir))}}
nlp <- if(is.function(mix)){
		if(is.null(lin2))length(attr(mixt,"parameters"))
		else length(attr(mixt,"parameters"))-1+npt2}
       else npt2
if(!common&&nlp!=npm)stop(paste("pshape should have",nlp,"initial estimates"))
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(mixt,"parameters"))))-shfn
	if(nlp!=npl)stop(paste("with a common parameter model, pmu should contain",nlp,"estimates"))}
p <- c(pmu,pmix,pshape)
if(respenv){
	if(inherits(envir,"repeated")&&(length(y$response$nobs)!=length(envir$response$nobs)||any(y$response$nobs!=envir$response$nobs)))stop("y and envir objects are incompatible")
	if(!is.null(y$response$wt)&&!is.na(y$response$wt))wt <- y$response$wt
	if(!is.null(y$response$delta))delta <- y$response$delta
	y <- response(y)}
else if(inherits(y,"response")){
	if(!is.null(y$wt)&&!is.na(y$wt))wt <- y$wt
	if(!is.null(y$delta))delta <- y$delta
	y <- response(y)}
if(any(is.na(y)))stop("NAs in y - use rmna")
if(distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="double Poisson"||distribution=="mult Poisson"||
	distribution=="gamma count"||distribution=="Consul"){
	if(!is.vector(y,mode="numeric"))stop("y must be a vector")
	n <- length(y)
	censor <- NULL
	cens <- ifelse(y==0,1,0)}
else {
	if(length(dim(y))!=2||ncol(y)!=2)
		stop(paste("Two column matrix required for response:",
		if(distribution=="binomial"||distribution=="beta binomial"||
			distribution=="double binomial"||
			distribution=="mult binomial")"successes and failures"
		else "times and censor indicator"))
	else {
		n <- nrow(y)
		if(distribution=="binomial"||distribution=="beta binomial"||
			distribution=="double binomial"||
			distribution=="mult binomial"){
			if(missing(censor))
				stop("Censoring must be left, right, or both")
			if(censor!="left"&&censor!="right"&&censor!="both")
				stop("Censoring must be left, right, or both")
			lcens <- ifelse((censor=="left"|censor=="both")&
				y[,1]==0,1,0)
			rcens <-ifelse((censor=="right"|censor=="both")&
				y[,2]==0,1,0)
			if(censor=="both"){
				lcens <- lcens/2
				rcens <- rcens/2}
			n <- nrow(y)
			nn <- y[,1]+y[,2]}
		else {
			if(any(delta<=0&y[,2]==1))
				stop("All deltas for uncensored data must be positive")
			else {
				delta <- ifelse(delta<=0,0.000001,delta)
				delta <- ifelse(y[,1]-delta/2<=0,delta-0.00001
				,delta)}
			y[,2] <- as.integer(y[,2])
			if(any(y[,2]!=-1&y[,2]!=0&y[,2]!=1))
				stop("Censor indicator must be -1, 0, or 1")
			if(censor!="left"&&censor!="right")
				stop("Censoring must be left or right")
			if(censor=="left"&!any(y[,2]==-1))
				stop("No left censored observations")
			if(censor=="right"&!any(y[,2]==0))
				stop("No right censored observations")
			cens <- as.integer(y[,2]==1)
			b <- as.integer((censor=="right"&y[,2]==0)|
				(censor=="left"&y[,2]==-1))
			r <- as.integer(censor=="left"&y[,2]==0)
			l <- as.integer(censor=="right"&y[,2]==-1)
			lc <- ifelse(censor=="left",1,0)
			rc <- ifelse(censor=="right",-1,1)}}
	if(distribution=="double Poisson"||distribution=="mult Poisson")
				my <- min(3*max(y),100)}
if((distribution!="normal"&&distribution!="logistic"&&distribution!="Cauchy"&&
	distribution!="Laplace"&&distribution!="Student t"&&
	distribution!="Poisson"&&distribution!="negative binomial"&&
	distribution!="Consul"&&distribution!="double Poisson"&&
	distribution!="mult Poisson"&&distribution!="gamma count"&&
	distribution!="binomial"&& distribution!="beta binomial"&&
	distribution!="double binomial"&&distribution!="mult binomial")&&
	(any(y[,1]<=0)))stop("All response values must be > 0")
else if((distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="gamma count"||distribution=="double Poisson"||
	distribution=="mult Poisson"||distribution=="Consul"||
	distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial")
	&&(any(y<0)))stop("All response values must be >= 0")
if(min(wt)<0)stop("All weights must be non-negative")
if(length(wt)==1)wt <- rep(wt,n)
if(length(delta)==1)delta <- rep(delta,n)
if(any(is.na(mu1(pmu))))stop("The location model returns NAs: probably invalid initial values")
if(distribution=="Levy"&&any(y[,1]<=mu1(p)))
	stop("location parameter must be strictly less than corresponding observation")
if(sht&&any(is.na((mixt(p)))))stop("The mix function returns NAs: probably invalid initial values")
ret <- switch(distribution,
	binomial={
		fcn <- function(p) {
			m <- mu1(p)
			s <- mixt(p)
			-wt*log((1-s)*(lcens+rcens)+s*m^y[,1]*(1-m)^y[,2])}
		const <- -wt*(lchoose(nn,y[,1]))},
	"beta binomial"={
		fcn <- function(p) {
			m <- mu1(p)
			s <- mixt(p)
			v <- exp(p[np])
			t <- v*m
			u <- v*(1-m)
			-wt*log((1-s)*(lcens+rcens)+s*beta(y[,1]+t,y[,2]+u)/
				beta(t,u))}
		const <- -wt*(lchoose(nn,y[,1]))},
	"double binomial"={
		fcn <- function(p) {
			-wt*log((1-s)*(lcens+rcens)+s*exp(.C("ddb",
				as.integer(y[,1]),as.integer(nn),
				as.double(mu1(p)),as.double(exp(p[np])),
				as.integer(n),as.double(wt),
				res=double(n),DUP=F)$res))}
		const <- 0},
	"mult binomial"={
		fcn <- function(p) {
			-wt*log((1-s)*(lcens+rcens)+s*exp(.C("dmb",
				as.integer(y[,1]),as.integer(nn),
				as.double(mu1(p)),as.double(exp(p[np])),
				as.integer(n),as.double(wt),
				res=double(n),DUP=F)$res))}
		const <- 0},
	Poisson={
		fcn <- function(p) {
			m <- mu1(p)
			s <- mixt(p)
			-wt*log((1-s)*cens+s*exp(-m)*m^y)}
		const <- wt*lgamma(y+1)},
	"negative binomial"={
		fcn <- function(p) {
			m <- mu1(p)
			s <- mixt(p)
			t <- exp(p[np])
			-wt*log((1-s)*cens+s*gamma(y+t)/gamma(t)
				*t^t*m^y/(t+m)^(y+t))}
		const <- wt*lgamma(y+1)},
	"double Poisson"={
		fcn <- function(p) {
			-wt*log((1-s)*cens+s*exp(.C("ddp",as.integer(y),
				as.integer(my),as.double(mu1(p)),
				as.double(exp(p[np])),as.integer(length(y)),
				as.double(wt),res=double(length(y)),DUP=F)$res))}
		const <- 0},
	"mult Poisson"={
		fcn <- function(p) {
			-wt*log((1-s)*cens+s*exp(.C("dmp",as.integer(y),
				as.integer(my),as.double(mu1(p)),
				as.double(exp(p[np])),as.integer(length(y)),
				as.double(wt),res=double(length(y)),DUP=F)$res))}
		const <- 0},
	"gamma count"={
		fcn <- function(p) {
			m <- mu1(p)
			s <- mixt(p)
			t <- exp(p[np])
			-wt*log((1-s)*cens+s*ifelse(y==0,1-pgamma(m*t,
				(y+1)*t,1),pgamma(m*t,y*t+(y==0),1)-
				pgamma(m*t,(y+1)*t,1)))}
		const <- 0},
	Consul={
		fcn <- function(p) {
			m <- mu1(p)
			s <- mixt(p)
			u <- exp(p[np])
			-wt*log((1-s)*cens+s*m*exp(-(m+y*(u-1))/u-y*p[np])*
				(m+y*(u-1))^(y-1))}
		const <- wt*lgamma(y+1)},
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np]/2)
				pn <- pnorm(y[,1],m,t)
				-wt*log(s*cens*(pnorm(y[,1]+delta/2,m,t)-
					pnorm(y[,1]-delta/2,m,t))
					+(1-cens)*((1+s*(rc*pn-lc))*b
					+s*(r+pn*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				pn <- pnorm(y[,1],m,exp(p[np]/2))
				-wt*log(s*cens*exp((-(p[np]+(y[,1]-m)^2
					*exp(-p[np]))/2))+(1-cens)*
					((1+s*(rc*pn-lc))*b+s*(r+pn*(l-r))))}
			const <- wt*cens*(log(2*pi)/2-log(delta))}},
        "inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pit <- pinvgauss(y[,1],m,t)
				-wt*log(s*cens*(pinvgauss(y[,1]+delta/2,m,t)-
					pinvgauss(y[,1]-delta/2,m,t))
					+(1-cens)*((1+s*(rc*pit-lc))*b
					+s*(r+pit*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pit <- pinvgauss(y[,1],m,t)
				-wt*log(s*cens*exp(-(p[np]+(y[,1]-m)^2/
					(y[,1]*t*m^2))/2)
					+(1-cens)*((1+s*(rc*pit-lc))*b
					+s*(r+pit*(l-r))))}
			const <- wt*cens*(log(2*pi*y[,1]^3)/2-log(delta))}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])*sqrt(3)/pi
				pl <- plogis(y[,1],m,t)
				-wt*log(s*cens*(plogis(y[,1]+delta/2,m,t)-
					plogis(y[,1]-delta/2,m,t))
					+(1-cens)*((1+s*(rc*pl-lc))*b
					+s*(r+pl*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])*sqrt(3)/pi
				y1 <- (y[,1]-m)/t
				pl <- plogis(y[,1],m,t)
				-wt*log(s*cens*exp(-y1-log(t)
					-2*log(1+exp(-y1)))
					+(1-cens)*((1+s*(rc*pl-lc))*b
					+s*(r+pl*(l-r))))}
			const <- -wt*cens*log(delta)}},
        "Student t"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				ps <- pt(y[,1]-m,t)
				-wt*log(s*cens*(pt(y[,1]+delta/2-m,t)-
					pt(y[,1]-delta/2-m,t))
					+(1-cens)*((1+s*(rc*ps-lc))*b
					+s*(r+ps*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				ps <- pt(y[,1]-m,t)
				-wt*log(s*cens*gamma((t+1)/2)/gamma(t/2)*
					exp(-p[np]/2-((t+1)/2)*
					log(1+(y[,1]-m)^2/t))
					+(1-cens)*((1+s*(rc*ps-lc))*b
					+s*(r+ps*(l-r))))}
			const <- wt*cens*(log(pi)/2-log(delta))}},
	Cauchy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np]/2)
				pc <- pcauchy(y[,1],m,t)
				-wt*log(s*cens*(pcauchy(y[,1]+delta/2,m,t)-
					pcauchy(y[,1]-delta/2,m,t))
					+(1-cens)*((1+s*(rc*pc-lc))*b
					+s*(r+pc*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np]/2)
				pc <- pcauchy(y[,1],m,t)
				-wt*log(s*cens/(t*(1+(y[,1]-m)^2/t^2))
					+(1-cens)*((1+s*(rc*pc-lc))*b
					+s*(r+pc*(l-r))))}
			const <- -wt*cens*log(delta/pi)}},
        Laplace={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pl <- plaplace((y[,1]-m)/t)
				-wt*log(s*cens*(plaplace((y[,1]+delta/2-m)/t)
					-plaplace((y[,1]-delta/2-m)/t))+
					(1-cens)*((1+s*(rc*pl-lc))*b
					+s*(r+pl*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pl <- plaplace((y[,1]-m)/t)
				-wt*log(s*cens*exp(-abs(y[,1]-m)/t-p[np])+
					(1-cens)*((1+s*(rc*pl-lc))*b
					+s*(r+pl*(l-r))))}
			const <- -wt*cens*log(delta/2)}},
        Levy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pl <- plevy(y[,1],m,t)
				-wt*log(s*cens*(plevy(y[,1]+delta/2,m,t)
					-plevy(y[,1]-delta/2,m,t))+
					(1-cens)*((1+s*(rc*pl-lc))*b
					+s*(r+pl*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pl <- plevy(y[,1],m,t)
				-wt*log(s*cens*sqrt(t/(2*pi))*log(y[,1]-m)^-1.5
					*exp(-t/(2*(y[,1]-m)))+(1-cens)*
					((1+s*(rc*pl-lc))*b+s*(r+pl*(l-r))))}
			const <- -wt*cens*log(delta/2)}},
        Pareto={
		if(exact){
			fcn <- function(p) {
				s <- mixt(p)
				u <- exp(p[np])
				t <- 1/(mu1(p)*u)
				pp <- 1-(1+y[,1]*t)^-u
				-wt*log(s*cens*((1+(y[,1]-delta/2)*t)^-u-
					(1+(y[,1]+delta/2)*t)^-u)
					+(1-cens)*((1+s*(rc*pp-lc))*b
					+s*(r+pp*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- mixt(p)
				u <- exp(p[np])
				t <- 1/(mu1(p)*u)
				pp <- 1-(1+y[,1]*t)^-u
				-wt*log(s*cens*u*t*(1+y[,1]*t)^(-(u+1))+
					(1-cens)*
					((1+s*(rc*pp-lc))*b+s*(r+pp*(l-r))))}
			const <- -wt*cens*log(delta)}},
	exponential={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				u <- exp(-y[,1]/m)
				-wt*log(s*cens*(-exp(-(y[,1]+delta/2)/m)+
					exp(-(y[,1]-delta/2)/m))
					+(1-cens)*((1+s*(rc*(1-u)-lc))*b
					+s*(r+(1-u)*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				u <- exp(-y[,1]/m)
				-wt*log(s*cens*exp(-y[,1]/m)/m
					+(1-cens)*((1+s*(rc*(1-u)-lc))*b
					+s*(r+(1-u)*(l-r))))}
			const <- -wt*cens*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				u <- m/t
				pg <- pgamma(y[,1],t,u)
				-wt*log(s*cens*(pgamma(y[,1]+delta/2,t,u)-
					pgamma(y[,1]-delta/2,t,u))
					+(1-cens)*((1+s*(rc*pg-lc))*b
					+s*(r+pg*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				u <- m/t
				pg <- pgamma(y[,1],t,u)
				-wt*log(s*cens*y[,1]^(t-1)*exp(-y[,1]/u)/
					(u^t*gamma(t))
					+(1-cens)*((1+s*(rc*pg-lc))*b
					+s*(r+pg*(l-r))))}
			const <- -wt*cens*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				pw <- pweibull(y[,1],t,m)
				-wt*log(s*cens*(pweibull(y[,1]+delta/2,t,m)-
					pweibull(y[,1]-delta/2,t,m))
					+(1-cens)*((1+s*(rc*pw-lc))*b
					+s*(r+pw*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				v <- y[,1]/m
				u <- exp(-v^t)
				-wt*log(s*cens*t*v^(t-1)*u/m+
					(1-cens)*((1+s*(rc*(1-u)-lc))*b
					+s*(r+(1-u)*(l-r))))}
			const <- -wt*cens*log(delta)}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				ey <- exp(y[,1])
				pw <- pweibull(ey,t,m)
				-wt*log(s*cens*(pweibull(ey+ey*delta/2,
					t,m)-pweibull(ey-ey*delta/2,t,m))+
					(1-cens)*((1+s*(rc*pw-lc))*b
					+s*(r+pw*(l-r))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- mixt(p)
				t <- exp(p[np])
				v <- exp(y[,1])/m
				u <- exp(-v^t)
				-wt*log(s*cens*t*v^(t-1)*u/m+
					(1-cens)*((1+s*(rc*(1-u)-lc))*b
					+s*(r+(1-u)*(l-r))))}
			const <- -wt*cens*log(delta)}},
	own={const <- 0})
fn <- function(p) sum(fcn(p))
if(fscale==1)fscale <- fn(p)
if(is.na(fn(p)))stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(fn, p=p, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
z0$minimum <- z0$minimum+sum(const)
fitted.values <- if(distribution=="binomial"||distribution=="beta binomial"||
		distribution=="double binomial"||distribution=="mult binomial")
		as.vector((y[,1]+y[,2])*mu1(z0$estimate))
	else as.vector(mu1(z0$estimate))
residuals <- if(distribution!="Poisson"&&distribution!="negative binomial"&&
	distribution!="Consul"&&distribution!="double Poisson"&&
	distribution!="mult Poisson"&&distribution!="gamma count")
		y[,1]-fitted.values
	else y-fitted.values
if(np==1)cov <- 1/z0$hessian
else {
	a <- qr(z0$hessian)
	if(a$rank==np)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=np,nrow=np)}
se <- sqrt(diag(cov))
like.comp <- as.vector(fcn(z0$estimate)+const)
if(!is.null(mu2))mu1 <- mu2
if(!is.null(mixt2))mixt <- mixt2
if(!is.null(lin1a))lin1 <- lin1a
if(!is.null(lin2a))lin2 <- lin2a
z1 <- list(
	call=call,
	delta=delta,
	distribution=distribution,
	likefn=fcn,
	mu=mu1,
	mix=mixt,
	linear=list(lin1,lin2),
	common=common,
	prior.weights=wt,
	censor=censor,
	maxlike=z0$minimum,
	fitted.values=fitted.values,
	residuals=residuals,
	like.comp=like.comp,
	aic=z0$minimum+np,
	df=sum(wt)-np,
	coefficients=z0$estimate,
	npl=npl,
	npm=npm,
	nps=as.numeric(sht),
	npf=0,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "gnlr"
return(z1)}
#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gnlr(y, distribution="normal", mu=NULL, shape=NULL, linear=NULL,
#	pmu=NULL, pshape=NULL, exact=F, wt=1, delta=1, shfn=F, common=F,
#	envir=sys.frame(sys.parent()), print.level=0, typsiz=abs(p),
#	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(p%*%p), steptol=0.00001,
#	iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models with a variety of
# one and two parameter distributions.

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

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

call <- sys.call()
if(!missing(distribution)&&!is.function(distribution)){
	distribution <- match.arg(distribution,c("binomial","beta binomial",
	"double binomial","mult binomial","Poisson","negative binomial",
	"double Poisson","mult Poisson","gamma count","Consul","logarithmic",
	"geometric","normal","inverse Gauss","logistic","exponential","gamma",
	"Weibull","extreme value","Pareto","Cauchy","Laplace","Levy"))}
shp <- distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"
if(common){
	if(!is.function(mu))stop("with common parameters, mu must be a function")
	if(!is.function(shape))stop("with common parameters, shape must be a function")
	if(!is.null(linear))stop("linear cannot be used with common parameters")}
if(!is.null(pmu))npl <- length(pmu)
else npl <- 0
if(!is.null(pshape))nps <- length(pshape)
else nps <- 0
np <- npl+nps
if(np<1)stop("At least one parameter must be estimated")
if(is.function(distribution)){
	fcn <- distribution
	distribution <- "own"}
respenv <- inherits(y,"repeated")
envname <- if(respenv)paste(deparse(substitute(y)))
	else NULL
lin1 <- lin2 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]}
else lin1 <- linear
if(inherits(mu,"formula"))lin1 <- mu
if(inherits(shape,"formula"))lin2 <- shape
lin1a <- lin2a <- mu2 <- sh2 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else "tccov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(lin1,"formula")){
		if(is.function(mu)){
			lin1a <- if(respenv)finterp(lin1,envir=y,name=envname)
			else finterp(lin1,envir=envir,name=envname)}
		class(lin1) <- c(class(lin1),type)}
	if(inherits(lin2,"formula")){
		if(is.function(shape)){
			lin2a <- if(respenv)finterp(lin2,envir=y,name=envname)
			else finterp(lin2,envir=envir,name=envname)}
		class(lin2) <- c(class(lin2),type)}
	if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=y,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu2 <- mu
		if(respenv)attr(mu2,"model") <- tmp}
	if(is.function(shape)){
		tmp <- parse(text=paste(deparse(shape))[-1])
		class(shape) <- type
		shape <- if(respenv)fnenvir(shape,envir=y,name=envname)
			else fnenvir(shape,envir=envir,name=envname)
		sh2 <- shape
		if(respenv)attr(sh2,"model") <- tmp}}
if(inherits(lin1,"formula")){
	mu1 <- if(respenv)finterp(lin1,envir=y,name=envname)
		else finterp(lin1,envir=envir,name=envname)
	npt1 <- length(attr(mu1,"parameters"))
	if(is.matrix(attr(mu1,"model"))){
		if(all(dim(attr(mu1,"model"))==1)){
			if(is.function(mu)){
				lin1 <- mu1
				mu1 <- function(p) mu(p,p[npl]*rep(1,n))}
			else {
				tmp <- attributes(mu1)
				mu1 <- function(p) p[1]*rep(1,n)
				attributes(mu1) <- tmp}}
		else {
			if(is.function(mu)){
				lf <- if(inherits(mu,"formulafn"))length(attr(mu,"parameters"))
					else length(if(respenv)attr(fnenvir(mu,envir=y),"parameters")
					     else attr(fnenvir(mu,envir=envir),"parameters"))
				dm1 <- attr(mu1,"model")
				lin1 <- mu1
				mu1 <- function(p)
					mu(p,dm1%*%p[lf:(lf+npt1-1)])}}}
	else {
		if(is.function(mu)){
			warning("ignoring mu function\n")
			mu <- mu2 <- NULL}
		if(npl!=npt1){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu1,"parameters"),names(pmu))
				pmu <- unlist(pmu)[o]
				if(sum(!is.na(o))!=length(pmu))stop("invalid estimates for mu - probably wrong names")}
			else pmu <- unlist(pmu)}}}
else if(!is.function(mu)){
	mu1 <- function(p) p[1]*rep(1,n)
	npt1 <- 1}
else {
	mu1 <- mu
	if(length(mu1(pmu))==1)mu1 <- function(p) mu(p)*rep(1,n)}
if(is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=y))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=y))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu)){
		if(is.null(lin1))length(attr(mu1,"parameters"))
		else length(attr(mu1,"parameters"))-1+npt1}
       else npt1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl1 <- if(common) 1 else npl+1
if(inherits(lin2,"formula")){
	sh1 <- if(respenv)finterp(lin2,envir=y,start=npl1,name=envname)
		else finterp(lin2,envir=envir,start=npl1,name=envname)
	npt2 <- length(attr(sh1,"parameters"))
	if(is.matrix(attr(sh1,"model"))){
		if(all(dim(attr(sh1,"model"))==1)){
			if(is.function(shape)){
				lin2 <- sh1
				sh1 <- if(shfn)function(p) shape(p[npl1:np],p[np]*rep(1,n), mu1(p))
					else function(p) shape(p[npl1:np],p[np])}
			else {
				tmp <- attributes(sh1)
				sh1 <- function(p) p[npl1]*rep(1,n)
				sh2 <- fnenvir(function(p) p[1]*rep(1,n))
				attributes(sh1) <- tmp}}
		else {
			if(is.function(shape)){
				lfs <- if(inherits(shape,"formulafn"))length(attr(shape,"parameters"))
					else length(if(respenv)attr(fnenvir(shape,envir=y),"parameters")
						else attr(fnenvir(shape,envir=envir),"parameters"))
				dm2 <- attr(sh1,"model")
				lin2 <- sh1
				sh1 <- if(shfn)function(p) shape(p[npl1:np],dm2%*%p[(npl+lfs):np], mu1(p))
					else function(p) shape(p[npl1:np],dm2%*%p[(npl+lfs):np])}}}
	else {
		if(is.function(shape)){
			warning("ignoring shape function\n")
			shape <- sh2 <- NULL}
		if(nps!=npt2){
			cat("\nParameters are ")
			cat(attr(sh1,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh1,"parameters"),names(pshape))
				pshape <- unlist(pshape)[o]
				if(sum(!is.na(o))!=length(pshape))stop("invalid estimates for shape - probably wrong names")}
			else pshape <- unlist(pshape)}}}
else if(!is.function(shape)&&shp){
	sh1 <- function(p) p[npl1]*rep(1,n)
	sh2 <- fnenvir(function(p) p[1]*rep(1,n))
	npt2 <- 1}
else if(shp){
	sh1 <- if(shfn)function(p) shape(p[npl1:np], mu1(p))
		else function(p) shape(p[npl1:np])}
else sh1 <- NULL
if(shp){
	if(is.null(attributes(sh1))){
		attributes(sh1) <- if(is.function(shape)){
			if(!inherits(shape,"formulafn")){
				if(respenv)attributes(fnenvir(shape,envir=y))
				else attributes(fnenvir(shape,envir=envir))}
			else attributes(shape)}
			else {
				if(respenv)attributes(fnenvir(sh1,envir=y))
				else attributes(fnenvir(sh1,envir=envir))}}
	nlp <- if(is.function(shape)){
			if(is.null(lin2))length(attr(sh1,"parameters"))-shfn
			else length(attr(sh1,"parameters"))-1+npt2-shfn}
		else npt2
	if(!common&&nlp!=nps)stop(paste("pshape should have",nlp,"initial estimates"))}
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(sh1,"parameters"))))-shfn
	if(nlp!=npl)stop(paste("with a common parameter model, pmu should contain",nlp,"estimates"))}
p <- c(pmu,pshape)
if(respenv){
	if(inherits(envir,"repeated")&&(length(y$response$nobs)!=length(envir$response$nobs)||any(y$response$nobs!=envir$response$nobs)))stop("y and envir objects are incompatible")
	if(!is.null(y$response$wt)&&!is.na(y$response$wt))wt <- y$response$wt
	if(!is.null(y$response$delta))delta <- y$response$delta
	y <- response(y)}
else if(inherits(y,"response")){
	if(!is.null(y$wt)&&!is.na(y$wt))wt <- y$wt
	if(!is.null(y$delta))delta <- y$delta
	y <- response(y)}
if(any(is.na(y)))stop("NAs in y - use rmna")
if(distribution=="binomial"||distribution=="double binomial"||
	distribution=="beta binomial"||distribution=="mult binomial"){
	if(length(dim(y))!=2||ncol(y)!=2)
		stop(paste("Two column matrix required for response: successes and failures"))
	if(any(y<0))stop("All response values must be positive")
	n <- nrow(y)
	nn <- y[,1]+y[,2]
	censor <- F}
else {
	censor <- length(dim(y))==2&&ncol(y)==2
	if(censor&&all(y[,2]==1)){
		y <- y[,1]
		censor <- F}
	if(!censor){
		if(!is.vector(y,mode="numeric"))stop("y must be a vector")
		n <- length(y)
		if(distribution=="double Poisson"||distribution=="mult Poisson")
			my <- 3*max(y)}}
if((distribution=="inverse Gauss"||distribution=="exponential"||
	distribution=="gamma"||distribution=="Weibull"||
	distribution=="extreme value")&&((censor&&any(y[,1]<=0))||
	(!censor&&any(y<=0))))stop("All response values must be > 0")
if((distribution=="Poisson"||distribution=="negative binomial"||
	distribution=="gamma count"||distribution=="double Poisson"||
	distribution=="mult Poisson")&&(any(y<0)))
	stop("All response values must be >= 0")
if(distribution=="logarithmic"&&any(y[wt>0]<1))
	stop("All response values must be integers > 0")
if(censor){
	n <- nrow(y)
	y[,2] <- as.integer(y[,2])
	if(any(y[,2]!=-1&y[,2]!=0&y[,2]!=1))
		stop("Censor indicator must be -1s, 0s, and 1s")
	cc <- ifelse(y[,2]==1,1,0)
	rc <- ifelse(y[,2]==0,1,ifelse(y[,2]==-1,-1,0))
	lc <- ifelse(y[,2]==-1,0,1)
	if(any(delta<=0&y[,2]==1))
		stop("All deltas for uncensored data must be positive")
	else {
		delta <- ifelse(delta<=0,0.000001,delta)
		delta <- ifelse(y[,1]-delta/2<=0,delta-0.00001,delta)}}
else {
	if(min(delta)<=0)stop("All deltas for must be positive")}
if(length(wt)==1)wt <- rep(wt,n)
else if(length(wt)!=n)stop("wt must be the same length as the other variables")
if(min(wt)<0)stop("All weights must be non-negative")
if(length(delta)==1)delta <- rep(delta,n)
else if(length(delta)!=n)stop("delta must be the same length as the other variables")
if(any(is.na(mu1(pmu))))stop("The location model returns NAs: probably invalid initial values")
if(distribution=="Levy"&&((!censor&&any(y<=mu1(p)))||(censor&&any(y[,1]<=mu1(p)))))
	stop("location parameter must be strictly less than corresponding observation")
if(distribution!="binomial"&&distribution!="Poisson"&&
	distribution!="exponential"&&distribution!="geometric"&&
	distribution!="logarithmic"&&any(is.na(sh1(p))))
	stop("The shape model returns NAs: probably invalid initial values")
if(distribution=="Pareto"&&exp(sh1(p))<=1)stop("shape parameters must be > 0")
if (!censor){
	ret <- switch(distribution,
	binomial={
		fcn <- function(p) {
			m <- mu1(p)
			-wt*(y[,1]*log(m)+y[,2]*log(1-m))}
		const <- -wt*lchoose(nn,y[,1])},
	"beta binomial"={
		fcn <- function(p) {
			m <- mu1(p)
			s <- exp(sh1(p))
			t <- s*m
			u <- s*(1-m)
			-wt*(lbeta(y[,1]+t,y[,2]+u)-lbeta(t,u))}
		const <- -wt*lchoose(nn,y[,1])},
	"double binomial"={
		fcn <- function(p) {
			-.C("ddb",as.integer(y[,1]),as.integer(nn),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(n),as.double(wt),res=double(n),DUP=F)$res}
		const <- 0},
	"mult binomial"={
		fcn <- function(p) {
			-.C("dmb",as.integer(y[,1]),as.integer(nn),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(n),as.double(wt),res=double(n),DUP=F)$res}
		const <- 0},
	Poisson={
		fcn <- function(p) {
			m <- mu1(p)
			-wt*(-m+y*log(m))}
		const <- wt*lgamma(y+1)},
	"negative binomial"={
		fcn <- function(p) {
			m <- mu1(p)
			t <- sh1(p)
			s <- exp(t)
			-wt*(lgamma(y+s)-lgamma(s)+s*t+y*log(m)
				-(y+s)*log(s+m))}
		const <- wt*lgamma(y+1)},
	"double Poisson"={
		fcn <- function(p) {
			-.C("ddp",as.integer(y),as.integer(my),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(length(y)),as.double(wt),
				res=double(length(y)),DUP=F)$res}
		const <- 0},
	"mult Poisson"={
		fcn <- function(p) {
			-.C("dmp",as.integer(y),as.integer(my),
				as.double(mu1(p)),as.double(exp(sh1(p))),
				as.integer(length(y)),as.double(wt),
				res=double(length(y)),DUP=F)$res}
		const <- 0},
	"gamma count"={
		fcn <- function(p) {
			m <- mu1(p)
			s <- exp(sh1(p))
			u <- m*s
			-wt*log(ifelse(y==0,1-pgamma(u,(y+1)*s,1),
				pgamma(u,y*s+(y==0),1)-
				pgamma(u,(y+1)*s,1)))}
		const <- 0},
	Consul={
		fcn <- function(p) {
			m <- mu1(p)
			t <- sh1(p)
			s <- exp(t)
			-wt*(log(m)-(m+y*(s-1))/s+(y-1)*log(m+y*(s-1))-y*t)}
		const <- wt*lgamma(y+1)},
	logarithmic={
		fcn <- function(p) {
			m <- exp(mu1(p))
			m <- m/(1+m)
			-wt*(y*log(m)-log(y)-log(-log(1-m)))}
		const <- 0},
	geometric={
		fcn <- function(p) {
			m <- mu1(p)
			-wt*(y*log(m)-(y+1)*log(1+m))}
		const <- 0},
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				-wt*log(pnorm(y+delta/2,m,s)
					-pnorm(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				t <- sh1(p)
				wt*(t+(y-mu1(p))^2/exp(t))/2}
			const <- wt*(log(2*pi)/2-log(delta))}},
        "inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*log(pinvgauss(y+delta/2,m,s)-
					pinvgauss(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				wt*(t+(y-m)^2/(y*exp(t)*m^2))/2}
			const <- wt*(log(2*pi*y^3)/2-log(delta))}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				-wt*log(plogis(y+delta/2,m,s)
					-plogis(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- (y-m)*pi/(exp(t)*sqrt(3))
				wt*(s+t+2*log(1+exp(-s)))}
			const <- -wt*(log(pi/sqrt(3))+log(delta))}},
	Cauchy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				-wt*log(pcauchy(y+delta/2,m,s)
					-pcauchy(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				wt*log(s*(1+((y-m)/s)^2))}
			const <- -wt*log(delta/pi)}},
        Laplace={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*log(plaplace(y+delta/2,m,s)
					-plaplace(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				t <- sh1(p)
				wt*(abs(y-mu1(p))/exp(t)+t)}
			const <- -wt*log(delta/2)}},
        Levy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*log(plevy(y+delta/2,m,s)
					-plevy(y-delta/2,m,s))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(0.5*log(s/(2*pi))-1.5*log(y-m)-
					s/(2*(y-m)))}
			const <- -wt*log(delta/2)}},
        Pareto={
		if(exact){
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*log((1+(y-delta/2)*t)^-s
					-(1+(y+delta/2)*t)^-s)}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*(log(s*t)-(s+1)*log(1+y*t))}
			const <- -wt*log(delta)}},
        exponential={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				-wt*log(-exp(-(y+delta/2)/m)
					+exp(-(y-delta/2)/m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				wt*(log(m)+y/m)}
			const <- -wt*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				u <- m/s
				-wt*log(pgamma(y+delta/2,s,u)
					-pgamma(y-delta/2,s,u))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(s*(t-log(m)-y/m)+(s-1)*log(y)-lgamma(s))}
			const <- -wt*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*log(pweibull(y+delta/2,s,m)
					-pweibull(y-delta/2,s,m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(t+(s-1)*log(y)-s*log(m)-(y/m)^s)}
			const <- -wt*log(delta)}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				ey <- exp(y[,1])
				-wt*log(pweibull(ey+ey*delta/2,s,m)
					-pweibull(ey-ey*delta/2,s,m))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(t+s*y-s*log(m)-(exp(y)/m)^s)}
			const <- -wt*log(delta)}},
	own={ const <- 0})}
else {
	ret <- switch(distribution,
	Poisson={
		fcn <- function(p) {
			m <- mu1(p)
			-wt*(cc*(-m+y[,1]*log(m))+
				log(lc-rc*ppois(y[,1],m)))}
		const <- wt*cc*lgamma(y[,1]+1)},
	"negative binomial"={
		fcn <- function(p) {
			m <- mu1(p)
			t <- sh1(p)
			s <- exp(t)
			-wt*(cc*(lgamma(y[,1]+s)-lgamma(s)
				+s*t+y[,1]*log(m)-(y[,1]+s)*log(s+m))+
				log(lc-rc*pnbinom(y[,1],s,1/(1+m/s))))}
		const <- wt*cc*lgamma(y[,1]+1)},
	geometric={
		fcn <- function(p) {
			m <- mu1(p)
			-wt*(cc*(y[,1]*log(m)-(y[,1]+1)*log(1+m))+
				log(lc-rc*pgeom(y[,1],1/(1+m))))}
		const <- 0},
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				-wt*(cc*log(pnorm(y[,1]+delta/2,m,s)-
					pnorm(y[,1]-delta/2,m,s))
					+log(lc-rc*pnorm(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(-(t+(y[,1]-m)^2/s)/2)+log(lc-rc
					*pnorm(y[,1],m,sqrt(s))))}
			const <- wt*cc*(log(2*pi)/2-log(delta))}},
        "inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(cc*log(pinvgauss(y[,1]+delta/2,m,s)-
					pinvgauss(y[,1]-delta/2,m,s))
					+log(lc-rc*pinvgauss(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(-(t+(y[,1]-m)^2/(y[,1]*s*m^2))/2)+
					log(lc-rc*pinvgauss(y[,1],m,s)))}
			const <- wt*cc*(log(2*pi*y[,1]^3)/2-log(delta))}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				-wt*(cc*log(plogis(y[,1]+delta/2,m,s)-
					plogis(y[,1]-delta/2,m,s))
					+log(lc-rc*plogis(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				y1 <- (y[,1]-m)/s
				-wt*(cc*(-y1-log(s)-2*log(1+exp(-y1)))
					+log(lc-rc*plogis(y[,1],m,s)))}
			const <- -wt*cc*log(delta)}},
	Cauchy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				-wt*(cc*log(pcauchy(y[,1]+delta/2,m,s)-
					pcauchy(y[,1]-delta/2,m,s))
					+log(lc-rc*pcauchy(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				-wt*(-cc*log(s*(1+((y[,1]-m)/s)^2))
					+log(lc-rc*pcauchy(y[,1],m,s)))}
			const <- -wt*cc*log(delta/pi)}},
        Laplace={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(cc*log(plaplace(y[,1]+delta/2,m,s)-
					plaplace(y[,1]-delta/2,m,s))
					+log(lc-rc*plaplace(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(-abs(y[,1]-m)/s-t)+log(lc-rc
					*plaplace(y[,1],m,s)))}
			const <- -wt*cc*log(delta/2)}},
        Levy={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(cc*log(plevy(y[,1]+delta/2,m,s)-
					plevy(y[,1]-delta/2,m,s))
					+log(lc-rc*plevy(y[,1],m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(0.5*log(s/(2*pi))-1.5*log(y[,1]-m)-
					s/(2*(y[,1]-m)))+log(lc-rc
					*plevy(y[,1],m,s)))}
			const <- -wt*cc*log(delta/2)}},
        Pareto={
		if(exact){
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*(cc*log((1+(y[,1]-delta/2)*t)^-s-
					(1+(y[,1]+delta/2)*t)^-s)
					+log(lc-rc*(-(1+(y[,1])*t)^-s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- exp(sh1(p))
				t <- 1/(mu1(p)*(s-1))
				-wt*(cc*(log(s*t)-(s+1)*log(1+y[,1]*t))
					+log(lc-rc*(1-(1+y[,1]*t)^-s)))}
			const <- -wt*cc*log(delta)}},
	exponential={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				-wt*(cc*log(-exp(-(y[,1]+delta/2)/m)
					+exp(-(y[,1]-delta/2)/m))+
					log(lc-rc*(1-exp(-y[,1]/m))))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				-wt*(cc*(-log(m)-y[,1]/m)+log(lc-rc*
					(1-exp(-y[,1]/m))))}
			const <- -wt*cc*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				u <- m/s
				-wt*(cc*log(pgamma(y[,1]+delta/2,s,u)-
					pgamma(y[,1]-delta/2,s,u))
					+log(lc-rc*pgamma(y[,1],s,u)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(s*(t-log(m)-y[,1]/m)+(s-1)*log(y[,1])
					-lgamma(s))+log(lc-rc
					*pgamma(y[,1],s,m/s)))}
			const <- -wt*cc*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				-wt*(cc*log(pweibull(y[,1]+delta/2,s,m)-
					pweibull(y[,1]-delta/2,s,m))
					+log(lc-rc*pweibull(y[,1],s,m)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				-wt*(cc*(t+(s-1)*log(y[,1])-s*log(m)
					-(y[,1]/m)^s)+log(lc-rc*
					pweibull(y[,1],s,m)))}
			const <- -wt*cc*log(delta)}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				ey <- exp(y[,1])
				pw <- pweibull(ey-ey*delta/2,s,m)
				-wt*(cc*log(pweibull(ey+ey*delta/2,s,m)-
					pweibull(ey-ey*delta/2,s,m))
					+log(lc-rc*pweibull(ey,s,m)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				ey <- exp(y[,1])
				-wt*(cc*(t+s*y[,1]-s*log(m)-(ey/m)^s)+log(lc-
					rc*pweibull(ey,s,m)))}
			const <- -wt*cc*log(delta)}},
	own={const <- 0})}
fn <- function(p) sum(fcn(p))
if(fscale==1)fscale <- fn(p)
if(is.na(fn(p)))stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(fn, p=p, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
z0$minimum <- z0$minimum+sum(const)
fitted.values <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial")
		as.vector((y[,1]+y[,2])*mu1(z0$estimate))
	else as.vector(mu1(z0$estimate))
residuals <- if(distribution=="binomial"||distribution=="beta binomial"||
	distribution=="double binomial"||distribution=="mult binomial"||censor)
		y[,1]-fitted.values
	else y-fitted.values
if(np==1)cov <- 1/z0$hessian
else {
	a <- qr(z0$hessian)
	if(a$rank==np)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=np,nrow=np)}
se <- sqrt(diag(cov))
like.comp <- as.vector(fcn(z0$estimate)+const)
if(!is.null(mu2))mu1 <- mu2
if(!is.null(sh2))sh1 <- sh2
if(!is.null(lin1a))lin1 <- lin1a
if(!is.null(lin2a))lin2 <- lin2a
z1 <- list(
	call=call,
	delta=delta,
	distribution=distribution,
	likefn=fcn,
	mu=mu1,
	shape=sh1,
	linear=list(lin1,lin2),
	common=common,
	prior.weights=wt,
	censor=censor,
	maxlike=z0$minimum,
	fitted.values=fitted.values,
	residuals=residuals,
	like.comp=like.comp,
	aic=z0$minimum+np,
	df=sum(wt)-np,
	coefficients=z0$estimate,
	npl=npl,
	npm=0,
	nps=nps,
	npf=0,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "gnlr"
return(z1)}
#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     gnlr3(y, distribution="normal", mu=NULL, shape=NULL,
#	family=NULL, linear=NULL, pmu=NULL, pshape=NULL, pfamily=NULL,
#	exact=F, wt=1, common=F, delta=1, envir=sys.frame(sys.parent()),
#	print.level=0,typsiz=abs(p), ndigit=10, gradtol=0.00001,
#	stepmax=10*sqrt(p%*%p), steptol=0.00001, iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models with a variety of
# three parameter distributions.


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

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

pburr <- function(q, m, s, f) 1-(1+(q/m)^s/f)^-f
pglogis <- function(y, m, s, f) (1+exp(-sqrt(3)*(y-m)/(s*pi)))^-f
pgweibull <- function(y, s, m, f) (1-exp(-(y/m)^s))^f
phjorth <- function(y, m, s, f) 1-(1+s*y)^(-f/s)*exp(-(y/m)^2/2)
pginvgauss <- function(y, m, s, f)
	.C("pginvgauss",
		as.double(y),
		as.double(m),
		as.double(s),
		as.double(f),
		len=as.integer(n),
		eps=as.double(1.0e-6),
		pts=as.integer(5),
		max=as.integer(16),
		err=integer(1),
		res=double(n),
		DUP=F)$res
ppowexp <- function(y, m, s, f){
	z <- .C("ppowexp",
		as.double(y),
		as.double(m),
		as.double(s),
		as.double(f),
		len=as.integer(n),
		eps=as.double(1.0e-6),
		pts=as.integer(5),
		max=as.integer(16),
		err=integer(1),
		res=double(n),
		DUP=F)$res
	ifelse(y-m>0,0.5+z,0.5-z)}

call <- sys.call()
if(!missing(distribution)&&!is.function(distribution)){
	distribution <- match.arg(distribution,c("normal","inverse Gauss",
	"logistic","Hjorth","gamma","Burr","Weibull","extreme value",
	"Student t","power exponential"))}
if(common){
	if(sum(is.function(mu)+is.function(shape)+is.function(family))<2)stop("with common parameters, at least two of mu, shape, and family must be functions")
	if((!is.function(mu)&&!is.null(mu))||(!is.function(shape)&&!is.null(shape))||(!is.function(family)&&!is.null(family)))stop("with common parameters, mu, shape, and family must either be functions or NULL")
	if(!is.null(linear))stop("linear cannot be used with common parameters")}
if(!is.null(pmu))npl <- length(pmu)
else npl <- 0
if(!is.null(pshape))nps <- length(pshape)
else nps <- 0
if(!is.null(pfamily))npf <- length(pfamily)
else npf <- 0
np <- npl+nps+npf
if(np<1)stop("At least one parameter must be estimated")
if(is.function(distribution)){
	fcn <- distribution
	distribution <- "own"}
respenv <- inherits(y,"repeated")
envname <- if(respenv)paste(deparse(substitute(y)))
	else NULL
lin1 <- lin2 <- lin3 <- NULL
if(is.list(linear)){
	lin1 <- linear[[1]]
	lin2 <- linear[[2]]
	lin3 <- linear[[3]]}
else lin1 <- linear
if(inherits(mu,"formula"))lin1 <- mu
if(inherits(shape,"formula"))lin2 <- shape
if(inherits(family,"formula"))lin3 <- family
lin1a <- lin2a <- lin3a <- mu2 <- sh2 <- fa2 <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else "tccov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(lin1,"formula")){
		if(is.function(mu)){
			lin1a <- if(respenv)finterp(lin1,envir=y,name=envname)
			else finterp(lin1,envir=envir,name=envname)}
		class(lin1) <- c(class(lin1),type)}
	if(inherits(lin2,"formula")){
		if(is.function(shape)){
			lin2a <- if(respenv)finterp(lin2,envir=y,name=envname)
			else finterp(lin2,envir=envir,name=envname)}
		class(lin2) <- c(class(lin2),type)}
	if(inherits(lin[[3]],"formula")){
		if(is.function(family)){
			lin3a <- if(respenv)finterp(lin3,envir=y,name=envname)
			else finterp(lin3,envir=envir,name=envname)}
		class(lin3) <- c(class(lin3),type)}
	if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=y,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu2 <- mu
		if(respenv)attr(mu2,"model") <- tmp}
	if(is.function(shape)){
		tmp <- parse(text=paste(deparse(shape))[-1])
		class(shape) <- type
		shape <- if(respenv)fnenvir(shape,envir=y,name=envname)
			else fnenvir(shape,envir=envir,name=envname)
		sh2 <- shape
		if(respenv)attr(sh2,"model") <- tmp}
	if(is.function(family)){
		tmp <- parse(text=paste(deparse(family))[-1])
		class(family) <- type
		family <- if(respenv)fnenvir(family,envir=y,name=envname)
			else fnenvir(family,envir=envir,name=envname)
		fa2 <- family
		if(respenv)attr(fa2,"model") <- tmp}}
if(inherits(lin1,"formula")){
	mu1 <- if(respenv)finterp(lin1,envir=y,name=envname)
		else finterp(lin1,envir=envir,name=envname)
	npt1 <- length(attr(mu1,"parameters"))
	if(is.matrix(attr(mu1,"model"))){
		if(all(dim(attr(mu1,"model"))==1)){
			if(is.function(mu)){
				lin1 <- mu1
				mu1 <- function(p) mu(p,p[npl]*rep(1,n))}
			else {
				tmp <- attributes(mu1)
				mu1 <- function(p) p[1]*rep(1,n)
				attributes(mu1) <- tmp}}
		else {
			if(is.function(mu)){
				lf <- if(inherits(mu,"formulafn"))length(attr(mu,"parameters"))
					else length(if(respenv)attr(fnenvir(mu,envir=y),"parameters")
						else attr(fnenvir(mu,envir=envir),"parameters"))
				dm1 <- attr(mu1,"model")
				lin1 <- mu1
				mu1 <- function(p) mu(p,dm1%*%p[lf:(lf+npt1-1)])}}}
	else {
		if(is.function(mu)){
			warning("ignoring mu function\n")
			mu <- mu2 <- NULL}
		if(npl!=npt1){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu1,"parameters"),names(pmu))
				pmu <- unlist(pmu)[o]
				if(sum(!is.na(o))!=length(pmu))stop("invalid estimates for mu - probably wrong names")}
			else pmu <- unlist(pmu)}}}
else if(!is.function(mu)){
	mu1 <- function(p) p[1]*rep(1,n)
	npt1 <- 1}
else {
	mu1 <- mu
	if(length(mu1(pmu))==1)mu1 <- function(p) mu(p)*rep(1,n)}
if(is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=y))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=y))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu)){
		if(is.null(lin1))length(attr(mu1,"parameters"))
		else length(attr(mu1,"parameters"))-1+npt1}
       else npt1
if(!common&&nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
npl1 <- if(common) 1 else npl+1
np1 <- npl+nps
if(inherits(lin2,"formula")){
	sh1 <- if(respenv)finterp(lin2,envir=y,start=npl1,name=envname)
		else finterp(lin2,envir=envir,start=npl1,name=envname)
	npt2 <- length(attr(sh1,"parameters"))
	if(is.matrix(attr(sh1,"model"))){
		if(all(dim(attr(sh1,"model"))==1)){
			if(is.function(shape)){
				lin2 <- sh1
				sh1 <- function(p) shape(p[npl1:np],p[np1]*rep(1,n))}
			else {
				tmp <- attributes(sh1)
				sh1 <- function(p) p[npl1]*rep(1,n)
				sh2 <- fnenvir(function(p) p[1]*rep(1,n))
				attributes(sh1) <- tmp}}
		else {
			if(is.function(shape)){
				lfs <- if(inherits(shape,"formulafn"))length(attr(shape,"parameters"))
					else length(if(respenv)attr(fnenvir(shape,envir=y),"parameters")
					     else attr(fnenvir(shape,envir=envir),"parameters"))
				dm2 <- attr(sh1,"model")
				lin2 <- sh1
				sh1 <- function(p) shape(p[npl1:np],dm2%*%p[(npl+lfs):np1])}}}
	else {
		if(is.function(shape)){
			warning("ignoring shape function\n")
			shape <- sh2 <- NULL}
		if(nps!=npt2){
			cat("\nParameters are ")
			cat(attr(sh1,"parameters"),"\n")
			stop(paste("pshape should have",npt2,"estimates"))}
		if(is.list(pshape)){
			if(!is.null(names(pshape))){
				o <- match(attr(sh1,"parameters"),names(pshape))
				pshape <- unlist(pshape)[o]
				if(sum(!is.na(o))!=length(pshape))stop("invalid estimates for shape - probably wrong names")}
			else pshape <- unlist(pshape)}}}
else if(!is.function(shape)){
	sh1 <- function(p) p[npl1]*rep(1,n)
	sh2 <- fnenvir(function(p) p[1]*rep(1,n))
	npt2 <- 1}
else sh1 <- function(p) shape(p[npl1:np])
if(is.null(attributes(sh1))){
	attributes(sh1) <- if(is.function(shape)){
		if(!inherits(shape,"formulafn")){
			if(respenv)attributes(fnenvir(shape,envir=y))
			else attributes(fnenvir(shape,envir=envir))}
		else attributes(shape)}
		else {
			if(respenv)attributes(fnenvir(sh1,envir=y))
			else attributes(fnenvir(sh1,envir=envir))}}
nlp <- if(is.function(shape)){
		if(is.null(lin2))length(attr(sh1,"parameters"))
		else length(attr(sh1,"parameters"))-1+npt2}
       else npt2
if(!common&&nlp!=nps)stop(paste("pshape should have",nlp,"initial estimates"))
nps1 <- np1+1
if(inherits(lin3,"formula")){
	fa1 <- if(respenv)finterp(lin3,envir=y,start=nps1,name=envname)
		else finterp(lin3,envir=envir,start=nps1,name=envname)
	npt3 <- length(attr(fa1,"parameters"))
	if(is.matrix(attr(fa1,"model"))){
		if(all(dim(attr(fa1,"model"))==1)){
			if(is.function(family)){
				lin3 <- fa1
				fa1 <- function(p) family(p[nps1:np],p[np]*rep(1,n))}
			else {
				tmp <- attributes(fa1)
				fa1 <- function(p) p[nps1]*rep(1,n)
				fa2 <- fnenvir(function(p) p[1]*rep(1,n))
				attributes(fa1) <- tmp}}
		else {
			if(is.function(family)){
				lff <- if(inherits(family,"formulafn"))length(attr(familt,"parameters"))
					else length(if(respenv)attr(fnenvir(family,envir=y),"parameters")
					     else attr(fnenvir(family,envir=envir),"parameters"))
				dm3 <- attr(fa1,"model")
				lin3 <- fa1
				fa1 <- function(p) family(p[nps1:np],dm3%*%p[(np1+lff):np])}}}
	else {
		if(is.function(family)){
			warning("ignoring family function\n")
			family <- fa2 <- NULL}
		if(npf!=npt3){
			cat("\nParameters are ")
			cat(attr(fa1,"parameters"),"\n")
			stop(paste("pfamily should have",npt3,"estimates"))}
		if(is.list(pfamily)){
			if(!is.null(names(pfamily))){
				o <- match(attr(fa1,"parameters"),names(pfamily))
				pfamily <- unlist(pfamily)[o]
				if(sum(!is.na(o))!=length(pfamily))stop("invalid estimates for family - probably wrong names")}
			else pfamily <- unlist(pfamily)}}
	if(npf<npt3)stop("Not enough initial estimates for family")}
else if(!is.function(family)){
	fa1 <- function(p) p[nps1]*rep(1,n)
	fa2 <- fnenvir(function(p) p[1]*rep(1,n))
	npt3 <- 1}
else fa1 <- function(p) family(p[nps1:np])
if(is.null(attributes(fa1))){
	attributes(fa1) <- if(is.function(family)){
		if(!inherits(family,"formulafn")){
			if(respenv)attributes(fnenvir(family,envir=y))
			else attributes(fnenvir(family,envir=envir))}
		else attributes(family)}
		else {
			if(respenv)attributes(fnenvir(fa1,envir=y))
			else attributes(fnenvir(fa1,envir=envir))}}
nlp <- if(is.function(family)){
		if(is.null(lin3))length(attr(fa1,"parameters"))
		else length(attr(fa1,"parameters"))-1+npt3}
       else npt3
if(!common&&nlp!=npf)stop(paste("pfamily should have",nlp,"initial estimates"))
if(common){
	nlp <- length(unique(c(attr(mu1,"parameters"),attr(sh1,"parameters"),attr(fa1,"parameters"))))
	if(nlp!=npl)stop(paste("with a common parameter model, pmu should contain",nlp,"estimates"))}
p <- c(pmu,pshape,pfamily)
if(respenv){
	if(inherits(envir,"repeated")&&(length(y$response$nobs)!=length(envir$response$nobs)||any(y$response$nobs!=envir$response$nobs)))stop("y and envir objects are incompatible")
	if(!is.null(y$response$wt)&&!is.na(y$response$wt))wt <- y$response$wt
	if(!is.null(y$response$delta))delta <- y$response$delta
	y <- response(y)}
else if(inherits(y,"response")){
	if(!is.null(y$wt)&&!is.na(y$wt))wt <- y$wt
	if(!is.null(y$delta))delta <- y$delta
	y <- response(y)}
if(any(is.na(y)))stop("NAs in y - use rmna")
censor <- length(dim(y))==2&&ncol(y)==2
if(censor&&all(y[,2]==1)){
	y <- y[,1]
	censor <- F}
if(censor){
	n <- nrow(y)
	y[,2] <- as.integer(y[,2])
	if(any(y[,2]!=-1&y[,2]!=0&y[,2]!=1))
		stop("Censor indicator must be -1s, 0s, and 1s")
	cc <- ifelse(y[,2]==1,1,0)
	rc <- ifelse(y[,2]==0,1,ifelse(y[,2]==-1,-1,0))
	lc <- ifelse(y[,2]==-1,0,1)
	if(delta<=0&y[,2]==1)
		stop("All deltas for uncensored data must be positive")
	else {
		delta <- ifelse(delta<=0,0.000001,delta)
		delta <- ifelse(y[,1]-delta/2<=0,delta-0.00001,delta)}}
else {
	if(!is.vector(y,mode="numeric"))stop("y must be a vector")
	n <- length(y)
	if(min(delta)<=0)stop("All deltas for must be positive")}
if((distribution!="logistic"&&distribution!="Student t"&&
	distribution!="power exponential")&&((censor&&any(y[,1]<=0))||
	(!censor&&any(y<=0))))stop("All response values must be > 0")
if(min(wt)<0)stop("All weights must be non-negative")
if(length(wt)==1)wt <- rep(wt,n)
if(length(delta)==1)delta <- rep(delta,n)
if(any(is.na(mu1(pmu))))stop("The location model returns NAs: probably invalid initial values")
if(any(is.na(sh1(p))))stop("The shape model returns NAs: probably invalid initial values")
if(any(is.na(fa1(p))))stop("The family model returns NAs: probably invalid initial values")
if (!censor){
	ret <- switch(distribution,
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- fa1(p)
				y <- y^f/f
				jy <- y^(2*f-1)*delta/(2*f)
				norm <- sign(f)*pnorm(0,m,s)
				ind <- f<0
				-wt*(log((pnorm(y+jy,m,s)-pnorm(y-jy,m,s)))
					-log(1-ind-norm))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- fa1(p)
				norm <- sign(f)*pnorm(0,m,s)
				ind <- f<0
				-wt*((f-1)*log(y)+log(dnorm(y^f/f,m,s))
					-log(1-ind-norm))}
			const <- -wt*log(delta)}},
	"power exponential"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- exp(fa1(p))
				-wt*log(ppowexp(y+delta/2,m,s)
					-ppowexp(y-delta/2,m,s,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				t <- 0.5*sh1(p)
				f <- exp(fa1(p))
				b <- 1+1/(2*f)
				wt*(t+(abs(y-mu1(p))/exp(t))^(2*f)/2+
					lgamma(b)+b*log(2))}
			const <- -wt*log(delta)}},
	"inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*log(pginvgauss(y+delta/2,m,s,f)
					-pginvgauss(y-delta/2,m,s,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*(-f*log(m)+(f-1)*log(y)-
					log(2*besselK(1/(s*m),abs(f)))-
					(1/y+y/m^2)/(2*s))}
			const <- -wt*log(delta)}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				-wt*log(pglogis(y+delta/2,m,s,f)
					-pglogis(y-delta/2,m,s,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				t <- sh1(p)
				m <- (y-mu1(p))/exp(t)*sqrt(3)/pi
				wt*(-fa1(p)+m+t+(exp(fa1(p))+1)*
					log(1+exp(-m)))}
			const <- -wt*(log(delta*sqrt(3)/pi))}},
	Hjorth={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*log(phjorth(y+delta/2,m,s,f)-
					phjorth(y-delta/2,m,s,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*(-f*log(1+s*y)/s-(y/m)^2/2+
					log(y/m^2+f/(1+s*y)))}
			const <- -wt*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				u <- (m/s)^f
				-wt*log(pgamma((y+delta/2)^f,s,u)
					-pgamma((y-delta/2)^f,s,u))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				u <- fa1(p)
				f <- exp(u)
				v <- s*f
				-wt*(v*(t-log(m))-(s*y/m)^f+u+(v-1)*log(y)
					-lgamma(s))}
			const <- -wt*log(delta)}},
	Burr={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				-wt*log(pburr(y+delta/2,m,s,f)-
					pburr(y-delta/2,m,s,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				y1 <- y/m
				-wt*(log(s/m)+(s-1)*log(y1)
					-(f+1)*log(1+y1^s/f))}
			const <- -wt*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				-wt*log(pgweibull(y+delta/2,s,m,f)
					-pgweibull(y-delta/2,s,m,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				u <- fa1(p)
				f <- exp(u)
				y1 <- (y/m)^s
				-wt*(t+u+(s-1)*log(y)-s*log(m)+
					(f-1)*log(1-exp(-y1))-y1)}
			const <- -wt*log(delta)}},
        "Student t"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- exp(fa1(p))
				-wt*log(pt((y+delta/2-m)/s,f)-
					pt((y-delta/2-m)/s,f))}
			const <- 0}
		else {
			fcn <- function(p) {
				s <- exp(0.5*sh1(p))
				-wt*log(dt((y-mu1(p))/s,exp(fa1(p)))/s)}
			const <- -wt*(log(delta))}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				y1 <- y^f/f
				ey <- exp(y1)
				jey <- y^(f-1)*ey*delta/2
				norm <- sign(f)*exp(-m^-s)
				ind <- f>0
				-wt*(log((pweibull(ey+jey,s,m)
					-pweibull(ey-jey,s,m))/
					(1-ind+norm)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				f <- fa1(p)
				y1 <- y^f/f
				norm <- sign(f)*exp(-m^-s)
				ind <- f>0
				-wt*(t+s*(y1-log(m))-(exp(y1)/m)^s
					+(f-1)*log(y)-
					log(1-ind+norm))}
			const <- -wt*log(delta)}},
	own={ const <- 0})}
else {
	ret <- switch(distribution,
	normal={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- fa1(p)
				y <- y[,1]^f/f
				jy <- y[,1]^(2*f-1)*delta/(2*f)
				norm <- sign(f)*pnorm(0,m,s)
				ind <- f<0
				-wt*(cc*log((pnorm(y+jy,m,s)-pnorm(y-jy,m,s)))+
					log(lc-rc*(pnorm(y,m,s)-(f>0)*norm)))/
					(1-ind-norm)}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(0.5*t)
				f <- fa1(p)
				norm <- sign(f)*pnorm(0,m,s)
				ind <- f<0
				-wt*(cc*(-(t+((y[,1]^f/f-m)/s)^2)/2+(f-1)*
					log(y[,1]))+log(lc-rc
					*(pnorm(y[,1]^f/f,m,s)
					-(f>0)*norm)))/(1-ind-norm)}
			const <- wt*cc*(log(2*pi)/2-log(delta))}},
	"power exponential"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- fa1(p)
				-wt*(cc*log(ppowexp(y[,1]+delta/2,m,s,f)-
					ppowexp(y[,1]-delta/2,m,s,f))
					+log(lc-rc*ppowexp(y[,1],m,s,f)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- 0.5*sh1(p)
				s <- exp(t)
				f <- exp(fa1(p))
				b <- 1+1/(2*f)
				-wt*(cc*(-t-(abs(y[,1]-mu1(p))/s)^(2*f)/2-
					lgamma(b)-b*log(2))+log(lc-rc
					*ppowexp(y[,1],m,s,f)))}
			const <- -wt*cc*(log(delta))}},
	"inverse Gauss"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p)/2)
				f <- fa1(p)
				-wt*(cc*log(pginvgauss(y[,1]+delta/2,m,s,f)-
					pginvgauss((y[,1]-delta/2)^f/f,m,s))+
					log(lc-rc*pginvgauss(y[,1]^f/f,m,s)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*(cc*(-f*log(m)+(f-1)*log(y[,1])-
					log(2*besselK(1/(s*m),abs(f)))-
					(1/y[,1]+y[,1]/m^2)/(2*s))+log(lc-rc
					*pginvgauss(y[,1],m,s,f)))}
			const <- -wt*cc*(log(delta))}},
	logistic={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				f <- exp(fa1(p))
				-wt*(cc*log(pglogis(y[,1]+delta/2,m,s,f)-
					pglogis(y[,1]-delta/2,m,s,f))
					+log(lc-rc*pglogis(y[,1],m,s,f)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))*sqrt(3)/pi
				y1 <- (y[,1]-m)/s
				u <- fa1(p)
				f <- exp(u)
				-wt*(cc*(u-y1-log(s)-(f+1)*log(1+exp(-y1)))
					+log(lc-rc*pglogis(y[,1],m,s,f)))}
			const <- -wt*cc*log(delta)}},
	Hjorth={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*(cc*log(phjorth(y[,1]+delta/2,m,s,f)-
					phjorth(y[,1]-delta/2,m,s,f))
					+log(lc-rc*phjorth(y[,1],m,s,f)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				-wt*(cc*(-f*log(1+s*y[,1])/s-(y[,1]/m)^2/2+
					log(y[,1]/m^2+f/(1+s*y[,1])))+
					log(lc-rc*phjorth(y[,1],m,s,f)))}
			const <- -wt*cc*log(delta)}},
        gamma={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				u <- (m/s)^f
				-wt*(cc*log(pgamma((y[,1]+delta/2)^f,s,u)-
					pgamma((y[,1]-delta/2)^f,s,u))
					+log(lc-rc*pgamma(y[,1]^f,s,u)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				u <- fa1(p)
				f <- exp(u)
				v <- s*f
				-wt*(cc*(v*(t-log(m))-(s*y[,1]/m)^f+u+(v-1)*
					log(y[,1])-lgamma(s))+log(lc-rc
					*pgamma(y[,1]^f,s,(m/s)^f)))}
			const <- -wt*cc*log(delta)}},
	Burr={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				-wt*(cc*log(pburr(y[,1]+delta/2,m,s,f)-
					pburr(y[,1]-delta/2,m,s,f))
					+log(lc-rc*pburr(y[,1],m,s,f)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				y1 <- y[,1]/m
				-wt*(cc*(log(s/m)+(s-1)*log(y1)
					-(f+1)*log(1+y1^s/f))+
					log(lc-rc*pburr(y[,1],m,s,f)))}
			const <- -wt*cc*log(delta)}},
        Weibull={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- exp(fa1(p))
				-wt*(cc*log(pgweibull(y[,1]+delta/2,s,m,f)-
					pgweibull(y[,1]-delta/2,s,m,f))
					+log(lc-rc*pgweibull(y[,1],s,m,f)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				u <- fa1(p)
				f <- exp(u)
				y1 <- (y[,1]/m)^s
				-wt*(cc*(t+u+(s-1)*log(y[,1])-s*log(m)+(f-1)
					*log(1-exp(-y1))-y1)+log(lc-rc*
					pgweibull(y[,1],s,m,f)))}
			const <- -wt*cc*log(delta)}},
        "Student t"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- exp(fa1(p))
				-wt*(cc*log(pt((y[,1]+delta/2-m)/s,f)-
					pt((y[,1]-delta/2-m)/s,f))
					+log(lc-rc*pt((y[,1]-m)/s,f)))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(0.5*sh1(p))
				f <- exp(fa1(p))
				-wt*(cc*log(dt((y[,1]-m)/s,f)/s)
					+log(lc-rc*pt((y[,1]-m)/s,f)))}
			const <- -wt*cc*(log(delta))}},
        "extreme value"={
		if(exact){
			fcn <- function(p) {
				m <- mu1(p)
				s <- exp(sh1(p))
				f <- fa1(p)
				y1 <- y[,1]^f/f
				ey <- exp(y1)
				jey <- y[,1]^(f-1)*ey*delta/2
				norm <- sign(f)*exp(-m^-s)
				ind <- f>0
				-wt*(cc*log(pweibull(ey+jey,s,m)-
					pweibull(ey-jey,s,m))
					+log(lc-rc*(pweibull(ey,s,m)-ind+
					(f>0)*norm))-log(1-ind+norm))}
			const <- 0}
		else {
			fcn <- function(p) {
				m <- mu1(p)
				t <- sh1(p)
				s <- exp(t)
				f <- fa1(p)
				y1 <- y[,1]^f/f
				ey <- exp(y1)
				norm <- sign(f)*exp(-m^-s)
				ind <- f>0
				-wt*(cc*(t+s*(y1-log(m))-(ey/m)^s
					+(f-1)*log(y[,1]))+log(lc-rc*
					(pweibull(ey,s,m)-ind+(f>0)*norm))-
					log(1-ind+norm))}
			const <- -wt*cc*log(delta)}},
	own={const <- 0})}
fn <- function(p) sum(fcn(p))
if(fscale==1)fscale <- fn(p)
if(is.na(fn(p)))stop("Likelihood returns NAs: probably invalid initial values")
z0 <- nlm(fn, p=p, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax, steptol=steptol,
	iterlim=iterlim, fscale=fscale)
z0$minimum <- z0$minimum+sum(const)
fitted.values <- as.vector(mu1(z0$estimate))
residuals <- y-fitted.values
if(np==1){
	cov <- 1/z0$hessian
	se <- as.vector(sqrt(cov))}
else {
	a <- qr(z0$hessian)
	if(a$rank==np)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=np,nrow=np)
	se <- sqrt(diag(cov))}
like.comp <- as.vector(fcn(z0$estimate)+const)
if(!is.null(mu2))mu1 <- mu2
if(!is.null(sh2))sh1 <- sh2
if(!is.null(fa2))fa1 <- fa2
if(!is.null(lin1a))lin1 <- lin1a
if(!is.null(lin2a))lin2 <- lin2a
if(!is.null(lin3a))lin3 <- lin3a
z1 <- list(
	call=call,
	delta=delta,
	distribution=distribution,
	likefn=fcn,
	mu=mu1,
	shape=sh1,
	family=fa1,
	linear=list(lin1,lin2,lin3),
	common=common,
	prior.weights=wt,
	censor=censor,
	maxlike=z0$minimum,
	fitted.values=fitted.values,
	residuals=residuals,
	like.comp=like.comp,
	aic=z0$minimum+np,
	df=sum(wt)-np,
	coefficients=z0$estimate,
	npl=npl,
	npm=0,
	nps=nps,
	npf=npf,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "gnlr"
return(z1)}
#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     nlr(y, mu=NULL, pmu=NULL, distribution="normal", wt=1, delta=1,
#	envir=sys.frame(sys.parent()), print.level=0, typsiz=abs(pmu),
#	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(pmu%*%pmu),
#	steptol=0.00001, iterlim=100, fscale=1)
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models for distributions
# in the exponential family.

nlr <- function(y, mu=NULL, pmu=NULL, distribution="normal", wt=1, delta=1,
	envir=sys.frame(sys.parent()), print.level=0, typsiz=abs(pmu),
	ndigit=10, gradtol=0.00001, stepmax=10*sqrt(pmu%*%pmu),
	steptol=0.00001, iterlim=100, fscale=1){
call <- sys.call()
if(!missing(distribution))distribution <- match.arg(distribution,c("normal","inverse Gauss","gamma"))
if(missing(pmu))stop("Initial parameter estimates must be supplied")
np <- length(pmu)
if(!is.vector(y,mode="numeric"))stop("y must be a vector")
if(any(is.na(y)))stop("NAs in y - use rmna")
n <- length(y)
mu2 <- NULL
respenv <- inherits(y,"repeated")
envname <- if(respenv)paste(deparse(substitute(y)))
	else NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(mu,"formula")){
		mu2 <- if(respenv)finterp(mu,envir=y,name=envname)
			else finterp(mu,envir=envir,name=envname)
		class(mu) <- c(class(mu),type)}
	else if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- if(respenv||inherits(envir,"repeated"))"repeated"
			else "tccov"
		mu <- if(respenv)fnenvir(mu,envir=y,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu2 <- mu
		if(respenv)attr(mu2,"model") <- tmp}}
if(inherits(mu,"formula")){
	mu1 <- mu
	mu <- if(respenv)finterp(mu,envir=y,name=envname)
		else finterp(mu,envir=envir,name=envname)
	npt1 <- length(attr(mu,"parameters"))
	if(is.matrix(attr(mu,"model"))){
		if(all(dim(attr(mu,"model"))==1)){
			tmp <- attributes(mu)
			mu <- function(p) p[1]*rep(1,n)
			attributes(mu) <- tmp}}
	else {
		if(np!=npt1){
			cat("\nParameters are ")
			cat(attr(mu,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu,"parameters"),names(pmu))
				pmu <- unlist(pmu)[o]
				if(sum(!is.na(o))!=length(pmu))stop("invalid estimates for mu - probably wrong names")}
			else pmu <- unlist(pmu)}}}
if(is.null(attributes(mu))){
	attributes(mu) <- if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=y))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
nlp <- if(is.function(mu1))length(attr(mu,"parameters"))
       else npt1
if(nlp!=np)stop(paste("pmu should have",nlp,"initial estimates"))
if(missing(mu)||!is.function(mu))stop("A mean function or formula must be supplied")
fn <- switch(distribution,
normal=function(p) sum(wt*(y-mu(p))^2),
gamma=function(p) -sum(wt*(log(y/mu(p))-(y-mu(p))/mu(p))),
"inverse Gauss"=function(p) sum(wt*((y-mu(p))^2)/(y*mu(p)^2)))
if(fscale==1)fscale <- fn(pmu)
if(is.na(fn(pmu)))
	stop("Non-numerical function value: probably invalid initial values")
z0 <- nlm(fn, p=pmu, hessian=T, print.level=print.level, typsiz=typsiz,
	ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
	steptol=steptol, iterlim=iterlim, fscale=fscale)
if(length(delta)==1)delta <- rep(delta,length(y))
if(length(wt)==1)wt <- rep(wt,length(y))
n <- sum(wt)
disp <- z0$minimum/n
p <- z0$estimate
switch(distribution,
normal=maxlike <- length(y)*(log(2*pi*disp)+1)/2,
gamma=maxlike <- (sum(wt*(y/mu(p)+log(mu(p))-log(y)))+n*log(disp))/
	disp+n*lgamma(1/disp)+sum(log(y)*wt),
"inverse Gauss"=maxlike <- (sum(wt)*(log(disp*2*pi)+1)+3*sum(log(y)*wt))/2)
maxlike <- maxlike-sum(log(delta))
fitted.values <-  as.vector(mu(z0$estimate))
residuals <-  y-fitted.values
if(np==1)cov <- 1/z0$hessian
else {
	a <- qr(z0$hessian)
	if(a$rank==np)cov <- solve(z0$hessian)
	else cov <- matrix(NA,ncol=np,nrow=np)}
cov <- 2*cov*z0$minimum/sum(wt)
se <- sqrt(diag(cov))
z1 <- list(
	call=call,
	distribution=distribution,
	delta=delta,
	mu=mu,
	prior.weights=wt,
	maxlike=maxlike,
	dispersion=disp,
	fitted.values=fitted.values,
	residuals=residuals,
	aic=maxlike+np+1,
	df=sum(wt)-np,
	coefficients=z0$estimate,
	np=np,
	se=se,
	cov=cov,
	corr=cov/(se%o%se),
	gradient=z0$gradient,
	iterations=z0$iterations,
	code=z0$code)
class(z1) <- "nlr"
return(z1)}

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

print.nlr <- function(z) {
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat(z$distribution,"distribution\n\n")
	cat("Mean 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")}
	cat("\n-Log likelihood   ",z$maxlike,"\n")
	cat("Degrees of freedom",z$df,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n\n")
	cat("Mean parameters:\n")
	coef.table <- cbind(z$coefficients[1:z$np], z$se[1:z$np])
	if(inherits(z$mu,"formulafn"))
		cname <- if(is.matrix(attr(z$mu,"model")))
				colnames(attr(z$mu,"model"))
			else attr(z$mu,"parameters")
	else cname <- seq(1,z$np)
	dimnames(coef.table) <- list(cname, c("estimate", "se"))
	print.default(coef.table, digits=4, print.gap=2)
	cat("\nDispersion estimate:",z$dispersion,"\n")
	if(z$np>1){
		cat("\nCorrelations:\n")
		dimnames(z$corr) <- list(seq(1,z$np),seq(1,z$np))
		print.default(z$corr, digits=4)}
	invisible(z)}
#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     nordr(y, distribution="proportional", mu, linear=NULL, pmu, 
#	pintercept, wt=NULL, envir=sys.frame(sys.parent()), print.level=0,
#	ndigit=10, gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
#	typsiz=abs(p), stepmax=10*sqrt(p%*%p))
#
#  DESCRIPTION
#
#    A function to fit nonlinear regression models for ordinal responses.

nordr <- function(y, distribution="proportional", mu, linear=NULL, pmu, 
	pintercept, wt=NULL, envir=sys.frame(sys.parent()), print.level=0,
	ndigit=10, gradtol=0.00001, steptol=0.00001, fscale=1, iterlim=100,
	typsiz=abs(p), stepmax=10*sqrt(p%*%p)){
lf <- function(p){
	g <- exp(mu1(p[1:npl])+block%*%p[npl1:np])
	g <- g/(1+g)
	if(mdl==1){
		g <- c(g,ext)
		g <- g[1:nlen]/g[nrows1:nlenr]
		g <- ifelse(g>=1,0.99,g)}
	-sum(pwt*(resp*log(g)+(1-resp)*log(1-g)))}
lf3 <- function(p){
	mu <- mu1(p[1:npl])
	g <- exp(mu*(y-1)+resp%*%p[npl1:np])/
	exp(mu%o%(0:my)+matrix(rep(cumsum(c(0,0,p[npl1:np])),nrows),ncol=my+1,byrow=T))%*%ext
	-sum(pwt*log(g))}
call <- sys.call()
tmp <- c("proportional odds","continuation ratio","adjacent categories")
mdl <- match(distribution <- match.arg(distribution,tmp),tmp)
if(!is.vector(y,mode="numeric"))stop("y must be a vector")
if(any(is.na(y)))stop("NAs in y - use rmna")
if(min(y)!=1)stop("ordinal values must start at 1")
else if(any(y!=trunc(y)))stop("ordinal values must be integers")
else my <- max(y)-1
nrows <- length(y)
nrows1 <- nrows+1
nlen <- my*nrows
nlenr <- nlen+nrows
npl <- length(pmu)
npl1 <- npl+1
if(missing(pintercept)||length(pintercept)!=my-1)
	stop(paste(my-1,"initial values of intercept parameters must be supplied"))
if(inherits(mu,"formula"))linear <- mu
respenv <- inherits(y,"repeated")
envname <- if(respenv)paste(deparse(substitute(y)))
	else NULL
lin1a <- mu2 <- name <- NULL
if(respenv||inherits(envir,"repeated")||inherits(envir,"tccov")){
	type <- if(respenv||inherits(envir,"repeated"))"repeated"
		else "tccov"
	if(is.null(envname))envname <- paste(deparse(substitute(envir)))
	if(inherits(linear,"formula")){
		if(is.function(mu)){
			lin1a <- if(respenv)finterp(linear,envir=y,name=envname)
			else finterp(linear,envir=envir,name=envname)}
		class(linear) <- c(class(linear),type)}
	if(is.function(mu)){
		tmp <- parse(text=paste(deparse(mu))[-1])
		class(mu) <- type
		mu <- if(respenv)fnenvir(mu,envir=y,name=envname)
			else fnenvir(mu,envir=envir,name=envname)
		mu2 <- mu
		if(respenv)attr(mu2,"model") <- tmp}}
if(inherits(linear,"formula")){
	mu1 <- if(respenv)finterp(linear,envir=y,name=envname)
		else finterp(linear,envir=envir,name=envname)
	npt1 <- length(attr(mu1,"parameters"))
	if(is.matrix(attr(mu1,"model"))){
		if(all(dim(attr(mu1,"model"))==1)){
			if(is.function(mu)){
				dm1 <- attr(mu1,"model")
				mu1 <- function(p) mu(p,p[npl]*rep(1,nrows))}
			else {
				tmp <- attributes(mu1)
				mu1 <- function(p) p[1]*rep(1,nrows)
				attributes(mu1) <- tmp}}
		else {
			if(nrow(attr(mu1,"model"))!=nrows)stop("mu model matrix does not match number of response observations")
			if(is.function(mu)){
				lf <- if(inherits(mu,"formulafn"))length(attr(mu,"parameters"))
					else length(if(respenv)attr(fnenvir(mu,envir=y),"parameters")
						else attr(fnenvir(mu,envir=envir),"parameters"))
				dm1 <- attr(mu1,"model")
				linear <- mu1
				mu1 <- function(p) mu(p,dm1%*%p[lf:npl])}}}
	else {
		if(is.function(mu)){
			warning("ignoring mu function\n")
			mu <- mu2 <- NULL}
		if(npl!=npt1){
			cat("\nParameters are ")
			cat(attr(mu1,"parameters"),"\n")
			stop(paste("pmu should have",npt1,"estimates"))}
		if(is.list(pmu)){
			if(!is.null(names(pmu))){
				o <- match(attr(mu1,"parameters"),names(pmu))
				pmu <- unlist(pmu)[o]
				if(sum(!is.na(o))!=length(pmu))stop("invalid estimates for mu - probably wrong names")}
			else pmu <- unlist(pmu)}}
	if(npl<npt1)stop("Not enough initial estimates for mu")}
else if(!is.function(mu)){
	mu1 <- function(p) p[1]*rep(1,nrows)
	npt1 <- 1}
else {
	mu1 <- mu
	if(length(mu1(pmu))==1)mu1 <- function(p) mu(p)*rep(1,nrows)}
if(is.null(attributes(mu1))){
	attributes(mu1) <- if(is.function(mu)){
		if(!inherits(mu,"formulafn")){
			if(respenv)attributes(fnenvir(mu,envir=y))
			else attributes(fnenvir(mu,envir=envir))}
		else attributes(mu)}
		else {
			if(respenv)attributes(fnenvir(mu1,envir=y))
			else attributes(fnenvir(mu1,envir=envir))}}
nlp <- if(is.function(mu)){
		if(is.null(linear))length(attr(mu1,"parameters"))
		else length(attr(mu1,"parameters"))-1+npt1}
       else npt1
if(nlp!=npl)stop(paste("pmu should have",nlp,"initial estimates"))
if(any(is.na(mu1(pmu))))stop("The location model returns NAs: probably invalid initial values")
if(mdl==1)ext <- rep(1,nrows)
else if(mdl==3)ext <- rep(1,my+1)
if(mdl==3)resp <- NULL
else resp <- matrix(as.integer(y==1),ncol=1)
block <- NULL
pwt <- matrix(as.integer(y<3),ncol=1,nrow=nrows)
for(i in 2:my){
	resp <- cbind(resp,as.integer(y<=i))
	block <- cbind(block,as.integer(c(rep(0,nrows*(i-1)),
		rep(1,nrows),rep(0,nrows*(my-i)))))
	pwt <- cbind(pwt,as.integer(y<i+2))}
if(mdl!=1)resp <- 1-resp
if(mdl!=3){
	resp <- as.vector(resp)
	pwt <- as.vector(pwt)}
else pwt <- rep(1,length(y))
if(!is.null(wt)){
	if(!is.vector(wt,mode="numeric"))stop("wt must be a vector")
	else if(length(wt)!=nrows)stop(paste("wt must have length",nrows))
	if(mdl==3)pwt <- wt
	else pwt <- rep(wt,my)*pwt}
p <- c(pmu,pintercept)
np <- length(p)
if(mdl==3){
	if(fscale==1)fscale <- lf3(p)
	if(is.na(lf3(p)))stop("Likelihood returns NAs: probably invalid initial values")
	z <- nlm(lf3, p, hessian=T, print.level=print.level,
		typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
		steptol=steptol, iterlim=iterlim, fscale=fscale)}
else {
	if(fscale==1)fscale <- lf(p)
	if(is.na(lf(p)))stop("Likelihood returns NAs: probably invalid initial values")
	z <- nlm(lf, p, hessian=T, print.level=print.level,
		typsiz=typsiz, ndigit=ndigit, gradtol=gradtol, stepmax=stepmax,
		steptol=steptol, iterlim=iterlim, fscale=fscale)}
maxlike <- z$minimum
a <- qr(z$hessian)
if(a$rank==np)cov <- solve(z$hessian)
else cov <- matrix(NA,ncol=np,nrow=np)
se <- sqrt(diag(cov))
corr <- cov/(se%o%se)
dimnames(corr) <- list(1:np,1:np)
if(!is.null(mu2))mu1 <- mu2
if(!is.null(lin1a))linear <- lin1a
z1 <- list(
   call=call,
   distribution=distribution,
   wt=wt,
   maxlike=maxlike,
   aic=maxlike+np,
   mu=mu1,
   linear=linear,
   coefficients=z$estimate[1:npl],
   np=np,
   npl=npl1-1,
   nrows=nrows,
   intercept=z$estimate[npl1:np],
   cov=cov,
   corr=corr,
   se=se,
   iterations=z$iter,
   code=z$code)
class(z1) <- "nordr"
z1}

print.nordr <- function(z, digits = max(3, .Options$digits - 3)){
	m <- z$states
	cat("\nCall:",deparse(z$call),sep="\n")
	cat("\n")
	cat(z$distribution,"model\n\n")
	if(z$code>2)cat("Warning: no convergence - error",z$code,"\n\n")
	cat("-Log likelihood   ",z$maxlike,"\n")
	cat("AIC               ",z$aic,"\n")
	cat("Iterations        ",z$iterations,"\n")
	cat("\nLocation coefficients\n")
	if(inherits(z$mu,"formulafn")){
		cat("Location function:\n")
		if(!is.null(attr(z$mu,"formula")))cat(deparse(attr(z$mu,"formula")),sep="\n")
		else if(!is.null(attr(z$mu,"model"))){
			t <- deparse(attr(z$mu,"model"))
			t[1] <- sub("expression\\(","",t[1])
			t[length(t)] <- sub("\\)$","",t[length(t)])
			cat(t,sep="\n")}
		if(inherits(z$linear,"formulafn"))
			cat("Linear part: ",deparse(attr(z$linear,"formula")),sep="\n")}
	cname <- if(is.matrix(attr(z$mu,"model")))colnames(attr(z$mu,"model"))
		else if(length(grep("linear",attr(z$mu,"parameters")))>0)
		attr(z$mu,"parameters")[grep("\\[",attr(z$mu,"parameters"))]
		else attr(z$mu,"parameters")
	if(!is.null(z$linear)&&!is.null(attr(z$linear,"parameters")))
		cname <- c(colnames(attr(z$linear,"model")),cname)
	coef.table <- cbind(z$coef,z$se[1:z$npl])
	dimnames(coef.table) <- list(cname,c("estimate","s.e."))
	print.default(coef.table, digits=digits, print.gap=2)
	cat("\nIntercept coefficients\n")
	coef.table <- cbind(z$intercept,z$se[(z$npl+1):z$np])
	dimnames(coef.table) <- list(paste("b[",2:(z$np-z$npl+1),"]",sep=""),
			     c("estimate","s.e."))
	print.default(coef.table, digits=digits, print.gap=2)
	cat("\nCorrelation matrix\n")
	print.default(z$corr, digits=digits)
}
#
#  gnlm : A Library of Special Functions for Nonlinear Regression
#  Copyright (C) 1998 J.K. Lindsey
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#  SYNOPSIS
#
#     rs2(y, x1, x2, power=c(1,1), weight=rep(1,length(x1)),
#	family=normal, iterlim=20)
#     rs3(y, x1, x2, x3, power=c(1,1,1), weight=rep(1,length(x1)),
#	family=normal, iterlim=20)
#
#  DESCRIPTION
#
#    A function to fit two- and three-covariate power-transformed
# response surface models for glms (Box-Tidwell transformation)

rs2 <- function(y, x1, x2, power=c(1,1), weight=rep(1,length(x1)),
	family=normal, iterlim=20){
	if(length(power)!=2)
		stop("Two estimates of power parameters must be supplied\n")
	if(any(c(x1,x2)<0))stop("All covariates must be non-negative")
	a <- power[1]
	b <- power[2]
	test <- T
	i <- 0
	while(test){
		xx1 <- x1^a
		xx2 <- x2^b
		u <- glm(y~xx1+xx2+I(xx1^2)+I(xx2^2)+xx1:xx2,family=family,
			weight=weight)
		z1 <- (u$coef[2]*xx1+2*u$coef[4]*xx1^2+u$coef[6]*xx1*xx2)*
			log(ifelse(x1==0,1,x1))
		z2 <- (u$coef[3]*xx2+2*u$coef[5]*xx2^2+u$coef[6]*xx1*xx2)*
			log(ifelse(x2==0,1,x2))
		if(any(is.na(c(z1,z2))))stop(paste("NAs in calculating estimates:",a,b))
		u <- glm(y~xx1+xx2+I(xx1^2)+I(xx2^2)+xx1:xx2+z1+z2,
			family=family,weight=weight)
		a <- a+u$coef[6]
		b <- b+u$coef[7]
		if(any(is.na(c(a,b))))stop(paste("NAs in calculating estimates:",a,b))
		i <- i+1
		test <- ((u$coef[6]^2>0.00001)||(u$coef[7]^2>0.00001))&&(i<iterlim)}
	z <- glm(y~xx1+xx2+I(xx1^2)+I(xx2^2)+xx1:xx2,family=family,
		weight=weight)
	z$df.residual <- z$df.residual-2
	z$aic <- z$aic+4
	z$powers <- c(a,b)
	z$iterations <- i
	class(z) <- c("rs",class(z))
	return(z)}

rs3 <- function(y, x1, x2, x3, power=c(1,1,1), weight=rep(1,length(x1)),
	family=normal, iterlim=20){
	if(length(power)!=3)
		stop("Three estimates of power parameters must be supplied\n")
	if(any(c(x1,x2,x3)<0))stop("All covariates must be non-negative")
	a <- power[1]
	b <- power[2]
	d <- power[3]
	test <- T
	i <- 0
	while(test){
		xx1 <- x1^a
		xx2 <- x2^b
		xx3 <- x3^d
		xx12 <- xx1*xx2
		xx13 <- xx1*xx3
		xx23 <- xx2*xx3
		u <- glm(y~xx1+xx2+xx3+I(xx1^2)+I(xx2^2)+I(xx3^2)+
			xx12+xx13+xx23,family=family,weight=weight)
		z1 <- (u$coef[2]*xx1+2*u$coef[5]*xx1^2+u$coef[8]*xx12+
			+u$coef[9]*xx13)*log(ifelse(x1==0,1,x1))
		z2 <- (u$coef[3]*xx2+2*u$coef[6]*xx2^2+u$coef[8]*xx12+
			u$coef[10]*xx23)*log(ifelse(x2==0,1,x2))
		z3 <- (u$coef[4]*xx2+2*u$coef[7]*xx2^2+u$coef[9]*xx13+
			u$coef[10]*xx23)*log(ifelse(x3==0,1,x3))
		if(any(is.na(c(z1,z2,z3))))stop(paste("NAs in calculating estimates:",a,b,d))
		u <- glm(y~xx1+xx2+xx3+I(xx1^2)+I(xx2^2)+I(xx3^2)+
			xx12+xx13+xx23+z1+z2+z3,family=family,weight=weight)
		a <- a+u$coef[11]
		b <- b+u$coef[12]
		d <- d+u$coef[13]
		if(any(is.na(c(a,b,d))))stop(paste("NAs in calculating estimates:",a,b,d))
		i <- i+1
		test <- ((u$coef[11]^2>0.00001)||(u$coef[12]^2>0.00001)||
			(u$coef[13]^2>0.00001))&&(i<iterlim)}
	z <- glm(y~xx1+xx2+xx3+I(xx1^2)+I(xx2^2)+I(xx3^2)+xx12+xx13+xx23,
		family=family,weight=weight)
	z$df.residual <- z$df.residual-3
	z$aic <- z$aic+6
	z$powers <- c(a,b,d)
	z$iterations <- i
	class(z) <- c("rs",class(z))
	return(z)}

print.rs <- function(z,...){
	cat("\nPowered transformed response surface\n\n")
	cat("Powers:",z$powers,"\n")
	cat("Iterations:",z$iterations,"\n")
	print.glm(z,...)}

print.summary.rs <- function(z,...){
	cat("\nPowered transformed response surface\n\n")
	cat("Powers:",z$powers,"\n")
	cat("Iterations:",z$iterations,"\n")
	print.summary.glm(z,...)}

summary.rs <- function(z,...){
	zz <- summary.glm(z,...)
	class(zz) <- c("summary.rs",class(zz))
	if(!is.null(z$powers))zz$powers <- z$powers
	if(!is.null(z$iterations))zz$iterations <- z$iterations
	zz}
