.packageName <- "npmlreg"
#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/alldist.R"
"alldist" <- 
 function(formula,
                    random=~1,
                    family = gaussian(),
                    data ,
                    k = 4,
                    random.distribution="np",
                    tol = 0.5,
                    offset,
                    weights,
                    pluginz,
                    na.action,
                    EMmaxit = 500,
                    EMdev.change = 0.001,
                    lambda = 0,
                    damp = TRUE,
                    damp.power = 1,
                    spike.protect = 0,
                    sdev,
                    shape,
                    plot.opt = 3,
                    verbose = TRUE,
                    ...)
{

  # R function alldist in package npmlreg.  NPML/GQ for overdispersed GLMs.
  # Type  ?npmlreg for licence, copyright, and version information.
  
  call <- match.call()
    if (is.character(family)) 
    family <- get(family, mode = "function", envir = parent.frame())
  if (is.function(family)) 
    family <- family()
  if (is.null(family$family)) {
    print(family)
    stop("`family' not recognized")
  }
   
  data <- as.data.frame(data)   #0.34-1
  ddim <- dim(data)
  mf   <- match.call(expand.dots = FALSE)
 
  # Test for inadmissibly removed intercept term
  if (k>1 && random.distribution=='np' && max(length(grep('- 1', deparse(formula(mf)))),length(grep('-1', deparse(formula(mf))))) >0 ){
      stop(" term '-1'  in model formula not supported for k>1 & random.distribution='np'. ")
  }

 
  # Test for incorrect offset specification in formula object
  testoffset<-try(is.null(attr(terms(formula(mf)),"offset")),silent=TRUE)
  if (!(class(testoffset)=="try-error" || testoffset)){
      stop("Please specify offset as separate argument outside the model formula.")
  }
  
  # Extract variables from call and set up initial (fixed effect) model
  m    <- match(c("formula", "data", "subset", "weights", "na.action", 
               "etastart", "mustart", "offset"), names(mf), 0)
  mf   <- mf[c(1, m)]
  mf$drop.unused.levels <- TRUE
  mf[[1]] <- as.name("model.frame")
  mf <- try(eval(mf,  parent.frame()), silent=TRUE)
  if (class(mf)=="try-error"){
      if (!missing(offset) && length(offset) != ddim[1]) {
      stop("Number of offsets is ", length(offset), ", should equal ", ddim[1], " (number of observations)")
      }
      if (!missing(weights) && length(weights) != ddim[1]){
      stop("Number of weights is ", length(weights), ", should equal ", ddim[1], " (number of observations)")
      }
      stop(geterrmessage())
  }
  offset  <- model.offset(mf) 
  weights <- model.weights(mf)
  X  <- Y <- XZ <- NULL
  Y  <- model.response(mf, "any") # response  # for 0.42 changed from "numeric to "any"
  Ym <- is.matrix(Y)
  N  <- NROW(Y)  # corresponds to ddim[1] if there are no missing values
  
  # Set up weights and offset for initial glm
  if (is.null(offset)){offset  <-rep(0,N) }
  if (is.null(weights)){weights<-rep(1,N)}   
  data$offset <- numeric(1); data$pweights<-numeric(1)
  data  <- if (is.matrix(Y)) data[dimnames(Y)[[1]],] else  data[names(Y),] # omit missing values   
  data$offset<-offset;  data$pweights<-weights

   
  # Extract variable names from random part 
  rform   <- random
  mform   <- strsplit(as.character(random)[2],'\\|')[[1]]
  mform   <- gsub(' ', '',mform)
  if (length(mform)==2){stop("Please use function allvc for two-level models")}
  if (random.distribution=='gq' && mform!="1"){stop("Random coefficient models are only supported for random.distribution='np'.")}
  
  
  # Initial fit and simple glm for k=1
  fit    <- glm(formula, family=family, weights=pweights, offset=offset, data=data,...)
  names0 <- dimnames(data)[[1]] 
  w0     <- fit$prior.weights  #store prior weights for output
  off0   <- fit$offset;   names(off0)<-names0   #store offset for output
  Y      <- fit$y  
  l0     <- length(fit$coef)
  tol0   <- tol # for main title of graphical output 
                      
  # For binomial models, check weights: case weights, or number of trials?
  if(family$family=="binomial"){
           data$pweights<- data$pweights^Ym         # these are the actual case weights
           YP<- binomial.expand(Y,1,w0/data$pweights)   # w0/data$pweights are the actual pop. sizes 
           Y<- YP[[1]]; PY<-YP[[2]];r<-YP[[3]]; n<-YP[[4]]                 
  } 
  
  # Initial estimates of  standard deviation and/or shape parameter (response distr.)       
  sdev.miss <- missing(sdev)
  shape.miss <-missing(shape)
  if (family$family=="gaussian"){
        sdev  <-  ifelse(sdev.miss, sqrt(summary(fit)$dispersion), sdev)
        shape <- 0
  } else if (family$family =="Gamma") {
         # Estimate sdev from residuals on linear predictor scale, see Einbeck & Hinde (2006):
        sdev  <- ifelse(sdev.miss, sqrt(switch(family$link,
                        "log"= sum(data$pweights*(log(Y)-log(fitted(fit)))^2)/(sum(data$pweights)),
                        "inverse"= sum(data$pweights*(1/Y-1/(fitted(fit)))^2)/(sum(data$pweights)),
                        "identity"= sum(data$pweights*(Y-fitted(fit))^2)/(sum(data$pweights)),
                        )), sdev) 
        shape <- ifelse(shape.miss,1/summary(fit)$dispersion, shape)
  } else {
        sdev  <- 1
        shape <- 0
  } 
 
  # Initial disparity (-2logL)
  ML.dev0 <- -2*sum(data$pweights*switch(family$family,
                "gaussian"= dnorm(fit$y, fitted(fit), sdev, log=TRUE),
                "poisson" = dpois(fit$y, fitted(fit), log=TRUE),
                "binomial"= dbinom(Y[,1],Y[,1]+Y[,2], fitted(fit),log=TRUE),
                "Gamma"   = dgamma(fit$y,  shape=shape, scale=fitted(fit)/shape, log=TRUE),
                ))

  # Return (glm) output and terminate if k=1  
  if (k == 1) {
      if (random.distribution=="np"){
            names(fit$coefficients) <- ifelse(names(fit$coefficients)=="(Intercept)", "MASS1", names(fit$coefficients))
      }
      fit <- c( fit[c(1,2,3,8,9)],
              disparity = ML.dev0,
              deviance = fit$dev,
              fit[c(12,16,17, 18)],
              call = call,  
              formula = formula,
              random = "none",
              data = list(subset(data,select=1:ddim[2])),
              model = list(model.matrix(fit)),
              weights = list(w0),
              offset = list(off0),
              mass.points = list(fit$coef[1]),
              masses = list(c("MASS1"=1)),
              sdev = list(list(sdev=sdev, sdevk=sdev)),
              shape = list(list(shape=shape,shapek=shape)),
              rsdev = 0,
              post.prob = list(matrix(1,N,1,dimnames=list(names0,"") )),
              post.int =  list(fit$coef[1]),
              ebp = list(family$linkfun(fit$fitted)),
              EMiter = 0,
              EMconverged = "none",
              lastglm = list(fit),
              Misc = list(list(lambda=lambda))
              )          
      if (random.distribution =="np"){
              class(fit) <- 'glmmNPML'
      } else {
             class(fit) <- 'glmmGQ'
      }
      return(fit)
  } else if (!(k %in% 1:600)){
      stop("This choice of k is not supported.")
  }

  # Omit integration point if GH weights are too small  
  tmp       <- gqz(k, minweight=1e-50)  # from version 0.39-1; changed to 1e-50 in v0.42
  k0        <- k  # from 0.42: save for glmmGQ output
  k         <- min(k, dim(tmp)[1])
  
  # Expand the data
  if(family$family=="binomial"){
      YP    <- binomial.expand(Y,k,rep(1,N)); Y<- YP[[1]]; PY<-YP[[2]];r<-YP[[3]]; n<-YP[[4]]
  }  else { 
      Y     <- rep(Y,k)
  }          
  datak     <- expand(data,k)
  kindex    <- rep(1:k,rep(N,k))# index for the mixtures, for version 0.31 or higher only used for allvc 
  #tmp       <- gqz(k,minweight=1e-55)  # omitted from version 0.39-1
  z0        <- -tmp$l
  z         <- rep(-tmp$l,rep(N,k))
  p         <- tmp$w
  offset    <- datak$offset
  pweights  <- datak$pweights

  # Generate the random design matrix and append to fixed matrix
  if (random.distribution=='np'){
      # Nonparametric random effect
      X <- model.matrix(formula,datak)[,-1,drop=FALSE]   
      datak$MASS <- gl(k,N) 
      if (mform=='1') {
        random <- formula(~MASS-1)
      } else {  
          # Nonparametric random coefficient
          random <- formula(paste('~ MASS + ',paste(mform,'MASS',sep=":",collapse='+'), '-1',sep=''))    
      }
  } else {
      X <- model.matrix(formula,datak)
      #if (mform=='1') {
      random <- formula(~ z - 1 )
      #} else { 
      #    stop("Random coefficients only supported with option random.distribution='np'")
      #} # 05/11/07
  }
  Z <- model.matrix(random,datak)
  if (dim(X)[1]!= dim(Z)[1]){ cat("The missing value routine cannot cope with this model. Please specify the random term also as fixed term and try again. " )}
  XZ <- cbind(X,Z)
  
  # Extend the linear predictor:
  if (missing(pluginz)){
      sz <- tol* sdev*z
  } else {
      if (length(pluginz)!=k){
        stop("pluginz needs to be a vector of length k.")  #30/09/09
      } else {
        sz <- rep(pluginz-fit$coef[[1]],rep(N,k))
      }
  }      
          
  Eta <- fit$linear.predictor + sz
           # The extra term stops unrelated regressions
           
  # Initial EM trajectory values 
  if (random.distribution=="np"){
      tol<- max(min(tol,1),1-damp)  #For tol >  1 or damp=F no Damping
      if(length(fit$coef)==1){
          followmass<-matrix(Eta[(1:k)*N],1,k)-offset[(1:k)*N]
      } else {
         followmass<-matrix(fit$coef[1]+sz[(1:k)*N],1,k)
      }
  } else {
      followmass<-NULL; tol<-1
  }
   
  # Expanded fitted values     
  Mu <- family$linkinv(Eta) 

  # Calculate loglikelihood for fixed model
  f <- switch(family$family,
              "gaussian" = dnorm(Y,Mu,tol*sdev,log=TRUE),
              "poisson"  = dpois(Y,Mu,log=TRUE),
              "binomial" = dbinom(r,n,Mu,log=TRUE),
              "Gamma"    = dgamma(Y,shape=shape/tol^2,scale=Mu*tol^2/shape ,log=TRUE),)
   

  # Calculate the weights from initial model
  tmp <-weightslogl.calc.w(p,matrix(f,ncol=k),pweights[1:N])
  w <- tmp$w
  
  # Initialize for EM loop
  ML.dev <- ML.dev0
  iter <- ml<- 1
  converged <- FALSE
  sdevk<-rep(sdev,k);  shapek<-rep(shape,k)
 
  ##########Start of EM ##########
  while (iter <= EMmaxit && (!converged || (iter<=9 && random.distribution=='np' && damp && (family$family=="gaussian" && sdev.miss || family$family=="Gamma"&& shape.miss)  ))){
      if (verbose){ cat(iter,"..") }

      # M-Step: Weighted GLM
      fit <- try(glm.fit(x=XZ, y=Y, weights = as.vector(w)*pweights, family = family, offset=offset, ...), silent=TRUE)
      if (class(fit)=="try-error"){
              stop("Singularity or Likelihood-Spike at iteration #",iter,". 
              Check model specification,  enable spike protection or smooth among components.")
      }
      
      #EM Trajectories   
      if (random.distribution=="np"){   
          masspoint<- fit$coef[l0:(l0+k-1)]
          followmass<-rbind(followmass, masspoint)
      }
   
      # Fitted response from current model
      Mu <- fitted(fit)
      
      # Unequal component dispersion parameters  
      if (family$family=="gaussian"){
          if (sdev.miss){ sdev<- sqrt(sum((as.vector(w)*pweights)*(Y-Mu)^2)/sum(as.vector(w)*pweights))}
          sdevk<-rep(sdev,k) 
          if (lambda!=0){
              for (l in 1:k){
                wk<-matrix(1,k,N); wk[1:k,]<-dkern(1:k,l,k,lambda);wk<-t(wk)
                sdevk[l] <-  sqrt(sum(wk* as.vector(w)*pweights *(Y-Mu)^2)/sum(wk*as.vector(w)*pweights))
              }
              sk<-rep(sdevk,rep(N,k))
          } else {
              sk<-sdev
          }
      }  else {
          sdevk <-rep(NA,k)
      }
      if (family$family=="Gamma"){
           if (shape.miss) { shape<-(sum(as.vector(w)*pweights))*1/sum(as.vector(w)*pweights*((Y-fitted(fit))/fitted(fit))^2)}
           shapek<-rep(shape,k) 
           if (lambda!=0){
                for (l in 1:k){
                  wk<-matrix(1,k,N); wk[1:k,]<-dkern(1:k,l,k,lambda);wk<-t(wk)
                  shapek[l] <- sum(wk*as.vector(w)*pweights)/ sum(wk* as.vector(w)*pweights*((Y-Mu)/Mu)^2)
                }
                shk<-rep(shapek,rep(N,k))
           } else {
                shk<-shape
           }
      } else {
           shapek<-rep(NA,k)
      }
      
      # Calculate loglikelihood for expanded model for this iteration
      f <- matrix(switch(family$family,
              "gaussian"=dnorm(Y,Mu,(1-(1-tol)^(damp.power*iter+1))*sk,log=TRUE),
              "poisson" =dpois(Y,Mu,log=TRUE),
              "binomial"=dbinom(r,n,Mu,log=TRUE),
              "Gamma"=dgamma(Y,shape=shk/(1-(1-tol)^(damp.power*iter+1))^2,scale=Mu*(1-(1-tol)^(damp.power*iter+1))^2/shk,log=TRUE),
              ),nrow=N, ncol=k)
              
       
      # Calculate the component proportions from the weights
      if (random.distribution=='np') {
          p <- as.vector(apply(w*pweights,2,sum))/sum(pweights[1:N]) #16-03-06
      }
             
      # E-Step: Update weights 
      tmp <- weightslogl.calc.w(p,f,pweights[1:N])
      w   <- tmp$w
      
      # Update disparity and check for convergence
      ML.dev[iter+1] <- ifelse(is.na(tmp$ML.dev), Inf, tmp$ML.dev)
      if (ML.dev[iter+1] > ML.dev0) {ml<-ml+1}  #only relevant for graphical output
      converged <- abs(ML.dev[iter+1] - ML.dev[iter])< EMdev.change
      iter <- iter + 1
      
      # Likelihood Spike Protection
      if (random.distribution != 'gq' && spike.protect!=0){
          if (family$family=='gaussian' && abs(min(sdevk/masspoint)) < 0.000001*spike.protect){break}  
          if (family$family=='Gamma' && abs(max(shapek/masspoint)) > 10^6*spike.protect){break}
      }  
  }###########################End of EM loop#############
 
 
  # Print on screen information on EM convergence
  if (verbose){
      cat("\n")
      if (converged){
          cat("EM algorithm met convergence criteria at iteration # ", iter-1,"\n")
      } else {
        cat("EM algorithm failed to meet convergence criteria at iteration # ",
        iter-1,"\n")  
      }
  }
  
  # Compute model deviance
  Deviance <- switch(family$family,
              "gaussian"= sdev^2*ML.dev[iter]-sdev^2* sum(data$pweights[1:N] * log(2*pi*sdev^2)),
              "poisson" = ML.dev[iter] +2*sum(data$pweights[1:N]*(-Y[1:N]+Y[1:N]*log(Y[1:N]+ (Y[1:N]==0))-lfactorial(Y[1:N]))),
              "binomial"= ML.dev[iter] +2*sum(data$pweights[1:N]*(lfactorial(n)-lfactorial(r)-lfactorial(n-r) - n*log(n) + r*log(r+(r==0))+(n-r)*log(n-r+((n-r)==0)))[1:N]),
              "Gamma"   = 1/shape*ML.dev[iter]+2/shape*(sum(data$pweights[1:N])*shape*(log(shape)-1)-sum(data$pweights[1:N])*lgamma(shape)-sum(data$pweights[1:N]*log(Y[1:N]))),
              )

  # Compute  posterior prob. etc. 
  mass.points   <- masses <- NULL
  np            <- length(fit$coef)
  ebp           <- apply(w*matrix(fit$linear.predictor,N,k,byrow=FALSE),1,sum)  # Emp. Bayes Pred. (Aitkin, 96)
  ebp.fitted    <- family$linkinv(ebp)
  ebp.residuals <- Y[1:N]- ebp.fitted
  names(ebp)    <- names(ebp.fitted) <- names(ebp.residuals) <- names0
  if (mform %in% substring(names(fit$coef),1, nchar(mform))){length(fit$coefficients) <- np <- np-1}# if one variable is random *and* fixed 
  # if (is.na(fit$coefficients[np])){length(fit$coefficients)<-np<-np-1}# replaced by the line above from 0.42 on
  m <- seq(1,np)[substr(attr(fit$coefficients,'names'),1,4)=='MASS']
  if (random.distribution=="np"){
      mass.points   <-  fit$coefficients[m] # from 0.42
  } else {  
      a <- ifelse(names(fit$coef[1])== "(Intercept)", fit$coef[1], 0) #02-08-06
      mass.points <- a + fit$coef["z"]*z0           # from 0.42, np replaced by "z"
  }
  post.prob     <- matrix(w, nrow=N, byrow=FALSE, dimnames=list(names0, 1:k) )
  post.int      <- as.vector(post.prob %*% mass.points[1:k]); names(post.int) <- names0

  # Write tol values as plot title if alldist is called from tolfind:
  if ((plot.opt==1 || plot.opt==2) && par("mfrow")[1]>2) { 
        plot.main <- substitute("tol"== tol0, list(tol0=tol0))
  } else {
        plot.main <- c("")
  }

  # Set up graphics device and plot disparity trend 
  if (plot.opt==3 && random.distribution=="np"){
      par(mfrow=c(2,1), cex=0.5, cex.axis=1.5, cex.lab=1.5)
  }
  if (plot.opt==1|| plot.opt==3){
      if  ((family$family=="gaussian" && sdev.miss|| family$family=="Gamma" && shape.miss) && damp  && random.distribution=='np' && iter>=max(8,ml+1)){
          # Linear interpolation for initial cycles
          ML.dev[2: max(7,ml)]<-ML.dev0+ 1:max(6,ml-1)/ max(7,ml)*(ML.dev[max(8,ml+1)]-ML.dev0) 
      }  
      plot(0:(iter-1),ML.dev, col=1,type="l",xlab='EM iterations',ylab='-2logL', main= plot.main )  
      if (verbose){ cat("Disparity trend plotted.\n")}
  }

  # Prepare output for glmmNPML objects
  if (random.distribution=="np") {
      
      # Mixture proportions 
      masses <- as.vector(apply(w*pweights,2,sum))/sum(pweights[1:N]) # 16-03-05
      names(masses) <- paste('MASS',1:k,sep='')
       
      # Estimate random effect standard deviation                  # from 0.42
      rsdev <- sqrt(sum(masses * (mass.points[1:length(masses)] - sum(masses*mass.points[1:length(masses)]) )^2))

      # Compute fixed part residuals
      if (family$family=="binomial"){
          R0 <- family$linkfun(PY[1:N])
      } else  {
          R0 <- family$linkfun(Y[1:N])
      }
      if(dim(X)[2]>0){
          R <- R0 - X[1:N,]%*%matrix(fit$coef[1:dim(X)[2]])-offset[1:N]
      } else {
          R <- R0 - offset[1:N]
      }
      R <-as.vector(R);  names(R) <- names0  
      
      # EM trajectory plot  
      if (mform=='1' && any(is.finite(R))){
           ylim <- c(min(R[is.finite(R)]), max(R[is.finite(R)]))  #29/06/2006
      } else  { 
            ylim <- c(min(followmass[,]),max(followmass[,]))
      }
      if(any(is.na(ylim)) &  plot.opt >1 ){
              cat("Singularity: EM Trajectory plot not available.", "\n");
              plot.opt<-min(plot.opt,1)
      }
      if (plot.opt==2|| plot.opt==3){
            plot(0:(iter-1),followmass[,1],col=1,type='l',ylim=ylim,ylab='mass points',xlab='EM iterations',  main=plot.main )
            for (i in 1:k){ lines(0:(iter-1), followmass[,i],col=i)
                        if (mform=='1'){ points(rep(iter-1,length(R)),R)}}
            if (verbose){ cat("EM Trajectories plotted.\n")}
      }
                 
      # glmmNPML output    
      fit <- c( fit[1],
                residuals = list(ebp.residuals),
                fitted.values = list(ebp.fitted),
                fit[c(8,9)],
                disparity = ML.dev[iter],
                deviance = Deviance,
                fit[12],  
                df.residual = N-np-k+1,
                df.null = N-1, 
                fit[18],
                call = call,
                formula = formula,
                random = rform,
                data = list(subset(data,select=1:ddim[2])),
                model = list(XZ),
                weights = list(w0),
                offset = list(off0),
                mass.points = list(mass.points),
                masses = list(masses),               
                sdev = list(list(sdev=sdev, sdevk=sdevk)),
                shape = list(list(shape=shape,shapek=shapek)),
                rsdev = list(rsdev),
                post.prob = list(post.prob),
                post.int = list(post.int),
                ebp = list(ebp),
                EMiter = iter - 1,
                EMconverged = converged,
                lastglm = list(fit),
                Misc = list(list(Disparity.trend=ML.dev,EMTrajectories=followmass,res=R,ylim=ylim, lambda=lambda,mform=mform))
            )
      class(fit) <- 'glmmNPML'
  
  } else {
      # glmmGQ output
      fit <- c( fit[1],
                residuals = list(ebp.residuals),
                fitted.values = list(ebp.fitted),
                fit[c(8,9)],
                disparity = ML.dev[iter],
                deviance = Deviance,
                fit[12],  
                df.residual = N - np,
                df.null = N - 1, 
                fit[18],
                call = call,
                formula = formula,
                random = rform,
                data = list(subset(data,select=1:ddim[2])),
                model = list(XZ),
                weights = list(w0),
                offset = list(off0), 
                mass.points = list(mass.points),
                masses = list(gqz(k0, minweight=1e-50)$w),          
                sdev = list(list(sdev=sdev, sdevk=sdevk)),
                shape = list(list(shape=shape,shapek=shapek)),
                rsdev = fit$coef[["z"]],
                post.prob = list(post.prob),
                post.int =  list(post.int),
                ebp = list(ebp),
                EMiter = iter - 1,
                EMconverged = converged,
                lastglm = list(fit),
                Misc = list(list(Disparity.trend=ML.dev, lambda=lambda, mform=mform))
           )
      class(fit) <- 'glmmGQ'       
  }
  fit
}
#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/allvc.R"
"allvc" <-
function(formula,
                    random=~1,
                    family = gaussian(),
                    data,
                    k = 4,
                    random.distribution="np",
                    tol = 0.5,
                    offset,
                    weights,
                    pluginz,
                    na.action,
                    EMmaxit=500,
                    EMdev.change=0.001,
                    lambda=0,
                    damp=TRUE,
                    damp.power=1,
                    spike.protect=0,
                    sdev,
                    shape,
                    plot.opt=3,
                    verbose=TRUE,
                    ...)
{
  # R function allvc in package npmlreg.  NPML/GQ for variance component models.
  # Type  ?npmlreg for licence, copyright, and version information.

  call <- match.call()
  if (is.character(family))
      family <- get(family, mode = "function", envir = parent.frame())
  if (is.function(family))
    family <- family()
  if (is.null(family$family)) {
    print(family)
    stop("`family' not recognized")
  }
  
  data  <-as.data.frame(data)
  ddim  <-dim(data)
  mf    <- match.call(expand.dots = FALSE)
  
  #  Test for inadmissibly removed intercept term
  if (k>1 && random.distribution=='np' && max(length(grep('- 1', deparse(formula(mf)))),length(grep('-1', deparse(formula(mf))))) >0 ){
      stop(" term '-1'  in model formula not supported for k>1 & random.distribution='np'. ")
  }
   
  # Test for incorrect offset specification in formula object
  testoffset<-try(is.null(attr(terms(formula(mf)),"offset")),silent=TRUE)
  if (!(class(testoffset)=="try-error" || testoffset)){
      stop("Please specify offset as separate argument outside the model formula.")
  }
  
  # Extract variables from call and set up initial (fixed effect) model
  m    <- match(c("formula", "data", "subset", "weights", "na.action", 
               "etastart", "mustart", "offset"), names(mf), 0)
  mf   <- mf[c(1, m)]
  mf$drop.unused.levels <- TRUE
  mf[[1]] <- as.name("model.frame")
  mf <- try(eval(mf,  parent.frame()), silent=TRUE)
  if (class(mf)=="try-error"){
      if (!missing(offset) && length(offset) != ddim[1]) {
      stop("Number of offsets is ", length(offset), ", should equal ", ddim[1], " (number of observations)")
      }
      if (!missing(weights) && length(weights) != ddim[1]){
      stop("Number of weights is ", length(weights), ", should equal ", ddim[1], " (number of observations)")
      }
      stop(geterrmessage())
  }
  offset  <- model.offset(mf) 
  weights <- model.weights(mf)
  X  <- Y <- XZ <- NULL
  Y  <- model.response(mf, "any") # response # for 0.42 changed from "numeric to "any"
  Ym <- is.matrix(Y)
  N  <- NROW(Y)  # corresponds to ddim[1] if there are no missing values
  
  # Set up weights and offset  for initial glm
  if (is.null(offset)){offset <- rep(0,N) }
  if (is.null(weights)){weights <- rep(1,N)}   
  data$offset <- numeric(1); data$pweights<-numeric(1)  
  data  <- if (is.matrix(Y)) data[dimnames(Y)[[1]],] else  data[names(Y),] # omit missing values   
  data$offset <- offset;  data$pweights <- weights
 
  # Extract variable names from random part 
  rform    <- random
  mform    <- strsplit(as.character(random)[2],'\\|')[[1]]
  mform    <- gsub(' ', '',mform)
  if (length(mform)==1){stop("Please use function alldist for overdispersion models")} 
  mform1   <- mform[1]
  mform2   <- mform[2]
  if(!(mform2 %in% names(data))){stop("The specified clustering variable is not contained in the data frame.")}  
  if (random.distribution=='gq' && mform1!="1"){stop("Random coefficient models are only supported for random.distribution='np'.")}
  
  # initial fit and simple glm for k=1
  fit    <- glm(formula, family=family, weights=pweights, offset=offset, data=data,...)
  names0 <- dimnames(data)[[1]] 
  w0     <- fit$prior.weights  # store prior weights for output
  off0   <- fit$offset; names(off0)<-names0   # store offset for output
  Y      <- fit$y  
  l0     <- length(fit$coef)  
  tol0   <- tol # for main title of graphical output 
  
  # For binomial models, check weights: case weights, or number of trials?
  if(family$family=="binomial"){
      data$pweights<- data$pweights^Ym
      YP<- binomial.expand(Y,1,w0/data$pweights); 
      Y<- YP[[1]]; PY<-YP[[2]];r<-YP[[3]]; n<-YP[[4]]
  } 
    
  # Initial estimates of  standard deviation and/or shape parameter  (response distr.)     
  sdev.miss  <- missing(sdev)
  shape.miss <- missing(shape)
  if (family$family=="gaussian"){
        sdev  <-  ifelse(sdev.miss, sqrt(summary(fit)$dispersion), sdev)
        shape <- 0
  } else if (family$family =="Gamma") {
         # Estimate sdev from residuals on linear predictor scale, see Einbeck & Hinde (2006):
        sdev  <- ifelse(sdev.miss, sqrt(switch(family$link,
                        "log"= sum(data$pweights*(log(Y)-log(fitted(fit)))^2)/(sum(data$pweights)),
                        "inverse"= sum(data$pweights*(1/Y-1/(fitted(fit)))^2)/(sum(data$pweights)),
                        "identity"= sum(data$pweights*(Y-fitted(fit))^2)/(sum(data$pweights)),
                        )), sdev) 
        shape <- ifelse(shape.miss,1/summary(fit)$dispersion, shape)
  } else {
        sdev  <- 1
        shape <- 0
  } 
   
  # Initial disparity (-2logL)    
  ML.dev0 <- -2*sum(data$pweights*switch(family$family,
             "gaussian"= dnorm(fit$y, fitted(fit), sdev, log=TRUE),
             "poisson" = dpois(fit$y, fitted(fit), log=TRUE),
             "binomial"= dbinom(Y[,1],Y[,1]+Y[,2], fitted(fit), log=TRUE),
             "Gamma"   = dgamma(fit$y, shape=shape, scale=fitted(fit)/shape, log=TRUE),             
            ))

  # Return (glm) output and terminate if k=1
  if (k == 1){
      if (random.distribution=="np"){
        names(fit$coefficients) <- ifelse(names(fit$coefficients)=="(Intercept)", "MASS1", names(fit$coefficients))
      }
      post.prob <-  matrix(1,N,1,dimnames=list(names0,"") )
      
      fit <- c( fit[c(1,2,3,8,9)],
              disparity = ML.dev0,
              deviance = fit$dev,
              fit[c(12,16,17,18)],
              call = call,  
              formula = formula,
              random = "none",
              data = list(subset(data,select=1:ddim[2])),
              model = list(model.matrix(fit)),
              weights = list(w0),
              offset = list(off0),
              mass.points = list(fit$coef[1]),
              masses = list(c("MASS1"=1)),
              sdev = list(list(sdev=sdev, sdevk=sdev)),
              shape = list(list(shape=shape,shapek=shape)),
              rsdev= 0,
              post.prob = list(post.prob),
              post.int =  list(fit$coef[1]),
              ebp = list(family$linkfun(fit$fitted)),
              EMiter = 0,
              EMconverged = "none",
              lastglm = list(fit),
              Misc = list(list(lambda=lambda))
              )
      if (random.distribution =="np"){
              class(fit) <- 'glmmNPML'
      } else {
             class(fit) <- 'glmmGQ'
      }     
      return(fit)
  } else if (!(k %in% 1:600)){
      stop("This choice of k is not supported.")
  }
  
  # Omit integration point if GH weights are too small  
  tmp      <- gqz(k, minweight = 1e-50)  # from version 0.39-1; changed to 1e-50 in v0.42
  k0       <- k   # from 0.42: save for glmmGQ output
  k        <- min(k, dim(tmp)[1]);
  
  # Expand the data
  if(family$family=="binomial"){
      YP   <- binomial.expand(Y,k,rep(1,N)); Y<- YP[[1]]; PY<-YP[[2]];r<-YP[[3]]; n<-YP[[4]]
  }  else  {
      Y    <- rep(Y,k)
  }
  X        <- expand.vc(X,k)# expand design matrix
  datak    <- expand.vc(data,k)
  kindex   <- rep(1:k,rep(N,k))# index for the mixtures
  #tmp      <- gqz(k,minweight=1e-55)  # omitted from version 0.39-1
  z0       <- -tmp$l
  z        <- rep(-tmp$l,rep(N,k))
  p        <- tmp$w
  group    <- factor(levels(factor(datak[,mform2])))# 20/04/06 
  offset   <- datak$offset    # expand offset
  pweights <- datak$pweights  # expand weights
  

  # Generate the random design matrix and append to fixed matrix
  if (random.distribution=='np'){  # Nonparametric random effect
      X <- model.matrix(formula,datak)[,-1,drop=FALSE]
      datak$MASS <- gl(k,N)
      if (mform1=='1'){ 
          random <- formula(~MASS-1) 
      } else {
          # Nonparametric random coefficient
          random <- formula(paste('~ MASS + ', paste(mform1, 'MASS',sep=":",collapse='+'), '-1',sep=''))
      }
  } else {
     print(mform)
      # Gaussian random effects
      X <- model.matrix(formula,datak)
      #if (mform1=='1')
      random <- formula('~ z - 1')
      #else
      #random <- formula(paste('~',paste(mform1,'z - 1',sep=':'),sep='')) ##R.E.D. 13/2/06 # this case seems to be excluded anyway. 05/11/07 JE
   }
  Z <- model.matrix(random,datak)
  if (dim(X)[1]!= dim(Z)[1]){cat("The missing value routine cannot cope with this model. Please specify the random term also as fixed term and try again. ")}
  XZ <- cbind(X,Z)
  
  # Set up indices for hierarchical model
  nr        <- nlevels(group)
  ijindex   <- rep(1:N,k)
  groupij   <- factor(data[,mform2]) # 20/04/06
  groupijk  <- rep(groupij,k)
  Intercept <- names(fit$effects)[1]=='(Intercept)'
  nf        <- length(names(fit$effects))

  # Extend linear predictor
  if (missing(pluginz)){
      sz <- tol* sdev*z
  } else {
      if (length(pluginz)!=k){
        stop("pluginz needs to be a vector of length k.")  # 30/09/09
      } else {
        sz <- rep(pluginz-fit$coef[[1]],rep(N,k))
      }
  }  
  Eta <- fit$linear.predictor + sz
        # The extra term stops unrelated regressions
  
  
  # Initial EM trajectory values 
  if (random.distribution=="np"){
      tol <- max(min(tol,1),1-damp)
      if(length(fit$coef)==1){
          followmass <- matrix(Eta[(1:k)*N],1,k)-offset[(1:k)*N]
          } else {
          followmass <- matrix(fit$coef[1]+sz[(1:k)*N],1,k)
          }
  }  else {
      followmass <- NULL; tol <- 1
  }

  # Expanded fitted values
  Mu <- family$linkinv(Eta) 

  # Calculate loglikelihood for fixed model
  f <- switch(family$family,
              "gaussian"=dnorm(Y,Mu,tol*sdev,log=TRUE),
              "poisson" =dpois(Y,Mu,log=TRUE),
              "binomial"=dbinom(r,n,Mu,log=TRUE),
               "Gamma"=dgamma(Y,shape=shape/tol^2,scale=Mu*tol^2/shape ,log=TRUE),
               )
  
  # Calculate the weights from initial model
  groupk <- interaction(groupijk,factor(kindex))
  mik    <- matrix(tapply(f*pweights,groupk,sum),nrow=nr,ncol=k)  #16-03-06
  tmp    <- weightslogl.calc.w(p,mik,rep(1,nr))   #16-03-06
  w      <- tmp$w[match(groupij,group),]    #17-03-06

  # Initialize for EM loop
  ML.dev    <- ML.dev0
  iter      <- ml <- 1
  converged <- FALSE
  sdevk<-rep(sdev,k);  shapek<-rep(shape,k)    #19-03-06
   
  ##########Start of EM ##########
  while (iter <= EMmaxit && (!converged || (iter<=9 && random.distribution=='np' && damp && (family$family=="gaussian" && sdev.miss || family$family=="Gamma"&& shape.miss)  ))){   
      if (verbose){cat(iter,'..')}

      # M-Step: Weighted GLM
      fit <- try(glm.fit(x=XZ, y=Y, weights = as.vector(w)*pweights, family = family, offset=offset,...))                                
      if (class(fit)=="try-error"){
                stop("Singularity or Likelihood-Spike at iteration #", iter,  ". 
                Check model specification, enable spike protection or smooth among components.")
      }
      
      # EM Trajectories      
      if (random.distribution=="np"){ 
          masspoint<- fit$coef[l0:(l0+k-1)]
          followmass<-rbind(followmass, masspoint)
      }
      
      # Fitted response from current model
      Mu <- fitted(fit)
      
      # Unequal component dispersion parameters  
      if (family$family=="gaussian"){
          if (sdev.miss){ sdev<- sqrt(sum((as.vector(w)*pweights)*(Y-Mu)^2)/sum(as.vector(w)*pweights))}
          sdevk<-rep(sdev,k) 
          if (lambda!=0){
              for (l in 1:k){
                wk<-matrix(1,k,N); wk[1:k,]<-dkern(1:k,l,k,lambda);wk<-t(wk)
                sdevk[l] <-  sqrt(sum(wk* as.vector(w)*pweights *(Y-Mu)^2)/sum(wk*as.vector(w)*pweights))
              }
              sk<-rep(sdevk,rep(N,k))
          } else {
              sk<-sdev
          }
      }  else {
          sdevk <-rep(NA,k)
      }
      if (family$family=="Gamma"){
           if (shape.miss) { shape<-(sum(as.vector(w)*pweights))*1/sum(as.vector(w)*pweights*((Y-fitted(fit))/fitted(fit))^2)}
           shapek<-rep(shape,k) 
           if (lambda!=0){
                for (l in 1:k){
                  wk<-matrix(1,k,N); wk[1:k,]<-dkern(1:k,l,k,lambda);wk<-t(wk)
                  shapek[l] <- sum(wk*as.vector(w)*pweights)/ sum(wk* as.vector(w)*pweights*((Y-Mu)/Mu)^2)
                  }
                shk<-rep(shapek,rep(N,k))
           } else {
                shk<-shape
           }
       } else {
           shapek<-rep(NA,k)
       }

      
      # Calculate loglikelihood for expanded model for this iteration
      f <- switch(family$family,
              "gaussian"=dnorm(Y,Mu,(1-(1-tol)^(damp.power*iter+1))*sk,log=TRUE),
              "poisson" =dpois(Y,Mu,log=TRUE),
              "binomial"=dbinom(r,n,Mu,log=TRUE),
               "Gamma"=dgamma(Y,shape=shk/(1-(1-tol)^(damp.power*iter+1))^2,scale=Mu*(1-(1-tol)^(damp.power*iter+1))^2/shk,log=TRUE),
           )
      
      # E-Step: Update weights     
      mik  <- matrix(tapply(f*pweights,groupk,sum),nrow=nr,ncol=k) #16-3-06
      tmp  <- weightslogl.calc.w(p,mik, rep(1,nr))   #16-03-06
      w    <- tmp$w[match(groupij,group),]
      
      # Calculate the component proportions from the weights
      if (random.distribution=='np'){ 
          p <- as.vector(apply(tmp$w,2,mean)) # differs from alldist - no weights needed on upper level! 
      }
      
      # Update disparity and check for convergence
      ML.dev[iter+1] <- ifelse(is.na(tmp$ML.dev), Inf, tmp$ML.dev)
      if (ML.dev[iter+1]>ML.dev0) {ml<-ml+1}
      converged <- abs(ML.dev[iter+1] - ML.dev[iter])< EMdev.change
      iter <- iter + 1
  
      # Check for likelihood spikes
      if (random.distribution != 'gq' && spike.protect!=0){
          if (family$family=='gaussian' && abs(min(sdevk/masspoint)) <0.000001*spike.protect){break}  # Avoid Likelihhod Spikes
          if (family$family=='Gamma' && abs(max(shapek/masspoint))> 10^6*spike.protect){break}
      }  
  
   }########################### End of EM loop #############

  # Print on screen information on EM convergence  
  if (verbose){cat("\n")
      if (converged){
        cat("EM algorithm met convergence criteria at iteration # ", iter-1,"\n")
      } else{
        cat("EM algorithm failed to meet convergence criteria at iteration # ", iter-1,"\n")
      }
  }
  
  # Compute model deviance
  Deviance <- switch(family$family,
              "gaussian"= sdev^2*ML.dev[iter]-sdev^2* sum(data$pweights[1:N] * log(2*pi*sdev^2)),
              "poisson" =ML.dev[iter] +2*sum(data$pweights[1:N]*(-Y[1:N]+Y[1:N]*log(Y[1:N]+(Y[1:N]==0))-lfactorial(Y[1:N]))),
              "binomial"=ML.dev[iter] +2*sum(data$pweights[1:N]*(lfactorial(n)-lfactorial(r)-lfactorial(n-r) - n*log(n) + r*log(r+(r==0))+(n-r)*log(n-r+((n-r)==0)))[1:N]),
              "Gamma"=1/shape*ML.dev[iter]+2/shape*(sum(data$pweights[1:N])*shape*(log(shape)-1)-sum(data$pweights[1:N])*lgamma(shape)-sum(data$pweights[1:N]*log(Y[1:N]))),            
              )
  
  # Compute  posterior prob. etc.                          
  mass.points   <- masses <- NULL
  np            <- length(fit$coef)
  ebp           <- apply(w*matrix(fit$linear.predictor,N,k,byrow=FALSE),1,sum)  # Emp. Bayes Pred. (Aitkin, 96)
  ebp.fitted    <- family$linkinv(ebp)
  ebp.residuals <- Y[1:N]- ebp.fitted
  names(ebp)    <- names(ebp.fitted) <- names(ebp.residuals) <- names0
  if (mform1 %in% substring(names(fit$coef),1, nchar(mform1))){length(fit$coefficients) <- np <- np-1}# if one variable is random *and* fixed 
  # if (is.na(fit$coefficients[np])){length(fit$coefficients) <- np <- np-1}# replaced by the line above from 0.42 on
  m <- seq(1,np)[substr(attr(fit$coefficients, 'names'),1,4)=='MASS']
  if (random.distribution=="np"){ 
      mass.points   <- fit$coefficients[m] # from 0.42
  } else {  
      a <- ifelse(names(fit$coef[1])== "(Intercept)", fit$coef[1], 0) 
      mass.points <- a + fit$coef["z"]*z0           # from 0.42, np replaced by "z"
  }
  post.prob     <- matrix(w, nrow=N, byrow=FALSE, dimnames=list(names0, 1:k) )
  post.int      <- as.vector(post.prob %*% mass.points[1:k]); names(post.int)<-names0
    
  # Write tol values as plot title if alldist is called from tolfind:
  if ((plot.opt==1 || plot.opt==2) && par("mfrow")[1]>2) { # Write tol values as plot title if alldist is called from tolfind:
           plot.main <- substitute("tol"== tol0, list(tol0=tol0))
      } else {
           plot.main <- c("")
  }
   
  # Set up graphics device and plot disparity trend 
  if (plot.opt==3 && random.distribution=="np"){
      par(mfrow=c(2,1), cex=0.5, cex.axis=1.5, cex.lab=1.5)
  }
  if (plot.opt==1|| plot.opt==3){
      if  ((family$family=="gaussian" && sdev.miss|| family$family=="Gamma" && shape.miss) && damp && random.distribution=='np' && iter>=max(8,ml+1)){
          # Linear interpolation for initial cycles
          ML.dev[2: max(7,ml)]<-ML.dev0+ 1:max(6,ml-1)/ max(7,ml)*(ML.dev[max(8,ml+1)]-ML.dev0) 
      }  
      plot(0:(iter-1),ML.dev, col=1,type="l",xlab='EM iterations',ylab='-2logL', main= plot.main )
      if (verbose){ cat("Disparity trend plotted.\n")}
  }

  # Prepare output for glmmNPML objects
  if (random.distribution=="np") {
      masses        <- as.vector(apply(tmp$w,2,mean))                # differs from alldist - no weights needed on upper level! 
      names(masses) <- paste('MASS',1:k,sep='')                    
      
      # Estimate random effect standard deviation # from 0.42
      rsdev         <- sqrt(sum(masses * (mass.points[1:length(masses)]- sum(masses*mass.points[1:length(masses)]) )^2))
      
      # Compute fixed part residuals
      if (family$family=="binomial"){
          R0 <- family$linkfun(PY[1:N])
      } else  {
          R0 <- family$linkfun(Y[1:N])
      }
      if(dim(X)[2]>0){
        R <-R0 - X[1:N,]%*%matrix(fit$coef[1:dim(X)[2]])-offset[1:N]
      } else {
        R <- R0 - offset[1:N]
      }
      R <- as.vector(R);  names(R) <- names0   
         
      # EM trajectory plot
      if ( mform1=='1' && all(is.finite(R))){ 
           ylim <- c(min(R), max(R))  #29/06/2006
      } else  { 
          ylim <- c(min(followmass[,]),max(followmass[,]))
      }
      if(any(is.na(ylim)) &  plot.opt >1 ){
              cat("Singularity: EM Trajectory plot not available.", "\n");
              plot.opt<-min(plot.opt,1)
      }
      if (plot.opt==2|| plot.opt==3){
            plot(0:(iter-1),followmass[,1],col=1,type='l',ylim=ylim,ylab='mass points',xlab='EM iterations', main= plot.main )
            for (i in 1:k){ lines(0:(iter-1), followmass[,i],col=i)
                 if (mform1=='1'){ points(rep(iter-1,length(R)),R)}}
            if (verbose){cat("EM Trajectories plotted.\n")}
      }

      
      # glmmNPML output 
      fit <- c( fit[1],
                residuals = list(ebp.residuals),
                fitted.values = list(ebp.fitted),
                fit[c(8,9)],
                disparity = ML.dev[iter],
                deviance = Deviance,
                fit[12],  
                df.residual = N - np -k+1, 
                df.null = N-1,
                fit[18],
                call = call,
                formula = formula,
                random = rform,
                data = list(subset(data,select=1:ddim[2])),
                model = list(XZ),
                weights = list(w0),
                offset = list(off0),
                mass.points = list(mass.points),
                masses = list(masses),               
                sdev = list(list(sdev=sdev, sdevk=sdevk)),
                shape = list(list(shape=shape,shapek=shapek)),
                rsdev = list(rsdev),
                post.prob = list(post.prob),
                post.int =  list(post.int),
                ebp = list(ebp),
                EMiter = iter - 1,
                EMconverged = converged,
                lastglm = list(fit),
                Misc=list(list(Disparity.trend=ML.dev,EMTrajectories=followmass, res=R,ylim=ylim,lambda=lambda,mform=mform1, mform2=mform2))
                )
      class(fit) <-'glmmNPML'
  } else {
      # glmmGQ output
      
      fit <- c( fit[1],
                residuals = list(ebp.residuals),
                fitted.values = list(ebp.fitted),
                fit[c(8,9)],
                disparity = ML.dev[iter],
                deviance = Deviance,
                fit[12],  
                df.residual = N-np,
                df.null = N-1,
                fit[18],
                call = call,
                formula = formula,
                random = rform,
                data = list(subset(data,select=1:ddim[2])),
                model = list(XZ),
                weights = list(w0),
                offset = list(off0), 
                mass.points = list(mass.points),
                masses = list(gqz(k0, minweight=1e-50)$w),          
                sdev = list(list(sdev=sdev, sdevk=sdevk)),
                shape = list(list(shape=shape,shapek=shapek)),
                rsdev = fit$coef[["z"]],
                post.prob = list(post.prob),
                post.int =  list(post.int),
                ebp = list(ebp),
                EMiter = iter - 1,
                EMconverged = converged,
                lastglm = list(fit),
                Misc=list(list(Disparity.trend=ML.dev,  lambda=lambda, mform=mform1, mform2=mform2))
                )
      class(fit) <-'glmmGQ'
  }
  fit
}
#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/binomial.expand.R"
"binomial.expand" <-
function(Y,k,w){
      
    if (is.matrix(Y)){
            r <- rep(Y[,1],k)
            n <- rep(Y[,2]+Y[,1],k)
    } else { N <- NROW(Y)
             r <- rep(as.numeric(Y*w),k)
             n <- rep(w,k)
             #w<-rep(1,N)
    }
    Y <- cbind(r,"n-r"=(n-r))
    PY<-Y[,1]/(Y[,1]+Y[,2])     
    list(Y,PY,r,n)
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/dkern.R"
"dkern" <-
function(x,y,k,lambda){
    ifelse(y==x, lambda, (1-lambda)/(k-1))
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/expand.R"
"expand" <-
function(x,k){
  xx <- x
  for ( i in 2:k) xx <- rbind(x,xx)
  xx}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/expand.vc.R"
"expand.vc" <-
function(x,ni){
  if (length(ni)==1){
      xx <- x
      for ( i in 2:ni) xx <- rbind(x,xx)
      xx
  } else {
      n <- dim(x)[[1]]
      c <- dim(x)[[2]]
      xx <- NULL
      for ( i in seq(1,n)){
          xx <- rbind(xx,matrix(rep(x[i,],ni[i]),ncol=c,byrow=TRUE))
      }
      xx
  }
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/family.glmmGQ.R"
"family.glmmGQ" <-
function(object, ...) {
     object$family
 }

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/family.glmmNPML.R"
"family.glmmNPML" <-
function(object, ...) {
     object$family
 }

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/gqz.R"
#  gqglim.R				Nick Sofroniou (July 13, 2005)

gqz <- function(numnodes=20, minweight=0.000001){
#  Calculate Gaussian Quadrature points for the Normal distribution
#  using the abscissas and weights for Hermite integration. The
#  conversion of the locations and weights is given in Lindsey (1992,
#  page 169:3) and Skrondal & Rabe-Hesketh (2004, page 165:1).
#  The argument numnodes is the theoretical number of quadrature points,
#  locations with weights that are less than the argument minweight will
#  be omitted.
#  The default vale of minweight=0.000001 returns 14 masspoints for the
#  default numnodes=20 as in Aitkin, Francis & Hinde (2005).
    out <- gauss.quad(numnodes, "hermite")
    h <- rbind(out$nodes*sqrt(2), out$weights/sum(out$weights))
#  Sort the locations and weights into columns in decending order of the
#  location vector.
    ord<-order(h[1,], decreasing = TRUE)
    h <- h[,ord]
    h <- cbind(h[1,], h[2,])
    h <- subset(as.data.frame(h), (h[,2] >= minweight))
    names(h) <- c("location","weight")
    h
    }



#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/model.matrix.glmmGQ.R"
"model.matrix.glmmGQ" <-
function(object, ...) {
     object$model
 }

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/model.matrix.glmmNPML.R"
"model.matrix.glmmNPML" <-
function(object, ...) {
     object$model
 }

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/plot.glmmGQ.R"
"plot.glmmGQ" <-
function(x,plot.opt=3, noformat=FALSE,  ...){

  k<-length(x$masses)  

  if(!noformat){
      if (k==1){
          stop("No graphical output for k=1")
      }
      if  (plot.opt==0){
          stop("Specify plot.opt >0")
      } else if (plot.opt %in% c(1,2)){
          par(mfrow=c(1,1))
      } else if (plot.opt ==3){
          par(mfrow=c(2,1),cex=0.5,cex.axis=1.5,cex.lab=1.5)
      }
  }
      
  if (plot.opt%%2==1){#Disparities
      plot(0:x$EMiter,x$Misc$Disparity.trend, col=1,type="l",xlab='EM iterations',ylab='-2logL')      
  }
  
  if (plot.opt %%4 %in% c(2,3) ){#  EBP vs true values #klappt
      class.col<-post(x, level="lower")$classif
      plot(x$y[1:length(x$weights)], predict(x,type="response"), xlab="true response", ylab="Emp. Bayes Pred." ,col=class.col)
      abline(0,1)         
  }
    
  invisible(x)
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/plot.glmmNPML.R"
"plot.glmmNPML" <-
function(x,plot.opt=15, noformat= FALSE, ...){

  k<-length(x$masses) 
  if (k==1){stop("No graphical output for k=1")} 

  if (!noformat){
      if  (plot.opt==0){
          stop("Specify plot.opt >0")
      } else if (plot.opt %in% c(1,2,4,8)){
          par(mfrow=c(1,1))
      } else if (plot.opt %in% c(3,5,6,9,10,12)){
          par(mfrow=c(2,1),cex=0.5,cex.axis=1.5,cex.lab=1.5)
      } else {
          par(mfrow=c(2,2),cex=0.5,cex.axis=1.1,cex.lab=1.1)
      }   
   }  
       
  if (plot.opt%%2==1){#Disparities
      plot(0:x$EMiter,x$Misc$Disparity.trend, col=1,type="l",xlab='EM iterations',ylab='-2logL')      
  }
  
  if (plot.opt %%4 %in% c(2,3) ){#  EM Trajectories
      R<- x$Misc$res; ylim<- x$Misc$ylim; followmass<-x$Misc$EMTraj     
      plot(0:x$EMiter,followmass[,1],col=1,type='l',ylim=ylim,ylab='mass points',xlab='EM iterations')
      for (i in 1:k){   
          lines(0:x$EMiter, followmass[,i],col=i)
          if (x$Misc$mform=="1"){points(rep(x$EMiter,length(R)),R)}
      }
  }
  
  if (plot.opt %%8 %in% c(4,5,6,7) ){#  EBP vs true values
       
      #class.col<- masspoint.classifier(x)
      class.col<- post(x, level="lower")$classif
      plot(x$y[1:length(x$weights)], predict(x,type="response"), xlab="true response", ylab="Emp. Bayes Pred." ,col=class.col)
      abline(0,1)         
  }
  
  if (plot.opt >7){   #wik
      if (is.infinite(abs(max(x$Misc$res)))){
          cat("Infinite values: Posterior probability plot not applicable for this object."); return()
      }
      pmax<-max(x$post.prob)
      plot(x$Misc$res, x$post.prob[,1],col=1,type="p",ylim=c(0,pmax),ylab="post.prob", xlab="Residuals")
      for (i in 2:k) {
          points(x$Misc$res, x$post.prob[,i],col=i,pch=i,type="p")
      }
  }
  
  invisible(x)
}
#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/post.R"
post <-
function(object, level="upper"){
 if (level=="upper" && !is.null(object$Misc$mform2)){
      data <- object$data
      mform2 <- object$Misc$mform2
      group <- object$data[mform2][row.names(unique(data[mform2])),]
      post.prob <- object$post.prob[row.names(unique(data[mform2])),] ; dimnames(post.prob)[[1]]<- group
      post.int  <- object$post.int[row.names(unique(data[mform2]))]; names(post.int)<- group
  } else {
      post.prob<- object$post.prob
      post.int <- object$post.int
  }
  classif <- apply(post.prob, 1, which.max)
  names(classif) <-  dimnames(post.prob)[[1]]
  
  if (is.null(object$Misc$mform2)){ level<- "none"}
  
  return(list(prob= post.prob, int=post.int, classif = classif, level=level))
}
#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/predict.glmmGQ.R"
"predict.glmmGQ" <-
function(object, newdata,  type="link", ...){
  if (missing(newdata)){#Emp. Bayes Pred. (Aitkin, 96)
      if (type=="link") {
          return(round(object$ebp,digits=4))
      } else {
          return(round(object$fitted.values,digits=4))
      }
  } else {      # Analytical mean of compounded model, see Aitkin, Francis, Hinde 2005, p. 459.
      if (object$family$link!="log"){
          stop("Prediction for objetcs of class glmmGQ only supported for log link")
      }
      Terms<-  delete.response(terms(object$formula))
      X<-model.matrix(Terms, model.frame(Terms,newdata))
      pred<-    as.vector(X%*%matrix(object$coef[1:dim(X)[2]])+1/2* (object$coef[length(object$coef)])^2)
      if (type=="link"){
          rpred<-as.vector(pred)
      } else {
          rpred<- exp(as.vector(pred))
      }
      names(rpred)<-dimnames(X)[[1]]
      return(round(rpred,digits=4))
  }
}
#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/predict.glmmNPML.R"
"predict.glmmNPML" <-
predict.glmmNPML<-function(object, newdata,  type="link", ...){

  if(missing(newdata)){ #Emp. Bayes Pred. (Aitkin, 96)
      if (type=="link") {
          return(round(object$ebp,digits=4))
      } else {
          #rebp <- object$fitted.values
          #rebp<- switch(object$family$link, "log"= exp(ebp),
          #                                  "logit"=exp(ebp)/(1+exp(ebp)),
          #                                  "identity"=ebp,
          #                                  "inverse"=1/ebp,
          #                                  "probit"= pnorm(ebp,0,1))
          return(round(object$fitted.values, digits=4))
      }

  } else  {
      m<-length(object$mass.points)
      k<-length(object$masses)
      Terms<-  delete.response(terms(object$formula))
      if (k==1){  # GLM
              X<-model.matrix(Terms, model.frame(Terms,newdata))
              dimnames(X)[[1]]<-dimnames(model.frame(Terms,newdata))[[1]]
              pred<-  as.vector(X%*%matrix(object$coef[1:dim(X)[2]]))
      }  else if (k==m){ #Overdispersion model
              X<-model.matrix(Terms, model.frame(Terms,newdata))[,-1,drop=FALSE]
              dimnames(X)[[1]]<-dimnames(model.frame(Terms,newdata))[[1]]
              if (dim(X)[2]!=0){
                    pred<- as.vector(X%*%matrix(object$coef[1:dim(X)[2]])+ sum(object$masses*object$mass.points))
              } else {
                    pred<- rep(0, dim(X)[1])+ sum(object$masses*object$mass.points)
              }
      } else { #Random coefficient models
              X<-model.matrix(Terms, model.frame(Terms,newdata))[,-1,drop=FALSE]
              dimnames(X)[[1]]<-dimnames(model.frame(Terms,newdata))[[1]]
              object$mass.points<- ifelse(is.na(object$mass.points),0,object$mass.points)
              #r<-  names(newdata) %in% gsub('~','',object$random)[2]
              r<-  names(newdata) %in% object$Misc$mform   #28/02/06
              if(is.factor(newdata[,r])){newdata[,r]<-as.numeric(newdata[,r])-1}  #28/02/06
              
              if (dim(X)[2]!=0){
                  pred<- as.vector(X%*%matrix(object$coef[1:dim(X)[2]])+ sum(object$masses*object$mass.points[1:k])+ newdata[,r]*sum(object$masses[1:(k-1)]*object$mass.points[(k+1):m])) #24-07-06
                  } else {
                  pred<- rep(0, dim(X)[1])+ sum(object$masses*object$mass.points[1:k])+ newdata[,r]*sum(object$masses[1:k]*object$mass.points[(k+1):m])
              }
      }
      if (type=="link"){
             rpred<-as.vector(pred)
      } else {
              rpred <- object$family$linkinv(pred)
      }
      names(rpred)<-dimnames(X)[[1]]
      return(round(rpred,digits=4))
  }

}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/print.glmmGQ.R"
"print.glmmGQ" <-
function(x,digits=max(3,getOption('digits')-3), ...)
{
  cat('\nCall: ',deparse(x$call),'\n\n')
  cat('Coefficients:\n')
  print.default(format(x$coefficients, digits = digits), print.gap = 2, quote = FALSE)
  if (x$family$family=='gaussian'&& x$Misc$lambda<=1/length(x$masses)){
      cat('\nComponent distribution - MLE of sigma:\t  ',format(signif(x$sdev$sdev,digits)),'\n')# 03/09/07
  }
  if (x$family$family=='Gamma'&& x$Misc$lambda<=1/length(x$masses)){ #print shape only if it is constant over components
       cat('\nComponent distribution - MLE of shape parameter:\t  ',format(signif(x$shape$shape,digits)),'\n')# 03/09/07
  }
  cat('Random effect distribution - standard deviation:\t  ', format(x$rsdev),'\n\n') # 03/09/07
  cat('-2 log L:\t   ',format(round(x$disparity,digits=1)),"\n")
  invisible(x)
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/print.glmmNPML.R"
"print.glmmNPML" <-
function(x,digits=max(3,getOption('digits')-3), ...){
  np <- length(x$coefficients)
  # print(names(x))
  if (np > 0){   
    m <- seq(1,np)[substr(attr(x$coefficients,'names'),1,4)=='MASS']
    mass.points <- x$coefficients[m]
    cat('\nCall: ',deparse(x$call),'\n\n')
    cat('Coefficients')
    cat(":\n")
    print.default(format(x$coefficients[1:np],digits = digits), print.gap = 2,quote = FALSE);cat('\n')
  } else {
    cat('\nCall: ',deparse(x$call),'\n\n')
    cat("No coefficients. \n")
  }
  
  if (x$family$family=='gaussian' && x$Misc$lambda<=1/length(x$masses)){ # print sigma only if it is constant over components
        cat('Component distribution - MLE of sigma:\t  ',                # 03/09/07
        format(signif(x$sdev$sdev,digits)),'\n')
    }
  if (x$family$family=='Gamma'&& x$Misc$lambda<=1/length(x$masses)){ # print shape only if it is constant over components
       cat('Component distribution - MLE of shape parameter:\t  ',format(signif(x$shape$shape,digits)),'\n')# 03/09/07
    }

  cat('Random effect distribution - standard deviation:\t  ', format(x$rsdev),'\n\n') # 03/09/07
  
  if (!is.null(x$post.prob)){
      p <- x$masses
      # names(p) <- paste('MASS',seq(1,ncol(x$post.prob)),sep='') # omitted from 0.42 
      cat('Mixture proportions')
      cat(":\n")
      print.default(format(p,digits),print.gap=2,quote=FALSE)
   }
  cat('-2 log L:\t   ', format(round(x$disparity,digits=1)),"\n")
  invisible(x)
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/summary.glmmGQ.R"
"summary.glmmGQ" <-
function(object, digits=max(3,getOption('digits')-3), ...){
  cat('\nCall: ',deparse(object$call),'\n\n')
  cat('Coefficients')
  cat(":\n")
  df.r <- object$lastglm$df.residual

  glm.dispersion <- if (any(object$family$family == c("poisson", 
            "binomial"))) 
            1
            else if (df.r > 0) {
                sum(object$lastglm$weights * object$lastglm$residuals^2, na.rm=TRUE)/df.r
            }
            else Inf
  # dispers<-  sum(object$lastglm$weights * object$lastglm$residuals^2, na.rm=TRUE)/object$lastglm$df.residual
  lastglmsumm <-  summary.glm(object$lastglm, dispersion=glm.dispersion)
  fitcoef     <- matrix(lastglmsumm$coeff[,1:3],ncol=3, dimnames=  list(dimnames(lastglmsumm$coef)[[1]], c(dimnames(lastglmsumm$coeff)[[2]][1:2], "t value")) )  #10-08-06
  print(fitcoef)

  p <- object$masses  # 23/07/07
  names(p) <- paste('MASS',seq(1,ncol(object$post.prob)),sep='') # 23/07/07
  
  # print(lastglmsumm$coeff[,1:3]) #21-4-06; 27-06-06.
  dispersion <- 1   #now calculate dispersion in the sense of 'dispersion parameter':
  if (object$family$family=='gaussian'){
      dispersion <- (object$sdev$sdev)^2
      if (object$Misc$lambda<=1/length(object$masses)){
          cat('\nComponent distribution - MLE of sigma:\t  ',format(signif(object$sdev$sdev,digits)),'\n')
      } else {
      cat('\nMLE of component standard deviations:\n'); s <- object$sdev$sdevk;   names(s)<- names(p); print.default(format(s,digits),print.gap=2,quote=FALSE); cat ('\n')
      }
  } else if (object$family$family=='Gamma'){
      dispersion <- 1/object$shape$shape
      if (object$Misc$lambda<=1/length(object$masses)){
          cat('\nComponent distribution - MLE of shape parameter:\t  ',format(signif(object$shape$shape,digits)),'\n')
          } else {
              cat('\nMLE of component shape parameters:\n'); s<- object$shape$shapek; names(s)<- names(p);  print.default(format(s,digits),print.gap=2,quote=FALSE); cat ('\n')
          }
  } else cat('\n')

  cat('Random effect distribution - standard deviation:\t  ', format(object$rsdev),'\n\n') # 03/09/07
  
  cat('\n-2 log L:\t   ',format(round(object$disparity,digits=1)),
        '     Convergence at iteration ',round(object$EMiter,0),"\n")
  invisible(c("coefficients"=list(fitcoef), object[-1],list(dispersion=dispersion), list(lastglmsumm=lastglmsumm) ))
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/summary.glmmNPML.R"
"summary.glmmNPML" <-
function(object,digits=max(3,getOption('digits')-3), ...){
  np   <-  length(object$coefficients)
  if (np > 0){
      m <- seq(1,np)[substr(attr(object$coefficients,'names'),1,4)=='MASS']
      mass.points <- object$coefficients[m]
      cat('\nCall: ',deparse(object$call),'\n\n')
      cat('Coefficients')
      cat(":\n")
      df.r <- object$lastglm$df.residual
       
      glm.dispersion <- if (any(object$family$family == c("poisson", "binomial"))) 
            1
            else if (df.r > 0) {
                sum(object$lastglm$weights * object$lastglm$residuals^2, na.rm=TRUE)/df.r
            }
            else Inf
      lastglmsumm <- summary.glm(object$lastglm, dispersion=glm.dispersion)
      fitcoef     <- matrix(lastglmsumm$coeff[,1:3], ncol=3,dimnames= list(dimnames(lastglmsumm$coef)[[1]], c(dimnames(lastglmsumm$coeff)[[2]][1:2], "t value") ))  #03-08-06
      print(fitcoef)
  } else {
      cat('\nCall: ',deparse(object$call),'\n\n')
      cat("No coefficients. \n")
  }
 
  p <- object$masses
  #names(p) <- paste('MASS',seq(1,ncol(object$post.prob)),sep='') # omitted from 0.42 on
  dispersion <- 1    # now calculate dispersion in the sense of 'dispersion parameter':
  
  cat('\nMixture proportions:\n')
  print.default(format(p,digits),print.gap=2,quote=FALSE)

  if (object$family$family=='gaussian'){
      dispersion <- (object$sdev$sdev)^2
      if (object$Misc$lambda<=1/length(object$masses)){
          cat('\nComponent distribution - MLE of sigma:\t  ',format(signif(object$sdev$sdev,digits)),'\n')
      } else {
          cat('\nMLE of component standard deviations:\n'); s<- object$sdev$sdevk; names(s)<- names(p);  print.default(format(s,digits),print.gap=2,quote=FALSE); cat ('\n')
      }
  } else if (object$family$family=='Gamma'){
      dispersion <- 1/object$shape$shape
      if (object$Misc$lambda<=1/length(object$masses)){cat('\nComponent distribution - MLE of shape parameter:\t  ',format(signif(object$shape$shape,digits)),'\n')
      } else {
          cat('\n MLE of component shape parameters:\n'); s<- object$shape$shapek; names(s)<- names(p);  print.default(format(s,digits),print.gap=2,quote=FALSE); cat ('\n')
      }
  } else cat('\n')

  cat('Random effect distribution - standard deviation:\t  ', format(object$rsdev),'\n\n') # 03/09/07
  
 
  cat('-2 log L:\t   ',format(round(object$disparity,digits=1)))
  if (!is.null(object$post.prob)) cat('     Convergence at iteration ',round(object$EMiter,0))
  cat('\n')
  
  if (np >0){
      invisible(c("coefficients"=list(fitcoef), object[-1],list(dispersion=dispersion), list(lastglmsumm=lastglmsumm)))
  } else {  
      invisible(c("coefficients"=list(fitcoef), object[-1],list(dispersion=dispersion)) )
  }
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/tolfind.R"
"tolfind" <-
function(formula,
                    random=~1,
                    family = gaussian(),
                    data ,
                    k = 4,
                    random.distribution="np",
                    offset,
                    weights,
                    na.action,
                    EMmaxit=500,
                    EMdev.change=0.001,
                    lambda=0,
                    damp=TRUE,
                    damp.power=1,
                    spike.protect=1,
                    sdev,
                    shape,
                    plot.opt=1,
                    steps=15,
                    find.in.range=c(0.05,0.8),
                    verbose=FALSE,
                    noformat=FALSE,
                    ...)

{
  # JE/JH, 2005/06.

  call <- match.call()
  if (is.character(family))
    family <- get(family, mode = "function", envir = parent.frame())
  if (is.function(family))
    family <- family()
  if (is.null(family$family)) {
    print(family)
    stop("`family' not recognized")
  }
  data <- as.data.frame(data)
  ddim <- dim(data)
  mf   <- match.call(expand.dots = FALSE)
  
  # Test for k>1 and for inadmissibly removed intercept term
  if (k==1){
      stop("Please choose k > 1.")
  } else if (k>1 && random.distribution=='np' && max(length(grep('- 1', deparse(formula(mf)))),length(grep('-1', deparse(formula(mf))))) >0 ){
      stop(" term '-1'  in model formula not supported for k>1 & random.distribution='np'. ")
  }
  
  # Test for incorrect offset specification in formula object
  testoffset <- try(is.null(attr(terms(formula(mf)),"offset")),silent=TRUE)
  if (!(class(testoffset)=="try-error" || testoffset)){
      stop("Please specify offset as separate argument outside the model formula.")
  }
  
  # Extract variables from call and set up initial (fixed effect) model
  m    <- match(c("formula", "data", "subset", "weights", "na.action", 
               "etastart", "mustart", "offset"), names(mf), 0)
  mf   <- mf[c(1, m)]
  mf$drop.unused.levels <- TRUE
  mf[[1]] <- as.name("model.frame")
  mf <- try(eval(mf,  parent.frame()), silent=TRUE)
  if (class(mf)=="try-error"){
      if (!missing(offset) && length(offset) != ddim[1]) {
      stop("Number of offsets is ", length(offset), ", should equal ", ddim[1], " (number of observations)")
      }
      if (!missing(weights) && length(weights) != ddim[1]){
      stop("Number of weights is ", length(weights), ", should equal ", ddim[1], " (number of observations)")
      }
      stop(geterrmessage())
  }
  
  offset  <- model.offset(mf) 
  weights <- model.weights(mf) 
  Y  <- model.response(mf, "numeric") # response
  Ym <- is.matrix(Y)
  N  <- NROW(Y)  # corresponds to ddim[1] if there are no missing values
  
  if (is.null(offset)){offset  <-rep(0,N) }
  if (is.null(weights)){weights<-rep(1,N)}   
  data$poffset <- numeric(1); data$pweights<-numeric(1)
  data  <- if (is.matrix(Y)) data[dimnames(Y)[[1]],] else  data[names(Y),] #omit missing values   
  data$poffset<-offset;  data$pweights<-weights
  
  all.Disparities <- all.converged <- rep(0,steps)
  min.Disp        <- min.Disp.conv <- 10^8
  step.min        <- step.min.conv <- 1
  mform           <- strsplit(as.character(random)[2],'\\|')[[1]]
  mform           <- gsub(' ', '',mform)
  
  # Configure graphics window
  if (!noformat){
      if (steps >8) par(mfrow=c(4,4), cex=0.5) else par(mfrow=c(3,3), cex=0.5,cex.axis=1.1 )
  }

  # Run alldist/allvc for a grid of tol values
  for (t in 1: steps){
     tol  <- find.in.range[1]+ (find.in.range[2]-find.in.range[1])*t/steps
     tol0 <- tol  #for main title of graphical output
     if(length(mform)==1){ 
         npfit<- try(alldist(formula=formula,random=formula(random),family=family, data=data,k=k,random.distribution=random.distribution,  offset=poffset,  weights=pweights, na.action=na.action,  tol=tol, EMmaxit=EMmaxit, EMdev.change=EMdev.change, lambda=lambda, damp=damp, damp.power=damp.power, spike.protect=spike.protect, sdev=sdev, shape=shape, plot.opt=plot.opt, verbose=verbose))         
         if(class(npfit)=="try-error"){
                cat("tolfind failed using tol=", tol, ". Hint:  specify another range of tol values and try again. "); return()
         }  
         all.Disparities[t]<-  npfit$disparity
         all.converged[t]<-  npfit$EMconverged
     } else { 
         vcfit<- try(allvc(formula=formula,random=formula(random),family=family, data=data,k=k,random.distribution=random.distribution,  offset=poffset, weights=pweights, na.action=na.action, tol=tol, EMmaxit=EMmaxit,EMdev.change=EMdev.change, lambda=lambda, damp=damp, damp.power=damp.power, spike.protect=spike.protect, shape=shape, sdev=sdev, plot.opt=plot.opt, verbose=verbose))
         if(class(vcfit)=="try-error"){
                cat("tolfind failed using tol=", tol,  ". Hint: specify another range of tol values and try again. "); return()
         } 
         all.Disparities[t]<-  vcfit$disparity
         all.converged[t]<-vcfit$EMconverged
     }
     
     if (all.Disparities[t]< min.Disp){min.Disp<- all.Disparities[t]; step.min<-t }
     if (all.Disparities[t]< min.Disp.conv && all.converged[t]){min.Disp.conv<- all.Disparities[t]; step.min.conv<-t }
  }
  
  tol.min       <- find.in.range[1] + (find.in.range[2]-find.in.range[1])*step.min/steps
  tol.min.conv  <- find.in.range[1] + (find.in.range[2]-find.in.range[1])*step.min.conv/steps
  npcolors      <- 2 + all.converged

  plot(find.in.range[1]+(find.in.range[2]-find.in.range[1])*(1:steps)/steps,all.Disparities,type="o",xlab="tol",ylab="Disparity",col=npcolors)
  segments(tol.min, min.Disp, tol.min, 1.1*min.Disp,col=4)
  cat("Minimal Disparity:", min.Disp, "at tol=", tol.min, "\n")

  # Print on screen
  if(max(all.converged)==1){
      cat("Minimal Disparity with EM converged:", min.Disp.conv, "at tol=", tol.min.conv, "\n")
  } else {
      cat(" No convergence achieved for any choice of tol.", "\n")
  }

  list("MinDisparity"=min.Disp.conv, "Mintol"=tol.min.conv, "AllDisparities"= all.Disparities , "Alltol"=  find.in.range[1]+ (find.in.range[2]-find.in.range[1])* (1:steps)/steps, "AllEMconverged"=all.converged==TRUE)
}

#line 1 "d:/Rcompile/CRANpkg/local/2.11/npmlreg/R/weightslogl.calc.w.R"
"weightslogl.calc.w" <- 
function(p,fjk,weights){
# amended to rescale posterior probabilities
# R.E.D. 15th Feb 2006
# p is a vector of length K containing the mixture proportions
# fjk is a JXK matrix of log densities
logpf <- t(apply(fjk,1,"+",log(p)))
Mi <- apply(logpf,1,max)
Sik <- logpf-Mi
ifelse(Sik < -760, 0, Sik) 
eSik <- exp(Sik)
SeSik <- as.vector(apply(eSik,1,sum))
w <- eSik/SeSik
ML.dev <- -2*sum(weights*log(apply(eSik,1,sum)))-2*sum(weights*Mi)
list(w=w, ML.dev=ML.dev)
} 



