.packageName <- "mixreg"
aux1 <- function(gma,k,l) {
#
# Auxilliary function to calculate the n-x-n matrix whose (i,j)-th
# entry is E[delta(z_i,k)*delta(z_j,l)] which is equal to
# gamma_{ik}*gamma_{jl} if i != j and is equal to
# delta(k,l)*gamma_{ik} if i == j.
#

gk <- gma[,k]
gl <- gma[,l]
rslt <- gk%o%gl
diag(rslt) <- if(k==l) gk else 0
rslt

}
aux2 <- function(t11,t12,t13,t21,t22,t23,t31,t32,t33) {
#
# Auxilliary function to pack the bits and pieces of
# info2 into a matrix.
#
	rslt <- cbind(rbind(t11,t21),c(t12,t22))
	if(!is.null(t13)) {
		rslt <- cbind(rslt,c(t13,t23))
		if(is.null(t31)) return(rslt)
		else return(rbind(rslt,c(t31,t32,t33)))
	}
	if(is.null(t31)) return(rslt)
	rbind(rslt,c(t31,t32))
}
aux3 <- function(m,ind)
{
#
# Auxilliary function to re-structure the information matrix
# in the case where the variances of all components are constrained
# to be equal.
#
x <- apply(m[,ind],1,sum)
s <- sum(x[ind])
y <- x[-ind]
r <- m[-ind,-ind]
rbind(cbind(r,y),c(y,s))
}
boot.sam <- function(mu,resid,prob) {
#
# Function boot.sam to draw a bootstrap sample from the (multiple)
# residuals of a mixture of regressions model.
#
# Think of the model as follows:  Marbles are labelled 1, 2, ..., n;
# each marble contains a set of pairs (j, eps_j) for j = 1, 2, ..., k
# where k is the number of components.  Each pair is labelled with a
# probability p_j, with p_1 + ... + p_k = 1 of course.  To form y_i^*
# choose a marble with probability 1/n; then choose a pair with
# probability p_j.  Then set y_i^* = mu_ij + eps_j.
#

nc  <- ncol(mu)
n   <- nrow(mu)
if(nc==1) return(drop(mu+sample(resid,n,T)))

ii  <- sample(1:n,n,T)
jj  <- apply(prob[ii,],1,function(x,k){sample(1:k,1,prob=x)},nc)
drop(mu[cbind(1:n,jj)] + resid[cbind(ii,jj)])

}
bootcomp <- function(x,y,ncomp=2,ncincr=1,intercept=TRUE,nboot=1000,
		     ts1=NULL,ts2=NULL,sem.par=FALSE,verb=FALSE,
                     print.prog=TRUE,...)
{
#
# Function bootcomp to test for K versus K+INCR components in
# a mixture of linear regressions (with normal errors) via
# a bootstrap distribution for the likelihood ratio statistic.
# (NOTE:  This statistic DOES NOT have a chi-squared-nu
# distribution!!!) (Where --- irrelevantly --- nu is the number of
# parameters for any one component, equal to p+2 where
# p is the number of linear parameters in each component.)
#
# Screw-ups: 0 <--> bailed out, n components;
#            1 <--> didn't converge, n components;
#            2 <--> bailed out, n+ncincr components;
#            3 <--> didn't converge, n+ncincr components;
#            4 <--> lrs(n) > lrs(n+ncincr).

obj1 <- mixreg(x,y,ncomp=ncomp,intercept=intercept,
               theta.start=ts1,verb=verb,...)
obj2 <- mixreg(x,y,ncomp=ncomp+ncincr,intercept=intercept,
               theta.start=ts2,verb=verb,...)
theta1 <- obj1$theta
theta2 <- obj2$theta

if(sem.par) {
	m     <- matrix(unlist(theta1),ncol=length(theta1))
	nr    <- nrow(m)
	m     <- m[-c(nr-1,nr),]
	mu    <- if(intercept) cbind(1,x)%*%m else x%*%m
	resid <- y-mu
	prob  <- if(intercept)
			gfun(cbind(1,x),y,theta1)$gamma
		else
			gfun(x,y,theta1)$gamma
}

rslt <- list()
screw.ups <- list()
aic1 <- list()
aic2 <- list()
k <- 0
for(i in 1:nboot) {
	repeat {
		save.seed <- .Random.seed
		yboot <- if(sem.par) boot.sam(mu,resid,prob)
			        else simmix(theta1,intercept,x)$y
		tmp <- mixreg(x,yboot,ncomp=ncomp,theta.start=theta1,
                              intercept=intercept,verb=verb,...)
		l1 <- tmp$log.like
		a1 <- tmp$aic
		if(!tmp$converged) {
			k <- k+1
			if(is.na(l1)) screw.ups[[k]] <- list(seed=save.seed,
                                                             i=i,type=0)
			else screw.ups[[k]] <- list(seed=save.seed,i=i,type=1)
			next
                }
		tmp <- mixreg(x,yboot,ncomp=ncomp+ncincr,theta.start=theta2,
                              intercept=intercept,verb=verb,...)
		l2  <- tmp$log.like
		a2  <- tmp$aic
		if(!tmp$converged) {
			k <- k+1
			if(is.na(l2)) screw.ups[[k]] <- list(seed=save.seed,
                                                             i=i,type=2)
                        else screw.ups[[k]] <- list(seed=save.seed,i=i,type=3)
			next
                }
		if(l1 > l2) {
			k <- k+1
                        screw.ups[[k]] <- list(seed=save.seed,i=i,type=4)
                        next
		} else break
	}
	rslt[[i]] <- 2*(l2-l1)
	aic1[[i]] <- a1
	aic2[[i]] <- a2
	if(print.prog) cat(i,'\n')
}

rslt <- sort(unlist(rslt))
lrs  <- 2*(obj2$log.like-obj1$log.like)
pval <- sum(lrs<=rslt)/nboot
if(length(screw.ups) > 0) {
	seeds <- matrix(unlist(lapply(screw.ups,function(x){x[[1]]})),
                        byrow=TRUE,nrow=length(screw.ups))
	times <- unlist(lapply(screw.ups,function(x){x[[2]]}))
	types <- unlist(lapply(screw.ups,function(x){x[[3]]}))
	scrps <- list(seeds=seeds,times=times,types=types)
}
else scrps <- NULL
df <- ncincr*length(theta1[[1]])
xxx <- list(lrs=lrs,pval.boot=pval,lrs.boot=rslt,unlist(aic1),unlist(aic2),
            screw.ups=scrps,df=df)
names(xxx)[4] <- paste('aic',ncomp,sep='.')
names(xxx)[5] <- paste('aic',ncomp+ncincr,sep='.')
xxx
}
cband <- function(object,cov.mat,x,y,alpha=0.05,xlen=100,plotit=FALSE,
                  type=NULL) {
#
# Function cband.  To do the calculations to provide 100(1-alpha)%
# confidence bands and prediction bands for a mixture of
# regressions model.
#

if(dim(as.matrix(x))[2] != 1)
	stop('Can do conf. bands for 1-var. regression only.')

theta  <- object$theta
K      <- length(theta)
int    <- object$intercept
eq.var <- object$eq.var

dimsok <- all(unlist(lapply(theta,function(x){length(x$beta)}))==1+int)
if(!dimsok) {
	cat('Values for beta are of wrong length for\n')
	cat('the dimension of the predictors.\n')
	stop('Bailing out.')
}

cdim <- length(unlist(theta)) - 1
if(eq.var) cdim <- cdim - K + 1
if(cdim != nrow(cov.mat)) {
	cat('The dimension of cov.mat is incompatible with\n')
	cat('the parameter values in object.\n')
	stop('Bailing out.')
}

if(is.null(type)) type <- 'both'
alpha.use <- if(type=='both') alpha/2 else alpha

xf <- if(int) cbind(1,seq(min(x),max(x),length=xlen))
	else
		as.matrix(seq(min(x),max(x),length=xlen))
tv <- qnorm(1-alpha.use)

do.up <- switch(type,both=TRUE,upper=TRUE,lower=FALSE)
if(is.null(do.up)) {
	cat('Argument type must be one of upper, lower, or both.\n')
	stop('Bailing out.')
}
do.dn <- switch(type,both=TRUE,upper=FALSE,lower=TRUE)
bnds <- list()
for(k in 1:K) {
	beta <- theta[[k]]$beta
	if(eq.var)
		ind  <- if(int) 3*(k-1) + 1:2 else 2*(k-1) + 1
	else
		ind  <- if(int) 4*(k-1) + 1:2 else 3*(k-1) + 1
	yf   <- xf%*%beta
	vf   <- apply(xf*(xf%*%cov.mat[ind,ind]),1,sum)
	ucb  <- if(do.up) yf + tv*sqrt(vf) else NULL
	lcb  <- if(do.dn) yf - tv*sqrt(vf) else NULL
	upb  <- if(do.up) yf + tv*sqrt(theta[[k]]$sigsq + vf) else NULL
	lpb  <- if(do.dn) yf - tv*sqrt(theta[[k]]$sigsq + vf) else NULL
	bnds[[k]] <- cbind(lcb,ucb,lpb,upb)
}

if(int) xf <- xf[,2] else xf <- c(xf)
rslt <- list(theta=theta,intercept=int,x=x,y=y,xf=xf,bnds=bnds,
             type=type,alpha=alpha)
class(rslt) <- 'cband'
if(plotit) {
	plot(rslt)
	return(invisible(rslt))
} else return(rslt)
}
covmix <- function(object,x,y) {
#
# Function covmix.  To calculate the covariance matrix of the
# parameter estimates produced by mixreg().
#

theta <- object$theta
K <- length(theta)
intercept <- object$intercept
eq.var <- if(is.null(object$eq.var)) FALSE else object$eq.var
x <- as.matrix(x)
bnms <- dimnames(x)[[2]]
if(is.null(bnms)) bnms <- paste('beta',1:ncol(x),sep='')
if(intercept) {
	x <- cbind(1,x)
	bnms <- c('Int',bnms)
}
dimsok <- all(unlist(lapply(theta,function(x){length(x$beta)}))==ncol(x))
if(!dimsok) {
	cat('The values for beta are of wrong length for\n')
	cat('the dimension of the predictors.\n')
	stop('Bailing out.')
}

g      <- gfun(x,y,theta)$gamma
info.1 <- info1(x,y,theta,g)
info.2 <- info2(x,y,theta,g)

nms   <- c(outer(c(bnms,'sigsq','lambda'),1:K,paste,sep='.'))
nms   <- nms[-length(nms)]
finfo <- info.1-info.2
if(eq.var) {
	p     <- length(bnms) + 2
	ind   <- (1:K)*p - 1
	nms   <- c(nms[-ind],'sigsq')
	finfo <- aux3(finfo,ind)
}

covmat <- solve(finfo)
dimnames(covmat) <- list(nms,nms)
covmat
}
dir.sum <- function(...)
{
# Function dir.sum.  To construct the direct sum of an arbitrary
# number of matrices.
	x <- list(...)
	x <- x[!sapply(x, is.null)]
	if(length(x) == 0)
		return(NULL)
	repeat {
		if(length(x) == 1) {
			if(is.list(x[[1]]))
				x <- x[[1]]
			else return(x[[1]])
		}
		else break
	}
	a <- as.matrix(x[[1]])
	b <- do.call("Recall", x[-1])
	ma <- nrow(a)
	na <- ncol(a)
	mb <- nrow(b)
	nb <- ncol(b)
	m <- ma + mb
	n <- na + nb
	rslt <- matrix(0, m, n)
	rslt[1:ma, 1:na] <- a
	rslt[(ma + 1):m, (na + 1):n] <- b
	rslt
}
gfun <- function(x,y,theta) {
#
# Function gfun.  To calculate the probabilites gamma[i,j]
# that observation i corresponds to state j for the Gaussian model.
#

# Argument theta is a list of lists; theta[[j]] has
# components beta, sigsq, and lambda.

K      <- length(theta)
theta  <- matrix(unlist(theta),ncol=K)
nr     <- nrow(theta)
sigsq  <- theta[nr-1,]
lambda <- theta[nr,]
beta   <- theta[-c(nr-1,nr),]
n      <- nrow(x)

yhat   <- x%*%beta
fff    <- matrix(dnorm(t(y-yhat)/sqrt(sigsq)),K,n)/sqrt(sigsq)

hhh    <- t(lambda*fff)
ll     <- apply(hhh,1,sum)
list(gamma=hhh/ll,log.like=sum(log(ll)))
}
hatfun <- function(x,g)
{
	Q  <- x%*%solve(t(x)%*%(g*x))%*%t(g*x)
	1 + diag(t(Q)%*%Q - Q - t(Q))
}
info1 <- function(x,y,theta,gma) {
#
# Note: The matrix x includes the column of 1's corresponding
# to the intercept term if an intercept is being fitted.
#
tmp <- list()
K   <- length(theta)
cK  <- sum(gma[,K])/theta[[K]]$lambda**2
po  <- function(a,b) {
	array(apply(b,2,"*",a), dim=c(dim(a),dim(b)[2]))
	}
tmp <- list()
for(k in 1:K) {
	bk <- theta[[k]]$beta
	vk <- theta[[k]]$sigsq
	lk <- theta[[k]]$lambda
	rk <- drop(y - x%*%bk)
# beta-beta:
	tmp1 <- -apply(gma[,k]*po(x,x),c(2,3),sum)/vk
# sigsq-sigsq:
	tmp2 <- -as.matrix(0.5*sum(gma[,k])/vk**2)
# lambda-lambda:
	tmp3 <- if(k < K) -as.matrix((sum(gma[,k])/lk**2 + cK)) else NULL
	tmp[[k]] <- dir.sum(tmp1,tmp2,tmp3)
}
#
# Note all ``cross terms'' are 0; beta-lambda and sigsq-lambda obviously
# so; sigsq-beta because the expression is essentially the sum of
# the weights times x times the residuals which is (linear algebra) 0.
#
rslt <- dir.sum(tmp)

ind <- (ncol(x)+2)*(1:(K-1))
n   <- length(ind)
m   <- cbind(rep(ind,n),rep(ind,rep(n,n)))
m   <- m[m[,1]!=m[,2],]
rslt[m] <- -cK

-rslt
}
info2 <- function(x,y,theta,gma) {
#
# Note: The matrix x includes the column of 1's corresponding
# to the intercept term if an intercept is being fitted.
#

K    <- length(theta)
lK   <- theta[[K]]$lambda
gKK  <- aux1(gma,K,K)
pp1  <- ncol(x) + 1
pp2  <- pp1 + 1
nd   <- K*pp2-1
rslt <- matrix(NA,nd,nd)
for(j in 1:K) {
	tj <- theta[[j]]
	bj <- tj$beta
	sj <- tj$sigsq
	lj <- tj$lambda
	rj <- drop(y - x%*%bj)
	mj <- rj*x/sj
	vj <- 0.5*(rj**2/sj-1)/sj
	gjK  <- aux1(gma,j,K)
	for(k in j:K) {
		tk <- theta[[k]]
		bk <- tk$beta
		sk <- tk$sigsq
		lk <- tk$lambda
		rk <- drop(y - x%*%bk)
		mk <- rk*x/sk
		vk <- 0.5*(rk**2/sk-1)/sk
		gjk  <- aux1(gma,j,k)
		gkK  <- aux1(gma,k,K)
# beta-beta:
		t11 <- t(mj)%*%gjk%*%mk
# sigsq-beta:
		t21 <- drop(vj%*%gjk%*%mk)
# beta-sigsq:
		t12 <- drop(vk%*%t(gjk)%*%mj)
# sigsq-sigsq:
		t22 <- sum(gjk*vj%o%vk)
		if(j < K) {
# lambda-beta:
			t31 <- apply(gjk%*%mk,2,sum)/lj -
					apply(t(gkK)%*%mk,2,sum)/lK
# lambda-sigsq:
			t32 <- sum(gjk%*%vk)/lj - sum(vk%*%gkK)/lK
		}
		else t31 <- t32 <- NULL
		if(k < K) {
# beta-lambda:
			t13 <- apply(t(gjk)%*%mj,2,sum)/lk -
					apply(t(gjK)%*%mj,2,sum)/lK
# sigsq-lambda:
			t23 <- sum(t(gjk)%*%vj)/lk - sum(vj%*%gjK)/lK
		}
		else t13 <- t23 <- NULL
# lambda-lambda:
		t33 <- if(k < K && j < K)
			sum(gjk)/(lj*lk) - sum(gjK)/(lj*lK) -
				sum(gkK)/(lk*lK) + sum(gKK)/(lK*lK)
			else
				NULL

		tmp <- aux2(t11,t12,t13,t21,t22,t23,t31,t32,t33)
		indj <- if(j < K) (j-1)*pp2 + (1:pp2) else (j-1)*pp2 + (1:pp1)
		indk <- if(k < K) (k-1)*pp2 + (1:pp2) else (k-1)*pp2 + (1:pp1)
		rslt[indj,indk] <- tmp
		if(j!=k) rslt[indk,indj] <- t(tmp)
	}
}
rslt
}
init.rand <- function(x,y,K,intercept) {
#
# Function init.rand.  To form starting values for the EM
# algorithm, randomly.
#

tmp <- lm(y~x-1)
ccc <- coef(tmp)
ncc <- length(ccc)
sdc <- 0.3*(abs(ccc))
vvv <- summary(tmp)$sigma**2
lll <- 1/K

rslt <- list()
for(j in 1:K) {
	cft <- rnorm(ncc,ccc,sdc)
	rslt[[j]] <- list(beta=cft,sigsq=vvv,lambda=lll)
}
rslt
}
mixreg <- function(x,y,ncomp=2,intercept=TRUE,eq.var=FALSE,theta.start=NULL,
                   itmax=1000,eps=1e-6,verb=TRUE,digits=7,
                   max.try=5,data.name=NULL) {
#
# Function mixreg.  To fit a mixture of regression models using the
# EM algorithm.
#

# Worry about names.
x <- as.matrix(x)
bnms <- dimnames(x)[[2]]
if(is.null(bnms)) bnms <- paste('beta',1:ncol(x),sep='')
if(intercept) {
	x <- cbind(1,x)
	bnms <- c('Int',bnms)
} else x <- as.matrix(x)

if(is.null(data.name)) {
	ynm <- deparse(substitute(y))
	xnm <- deparse(substitute(x))
	data.name <- paste(ynm,xnm,sep='.on.')
}

# Get starting values; if these are not supplied they are
# basically generated at random; it is HIGHLY recommended that
# they be supplied.  I.e. a reasonable starting guess is ususally
# vital for a reasonable outcome.
K         <- ncomp
theta.old <- if(is.null(theta.start))
		init.rand(x,y,K,intercept) else theta.start
dimsok <- all(unlist(lapply(theta.old,function(x){length(x$beta)}))==ncol(x))
if(!dimsok) {
	cat('Starting values for beta are of wrong length for\n')
	cat('the dimension of the predictors.\n')
	stop('Bailing out.')
}

# Sort the initial parameter list according to the first regression
# coefficient, with the largest coefficient coming first.
tmp <- matrix(unlist(theta.old),byrow=TRUE,nrow=K)
i   <- if(intercept) 2 else 1
ind <- rev(order(tmp[,i]))
theta.old <- theta.old[ind]

# Iterate:
em.step <- 0
ntry    <- 1
theta   <- list()
sigzero <- .Machine$double.eps
repeat {
	restart <- FALSE
	em.step <- em.step + 1
	gma <- gfun(x,y,theta.old)$gamma
	lma <- apply(gma,2,mean)
	if(eq.var) sigsq <- 0
	sing <- FALSE
	for(k in 1:K) {
		nzw  <- sum(gma[,k] > sigzero)
		if(nzw > ncol(x)) {
			tmp <- lm(y ~ x - 1,weights=gma[,k])
			ccc  <- coef(tmp)
			names(ccc) <- NULL
			yhat <- fitted(tmp)
			vvv  <- sum(gma[,k]*(y-yhat)**2)
			if(eq.var) {
				sigsq <- sigsq + vvv
                		theta[[k]] <- list(beta=ccc,
                                                   sigsq=NA,lambda=lma[k])
				next
			}
			else vvv  <- vvv/sum(gma[,k])
			if(vvv < sigzero) sing <- TRUE
		}
		else sing <- TRUE
		if(sing) {
			cat('Hit singularity in likelihood surface.\n')
			if(ntry <= max.try) {
				restart <- TRUE
				cat('Trying a new starting configuration.\n')
				ntry <- ntry+1
				em.step <- 0
				theta.old <- init.rand(x,y,K,intercept)
				break
			}
			else {
				cat('Too many tries; bailing out.\n')
				return(list(theta=NA,log.like=NA,
                                         intercept=intercept,nsteps=em.step,
                                         converged=FALSE,data.name=data.name))
			}
		}
		if(restart) break
                theta[[k]] <- list(beta=ccc,sigsq=vvv,lambda=lma[k])
	}
	if(restart) next
	if(eq.var) {
		sigsq <- sigsq/length(y)
		for(k in 1:K) theta[[k]]$sigsq <- sigsq
	}
	chnge   <- max(abs(unlist(theta)-unlist(theta.old)))
	if(verb) {
		cat(paste('     EM step ',em.step,':\n',sep=''))
                cat('     max abs. change in coef.: ',
                format(round(chnge,digits)),'\n',sep='')
	}
	if(chnge < eps) {
		converged <- TRUE
		break
	}
	if(em.step == itmax) {
                cat('Failed to converge in ',itmax,' EM steps.\n',sep='')
                converged  <- FALSE
                break
        }
	theta.old <- theta
}

# Wrap it up and quit:
ll     <- gfun(x,y,theta)$log.like
M      <- K*ncol(x) + K-1 + (if(eq.var) 1 else K)
aic    <- -2*ll + 2*M
parmat <- matrix(unlist(theta),byrow=TRUE,nrow=K)
dimnames(parmat) <- list(NULL,c(bnms,'sigsq','lambda'))
rslt <- list(parmat=parmat,theta=theta,log.like=ll,aic=aic,
             intercept=intercept,eq.var=eq.var,bnms=bnms,
             nsteps=em.step,converged=converged,data.name=data.name)
class(rslt) <- 'mixreg'
rslt
}
plot.cband <- function(x,cbands=TRUE,pbands=TRUE,
                       xlab=NULL,ylab=NULL,main=NULL,...) {
#
# Function plot.cband.  To plot data, fitted lines, confidence
# and prediction bands for a mixture of regressions.
# The argument ``x'' is as returned by the function cband().
#

y     <- x$y
xf    <- x$xf
bnds  <- x$bnds
type  <- x$type
theta <- x$theta
int   <- x$intercept
alpha <- x$alpha
x     <- x$x
K     <- length(theta)
ylim  <- range(c(y,unlist(bnds)),na.rm=TRUE)
xt    <- range(x)

i1 <- if(type=='both') 1:2 else 1
i2 <- if(type=='both') 3:4 else 2
if(is.null(main)) {
	tit <- if(type=='both')
		paste('Prediction and confidence bands, level = ',
                               100*(1-alpha),'%.',sep='')
	else if(type=='upper')
		paste('Upper prediction and confidence bands, level = ',
                              100*(1-alpha),'%.',sep='')
	else
		paste('Lower prediction and confidence bands, level = ',
            100*(1-alpha),'%.',sep='')
} else tit <- main
if(is.null(xlab)) xlab <- 'x'
if(is.null(ylab)) ylab <- 'y'

plot(0,0,type='n',xlim=range(x),ylim=ylim,xlab=xlab,ylab=ylab)
points(x,y)
for(j in 1:K) {
	beta <- theta[[j]]$beta
	yt  <- if(int) cbind(1,xt)%*%beta else beta*xt
	lines(xt,yt)
	if(cbands)
		for(i in i1) lines(xf,bnds[[j]][,i],lty=2)
	if(pbands)
		for(i in i2) lines(xf,bnds[[j]][,i],lty=3)
}
title(main=tit)

invisible()
}
plot.mresid <- function(x,vs.fit=FALSE,whichx=1,shape='disc',
                        ngon=20,size=1,xlab=NULL,...) {
	K      <- ncol(x$resid)
	resid  <- c(x$resid)
	gamma  <- c(x$gamma)
	if(vs.fit) {
		x <- x$y - resid
		if(is.null(xlab)) xlab <- 'fitted values'
	}
	else {
		x <- rep(as.matrix(x$x)[,whichx],K)
		if(is.null(xlab)) xlab <- 'x'
	}
	ishape <- pmatch(shape,c('disc','diamond','square'))
	if(is.na(ishape))
		stop(paste('Shape ',shape,' not recognized.',sep=''))
	plot(x,resid,type='n',xlab=xlab,ylab='residuals')
	uin  <- par()$uin # user units per inch
	if(ishape==1) {
		phi <- c(seq(0,2*pi,length=ngon),0)
		scale <- 0.03*size/uin
		sym <- list(x=cos(phi)*scale[1],y=sin(phi)*scale[2])
	} else if(ishape==2) {
		scale <- 0.03*size/uin
		sym <- list(x=c(1,0,-1,0,1)*scale[1],y=c(0,1,0,-1,0)*scale[2])
	} else {
		scale <- 0.03*size/(sqrt(2)*uin)
		sym <- list(x=c(1,-1,-1,1,1)*scale[1],y=c(1,1,-1,-1,1)*scale[2])
	}
	N <- length(x)
	for(i in 1:N) polygon(x[i] + sym$x*gamma[i],resid[i] +
                                     sym$y*gamma[i],...)
	invisible()
}
qq.mix <- function(object,xlim=NULL,ylim=NULL,shape='disc',ngon=20,size=1,...)
{
	K      <- ncol(object$resid)
	resid  <- c(object$resid)
	gamma  <- c(object$gamma)
	ind    <- order(resid)
	resid  <- resid[ind]
	gamma  <- gamma[ind]
	N      <- length(resid)
	x      <- qnorm((0.5+(1:N))/(N+1))

	ishape <- pmatch(shape,c('disc','diamond','square'))
	if(is.na(ishape))
		stop(paste('Shape ',shape,' not recognized.',sep=''))
	if(is.null(xlim)) xlim <- range(x)
	if(is.null(ylim)) ylim <- range(resid)
	plot(x,resid,type='n',xlim=xlim,ylim=ylim,
             xlab='normal quantiles',ylab='empirical quantiles')
	uin  <- par()$uin # user units per inch
	if(ishape==1) {
		phi <- c(seq(0,2*pi,length=ngon),0)
		scale <- 0.03*size/uin
		sym <- list(x=cos(phi)*scale[1],y=sin(phi)*scale[2])
	} else if(ishape==2) {
		scale <- 0.03*size/uin
		sym <- list(x=c(1,0,-1,0,1)*scale[1],y=c(0,1,0,-1,0)*scale[2])
	} else {
		scale <- 0.03*size/(sqrt(2)*uin)
		sym <- list(x=c(1,-1,-1,1,1)*scale[1],y=c(1,1,-1,-1,1)*scale[2])
	}
	N <- length(x)
	for(i in 1:N) polygon(x[i] + sym$x*gamma[i],resid[i] +
                                     sym$y*gamma[i],err=-1,...)
	invisible()
}
resid.mix <- function(object,x,y,std=FALSE)
{
	int <- object$intercept
	if(int) x <- cbind(1,x)
	theta <- object$theta
	K     <- length(theta)
	resid <- list()
	gamma <- gfun(x,y,theta)$gamma
	for(k in 1:K) {
		div <- if(std)
			sqrt(hatfun(x,gamma[,k])*theta[[k]]$sigsq)
		else 
			1
		resid[[k]] <- drop(y-x%*%theta[[k]]$beta)/div
	}
	rslt <- list(resid=matrix(unlist(resid),ncol=K),gamma=gamma,
                     x=if(int) drop(x[,-1]) else x,y=y)
	class(rslt) <- "mresid"
	rslt
}
simmix <- function(theta,intercept,x) {
#
# Function simmix.  To simulate data from a mixture of regressions
# model.
#

K      <- length(theta)
n      <- nrow(as.matrix(x))
theta  <- matrix(unlist(theta),ncol=length(theta))
nr     <- nrow(theta)
sigsq  <- theta[nr-1,]
lambda <- theta[nr,]
beta   <- theta[-c(nr-1,nr),]
yhat   <- if(intercept) cbind(1,x)%*%beta else x%*%beta
state  <- sample(1:K,n,TRUE,lambda)
yhat   <- yhat[n*(state-1)+(1:n)]
errr   <- rnorm(n,0,sqrt(sigsq[state]))

list(x=x,y=drop(yhat+errr))
}
