### $Id: AAA.R,v 1.1 1999/11/04 16:42:28 saikat Exp $
###
### nlme for R
###
### Copyright 1999-1999 Douglas M. Bates <bates@stat.wisc.edu>,
###                     Saikat DebRoy <saikat@stat.wisc.edu>
###
### This file is part of the nlme library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

require( "nls" )

if(R.version$minor < 90) {
  stop("The nlme package requires R-0.90.0 or later.  Please upgrade.")
}
### $Id: VarCorr.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###          Extract variance components of lme models.
###
### Copyright 1997-1999  Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

VarCorr <- function( x, sigma = 1, rdig = 3) UseMethod("VarCorr")

VarCorr.lme <- function( x, sigma = 1., rdig = 3)
{
  sigma <- x$sigma
  m <- lapply( rev( x$modelStruct$reStruct ), VarCorr,
              sigma = sigma, rdig = rdig)
  Q <- length( m )
  if (Q <= 1) {
    nm <- names(m)
    m <- m[[1]]
    mm <- rbind(m, Residual = c(Variance = sigma^2, StdDev = sigma))
    v <- array( "", dim(mm), dimnames(mm) )
    v[, 1] <- format( mm[, 1] )
    v[, 2] <- format( mm[, 2] )
    if (!is.null( attr(m, "corr") ) ) {
      v <- cbind( v, rbind(attr(m, "corr"),
                           Residual = rep("", ncol(attr(m, "corr")))))
    }
    attr( v, "title" ) <-
      paste( nm, "=", attr( m, "formStr" ) )
    class( v ) <- "VarCorr.lme"
    return( v )
  }
  ## multiple nested levels case
  nrows <- sapply( m, nrow )
  trows <- 1 + c(0, cumsum(1 + nrows))[1:Q]
  bd <- rbind( do.call("rbind", m),
              c(Variance = sigma^2, StdDev = sigma) )
  corr <- lapply( m, attr, which = "corr")
  colnames <- colnames(bd)
  maxCorr <- 0
  if ( !all( Nulls <- sapply( corr, is.null ) ) ) {
    maxCorr <- max( sapply( corr[!Nulls], ncol ) )
    colnames <- c( colnames, "Corr", rep("", maxCorr - 1 ) )
  }
  v <- array("", c(sum(nrows) + Q + 1, 2 + maxCorr), list(NULL, colnames))
  v[-trows, 1] <- format(bd[, 1])
  v[-trows, 2] <- format(bd[, 2])
  v[trows, 1] <- sapply( m, attr, which = "formStr" )
  rownames <- rep("", sum(nrows) + Q)
  rownames[trows] <- paste( names( m ), "=" )
  rr <- 1
  for (i in seq( along = m ) ) {
    rownames[ rr + (1:nrows[i]) ] <- dimnames( m[[i]] )[[1]]
    if (!is.null( corr[[i]] )) {
      v[ rr + (1:nrows[i]), 2 + (1:ncol(corr[[i]])) ] <- corr[[i]]
    }
    rr <- rr + nrows[i] + 1
  }
  rownames(v) <- c(rownames, "Residual")
  class(v) <- "VarCorr.lme"
  v
}

print.VarCorr.lme <- function(x, ...)
{
  if (!is.null(attr(x, "title"))) {
    cat(attr( x, "title" ), "\n")
    attr(x, "title") <- NULL
  }
  print(unclass(x), ..., quote = FALSE )
}


VarCorr.pdMat <- function( x, sigma = 1., rdig = 3)
{
  sx <- summary( x )
  sd <- sigma * attr( sx, "stdDev" )
  var <- sd^2
  p <- dim(sx)[2]
  v <- array(c(var, sd), c(p, 2), list( names(sd), c( "Variance", "StdDev" )))
#   attr(v, "formStr") <- deparse(as.call(list(as.name(class(x)[[1]]),
#                                        as.vector(attr(x, "formula")))))
# ## puts in an extra blank.  We'll do it the clunky way instead
  attr(v, "formStr") <-
    if ( inherits( attr(x, "formula"), "listForm" ) ) {# an nlme'ism
      paste(class(x)[[1]], "(list(", 
            paste( sapply( attr(x, "formula"),
                          function(x) as.character(deparse(as.vector(x)))),
                  collapse=","), "))", sep = "")
    } else {
      paste(class(x)[[1]], "(",
            substring(deparse(as.vector(attr(x, "formula"))), 2), ")", sep = "")
    }
      if ( attr(sx, "noCorrelation") | (p <= 1) ) {
    return(v)
  }
  ll <- lower.tri(sx)
  sx[ll] <- format(round(sx[ll], digits = rdig))
  sx[!ll] <- ""
  if (!is.null(colnames(sx))) {
    sx[1,] <- abbreviate(colnames(sx), minlength = rdig + 3)
  }
  dimnames(sx) <- list(names(sd), c("Corr", rep("", p - 1)))
  attr(v, "corr") <- sx[, -p, drop = FALSE ]
  v
}

VarCorr.pdBlocked <- function( x, sigma = 1., rdig = 3)
{
  m <- lapply( x, VarCorr, sigma = sigma, rdig = rdig)
  bd <- do.call("rbind", m)
  corr <- lapply( m, attr, which = "corr")
  maxCorr <- 0
  if ( !all( Nulls <- sapply( corr, is.null ) ) ) {
    maxCorr <- max( sapply( corr[!Nulls], ncol ) )
    
  }
  attr(bd, "formStr") <-
    paste( sapply( m, attr, which = "formStr" ), collapse = ", ")
  bd
}
  
### Local variables:
### mode: S
### End:
### $Id: corStruct.q,v 1.2 1999/11/17 22:09:19 saikat Exp $
###
###              Classes of correlation structures
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


##*## Generics that should be implemented for any corStruct class

corFactor <-
  ## extractor for transpose inverse square root factor of corr matrix
  function(object, ...) UseMethod("corFactor")

corMatrix <-
  ## extractor for correlation matrix or the transpose inverse 
  ## square root matrix
  function(object, ...) UseMethod("corMatrix")

###*# Constructor
### There is no constructor function for this class (i.e. no function
### called corStruct) because the class is virtual.

###*# Methods for local generics

corFactor.corStruct <-
  function(object) 
{
  if (!is.null(aux <- attr(object, "factor"))) {
    return(aux)
  }
  corD <- Dim(object)
  val <- .C("corStruct_factList",
	    as.double(unlist(corMatrix(object))),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
            logDet = double(1),
            PACKAGE="nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}
  
corMatrix.corStruct <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (corr) {
    ## Do not know how to calculate the correlation matrix
    stop(paste("Don't know how to calculate correlation matrix of",
	       class(object)[1],"object"))
  } else {
    ## transpose inverse square root
    if (data.class(covariate) == "list") {
      if (is.null(names(covariate))) {
	names(covariate) <- 1:length(covariate)
      }
      corD <- Dim(object, rep(names(covariate), 
			      unlist(lapply(covariate, length))))
    } else {
      corD <- Dim(object, rep(1, length(covariate)))
    }
    val <- .C("corStruct_factList",
	      as.double(unlist(corMatrix(object, covariate))),
	      as.integer(unlist(corD)),
	      factor = double(corD[["sumLenSq"]]),
	      logDet = double(1),
              PACKAGE="base")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
    if (corD[["M"]] > 1) {
      val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
      val <- lapply(val, function(el) {
        nel <- round(sqrt(length(el)))
        array(el, c(nel, nel))
      })
      names(val) <- names(corD[["len"]])
      val <- as.list(val)
    } else {
      val <- array(val, c(corD[["N"]], corD[["N"]]))
    }
    attr(val, "logDet") <- lD
    val
  }
}

###*# Methods for standard generics

as.matrix.corStruct <-
  function(x) corMatrix(x)

coef.corStruct <-
  ## Accessor for constrained or unconstrained parameters of
  ## corStruct objects 
  function(object, unconstrained = TRUE) 
{
  if (unconstrained) {
    if (is.null(isFix <- attr(object, "fixed"))) {
      stop("corStruct object must have a \"fixed\" attribute.")
    }
    if (isFix) {
      numeric(0)
    } else {
      as.vector(object)
    }
  } else {
    stop(paste("Don't know how to obtain parameters of",
	       class(object)[1], "object"))
  }
}

"coef<-.corStruct" <-
  function(object, value)
{
  ## Assignment of the unconstrained parameter of corStruct objects
  value <- as.numeric(value)
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  object[] <- value
  ## updating the factor list and logDet, by forcing a recalculation
  attr(object, "factor") <- NULL
  attr(object, "factor") <- corFactor(object)
  attr(object, "logDet") <- NULL
  attr(object, "logDet") <- logDet(object)
  object
}

Dim.corStruct <-
  function(object, groups) 
{
  if (missing(groups)) return(attr(object, "Dim"))
  ugrp <- unique(groups)
  groups <- factor(groups, levels = ugrp)
  len <- table(groups)
  list(N = length(groups),
       M = length(len),
       maxLen = max(len),
       sumLenSq = sum(len^2),
       len = len,
       start = match(ugrp, groups) - 1)
}

formula.corStruct <-
  ## Accessor for the covariate formula
  function(object) eval(attr(object, "formula"))

getCovariate.corStruct <- 
  function(object, form = formula(object), data) 
{
  if (!missing(form)) {
    form <- formula(object)
    warning("Cannot change \"form\".")
  }
  if (is.null(covar <- attr(object, "covariate"))) { # need to calculate it
    if (missing(data)) {
      stop("Need data to calculate covariate of corStruct object")
    }
    covForm <- getCovariateFormula(form)
    if (!is.null(getGroupsFormula(form))) {
      grps <- getGroups(object, data = data)
    } else {
      grps <- NULL
    }
    if (length(all.vars(covForm)) > 0) { # primary covariate present
      if (is.null(grps)) {
        covar <- getCovariate(data, covForm)
      } else {
        if (all(all.vars(covForm) == sapply(splitFormula(covForm, "+"),
                          function(el) deparse(el[[2]])))) {
          covar <- split(getCovariate(data, covForm), grps)
        } else {
          covar <- lapply(split(data, grps), getCovariate, covForm)
        }
      }
    } else {
      if (is.null(grps)) {
        covar <- 1:nrow(data)
      } else {
	covar <- lapply(split(grps, grps), function(x) 1:length(x))
      }
    }
    if (!is.null(grps)) {
      covar <- as.list(covar)
    }
  }
  covar
}

getGroups.corStruct <-
  function(object, form = formula(object), level, data, sep)
{
  if (is.null(val <- attr(object, "groups"))) { # need to calculate
    if (!missing(data)) {
      if ((grpLev <- length(getGroupsFormula(form, asList = TRUE))) > 0) {
        ## use innermost grouping level
        val <- getGroups(data, form, level = grpLev)
        factor(val, levels = unique(as.character(val)))
      } else {
        rep(1, dim(data)[1])
      }
    } else {
      NULL
    }
  } else {
    val
  }
}

initialize.corStruct <-
  ## Initializes some attributes of corStruct objects
  function(object, data, ...)
{
  form <- formula(object)
  ## obtaining the groups information, if any
  if (!is.null(getGroupsFormula(form))) {
    attr(object, "groups") <- getGroups(object, form, data = data)
    attr(object, "Dim") <- Dim(object, attr(object, "groups"))
  } else {                              # no groups
    attr(object, "Dim") <- Dim(object, as.factor(rep(1, nrow(data))))
  }
  ## obtaining the covariate(s)
  attr(object, "covariate") <- getCovariate(object, data = data)
  object
}

logDet.corStruct <- 
  function(object, covariate = getCovariate(object))
{
  if (!is.null(aux <- attr(object, "logDet"))) {
    return(aux)
  }
  if (is.null(aux <- attr(object, "factor"))) {
    ## getting the transpose sqrt factor
    aux <- corMatrix(object, covariate = covariate, corr = FALSE)
  }
  if (is.null(aux1 <- attr(aux, "logDet"))) {
    ## checking for logDet attribute; if not present, get corr matrix
    aux <- corMatrix(object, covariate)
    if (data.class(aux) == "list") {    # by group
      sum(log(abs(unlist(lapply(aux, function(el) svd(el)$d)))))/2
    } else {
      sum(log(abs(svd(aux)$d)))/2
    }
  } else {
    -aux1
  }
}

logLik.corStruct <-
  function(object, data) -logDet(object)

needUpdate.corStruct <-
  function(object) FALSE

print.corStruct <-
  function(x, ...)
{
  if (length(aux <- coef(x, FALSE)) > 0) {
    cat("Correlation structure of class", class(x)[1], "representing\n")
    print(invisible(aux), ...)
  } else {
    cat("Uninitialized correlation structure of class", class(x)[1], "\n")
  }
}

print.summary.corStruct <-
  function(x, ...)
{
  class(x) <- attr(x, "oClass")
  cat(paste("Correlation Structure: ", attr(x, "structName"), "\n", sep = ""))
  cat(paste(" Formula:", deparse(as.vector(formula(x))),"\n"))
  cat(" Parameter estimate(s):\n")
  print(coef(x, FALSE))
}


recalc.corStruct <-
  function(object, conLin)
{
  conLin[["Xy"]][] <-
    .C("corStruct_recalc", 
       Xy = as.double(conLin[["Xy"]]),
       as.integer(unlist(Dim(object))),
       as.integer(ncol(conLin[["Xy"]])),
       as.double(unlist(corFactor(object))),
       PACKAGE="nlme")[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + logLik(object)
  conLin
}
	 
summary.corStruct <-
  function(object, structName = class(object)[1])
{
  attr(object, "structName") <- structName
  attr(object, "oClass") <- class(object)
  class(object) <- "summary.corStruct"
  object
}

update.corStruct <-
  function(object, data)
{
  object
}

##*## Classes that substitute for (i.e. inherit from) corStruct

###*# corSymm - general, unstructured correlation 

####* Constructor

corSymm <-
  ## Constructor for the corSymm class
  function(value = numeric(0), form = ~ 1, fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "fixed") <- fixed
  class(value) <- c("corSymm", "corStruct")
  value
}

###*# Methods for local generics

corFactor.corSymm <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("symm_factList",
	    as.double(as.vector(object)),
	    as.integer(unlist(attr(object, "covariate"))),
	    as.integer(attr(object, "maxCov")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
            PACKAGE="nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corSymm <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, length))))
  } else {
    corD <- Dim(object, rep(1, length(covariate)))
  }
  if (corr) {
    val <- .C("symm_matList",
	      as.double(as.vector(object)),
	      as.integer(unlist(covariate)),
	      as.integer(attr(object, "maxCov")),
	      as.integer(unlist(corD)),
	      mat = double(corD[["sumLenSq"]]),
              PACKAGE="nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("symm_factList",
              as.double(as.vector(object)),
              as.integer(unlist(covariate)),
              as.integer(attr(object, "maxCov")),
              as.integer(unlist(corD)),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE="nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for standard generics

coef.corSymm <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained) {
    if (attr(object, "fixed")) {
      return(numeric(0))
    } else {
      return(as.vector(object))
    }
  }
  mC <- attr(object, "maxCov")
  .C("symm_fullCorr", as.double(object), 
     as.integer(mC), corr = double(round(mC * (mC - 1) / 2)),
     PACKAGE="nlme")[["corr"]]
}

"coef<-.corSymm" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  object[] <- value
  corD <- attr(object, "Dim")
  ## updating the factor list and logDet
  aux <- .C("symm_factList",
	    as.double(as.vector(object)),
	    as.integer(unlist(getCovariate(object))),
	    as.integer(attr(object, "maxCov")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
            PACKAGE="nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corSymm <-
  function(object, data, ...)
{
  if (!is.null(attr(object, "maxCov"))) {# initialized - nothing to do
    return(object)
  }
  object <- NextMethod()

  covar <- attr(object, "covariate")
  if (data.class(covar) != "list") {
    covar <- list(covar)
  }
  if (any(unlist(lapply(covar, duplicated)))) {
    stop(paste("Covariate must have unique values",
	       "within groups for corSymm objects"))
  }
  covar <- unlist(covar) - 1
  maxCov <- max(uCov <- unique(covar)) + 1
  if (length(uCov) != maxCov) {
    stop(paste("Unique values of the covariate  for \"corSymm\"",
	       "objects must be a sequence of consecutive integers"))
  }
  if (Dim(object)[["M"]] > 1) {
    attr(object, "covariate") <- split(covar, getGroups(object))
  } else {
    attr(object, "covariate") <- covar
  }
  attr(object, "maxCov") <- maxCov
  natPar <- as.vector(object)
  if (length(natPar) > 0) {
    ## parameters assumed in constrained form
    if (length(natPar) != round(maxCov * (maxCov - 1) / 2)) {
      stop("Initial value for corSymm parameters of wrong dimension")
    }
    if (max(abs(natPar)) >= 1) {
      stop("Initial values for corSymm must be between -1 and 1")
    }
    natMat <- diag(maxCov)/2
    natMat[lower.tri(natMat)] <- natPar
    natMat <- (t(natMat) + natMat)
    ## checking if positive-definite
    if (any(eigen(natMat)$values <= 0)) {
      stop(paste("Initial values for corSymm do not define",
                 "a positive-definite correlation structure"))
    }
    natMat <- chol(natMat)
    uncPar <- numeric(0)
    for(i in 2:maxCov) {
      aux <- acos(natMat[1:(i-1),i]/sqrt(cumsum(natMat[i:1,i]^2)[i:2]))
      uncPar <- c(uncPar, log(aux/(pi - aux)))
    }
    coef(object) <- uncPar
  } else {				# initializing the parameters
    oldAttr <- attributes(object)
    object <- double(round(maxCov * (maxCov - 1) / 2))
    attributes(object) <- oldAttr
    attr(object, "factor") <- corFactor(object)
    attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  }
  object
}

print.corSymm <-
  function(x, ...)
{
  if (length(as.vector(x)) > 0 &&
      !is.null(mC <- attr(x, "maxCov"))) {
    aux <- coef(x, FALSE)
    val <- diag(mC)
    dimnames(val) <- list(1:mC, 1:mC)
    val[lower.tri(val)] <- aux
    class(val) <- "correlation"
    cat("Correlation structure of class corSymm representing\n")
    print(val, ...)
  }
  else cat("Unitialized correlation structure of class corSymm\n")
}

print.summary.corSymm <-
  function(x, ...)
{
  if (length(as.vector(x)) > 0 &&
      !is.null(mC <- attr(x, "maxCov"))) {
    cat("Correlation Structure: General\n")
    cat(paste(" Formula:", deparse(as.vector(formula(x))),"\n"))
    cat(" Parameter estimate(s):\n")
    aux <- coef(x, FALSE)
    val <- diag(mC)
    dimnames(val) <- list(1:mC, 1:mC)
    val[lower.tri(val)] <- aux
    class(val) <- "correlation"
    print(val, ...)
  } else cat("Unitialized correlation structure of class corSymm\n")
}

recalc.corSymm <- 
  function(object, conLin)
{
  val <-
    .C("symm_recalc", 
       Xy = as.double(conLin[["Xy"]]),
       as.integer(unlist(Dim(object))),
       as.integer(ncol(conLin[["Xy"]])),
       as.double(as.vector(object)),
       as.integer(unlist(getCovariate(object))),
       as.integer(attr(object, "maxCov")),
       logLik = double(1),
       PACKAGE="nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corSymm <- 
  function(object, structName = "General correlation")
{
  attr(object, "structName") <- structName
  class(object) <- "summary.corSymm"
  object
}

###*# corNatural - general correlation in natural parametrization

####* Constructor

corNatural <-
  ## Constructor for the corSymm class
  function(value = numeric(0), form = ~ 1, fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "fixed") <- fixed
  class(value) <- c("corNatural", "corStruct")
  value
}

###*# Methods for local generics

corFactor.corNatural <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("nat_factList",
	    as.double(as.vector(object)),
	    as.integer(unlist(attr(object, "covariate"))),
	    as.integer(attr(object, "maxCov")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
            logDet = double(1),
            PACKAGE="nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corNatural <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, length))))
  } else {
    corD <- Dim(object, rep(1, length(covariate)))
  }
  if (corr) {
    val <- .C("nat_matList",
	      as.double(as.vector(object)),
	      as.integer(unlist(covariate)),
	      as.integer(attr(object, "maxCov")),
	      as.integer(unlist(corD)),
              mat = double(corD[["sumLenSq"]]),
              PACKAGE="nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("nat_factList",
              as.double(as.vector(object)),
              as.integer(unlist(covariate)),
              as.integer(attr(object, "maxCov")),
              as.integer(unlist(corD)),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE="nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for standard generics

coef.corNatural <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained) {
    if (attr(object, "fixed")) {
      return(numeric(0))
    } else {
      return(as.vector(object))
    }
  }
  mC <- attr(object, "maxCov")
  val <- .C("nat_fullCorr", as.double(object), 
            as.integer(mC), corr = double(round(mC * (mC - 1) / 2)),
            PACKAGE="nlme")[["corr"]]
  names(val) <- outer(1:mC, 1:mC,
                      function(x,y) {
                        paste("cor(",y,",",x,")",sep="")
                      })[lower.tri(diag(mC))]
  val
}

"coef<-.corNatural" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  object[] <- value
  corD <- attr(object, "Dim")
  ## updating the factor list and logDet
  aux <- .C("nat_factList",
	    as.double(as.vector(object)),
	    as.integer(unlist(getCovariate(object))),
	    as.integer(attr(object, "maxCov")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
            PACKAGE="nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corNatural <-
  function(object, data, ...)
{
  if (!is.null(attr(object, "maxCov"))) {# initialized - nothing to do
    return(object)
  }
  object <- NextMethod()

  covar <- attr(object, "covariate")
  if (data.class(covar) != "list") {
    covar <- list(covar)
  }
  if (any(unlist(lapply(covar, duplicated)))) {
    stop(paste("Covariate must have unique values",
	       "within groups for corNatural objects"))
  }
  covar <- unlist(covar) - 1
  maxCov <- max(uCov <- unique(covar)) + 1
  if (length(uCov) != maxCov) {
    stop(paste("Unique values of the covariate  for corNatural",
	       "objects must be a sequence of consecutive integers"))
  }
  if (Dim(object)[["M"]] > 1) {
    attr(object, "covariate") <- split(covar, getGroups(object))
  } else {
    attr(object, "covariate") <- covar
  }
  attr(object, "maxCov") <- maxCov
  natPar <- as.vector(object)
  if (length(natPar) > 0) {
    ## parameters assumed in constrained form
    if (length(natPar) != round(maxCov * (maxCov - 1) / 2)) {
      stop("Initial value for corNatural parameters of wrong dimension")
    }
    if (max(abs(natPar)) >= 1) {
      stop("Initial values for corNatural must be between -1 and 1")
    }
    natMat <- diag(maxCov)/2
    natMat[lower.tri(natMat)] <- natPar
    natMat <- (t(natMat) + natMat)
    ## checking if positive-definite
    if (any(eigen(natMat)$values <= 0)) {
      stop(paste("Initial values for corNatural do not define",
                 "a positive-definite correlation structure"))
    }
    coef(object) <- log((natPar + 1)/(1 - natPar))
  } else {				# initializing the parameters
    oldAttr <- attributes(object)
    object <- double(round(maxCov * (maxCov - 1) / 2))
    attributes(object) <- oldAttr
    attr(object, "factor") <- corFactor(object)
    attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  }
  object
}

print.corNatural <-
  function(x, ...)
{
  if (length(as.vector(x)) > 0 &&
      !is.null(mC <- attr(x, "maxCov"))) {
    aux <- coef(x, FALSE)
    val <- diag(mC)
    dimnames(val) <- list(1:mC, 1:mC)
    val[lower.tri(val)] <- aux
    class(val) <- "correlation"
    cat("Correlation structure of class corNatural representing\n")
    print(val, ...)
  }
  else cat("Unitialized correlation structure of class corNatural\n")
}

print.summary.corNatural <-
  function(x, ...)
{
  if (length(as.vector(x)) > 0 &&
      !is.null(mC <- attr(x, "maxCov"))) {
    cat("Correlation Structure: General\n")
    cat(paste(" Formula:", deparse(as.vector(formula(x))),"\n"))
    cat(" Parameter estimate(s):\n")
    aux <- coef(x, FALSE)
    val <- diag(mC)
    dimnames(val) <- list(1:mC, 1:mC)
    val[lower.tri(val)] <- aux
    class(val) <- "correlation"
    print(val, ...)
  } else cat("Unitialized correlation structure of class corNatural\n")
}

recalc.corNatural <- 
  function(object, conLin)
{
  val <-
    .C("nat_recalc", 
       Xy = as.double(conLin[["Xy"]]),
       as.integer(unlist(Dim(object))),
       as.integer(ncol(conLin[["Xy"]])),
       as.double(as.vector(object)),
       as.integer(unlist(getCovariate(object))),
       as.integer(attr(object, "maxCov")),
       logLik = double(1),
       PACKAGE="nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corNatural <- 
  function(object,
           structName = "General correlation, with natural parametrization")
{
  attr(object, "structName") <- structName
  class(object) <- "summary.corNatural"
  object
}

###*# corIdent - independent structure

####* Constructor

corIdent <-
  ## Constructor for the corIdent class
  function(form = NULL)
{
  value <- numeric(0)
  attr(value, "formula") <- form
  attr(value, "fixed") <- TRUE
  class(value) <- c("corIdent", "corStruct")
  value
}

###*# Methods for local generics

corMatrix.corIdent <-
  function(object, covariate = getCovariate(object), corr) 
{
  if (data.class(covariate) == "list") {# by group
    as.list(lapply(covariate, function(el, object) corMatrix(object, el)))
  } else {
    diag(length(covariate))
  }
}

###*# Methods for standard generics

coef.corIdent <-
  function(object, unconstrained = TRUE) numeric(0)

"coef<-.corIdent" <- 
  function(object, value) object

initialize.corIdent <- 
  function(object, data, ...)
{
  attr(object, "logDet") <- 0
  object
}

logDet.corIdent <-
  function(object, covariate) 0

recalc.corIdent <- 
  function(object, conLin)
{
  conLin
}

summary.corIdent <-
  function(object, structName = "Independent")
{
  summary.corStruct(object, structName)
}

###*# corAR1 - autoregressive of order one structure

####* Constructor

corAR1 <-
  ## Constructor for the corAR1 class
  function(value = 0, form = ~ 1, fixed = FALSE)
{
  if (abs(value) >= 1) {
    stop("Parameter in AR(1) structure must be between -1 and 1")
  }
  value <- log((1 + value)/( 1 - value))
  attr(value, "formula") <- form
  attr(value, "fixed") <- fixed
  class(value) <- c("corAR1", "corStruct")
  value
}

###*# Methods for local generics

corFactor.corAR1 <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("AR1_factList",
	    as.double(as.vector(object)),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
            PACKAGE="nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corAR1 <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, length))))
  } else {
    corD <- Dim(object, rep(1, length(covariate)))
  }
  if (corr) {
    val <- .C("AR1_matList",
	      as.double(as.vector(object)),
	      as.integer(unlist(corD)),
	      mat = double(corD[["sumLenSq"]]),
              PACKAGE="nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("AR1_factList",
              as.double(as.vector(object)),
              as.integer(unlist(corD)),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE="nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for standard generics

coef.corAR1 <- 
  function(object, unconstrained = TRUE) 
{
  if (unconstrained) {
    if (attr(object, "fixed")) {
      return(numeric(0))
    } else {
      return(as.vector(object))
    }
  }
  aux <- exp(as.vector(object))
  aux <- c((aux - 1)/(aux + 1))
  names(aux) <- "Phi"
  aux
}

"coef<-.corAR1" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  object[] <- value
  corD <- attr(object, "Dim")
  ## updating the factor list and logDet
  aux <- .C("AR1_factList",
	    as.double(as.vector(object)),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corAR1 <-
  ## Initializes corAR1 objects
  function(object, data, ...)
{
  object <- NextMethod()
  covar <- attr(object, "covariate")
  if (data.class(covar) != "list") {
    covar <- list(covar)
  }
  if (any(unlist(lapply(covar, duplicated)))) {
    stop(paste("Covariate must have unique values",
	       "within groups for corAR1 objects"))
  }
  if (any(unlist(lapply(covar, diff)) != 1)) {
    ## Cannot use formulas for inverse of square root matrix
    ## will convert to class ARMA(1,0)
    attr(object, "p") <- 1
    attr(object, "q") <- 0
    class(object) <- c("corARMA", "corStruct")
    initialize(object, data)
  } else {
    ## obtaining the factor list and logDet
    attr(object, "factor") <- corFactor(object)
    attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
    object
  }
}

recalc.corAR1 <- 
  function(object, conLin)
{
  val <-
    .C("AR1_recalc", 
       Xy = as.double(conLin[["Xy"]]),
       as.integer(unlist(Dim(object))),
       as.integer(ncol(conLin[["Xy"]])),
       as.double(as.vector(object)),
       logLik = double(1),
       PACKAGE = "nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corAR1 <- 
  function(object, structName = "AR(1)")
{
  summary.corStruct(object, structName)
}

####*# corCAR1 - continuous time autoregressive of order one structure

#####* Constructor

corCAR1 <-
  ## Constructor for the corCAR1 class
  function(value = 0.2, form = ~ 1, fixed = FALSE)
{
  if (value <= 0 | value >= 1) {
    stop("Parameter in CAR(1) structure must be between 0 and 1")
  }
  value <- log(value / (1 - value))
  attr(value, "formula") <- form
  attr(value, "fixed") <- fixed
  class(value) <- c("corCAR1", "corStruct")
  value
}


###*# Methods for local generics

corFactor.corCAR1 <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("CAR1_factList",
	    as.double(as.vector(object)),
	    as.double(unlist(attr(object, "covariate"))),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corCAR1 <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, length))))
  } else {
    corD <- Dim(object, rep(1, length(covariate)))
  }
  if (corr) {
    val <- .C("CAR1_matList",
	      as.double(as.vector(object)),
	      as.double(unlist(covariate)),
	      as.integer(unlist(corD)),
	      mat = double(corD[["sumLenSq"]]),
	      PACKAGE = "nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("CAR1_factList",
              as.double(as.vector(object)),
              as.double(unlist(covariate)),
              as.integer(unlist(corD)),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE = "nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for standard generics

coef.corCAR1 <- 
  function(object, unconstrained = TRUE) 
{
  if (unconstrained) {
    if (attr(object, "fixed")) {
      return(numeric(0))
    } else {
      return(as.vector(object))
    }
  }
  aux <- c(exp(as.vector(object)))
  aux <- aux/(1+aux)  
  names(aux) <- "Phi"
  aux
}

"coef<-.corCAR1" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  object[] <- value
  corD <- attr(object, "Dim")
  ## updating the factor list and logDet
  aux <- .C("CAR1_factList",
	    as.double(as.vector(object)),
	    as.double(unlist(getCovariate(object))),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corCAR1 <-
  ## Initializes corCAR1 objects
  function(object, data, ...)
{
  object <- NextMethod()
  covar <- attr(object, "covariate")
  if (data.class(covar) != "list") {
    covar <- list(covar)
  }

  if (any(unlist(lapply(covar, duplicated)))) {
    stop(paste("Covariate must have unique values",
	       "within groups for corCAR1 objects"))
  }
  attr(object, "factor") <- corFactor(object)
  attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  object
}

recalc.corCAR1 <- 
  function(object, conLin)
{
  val <- 
    .C("CAR1_recalc", 
     Xy = as.double(conLin[["Xy"]]),
     as.integer(unlist(Dim(object))),
     as.integer(ncol(conLin[["Xy"]])),
     as.double(as.vector(object)),
     as.double(unlist(getCovariate(object))),
     logLik = double(1),
     PACKAGE = "nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corCAR1 <- 
  function(object, structName = "Continuous AR(1)")
{
  summary.corStruct(object, structName)
}

###*# corARMA - autoregressive-moving average structures

####* Constructor

corARMA <-
  ## Constructor for the corARMA class
  function(value = double(p + q), form = ~ 1, p = 0, q = 0, fixed = FALSE)
{
  if (!(p >= 0 && (p == round(p)))) {
    stop("Autoregressive order must be a non-negative integer")
  }
  if (!(q >= 0 && (q == round(q)))) {
    stop("Moving average order must be a non-negative integer")
  }
  if (0 == (p + q)) {
    return(corIdent())
  }
  if (length(value) != p + q) {
    stop("Initial value for parameter of wrong length")
  }
  if (max(abs(value)) >= 1) {
    stop("Parameters in ARMA structure must be < 1 in absolute value")
  }
  ## unconstrained parameters
  value <- .C("ARMA_unconstCoef", 
	      as.integer(p), 
	      as.integer(q), 
	      pars = as.double(value),
	      PACKAGE = "nlme")$pars
  attributes(value) <- list(formula = form, p = p, q = q, fixed = fixed)
  class(value) <- c("corARMA", "corStruct")
  value
}


###*# Methods for local generics

corFactor.corARMA <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("ARMA_factList",	
	    as.double(as.vector(object)),
	    as.integer(attr(object, "p")),
	    as.integer(attr(object, "q")),
	    as.integer(unlist(attr(object, "covariate"))),
	    as.integer(attr(object, "maxLag")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

    
corMatrix.corARMA <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, length))))
  } else {
    corD <- Dim(object, rep(1, length(covariate)))
  }
  p <- attr(object, "p")
  q <- attr(object, "q")
  maxLag <- attr(object, "maxLag")
  if (corr) {
    val <- .C("ARMA_matList",
	      as.double(as.vector(object)),
	      as.integer(p),
	      as.integer(q),
	      as.integer(unlist(covariate)),
	      as.integer(maxLag),
	      as.integer(unlist(corD)),
	      mat = double(corD[["sumLenSq"]]),
	      PACKAGE = "nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("ARMA_factList",	
              as.double(as.vector(object)),
              as.integer(attr(object, "p")),
              as.integer(attr(object, "q")),
              as.integer(unlist(covariate)),
              as.integer(attr(object, "maxLag")),
              as.integer(unlist(corD)),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE = "nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for standard generics

coef.corARMA <- 
  function(object, unconstrained = TRUE) 
{
  if (attr(object, "fixed") && unconstrained) {
    return(numeric(0))
  } 
  val <-  as.vector(object)
  if (!unconstrained) {
    p <- attr(object, "p")
    q <- attr(object, "q")
    nams <- NULL
    if (p > 0) {
      nams <- paste(rep("Phi", p), 1:p, sep="")
    }
    if (q > 0) {
      nams <- c(nams, paste(rep("Theta", q), 1:q, sep=""))
    }
    val <- c(.C("ARMA_constCoef", as.integer(attr(object,"p")), 
		as.integer(attr(object,"q")),
		pars = as.double(val),
		PACKAGE = "nlme")$pars)
    names(val) <- nams
  }
  val
}

"coef<-.corARMA" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  p <- attr(object, "p")
  q <- attr(object, "q")
  object[] <- value
  ## updating the factor list and logDet
  corD <- Dim(object)
  aux <- .C("ARMA_factList",
	    as.double(as.vector(object)),
	    as.integer(p),
	    as.integer(q),
	    as.integer(unlist(getCovariate(object))),
	    as.integer(attr(object, "maxLag")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corARMA <-
  function(object, data, ...)
{
  ## Initializes corARMA objects
  object <- NextMethod()
  covar <- attr(object, "covariate")
  if (data.class(covar) != "list") {
    covar <- list(covar)
  }
  if (any(unlist(lapply(covar, duplicated)))) {
    stop(paste("Covariate must have unique values",
	       "within groups for corARMA objects"))
  }
  if ((attr(object, "p") == 1) && (attr(object, "q") == 0) &&
     all(unlist(lapply(covar, diff)) == 1)) {
    ## Use AR1 methods instead
    class(object) <- c("corAR1", "corStruct")
    initialize(object, data)
  } else {
    attr(object, "maxLag") <- 
      max(unlist(lapply(covar, function(el) max(abs(outer(el,el,"-"))))))
    attr(object, "factor") <- corFactor(object)
    attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
    object
  }
}

recalc.corARMA <- 
  function(object, conLin)
{
  val <- 
    .C("ARMA_recalc", 
     Xy = as.double(conLin[["Xy"]]),
     as.integer(unlist(Dim(object))),
     as.integer(ncol(conLin[["Xy"]])),
     as.double(as.vector(object)),
     as.integer(attr(object, "p")),
     as.integer(attr(object, "q")),
     as.integer(unlist(getCovariate(object))),
     as.integer(attr(object, "maxLag")),
     logLik = double(1),
     PACKAGE = "nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corARMA <- 
  function(object, structName = paste("ARMA(",attr(object,"p"),",",
		     attr(object,"q"), ")", sep = ""))
{
  summary.corStruct(object, structName)
}

###*# corCompSymm - Compound symmetry structure structure

####* Constructor

corCompSymm <-
  ## Constructor for the corCompSymm class
  function(value = 0, form = ~ 1, fixed = FALSE)
{
  if (abs(value) >= 1) {
    stop(paste("Parameter in \"corCompSymm\" structure",
	       "must be < 1 in absolute value"))
  }
  attr(value, "formula") <- form
  attr(value, "fixed") <- fixed
  class(value) <- c("corCompSymm", "corStruct")
  value
}

###*# Methods for local generics

corFactor.compSymm <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("compSymm_factList",
	    as.double(as.vector(object)),
	    as.double(attr(object, "inf")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corCompSymm <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, length))))
  } else {
    corD <- Dim(object, rep(1, length(covariate)))
  }
  if (corr) {
    val <- .C("compSymm_matList",
	      as.double(as.vector(object)),
	      as.double(attr(object, "inf")),
	      as.integer(unlist(corD)),
	      mat = double(corD[["sumLenSq"]]),
	      PACKAGE = "nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("compSymm_factList",
              as.double(as.vector(object)),
              as.double(attr(object, "inf")),
              as.integer(unlist(corD)),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE = "nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for local generics

coef.corCompSymm <- 
  function(object, unconstrained = TRUE) 
{
  if (unconstrained) {
    if (attr(object, "fixed")) {
      return(numeric(0))
    } else {
      return(as.vector(object))
    }
  }
  val <- exp(as.vector(object))
  val <- c((val + attr(object, "inf"))/(val + 1))
  names(val) <- "Rho"
  val
}

"coef<-.corCompSymm" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter of a corStruct object")
  }
  object[] <- value
  corD <- attr(object, "Dim")
  ## updating the factor list and logDet
  aux <- .C("compSymm_factList",
	    as.double(as.vector(object)),
	    as.double(attr(object, "inf")),
	    as.integer(unlist(corD)),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corCompSymm <-
  ## Initializes corCompSymm objects
  function(object, data, ...)
{
  if (!is.null(attr(object, "inf"))) {   # initialized - nothing to do
    return(object)
  }
  object <- NextMethod()
  natPar <- as.vector(object)
  corD <- Dim(object)
  if (natPar <= (attr(object, "inf") <- -1/(corD[["maxLen"]] - 1))) {
    stop(paste("Initial value in corCompSymm must be > than",
               attr(object, "inf")))
  }
  object[] <- log((natPar - attr(object, "inf"))/(1 - natPar))	
  attr(object, "factor") <- corFactor(object)
  attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  object
}

recalc.corCompSymm <- 
  function(object, conLin)
{
  val <- 
    .C("compSymm_recalc", 
       Xy = as.double(conLin[["Xy"]]),
       as.integer(unlist(Dim(object))),
       as.integer(ncol(conLin[["Xy"]])),
       as.double(as.vector(object)),
       as.double(attr(object, "inf")),
       logLik = double(1),
       PACKAGE = "nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corCompSymm <- 
  function(object, structName = "Compound symmetry")
{
  summary.corStruct(object, structName)
}

####*# corHF - Huyn-Feldt structure

#corHF <-
#  ## Constructor for the corHuynFeldt class
#  function(value = numeric(0), form = ~ 1)
#{
#  attr(value, "formula") <- form
#  class(value) <- c("corHF", "corStruct")
#  value
#}

####*# Methods for local generics

#corFactor.corHF <-
#  function(object)
#{
#  corD <- Dim(object)
#  val <- .C("HF_factList",
#	    as.double(as.vector(object)),
#	    as.integer(attr(object, "maxCov")),
#	    as.integer(unlist(getCovariate(object))),
#	    as.integer(unlist(corD)),
#	    factor = double(corD[["sumLenSq"]]),
#	    logDet = double(1))[c("factor", "logDet")]
#  lD <- val[["logDet"]]
#  val <- val[["factor"]]
#  attr(val, "logDet") <- lD
#  val
#}

#corMatrix.corHF <-
#  function(object, covariate = getCovariate(object), corr = TRUE)
#{
#  if (data.class(covariate) == "list") {
#    if (is.null(names(covariate))) {
#      names(covariate) <- 1:length(covariate)
#    }
#    corD <- Dim(object, rep(names(covariate), 
#			    unlist(lapply(covariate, length))))
#  } else {
#    corD <- Dim(object, rep(1, length(covariate)))
#  }
#  if (corr) {
#    val <- .C("HF_matList",
#	      as.double(as.vector(object)),
#	      as.integer(attr(object, "maxCov")),
#	      as.integer(unlist(covariate)),
#	      as.integer(unlist(corD)),
#	      mat = double(corD[["sumLenSq"]]))[["mat"]]
#    lD <- NULL
#  } else {
#    val <- .C("HF_factList",
#              as.double(as.vector(object)),
#              as.integer(attr(object, "maxCov")),
#              as.integer(unlist(covariate)),
#              as.integer(unlist(corD)),
#              factor = double(corD[["sumLenSq"]]),
#              logDet = double(1))[c("factor", "logDet")]
#    lD <- val[["logDet"]]
#    val <- val[["factor"]]
#  }
#  if (corD[["M"]] > 1) {
#    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
#    val <- lapply(val, function(el) {
#      nel <- round(sqrt(length(el)))
#      array(el, c(nel, nel))
#    })
#    names(val) <- names(corD[["len"]])
#  } else {
#    val <- array(val, c(corD[["N"]], corD[["N"]]))
#  }
#  attr(val, "logDet") <- lD
#  val
#}

####*# Methods for standard generics

#coef.corHF <-
#  function(object, unconstrained = TRUE)
#{
#  aux <- as.vector(object)
#  if (!unconstrained) {
#    aux <- 2 * (exp(aux) + attr(object, "inf")) + 1
#  }
#  aux
#}

#"coef<-.corHF" <-
#  function(object, value) 
#{
#  if (length(value) != length(object)) {
#    stop("Cannot change the length of the parameter of a corStruct object")
#  }
#  object[] <- value
#  corD <- attr(object, "Dim")
#  ## updating the factor list and logDet
#  aux <- .C("HF_factList",
#	    as.double(as.vector(object)),
#	    as.integer(attr(object, "maxCov")),
#	    as.integer(unlist(getCovariate(object))),
#	    as.integer(unlist(corD)),
#	    factor = double(corD[["sumLenSq"]]),
#	    logDet = double(1))[c("factor", "logDet")]
#  attr(object, "factor") <- aux[["factor"]]
#  attr(object, "logDet") <- -aux[["logDet"]]
#  object
#}

#initialize.corHF <-
#  function(object, data, ...)
#{
#  if (!is.null(attr(object, "inf"))) {   # initialized - nothing to do
#    return(object)
#  }
#  object <- NextMethod()
#  covar <- attr(object, "covariate")
#  if (data.class(covar) == "list") {
#    attr(object, "covariate") <- covar <- 
#      lapply(covar, function(el) el - 1)
#  } else {
#    attr(object, "covariate") <- covar <- covar - 1
#    covar <- list(covar)
#  }
#  if (any(unlist(lapply(covar, duplicated)))) {
#    stop(paste("Covariate must have unique values",
#               "within groups for corHF objects"))
#  }
#  maxCov <- max(uCov <- unique(unlist(covar))) + 1
#  if (length(uCov) != maxCov) {
#    stop(paste("Unique values of the covariate  for \"corHF\"",
#               "objects must be a sequence of consecutive integers"))
#  }
#  attr(object, "maxCov") <- maxCov
#  attr(object, "inf") <- -1/(2*maxCov)
#  natPar <- as.vector(object)
#  if (length(natPar) > 0) {
#    if (length(aux) != attr(object, "maxCov"))
#      stop("Initial value for Huyn-Feldt parameters of wrong dimension")
#    ## verifying if initial values satisfy constraints
#    if (any(natPar <= attr(object, "inf"))) {
#      stop(paste("Initial values for \"corHF\" parameters",
#		 "must be > than", attr(object, "inf")))
#    }
#    object[] <- log(natPar - attr(object, "inf"))
#  } else {				# initializing the parameters
#    oldAttr <- attributes(object)
#    object <- log(rep(-attr(object, "inf"), att(object, "maxCov")))
#    attributes(object) <- oldAttr
#  }
#  attr(object, "factor") <- corFactor(object)
#  attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
#  object
#}

#print.corHF <-
#  function(x, ...)
#{
#  if (length(as.vector(x)) > 0 && !is.null(attr(object, "maxCov")))
#    NextMethod()
#  else cat("Unitialized correlation structure of class corHF\n")
#}

#recalc.corHF <- 
#  function(object, conLin)
#{
#  val <-
#    .C("HF_recalc", 
#       Xy = as.double(conLin[["Xy"]]),
#       as.integer(unlist(Dim(object))),
#       as.integer(ncol(conLin[["Xy"]])),
#       as.double(as.vector(object)),
#       as.integer(unlist(getCovariate(object))),
#       as.integer(attr(object, "maxCov")),
#       logLik = double(1))[c("Xy", "logLik")]
#  conLin[["Xy"]][] <- val[["Xy"]]
#  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
#  conLin
#}

#summary.corHF <- 
#  function(object, structName = "Huyn-Feldt")
#{
#  summary.corStruct(object, structName)
#}

###*# corSpatial - a virtual class of spatial correlation structures

###*# Constructor

corSpatial <-
  ## Constructor for the corSpatial class
  function(value = numeric(0), form = ~ 1, nugget = FALSE,
	   type = c("spherical", "exponential", "gaussian", "linear",
             "rational"),
	   metric = c("euclidean", "maximum", "manhattan"), fixed = FALSE)
{
  type <- match.arg(type)
  spClass <- switch(type,
		    spherical = "corSpher",
		    exponential = "corExp",
		    gaussian = "corGaus",
		    linear = "corLin",
                    rational = "corRatio")
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  attr(value, "fixed") <- fixed
  class(value) <- c(spClass, "corSpatial", "corStruct")
  value
}

###*# Methods for local generics

corFactor.corSpatial <-
  function(object)
{
  corD <- Dim(object)
  val <- .C("spatial_factList",
	    as.double(as.vector(object)),
	    as.integer(attr(object, "nugget")),
	    as.double(unlist(getCovariate(object))),
	    as.integer(unlist(corD)),
	    as.double(attr(object, "minD")),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corSpatial <-
  function(object, covariate = getCovariate(object), corr = TRUE)
{
  if (data.class(covariate) == "list") {
    if (is.null(names(covariate))) {
      names(covariate) <- 1:length(covariate)
    }
    corD <- Dim(object, rep(names(covariate), 
			    unlist(lapply(covariate, 
		  function(el) round((1 + sqrt(1 + 8 * length(el)))/2)))))
  } else {
    corD <- Dim(object, rep(1, round((1 + sqrt(1 + 8* length(covariate)))/2)))
  }
  if (corr) {
    val <- .C("spatial_matList",
	      as.double(as.vector(object)),
	      as.integer(attr(object, "nugget")),
	      as.double(unlist(covariate)),
	      as.integer(unlist(corD)),
	      as.double(attr(object, "minD")),
	      mat = double(corD[["sumLenSq"]]),
	      PACKAGE = "nlme")[["mat"]]
    lD <- NULL
  } else {
    val <- .C("spatial_factList",
              as.double(as.vector(object)),
              as.integer(attr(object, "nugget")),
              as.double(unlist(getCovariate(object))),
              as.integer(unlist(corD)),
              as.double(attr(object, "minD")),
              factor = double(corD[["sumLenSq"]]),
              logDet = double(1),
              PACKAGE = "nlme")[c("factor", "logDet")]
    lD <- val[["logDet"]]
    val <- val[["factor"]]
  }
  if (corD[["M"]] > 1) {
    val <- split(val, rep(1:corD[["M"]], (corD[["len"]])^2))
    val <- lapply(val, function(el) {
      nel <- round(sqrt(length(el)))
      array(el, c(nel, nel))
    })
    names(val) <- names(corD[["len"]])
    val <- as.list(val)
  } else {
    val <- array(val, c(corD[["N"]], corD[["N"]]))
  }
  attr(val, "logDet") <- lD
  val
}

###*# Methods for standard generics

coef.corSpatial <-
  function(object, unconstrained = TRUE)
{
  if (attr(object, "fixed") && unconstrained) {
    return(numeric(0))
  }
  val <- as.vector(object)
  if (length(val) == 0) {               # uninitialized
    return(val)
  }
  if (!unconstrained) {
    val <- exp(val)
    if (attr(object, "nugget")) val[2] <- val[2]/(1+val[2])
  }
  if (attr(object, "nugget")) names(val) <- c("range", "nugget")
  else names(val) <- "range"
  val
}

"coef<-.corSpatial" <-
  function(object, value) 
{
  if (length(value) != length(object)) {
    stop("Cannot change the length of the parameter after initialization")
  }
  object[] <- value
  corD <- attr(object, "Dim")
  ## updating the factor list and logDet
  aux <- .C("spatial_factList",
	    as.double(as.vector(object)),
	    as.integer(attr(object, "nugget")),
	    as.double(unlist(getCovariate(object))),
	    as.integer(unlist(corD)),
	    as.double(attr(object, "minD")),
	    factor = double(corD[["sumLenSq"]]),
	    logDet = double(1),
	    PACKAGE = "nlme")[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

Dim.corSpatial <-
  function(object, groups)
{
  if (missing(groups)) return(attr(object, "Dim"))
  val <- Dim.corStruct(object, groups)
  val[["start"]] <- 
    c(0, cumsum(val[["len"]] * (val[["len"]] - 1)/2)[-val[["M"]]])
  ## will use third component of Dim list for spClass
  names(val)[3] <- "spClass"
  val[[3]] <- 
    match(class(object)[1], c("corSpher", "corExp", "corGaus", "corLin",
                              "corRatio"), 0)
  val
}

getCovariate.corSpatial <- 
  function(object, form = formula(object), data) 
{
  if (is.null(covar <- attr(object, "covariate"))) { # need to calculate it
    if (missing(data)) {
      stop("Need data to calculate covariate")
    }
    covForm <- getCovariateFormula(form)
    if (length(all.vars(covForm)) > 0) { # covariate present
      if (attr(terms(covForm), "intercept") == 1) {
	covForm <-
          eval(parse(text = paste("~", deparse(covForm[[2]]),"-1",sep="")))
      }
      covar <- as.data.frame(unclass(model.matrix(covForm, 
					      model.frame(covForm, data))))
    } else {
      covar <- NULL
    }
      
    if (!is.null(getGroupsFormula(form))) { # by groups
      grps <- getGroups(object, data = data)
      if (is.null(covar)) {
	covar <- lapply(split(grps, grps),
                        function(x) as.vector(dist(1:length(x))))
      } else {
	covar <- lapply(split(covar, grps), 
			function(el, metric) {
                          el <- as.matrix(el)
                          if (nrow(el) > 1) {
                            as.vector(dist(el, metric))
                          } else {
                            numeric(0)
                          }
			}, metric = attr(object, "metric"))
      }
      covar <- covar[sapply(covar, length) > 0]  # no 1-obs groups
    } else {				# no groups
      if (is.null(covar)) {
	covar <- as.vector(dist(1:nrow(data)))
      } else {
	covar <- as.vector(dist(as.matrix(covar),
                                metric = attr(object, "metric")))
      }
    }
    if (any(unlist(covar) == 0)) {
      stop("Cannot have zero distances in \"corSpatial\"")
    }
  }
  covar
}

initialize.corSpatial <-
  function(object, data, ...)
{
  if (!is.null(attr(object, "minD"))) { #already initialized
    return(object)
  }
  object <- initialize.corStruct(object, data)
  nug <- attr(object, "nugget")

  val <- as.vector(object)
  if (length(val) > 0) {		# initialized
    if (val[1] <= 0) {
      stop("Range must be > 0 in \"corSpatial\" initial value")
    }
    if (nug) {				# with nugget effect
      if (length(val) == 1) {		# assuming nugget effect not given
	val <- c(val, 0.1)		# setting it to 0.1
      } else {
	if (length(val) != 2) {
	  stop("Initial value for corSpatial parameters of wrong dimension")
	}
      }
      if ((val[2] <= 0) || (val[2] >= 1)) {
	stop("Initial value of nugget ratio must be between 0 and 1")
      }
    } else {				# only range parameter
      if (length(val) != 1) {
	stop("Initial value for corSpatial parameters of wrong dimension")
      }
    }
  } else {
    val <- min(unlist(attr(object, "covariate"))) * 0.9
    if (nug) val <- c(val, 0.1)
  }
  val[1] <- log(val[1])
  if (nug) val[2] <- log(val[2]/(1 - val[2]))
  oldAttr <- attributes(object)
  object <- val
  attributes(object) <- oldAttr
  attr(object, "minD") <- min(unlist(attr(object, "covariate")))
  attr(object, "factor") <- corFactor(object)
  attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  object
}

recalc.corSpatial <- 
  function(object, conLin)
{
  val <-
    .C("spatial_recalc", 
       Xy = as.double(conLin[["Xy"]]),
       as.integer(unlist(Dim(object))),
       as.integer(ncol(conLin[["Xy"]])),
       as.double(as.vector(object)),
       as.double(unlist(getCovariate(object))),
       as.double(attr(object, "minD")),
       as.integer(attr(object, "nugget")),
       logLik = double(1),
       PACKAGE="nlme")[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

Variogram.corSpatial <-
  function(object, distance = NULL, sig2 = 1, length.out = 50, FUN)
{
  if (is.null(distance)) {
    rangeDist <- range(unlist(getCovariate(object)))
    distance <- seq(rangeDist[1], rangeDist[2], length = length.out)
  }
  params <- coef(object, unconstrained = FALSE)
  if (length(params) == 1) {            # no nugget effect
    rang <- params
    nugg <- 0
  } else {                              # nugget effect
    rang <- params[1]
    nugg <- params[2]
  }
  val <- data.frame(variog = sig2 * (nugg + (1 - nugg) * FUN(distance, rang)),
                    dist = distance)
  class(val) <- c("Variogram", "data.frame")
  val
}

###*# corExp - exponential spatial correlation structure

corExp <-
  ## Constructor for the corExp class
  function(value = numeric(0), form = ~ 1, nugget = FALSE,
	   metric = c("euclidean", "maximum", "manhattan"), fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  attr(value, "fixed") <- fixed
  class(value) <- c("corExp", "corSpatial", "corStruct")
  value
}

###*# Methods for standard generics

summary.corExp <- 
  function(object, structName = "Exponential spatial correlation")
{
  summary.corStruct(object, structName)
}

Variogram.corExp <-
  function(object, distance = NULL, sig2 = 1, length.out = 50)
{
  Variogram.corSpatial(object, distance, sig2, length.out,
                       function(x, y) { 1 - exp(-x/y) })
}

###*# corGaus - Gaussian spatial correlation structure

corGaus <-
  ## Constructor for the corGaus class
  function(value = numeric(0), form = ~ 1, nugget = FALSE,
	   metric = c("euclidean", "maximum", "manhattan"), fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  attr(value, "fixed") <- fixed
  class(value) <- c("corGaus", "corSpatial", "corStruct")
  value
}

###*# Methods for standard generics

summary.corGaus <- 
  function(object, structName = "Gaussian spatial correlation")
{
  summary.corStruct(object, structName)
}

Variogram.corGaus <-
  function(object, distance = NULL, sig2 = 1, length.out = 50)
{
  Variogram.corSpatial(object, distance, sig2, length.out,
                       function(x, y){ 1 - exp(-(x/y)^2) })
}

###*# corLin - Linear spatial correlation structure

corLin <-
  ## Constructor for the corLin class
  function(value = numeric(0), form = ~ 1, nugget = FALSE,
	   metric = c("euclidean", "maximum", "manhattan"), fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  attr(value, "fixed") <- fixed
  class(value) <- c("corLin", "corSpatial", "corStruct")
  value
}

###*# Methods for standard generics

coef.corLin <-
  function(object, unconstrained = TRUE)
{
  val <- NextMethod()
  if (!unconstrained) val[1] <- val[1] + attr(object, "minD")
  val
}

initialize.corLin <-
  function(object, data, ...)
{
  if (!is.null(attr(object, "minD"))) { #already initialized
    return(object)
  }
  object <- initialize.corStruct(object, data)
  nug <- attr(object, "nugget")

  minD <- min(unlist(attr(object, "covariate")))
  val <- as.vector(object)
  if (length(val) > 0) {		# initialized
    if (val[1] <= 0) {
      stop("Range must be > 0 in \"corLin\" initial value")
    }
    if (val[1] <= minD) {
      warning(paste("Initial value for range less than minimum distance.",
		    "Setting it to 1.1 * min(distance)"))
      val[1] <- 1.1 * minD
    }
    if (nug) {				# with nugget effect
      if (length(val) == 1) {		# assuming nugget effect not given
	val <- c(val, 0.1)		# setting it to 0.1
      } else {
	if (length(val) != 2) {
	  stop("Initial value for corSpher parameters of wrong dimension")
	}
      }
      if ((val[2] <= 0) || (val[2] >= 1)) {
	stop("Initial value of nugget ratio must be in (0,1)")
      }
    } else {				# only range parameter
      if (length(val) != 1) {
	stop("Initial value for corLin parameters of wrong dimension")
      }
    }
  } else {
    val <- minD * 1.1
    if (nug) val <- c(val, 0.1)
  }
  val[1] <- log(val[1] - minD)
  if (nug) val[2] <- log(val[2]/(1 - val[2]))
  oldAttr <- attributes(object)
  object <- val
  attributes(object) <- oldAttr
  attr(object, "minD") <- minD
  attr(object, "factor") <- corFactor(object)
  attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  object
}

summary.corLin <- 
  function(object, structName = "Linear spatial correlation")
{
  summary.corStruct(object, structName)
}

Variogram.corLin <-
  function(object, distance = NULL, sig2 = 1, length.out = 50)
{
  Variogram.corSpatial(object, distance, sig2, length.out,
                       function(x, y) { pmin(x/y, 1) })
}

###*# corRatio - rational quadratic spatial correlation structure

corRatio <-
  ## Constructor for the corRational class
  function(value = numeric(0), form = ~ 1, nugget = FALSE,
	   metric = c("euclidean", "maximum", "manhattan"), fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  attr(value, "fixed") <- fixed
  class(value) <- c("corRatio", "corSpatial", "corStruct")
  value
}

###*# Methods for standard generics

summary.corRatio <- 
  function(object, structName = "Rational quadratic spatial correlation")
{
  summary.corStruct(object, structName)
}

Variogram.corRatio <-
  function(object, distance = NULL, sig2 = 1, length.out = 50)
{
  Variogram.corSpatial(object, distance, sig2, length.out,
                       function(x, y) {
                         x <- (x/y)^2
                         x/(1+x)
                       })
}

###*# corSpher - spherical spatial correlation structure

corSpher <-
  ## Constructor for the corSpher class
  function(value = numeric(0), form = ~ 1, nugget = FALSE,
	   metric = c("euclidean", "maximum", "manhattan"), fixed = FALSE)
{
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  attr(value, "fixed") <- fixed
  class(value) <- c("corSpher", "corSpatial", "corStruct")
  value
}

###*# Methods for standard generics

coef.corSpher <-
  function(object, unconstrained = TRUE)
{
  val <- NextMethod()
  if (!unconstrained) val[1] <- val[1] + attr(object, "minD")
  val
}

initialize.corSpher <-
  function(object, data, ...)
{
  if (!is.null(attr(object, "minD"))) { #already initialized
    return(object)
  }
  object <- initialize.corStruct(object, data)
  nug <- attr(object, "nugget")

  minD <- min(unlist(attr(object, "covariate")))
  val <- as.vector(object)
  if (length(val) > 0) {		# initialized
    if (val[1] <= 0) {
      stop("Range must be > 0 in \"corSpher\" initial value")
    }
    if (val[1] <= minD) {
      warning(paste("Initial value for range less than minimum distance.",
		    "Setting it to 1.1 * min(distance)"))
      val[1] <- 1.1 * minD
    }
    if (nug) {				# with nugget effect
      if (length(val) == 1) {		# assuming nugget effect not given
	val <- c(val, 0.1)		# setting it to 0.1
      } else {
	if (length(val) != 2) {
	  stop("Initial value for corSpher parameters of wrong dimension")
	}
      }
      if ((val[2] <= 0) || (val[2] >= 1)) {
	stop("Initial value of nugget ratio must be between 0 and 1")
      }
    } else {				# only range parameter
      if (length(val) != 1) {
	stop("Initial value for corSpher parameters of wrong dimension")
      }
    }
  } else {
    val <- minD * 1.1
    if (nug) val <- c(val, 0.1)
  }
  val[1] <- log(val[1] - minD)
  if (nug) val[2] <- log(val[2]/(1 - val[2]))
  oldAttr <- attributes(object)
  object <- val
  attributes(object) <- oldAttr
  attr(object, "minD") <- minD
  attr(object, "factor") <- corFactor(object)
  attr(object, "logDet") <- -attr(attr(object, "factor"), "logDet")
  object
}

summary.corSpher <- 
  function(object, structName = "Spherical spatial correlation")
{
  summary.corStruct(object, structName)
}

Variogram.corSpher <-
  function(object, distance = NULL, sig2 = 1, length.out = 50)
{
  Variogram.corSpatial(object, distance, sig2, length.out,
                       function(x, y) {
                         x <- pmin(x/y, 1)
                         1.5 * x - 0.5 * x^3
                       })
}

####*# corWave - Wave spatial correlation structure

#corWave <-
#  ## Constructor for the corWave class
#  function(value = numeric(0), form = ~ 1, nugget = FALSE,
#	   metric = c("euclidean", "maximum", "manhattan"))
#{
#  attr(value, "formula") <- form
#  attr(value, "nugget") <- nugget
#  attr(value, "metric") <- match.arg(metric)
#  class(value) <- c("corWave", "corSpatial", "corStruct")
#  value
#}

####*# Methods for standard generics

#summary.corWave <- 
#  function(object, structName = "Wave spatial correlation")
#{
#  summary.corStruct(object, structName)
#}


##*## Beginning of epilogue
### This file is automatically placed in Outline minor mode.
### The file is structured as follows:
### Chapters:     ^L # 
### Sections:    ##*##
### Subsections: ###*###
### Components:  non-comment lines flushed left
###              Random code beginning with a ####* comment

### Local variables:
### mode: S
### mode: outline-minor
### outline-regexp: "\^L\\|\\`#\\|##\\*\\|###\\*\\|[a-zA-Z]\\|\\\"[a-zA-Z]\\|####\\*"
### End:


### $Id: deriv.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###            symbolic differentiation for expressions
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


### Local variables:
### mode: S
### End:
### $Id: gls.q,v 1.6 1999/11/19 00:16:32 bates Exp $
###
###  Fit a linear model with correlated errors and/or heteroscedasticity
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

gls <- 
  ## fits linear model with serial correlation and variance functions,
  ## by maximum likelihood using a Newton-Raphson algorithm.
  function(model,
	   data = sys.frame(sys.parent()),
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   method = c("REML", "ML"), 
	   na.action = na.fail, 
	   control = list(),
	   verbose = FALSE)
{
  Call <- match.call()
  ## control parameters
  controlvals <- glsControl()
  if (!missing(control)) {
    if(!is.null(control$nlmStepMax) && control$nlmStepMax < 0) {
      warning("Negative control$nlmStepMax - using default value")
      control$nlmStepMax <- NULL
    }
    controlvals[names(control)] <- control
  }

  ##
  ## checking arguments
  ##
  if (!inherits(model, "formula") || length(model) != 3) {
    stop("\nModel must be a formula of the form \"resp ~ pred\"")
  }
  method <- match.arg(method)
  REML <- method == "REML"
  ## check if correlation is present and has groups
  if (!is.null(correlation)) {
    groups <- getGroupsFormula(correlation)
  } else groups <- NULL
  ## create a gls structure containing the plug-ins
  glsSt <- 
    glsStruct(corStruct = correlation, varStruct = varFunc(weights))

  ## extract a data frame with enough information to evaluate
  ## formula, groups, corStruct, and varStruct
  mfArgs <- list(formula = asOneFormula(formula(glsSt), model, groups),
		 data = data, na.action = na.action)
  if (!missing(subset)) {
    mfArgs[["subset"]] <- asOneSidedFormula(Call[["subset"]])[[2]]
  }
  dataMod <- do.call("model.frame", mfArgs)
  origOrder <- row.names(dataMod)	# preserve the original order
  if (!is.null(groups)) {
    ## sort the model.frame by groups and get the matrices and parameters
    ## used in the estimation procedures
    ## always use innermost level of grouping
    groups <- eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|")))
    grps <- getGroups(dataMod, groups,
                      level = length(getGroupsFormula(groups, asList = TRUE)))
    ## ordering data by groups
    ord <- order(grps)	
    grps <- grps[ord]
    dataMod <- dataMod[ord, ,drop = FALSE]
    revOrder <- match(origOrder, row.names(dataMod)) # putting in orig. order
  } else grps <- NULL
  
  ## obtaing basic model matrices
  X <- model.frame(model, dataMod)
  ## keeping the contrasts for later use in predict
  contr <- lapply(X, function(el) 
		  if (inherits(el, "factor")) contrasts(el))
  contr <- contr[!unlist(lapply(contr, is.null))]
  X <- model.matrix(model, X)
  y <- eval(model[[2]], dataMod)
  N <- nrow(X)
  p <- ncol(X)				# number of coefficients
  parAssign <- attr(X, "assign")
  fTerms <- terms(as.formula(model))
  namTerms <- attr(fTerms, "term.labels")
  if (attr(fTerms, "intercept") > 0) {
    namTerms <- c("(Intercept)", namTerms)
  }
  namTerms <- factor(parAssign, labels = namTerms)
  parAssign <- split(order(parAssign), namTerms)
  ## creating the condensed linear model
  attr(glsSt, "conLin") <-
    list(Xy = array(c(X, y), c(N, ncol(X) + 1), list(row.names(dataMod), 
	     c(colnames(X), deparse(model[[2]])))), 
	 dims = list(N = N, p = p, REML = as.integer(REML)), logLik = 0)

  ## initialization
  glsEstControl <- controlvals[c("singular.ok","qrTol")]
  glsSt <- initialize(glsSt, dataMod, glsEstControl)
  parMap <- attr(glsSt, "pmap")

  ##
  ## getting the fitted object, possibly iterating for variance functions
  ##
  numIter <- numIter0 <- 0
  repeat {
    oldPars <- c(attr(glsSt, "glsFit")[["beta"]], coef(glsSt))
    if (length(coef(glsSt))) {		# needs ms()
      aNlm <- nlm(f = function(glsPars) -logLik(glsSt, glsPars),
                  p = c(coef(glsSt)),
                  hessian = TRUE,
                  print = ifelse(controlvals$msVerbose, 2, 0),
                  stepmax = controlvals$nlmStepMax*max(sqrt(sum(coef(glsSt)^2)),
                    1.0),
                  check = FALSE)
      numIter0 <- NULL
      coef(glsSt) <- aNlm$estimate
    }
    attr(glsSt, "glsFit") <- glsEstimate(glsSt, control = glsEstControl)
    ## checking if any updating is needed
    if (!needUpdate(glsSt)) break
    ## updating the fit information
    numIter <- numIter + 1
    glsSt <- update(glsSt, dataMod)
    ## calculating the convergence criterion
    aConv <- c(attr(glsSt, "glsFit")[["beta"]], coef(glsSt))
    conv <- abs((oldPars - aConv)/ifelse(aConv == 0, 1, aConv))
    aConv <- c("beta" = max(conv[1:p]))
    conv <- conv[-(1:p)]
    for(i in names(glsSt)) {
      if (any(parMap[,i])) {
	aConv <- c(aConv, max(conv[parMap[,i]]))
	names(aConv)[length(aConv)] <- i
      }
    }
    if (verbose) {
      cat("\nIteration:",numIter)
      cat("\nObjective:", format(aNlm$minimum), "\n")
      print(glsSt)
      cat("\nConvergence:\n")
      print(aConv)
    }
    if (max(aConv) <= controlvals$tolerance) {
      break
    }
    if (numIter > controlvals$maxIter) {
      stop("Maximum number of iterations reached without convergence.")
    }
  }
  ## wrapping up
  glsFit <- attr(glsSt, "glsFit")
  namBeta <- names(glsFit$beta)
  attr(parAssign, "varBetaFact") <- varBeta <-
    glsFit$sigma * glsFit$varBeta * sqrt((N - REML * p)/(N - p))
  varBeta <- crossprod(varBeta)
  dimnames(varBeta) <- list(namBeta, namBeta)
  ##
  ## fitted.values and residuals (in original order)
  ##
  Fitted <- fitted(glsSt)
  ## putting groups back in original order, if present
  if (!is.null(grps)) {
    grps <- grps[revOrder]
    Fitted <- Fitted[revOrder]
    Resid <- y[revOrder] - Fitted
    attr(Resid, "std") <- glsFit$sigma/(varWeights(glsSt)[revOrder])
  } else {
    Resid <- y - Fitted
    attr(Resid, "std") <- glsFit$sigma/(varWeights(glsSt))
  }
    
  ## getting the approximate var-cov of the parameters 
  if (controlvals$apVar) {
    apVar <- glsApVar(glsSt, glsFit$sigma, 
		      .relStep = controlvals[[".relStep"]],
                      minAbsPar = controlvals[["minAbsParApVar"]],
                      natural = controlvals[["natural"]])
  } else {
    apVar <- "Approximate variance-covariance matrix not available"
  }
  ## getting rid of condensed linear model and fit
  dims <- attr(glsSt, "conLin")[["dims"]]
  dims[["p"]] <- p
  attr(glsSt, "conLin") <- NULL
  attr(glsSt, "glsFit") <- NULL
  ##
  ## creating the  gls object
  ##
  estOut <- list(modelStruct = glsSt,
		 dims = dims,
		 contrasts = contr,
		 coefficients = glsFit[["beta"]],
		 varBeta = varBeta,
		 sigma = glsFit$sigma,
		 apVar = apVar,
		 logLik = glsFit$logLik,
		 numIter = if (needUpdate(glsSt)) numIter
		   else numIter0, 
		 groups = grps,
		 call = Call,
		 method = method,
		 fitted = Fitted,
		 residuals = Resid,
                 parAssign = parAssign)
  if (inherits(data, "groupedData")) {
    ## saving labels and units for plots
    attr(estOut, "units") <- attr(data, "units")
    attr(estOut, "labels") <- attr(data, "labels")
  }
  attr(estOut, "namBetaFull") <- colnames(X)
  class(estOut) <- "gls"
  estOut
}

### Auxiliary functions used internally in gls and its methods

glsApVar <-
  function(glsSt, sigma, conLin = attr(glsSt, "conLin"),
           .relStep = (.Machine$double.eps)^(1/3), minAbsPar = 0,
           natural = TRUE)
{
  ## calculate approximate variance-covariance matrix of all parameters
  ## except the coefficients
  fullGlsLogLik <-
    function(Pars, object, conLin, dims, N)
    {
      ## logLik as a function of sigma and coef(glsSt)
      npar <- length(Pars)
      lsigma <- Pars[npar]              # within-group std. dev.
      Pars <- Pars[-npar]
      coef(object) <- Pars
      conLin <- recalc(object, conLin)
      val <- .C("gls_loglik",
		as.double(conLin$Xy),
		as.integer(unlist(dims)),
		logLik = double(1),
		lRSS = double(1), NAOK = TRUE,
		PACKAGE = "nlme")[c("logLik", "lRSS")]
      aux <- 2 * (val[["lRSS"]] - lsigma)
      conLin[["logLik"]] + val[["logLik"]] + (N * aux - exp(aux))/2
    }
  if (length(glsCoef <- coef(glsSt)) > 0) {
    cSt <- glsSt[["corStruct"]]
    if (!is.null(cSt) && inherits(cSt, "corSymm") && natural) {
      cStNatPar <- coef(cSt, unconstrained = FALSE)
      class(cSt) <- c("corNatural", "corStruct")
      coef(cSt) <- log((cStNatPar + 1)/(1 - cStNatPar))
      glsSt[["corStruct"]] <- cSt
      glsCoef <- coef(glsSt)
    }
    dims <- conLin$dims
    N <- dims$N - dims$REML * dims$p
    conLin[["logLik"]] <- 0               # making sure
    Pars <- c(glsCoef, lSigma = log(sigma))
    val <- fdHess(Pars, fullGlsLogLik, glsSt, conLin, dims, N,
		  .relStep = .relStep, minAbsPar = minAbsPar)[["Hessian"]]
    if (all(eigen(val)$values < 0)) {
      ## negative definite - OK
      val <- solve(-val)
      nP <- names(Pars)
      dimnames(val) <- list(nP, nP)
      attr(val, "Pars") <- Pars
      attr(val, "natural") <- natural
      val
    } else {
      ## problem - solution is not a maximum
      "Non-positive definite approximate variance-covariance"
    }
  } else {
    NULL
  }
}

glsEstimate <-
  function(object, conLin = attr(object, "conLin"), 
	   control = list(singular.ok = FALSE, qrTol = .Machine$single.eps))
{
  dd <- conLin$dims
  p <- dd$p
  oXy <- conLin$Xy
  conLin <- recalc(object, conLin)	# updating for corStruct and varFunc
  val <- .C("gls_estimate",
	    as.double(conLin$Xy),
	    as.integer(unlist(dd)),
	    beta = double(p),
	    sigma = double(1),
	    logLik = double(1),
	    varBeta = double(p * p),
	    rank = integer(1),
	    pivot = as.integer(1:(p + 1)),
            NAOK = TRUE,
            PACKAGE = "nlme")[c("beta","sigma","logLik","varBeta",
		"rank", "pivot")]
  rnk <- val[["rank"]]
  rnkm1 <- rnk - 1
  if (!(control$singular.ok) && (rnkm1 < p )) {
    stop(paste("computed gls fit is singular, rank", rnk))
  }
  N <- dd$N - dd$REML * p
  namCoef <- colnames(oXy)[val[["pivot"]][1:rnkm1] + 1]	# coef names
  ll <- conLin$logLik + val[["logLik"]]
  varBeta <- t(array(val[["varBeta"]], c(rnkm1, rnkm1), 
		     list(namCoef, namCoef)))
  beta <- val[["beta"]][1:rnkm1]
  names(beta) <- namCoef
  fitVal <- oXy[, namCoef, drop = FALSE] %*% beta
  list(logLik = N * (log(N) - (1 + log(2 * pi)))/2 + ll, beta = beta,
       sigma = val[["sigma"]], varBeta = varBeta, 
       fitted = c(fitVal), resid = c(oXy[, p + 1] - fitVal))
}

### Methods for standard generics

ACF.gls <-
  function(object, maxLag, resType = c("pearson", "response", "normalized"),
           form = ~1, na.action = na.fail, ...)
{
  resType <- match.arg(resType)
  res <- resid(object, type = resType)
  wchRows <- NULL
  if (is.null(grps <- getGroups(object))) {
    ## check if formula defines groups
    if (!is.null(grpsF <- getGroupsFormula(form))) {
      if (is.null(data <- getData(object))) {
        ## will try to construct
        allV <- all.vars(grpsF)
        if (length(allV) > 0) {
          alist <- lapply(as.list(allV), as.name)
          names(alist) <- allV
          alist <- c(as.list(as.name("data.frame")), alist)
          mode(alist) <- "call"
          data <- eval(alist, sys.parent(1))
        } 
      }
      grps <- model.frame(grpsF, data, na.action = na.action)
      wchRows <- !is.na(match(row.names(data), row.names(grps)))
      grps <- getGroups(grps, grpsF)
    }
  }
  if (!is.null(grps)) {
    if (!is.null(wchRows)) {
      res <- res[wchRows]
    }
    res <- split(res, grps)
  } else {
    res <- list(res)
  }
  if(missing(maxLag)) {
    maxLag <- min(c(maxL <- max(sapply(res, length)) - 1, 
                    as.integer(10 * log10(maxL + 1))))
  }
  val <- lapply(res,
                function(el, maxLag) {
                  N <- maxLag + 1
                  tt <- double(N)
                  nn <- integer(N)
                  N <- min(c(N, n <- length(el)))
                  nn[1:N] <- n + 1 - 1:N
                  ## el <- el - mean(el) 
                  for(i in 1:N) {
                    el1 <- el[1:(n-i+1)]
                    el2 <- el[i:n]
                    tt[i] <- sum(el1 * el2)
                  }
                  array(c(tt,nn), c(length(tt), 2))
                }, maxLag = maxLag)
  val0 <- apply(sapply(val, function(x) x[,2]), 1, sum)
  val1 <- apply(sapply(val, function(x) x[,1]), 1, sum)/val0
  val2 <- val1/val1[1]
  z <- data.frame(lag = 0:maxLag, ACF = val2)
  attr(z, "n.used") <- val0
  class(z) <- c("ACF", "data.frame")
  z
}

anova.gls <- 
  function(object, ..., test = TRUE, type = c("sequential", "marginal"),
           adjustSigma = TRUE, Terms, L, verbose = FALSE)
{
  ## returns the likelihood ratio statistics, the AIC, and the BIC
  dots <- list(...)
  if ((rt <- length(dots) + 1) == 1) {
    if (!inherits(object,"gls")) {
      stop("Object must inherit from class \"gls\" ")
    }
    if (inherits(object, "gnls") && missing(adjustSigma)) {
      ## REML correction already applied to gnls objects
      adjustSigma <- FALSE
    }
    dims <- object$dims
    N <- dims$N
    p <- dims$p
    REML <- dims$REML
    assign <- object$parAssign
    vBeta <- attr(assign, "varBetaFact")
    if ((!REML) && adjustSigma == TRUE) {
      ## using REML-like estimate of sigma under ML
      vBeta <- sqrt(N/(N - p)) * vBeta
    }
    c0 <- solve(t(vBeta), coef(object))
    nTerms <- length(assign)
    dDF <- N - p
    lab <- paste("Denom. DF:", dDF,"\n")
    if (missing(Terms) && missing(L)) {
      ## returns the F.table (Wald) for the fixed effects
      type <- match.arg(type)
      Fval <- Pval <- double(nTerms)
      nDF <- integer(nTerms)
      for(i in 1:nTerms) {
        nDF[i] <- length(assign[[i]])
        if (type == "sequential") {       # type I SS
          c0i <- c0[assign[[i]]]
        } else {
          c0i <- c(qr.qty(qr(vBeta[, assign[[i]], drop = FALSE]), c0))[1:nDF[i]]
        }
        Fval[i] <- sum(c0i^2)/nDF[i]
        Pval[i] <- 1 - pf(Fval[i], nDF[i], dDF)
      }
      ##
      ## fixed effects F-values, df, and p-values
      ##
      aod <- data.frame(nDF, Fval, Pval)
      dimnames(aod) <- 
        list(names(assign),c("numDF", "F-value", "p-value"))
    } else {
      if (missing(L)) {                 # terms is given
        if (is.numeric(Terms) && all(Terms == as.integer(Terms))) {
          if (min(Terms) < 1 || max(Terms) > nTerms) {
            stop(paste("Terms must be between 1 and", nTerms))
          }
        } else {
          if (is.character(Terms)) {
            if (any(noMatch <- is.na(match(Terms, names(assign))))) {
              stop(paste("Term(s)", paste(Terms[noMatch], collapse = ", "),
                         "not matched"))
            }
          } else {
            stop("Terms can only be integers or characters")
          }
        }
        lab <-
          paste(lab, "F-test for:",
                paste(names(assign[Terms]),collapse=", "),"\n")
        L <- diag(p)[unlist(assign[Terms]),,drop=FALSE]
      } else {
        L <- as.matrix(L)
        if (ncol(L) == 1) L <- t(L)     # single linear combination
        nrowL <- nrow(L)
        ncolL <- ncol(L)
        if (ncol(L) > p) {
          stop(paste("L must have at most", p,"columns"))
        }
        dmsL1 <- rownames(L)
        L0 <- array(0, c(nrowL, p), list(NULL, names(coef(object))))
        if (is.null(dmsL2 <- colnames(L))) {
          ## assume same order as effects
          L0[, 1:ncolL] <- L
        } else {
          if (any(noMatch <- is.na(match(dmsL2, colnames(L0))))) {
            stop(paste("Effects",paste(dmsL2[noMatch],collapse=", "),
                       "not matched"))
          }
          L0[, dmsL2] <- L
        }
        L <- L0[noZeroRowL <- as.logical((L0 != 0) %*% rep(1, p)), , drop = FALSE]
        nrowL <- nrow(L)
        noZeroColL <- as.logical(c(rep(1,nrowL) %*% (L != 0)))
        if (is.null(dmsL1)) {
          dmsL1 <- 1:nrowL
        } else {
          dmsL1 <- dmsL1[noZeroRowL]
        }
        rownames(L) <- dmsL1
        lab <- paste(lab, "F-test for linear combination(s)\n")
      }
      nDF <- sum(svd(L)$d > 0)
      c0 <- c(qr.qty(qr(vBeta %*% t(L)), c0))[1:nDF]
      Fval <- sum(c0^2)/nDF
      Pval <- 1 - pf(Fval, nDF, dDF)
      aod <- data.frame(nDF, Fval, Pval)
      names(aod) <- c("numDF", "F-value", "p-value")
      if (!missing(L)) {
        if (nrow(L) > 1) attr(aod, "L") <- L[, noZeroColL, drop = F]
        else attr(aod, "L") <- L[, noZeroColL]
      }
    }
    attr(aod, "label") <- lab
    attr(aod,"rt") <- rt
    class(aod) <- c("anova.lme", "data.frame")
    aod
  }
  ##
  ## Otherwise construct the likelihood ratio and information table
  ## objects in ... may inherit from gls, lm, lmList, and lme (for now)
  ##
  else do.call("anova.lme", as.list(match.call()[-1]))
}

augPred.gls <- 
  function(object, primary = NULL, minimum = min(primary), 
	   maximum = max(primary), length.out = 51, ...)
{
  data <- eval(object$call$data)
  if (!inherits(data, "data.frame")) {
    stop(paste("Data in", substitute(object),
               "call must evaluate to a data frame"))
  }
  if(is.null(primary)) {
    if (!inherits(data, "groupedData")) {
      stop(paste(sys.call()[[1]],
      "without \"primary\" can only be used with fits of groupedData objects"))
    }
    primary <- getCovariate(data)
    prName <- deparse(getCovariateFormula(data)[[2]])
  } else{
    primary <- asOneSidedFormula(primary)[[2]]
    prName <- deparse(primary)
    primary <- eval(primary, data)
  }
  newprimary <- seq(from = minimum, to = maximum, length.out = length.out)
  groups <- getGroups(object)
  grName <- ".groups"
  if (is.null(groups)) {		# no groups used
    noGrp <- TRUE
    groups <- rep("1", length(primary))
    value <- data.frame(newprimary, rep("1", length(newprimary)))
  } else {
    noGrp <- FALSE
    ugroups <- unique(groups)
    value <- data.frame(rep(newprimary, length(ugroups)),
			rep(ugroups, rep(length(newprimary), length(ugroups))))
  }
  names(value) <- c(prName, grName)
  ## recovering other variables in data that may be needed for predictions
  ## varying variables will be replaced by their means
  summData <- gsummary(data, groups = groups)
  if (any(toAdd <- is.na(match(names(summData), names(value))))) {
    summData <- summData[, toAdd, drop = FALSE]
  }
  value[, names(summData)] <- summData[value[, 2], ]
  pred <- predict(object, value)
  newvals <- cbind(value[, 1:2], pred)
  names(newvals)[3] <- respName <-
    deparse(getResponseFormula(object)[[2]])
  orig <- data.frame(primary, groups, getResponse(object))
  names(orig) <- names(newvals)
  value <- rbind(orig, newvals)
  attributes(value[, 2]) <- attributes(groups)
  value[, ".type"] <- ordered(c(rep("original", nrow(data)),
				rep("predicted", nrow(newvals))),
			      levels = c("predicted", "original"))
  labs <- list(x = prName, y = respName)
  unts <- list(x = "", y = "")
  if(inherits(data, "groupedData")) {
    labs[names(attr(data, "labels"))] <- attr(data, "labels")
    unts[names(attr(data, "units"))] <- attr(data, "units")
    attr(value, "units") <- attr(data, "units")
  } 
  attr(value, "labels") <- labs
  attr(value, "units") <- unts
  if (noGrp) {
    attr(value, "formula") <- 
      eval(parse(text = paste(respName, prName, sep = "~")))
  } else {
    attr(value, "formula") <- 
      eval(parse(text = paste(respName, "~", prName, "|", grName)))
  }
  class(value) <- c("augPred", class(value))
  value
}

coef.gls <-
  function(object, allCoef = FALSE)
{
  val <- object$coefficients
  if (allCoef) {
    namFull <- attr(object, "namBetaFull")
    if (length(val) != (lF <- length(namFull))) {
      aux <- rep(NA, lF)
      names(aux) <- namFull
      aux[names(val)] <- val
      val <- aux
    }
  }
  val
}

comparePred.gls <-
  function(object1, object2, primary = NULL, 
	   minimum = min(primary), maximum = max(primary),
	   length.out = 51, level = NULL, ...) 
{
  if (length(level) > 1) {
    stop("Only one level allowed for predictions")
  }
  args <- list(object = object1, 
	       primary = primary,
	       level = level,
	       length.out = length.out)
  if (!is.null(primary)) {
    args[["minimum"]] <- minimum
    args[["maximum"]] <- maximum
  }
  val1 <- do.call("augPred", args)
  dm1 <- dim(val1)
  c1 <- deparse(substitute(object1))
  levels(val1[,4])[1] <- c1
  args[["object"]] <- object2
  val2 <- do.call("augPred", args)
  dm2 <- dim(val2)
  c2 <- deparse(substitute(object2))
  levels(val2[, 4])[1] <- c2
  val2 <- val2[val2[, 4] != "original", , drop = F]
  names(val2) <- names(val1)

  if (dm1[1] == dm2[1]) {
    lv1 <- sort(levels(val1[, 2]))
    lv2 <- sort(levels(val2[, 2]))
    if ((length(lv1) != length(lv2)) || any(lv1 != lv2)) {
      stop(paste(c1, "and", c2, "must have the same group levels"))
    }
    val <- rbind(val1[, -4], val2[, -4])
    val[, ".type"] <- 
      ordered(c(as.character(val1[,4]), as.character(val2[,4])),
		levels = c(c1, c2, "original"))
    attr(val, "formula") <- attr(val1, "formula")
  } else {				# one may have just "fixed"
    if (dm1[1] > dm2[1]) {
      mult <- dm1[1] %/% dm2[1]
      if ((length(levels(val2[, 2])) != 1) ||
	  (length(levels(val1[, 2])) != mult))
	{
	  stop("Wrong group levels")
	}
      val <- 
	data.frame(c(val1[,1], rep(val2[,1], mult)), rep(val1[,1], 2),
	   c(val1[,3], rep(val2[,3], mult)),
	   ordered(c(as.character(val1[,4]), 
		     rep(as.character(val2[,4]), mult)), 
		   levels = c(c1, c2, "original")))
      attr(val, "formula") <- attr(val1, "formula")
    } else {
      mult <- dm2[1] %/% dm1[1]
      if ((length(levels(val1[, 2])) != 1) ||
	  (length(levels(val2[, 2])) != mult))
	{
	  stop("Wrong group levels")
	}
      val <- 
	data.frame(c(rep(val1[,1], mult), val2[,1]), rep(val2[,1], 2),
	   c(rep(val1[,3], mult), val2[,3]),
	   ordered(c(rep(as.character(val1[,4]), mult), 
		     as.character(val1[,4])), levels = c(c1, c2, "original")))
      attr(val, "formula") <- attr(val2, "formula")
    }
  }
  class(val) <- c("comparePred", "augPred", class(val))
  attr(val, "labels") <- attr(val1, "labels")
  attr(val, "units") <- attr(val1, "units")
  val
}

fitted.gls <-
  function(object)
{
  val <- object$fitted
  lab <- "Fitted values"
  if (!is.null(aux <- attr(object, "units")$y)) {
    lab <- paste(lab, aux)
  }
  attr(val, "label") <- lab
  val
}


formula.gls <- function(object) eval(object$call$model)

getGroups.gls <- function(object, form, level, data, sep) object$groups

getGroupsFormula.gls <-
  function(object, asList = FALSE, sep)
{
  if (!is.null(cSt <- object$modelStruct$corStruct)) {
    getGroupsFormula(cSt, asList)
  } else {
    NULL
  }
}

getResponse.gls <-
  function(object, form)
{
  val <- resid(object) + fitted(object)
  if (is.null(lab <- attr(object, "labels")$y)) {
    lab <- deparse(getResponseFormula(object)[[2]])
  }
  if (!is.null(aux <- attr(object, "units")$y)) {
    lab <- paste(lab, aux)
  }
  attr(val, "label") <- lab
  val
}

intervals.gls <-
  function(object, level = 0.95, which = c("all", "var-cov", "coef"))
{
  which <- match.arg(which)
  val <- list()
  dims <- object$dims
  if (which != "var-cov") {		# coefficients included
    len <- -qt((1-level)/2, dims$N - dims$p) * sqrt(diag(object$varBeta))
    est <- coef(object)
    val[["coef"]] <- 
      array(c(est - len, est, est + len), 
	    c(length(est), 3), list(names(est), c("lower", "est.", "upper")))
    attr(val[["coef"]], "label") <- "Coefficients:"
  }

  if (which != "coef") {		# variance-covariance included
    if (is.null(aV <- object$apVar)) {	# only sigma
      if (inherits(object, "gnls")) {   #always REML-like sigma
        Nr <- dims$N - dims$p
      } else {
        Nr <- dims$N - dims$REML * dims$p
      }
      est <- object$sigma * sqrt(Nr)
      val[["sigma"]] <- 
	structure(c(est/sqrt(qchisq((1+level)/2, Nr)), object$sigma, 
		est/sqrt(qchisq((1-level)/2, Nr))),
                  names = c("lower", "est.", "upper"))
      attr(val[["sigma"]], "label") <- "Residual standard error:"
    } else {
      if (is.character(aV)) {
	stop(paste("Cannot get confidence intervals on var-cov components:",
		   aV))
      }
      len <- -qnorm((1-level)/2) * sqrt(diag(aV))
      est <- attr(aV, "Pars")
      nP <- length(est)
      glsSt <- object[["modelStruct"]]
      if (!all(whichKeep <- apply(attr(glsSt, "pmap"), 2, any))) {
        ## need to deleted components with fixed coefficients
        aux <- glsSt[whichKeep]
        class(aux) <- class(glsSt)
        attr(aux, "settings") <- attr(lmeSt, "settings")
        attr(aux, "pmap") <- attr(glsSt, "pmap")[, whichKeep, drop = F]
        glsSt <- aux
      }
      cSt <- glsSt[["corStruct"]]
      if (!is.null(cSt) && inherits(cSt, "corSymm") && attr(aV, "natural")) {
        ## converting to corNatural
        class(cSt) <- c("corNatural", "corStruct")
        glsSt[["corStruct"]] <- cSt
      }
      pmap <- attr(glsSt, "pmap")
      namG <- names(glsSt)
      auxVal <- vector("list", length(namG) + 1)
      names(auxVal) <- c(namG, "sigma")
      aux <-
	array(c(est - len, est, est + len),
	      c(nP, 3), list(NULL, c("lower", "est.", "upper")))
      auxVal[["sigma"]] <- exp(aux[nP, ])
      attr(auxVal[["sigma"]], "label") <- "Residual standard error:"
      aux <- aux[-nP,, drop = FALSE]
      rownames(aux) <- namP <- names(coef(glsSt, FALSE))
      for(i in 1:3) {
	coef(glsSt) <- aux[,i]
	aux[,i] <- coef(glsSt, unconstrained = FALSE)
      }
      for(i in namG) {
	auxVal[[i]] <- aux[pmap[,i], , drop = FALSE]
	dimnames(auxVal[[i]])[[1]] <- 
	  substring(dimnames(auxVal[[i]])[[1]], nchar(i) + 2)
	attr(auxVal[[i]], "label") <-
	  switch(i,
		 corStruct = "Correlation structure:",
		 varStruct = "Variance function:",
		 paste(i,":",sep=""))
      }
      val <- c(val, auxVal)
    }
  }
  attr(val, "level") <- level
  class(val) <- "intervals.gls"
  val
}

logLik.gls <-
  function(object, REML)
{
  p <- object$dims$p
  N <- object$dims$N
  Np <- N - p
  estM <- object$method
  if (missing(REML)) REML <- estM == "REML"
  val <- object[["logLik"]]
  if (REML && (estM == "ML")) {			# have to correct logLik
    val <- val + (p * (log(2 * pi) + 1) + Np * log(1 - p/N) +
		  sum(log(abs(svd(object$varBeta)$d)))) / 2
  }
  if (!REML && (estM == "REML")) {	# have to correct logLik
    val <- val - (p * (log(2*pi) + 1) + N * log(1 - p/N) +
		  sum(log(abs(svd(object$varBeta)$d)))) / 2
  }
  attr(val, "nall") <- N
  attr(val, "nobs") <- N - REML * p
  attr(val, "df") <- p + length(coef(object[["modelStruct"]])) + 1
  class(val) <- "logLik"
  val
}

plot.gls <- 
  function(object, form = resid(., type = "pearson") ~ fitted(.), abline, 
	   id = NULL, idLabels = NULL, idResType = c("pearson", "normalized"),
           grid, ...)  
  ## Diagnostic plots based on residuals and/or fitted values
{
  do.call("plot.lme", as.list(match.call()[-1]))
}

predict.gls <- 
  function(object, newdata, na.action = na.fail)  
{
  ##
  ## method for predict() designed for objects inheriting from class gls
  ##
  if (missing(newdata)) {		# will return fitted values
    return(fitted(object))
  }
  form <- getCovariateFormula(object)
  mfArgs <- list(formula = form, data = newdata, na.action = na.action)
  dataMod <- do.call("model.frame", mfArgs)
  ## making sure factor levels are the same as in contrasts
  contr <- object$contrasts
  for(i in names(dataMod)) {
    if (inherits(dataMod[,i], "factor") && !is.null(contr[[i]])) {
      levs <- levels(dataMod[,i])
      levsC <- dimnames(contr[[i]])[[1]]
      if (any(wch <- is.na(match(levs, levsC)))) {
        stop(paste("Levels", paste(levs[wch], collapse = ","),
                   "not allowed for", i))
      }
      attr(dataMod[,i], "contrasts") <- contr[[i]][levs, , drop = FALSE]
#      if (length(levs) < length(levsC)) {
#        if (inherits(dataMod[,i], "ordered")) {
#          dataMod[,i] <- ordered(as.character(dataMod[,i]), levels = levsC)
#        } else {
#          dataMod[,i] <- factor(as.character(dataMod[,i]), levels = levsC)
#        }
#      }
    }
  }
  N <- nrow(dataMod)
  if (length(all.vars(form)) > 0) {
#    X <- model.matrix(form, dataMod, contr)
    X <- model.matrix(form, dataMod)
  } else {
    X <- array(1, c(N, 1), list(row.names(dataMod), "(Intercept)"))
  }
  cf <- coef(object)
  val <- c(X[, names(cf), drop = FALSE] %*% cf)
  attr(val, "label") <- "Predicted values"
  if (!is.null(aux <- attr(object, "units")$y)) {
    attr(val, "label") <- paste(attr(val, "label"), aux)
  }
  val
}

print.intervals.gls <-
  function(x, ...)
{
  cat(paste("Approximate ", attr(x, "level") * 100,
	    "% confidence intervals\n", sep = ""))
  for(i in names(x)) {
    aux <- x[[i]]
    cat("\n ",attr(aux, "label"), "\n", sep = "")
    if (i == "sigma") print(c(aux), ...)
    else print.matrix(aux, ...)
  }
}

print.gls <- 
  ## method for print() used for gls objects
  function(x, ...)
{
  dd <- x$dims
  mCall <- x$call
  if (inherits(x, "gnls")) {
    cat("Generalized nonlinear least squares fit\n")
  } else {
    cat("Generalized least squares fit by ")
    cat(ifelse(x$method == "REML", "REML\n", "maximum likelihood\n"))
  }
  cat("  Model:", deparse(as.vector(mCall$model)), "\n")
  cat("  Data:", deparse( mCall$data ), "\n")
  if (!is.null(mCall$subset)) {
    cat("  Subset:", deparse(asOneSidedFormula(mCall$subset)[[2]]),"\n")
  }
  if (inherits(x, "gnls")) {
    cat("  Log-likelihood: ", format(x$logLik), "\n", sep = "")
  } else {
    cat("  Log-", ifelse(x$method == "REML", "restricted-", ""),
        "likelihood: ", format(x$logLik), "\n", sep = "")
  }
  cat("\nCoefficients:\n")
  print(coef(x))
  cat("\n")
  if (length(x$modelStruct) > 0) {
    print(summary(x$modelStruct))
  }
  cat("Degrees of freedom:", dd[["N"]],"total;",dd[["N"]] - dd[["p"]],
      "residual\n")
  cat("Residual standard error:", format(x$sigma),"\n")
}

print.summary.gls <-
  function(x, verbose = FALSE, digits = .Options$digits, ...)
{
  dd <- x$dims
  verbose <- verbose || attr(x, "verbose")
  mCall <- x$call
  if (inherits(x, "gnls")) {
    cat("Generalized nonlinear least squares fit\n")
  } else {
    cat("Generalized least squares fit by ")
    cat(ifelse(x$method == "REML", "REML\n", "maximum likelihood\n"))
  }
  cat("  Model:", deparse(as.vector(mCall$model)), "\n")
  cat("  Data:", deparse( mCall$data ), "\n")
  if (!is.null(mCall$subset)) {
    cat("  Subset:", deparse(asOneSidedFormula(mCall$subset)[[2]]),"\n")
  }
  print( data.frame(AIC=x$AIC,BIC=x$BIC,logLik=x$logLik,row.names = " "))
  if (verbose) { cat("Convergence at iteration:",x$numIter,"\n") }
  if (length(x$modelStruct)) {
    cat("\n")
    print(summary(x$modelStruct))
  }
  cat("\nCoefficients:\n")
  xtTab <- as.data.frame(x$tTable)
  wchPval <- match("p-value", names(xtTab))
  for(i in names(xtTab)[-wchPval]) {
    xtTab[, i] <- format(zapsmall(xtTab[, i]))
  }
  xtTab[,wchPval] <- format(round(xtTab[,wchPval], 4))
  if (any(wchLv <- (as.double(levels(xtTab[, wchPval])) == 0))) {
    levels(xtTab[, wchPval])[wchLv] <- "<.0001"
  }
  row.names(xtTab) <- dimnames(x$tTable)[[1]]
  print(xtTab)
  if (nrow(x$tTable) > 1) {
    corr <- x$corBeta
    class(corr) <- "correlation"
    print(corr,
	  title = "\n Correlation:",
	  ...)
  }
  cat("\nStandardized residuals:\n")
  print(x$residuals)
  cat("\n")
  cat("Residual standard error:", format(x$sigma),"\n")
  cat("Degrees of freedom:", dd[["N"]],"total;",dd[["N"]] - dd[["p"]],
      "residual\n")
}

residuals.gls <- 
  function(object, type = c("response", "pearson", "normalized"))
{
  type <- match.arg(type)
  val <- object$residuals
  if (type != "response") {
    val <- val/attr(val, "std")
    attr(val, "label") <- "Standardized residuals"
    if (type == "normalized") {
      if (!is.null(cSt <- object$modelStruct$corStruct)) {
        ## normalize according to inv-trans factor
        val <- recalc(cSt, list(Xy = as.matrix(val)))$Xy[, 1]
        attr(val, "label") <- "Normalized residuals"
      }
    } 
  } else {
    lab <- "Residuals"
    if (!is.null(aux <- attr(object, "units")$y)) {
      lab <- paste(lab, aux)
    }
    attr(val, "label") <- lab
  }
  val
}

summary.gls <- function(object, verbose = FALSE) {
  ##
  ## generates an object used in the print.summary method for lme
  ##
  ##  variance-covariance estimates for coefficients
  ##
  stdBeta <- sqrt(diag(as.matrix(object$varBeta)))
  corBeta <- t(object$varBeta/stdBeta)/stdBeta
  ##
  ## coefficients, std. deviations and z-ratios
  ##
  beta <- coef(object)
  dims <- object$dims
  dimnames(corBeta) <- list(names(beta),names(beta))
  object$corBeta <- corBeta
  tTable <- data.frame(beta, stdBeta, beta/stdBeta, beta)
  dimnames(tTable)<-
    list(names(beta),c("Value","Std.Error","t-value","p-value"))
  tTable[, "p-value"] <- 2 * pt(-abs(tTable[,"t-value"]), dims$N - dims$p)
  object$tTable <- as.matrix(tTable)
  ##
  ## residuals
  ##
  resd <- resid(object, type = "pearson")
  if (length(resd) > 5) {
    resd <- quantile(resd)
    names(resd) <- c("Min","Q1","Med","Q3","Max")
  }
  object$residuals <- resd
  ##
  ## generating the final object
  ##
  aux <- logLik(object)
  object$BIC <- BIC(aux)
  object$AIC <- AIC(aux)
  attr(object, "verbose") <- verbose
  class(object) <- c("summary.gls", class(object))
  object
}

update.gls <-
  function(object, model, data, correlation, weights, subset, method,
	   na.action, control, verbose)
{
  thisCall <- as.list(match.call())[-(1:2)]
  nextCall <- as.list(object$call)[-1]
  if (is.na(match("correlation", names(thisCall))) &&
      !is.null(thCor <- object$modelStruct$corStruct)) {
    thisCall$correlation <- thCor
  }
  if (is.na(match("weights", names(thisCall))) &&
      !is.null(thWgt <- object$modelStruct$varStruct)) {
    thisCall$weights <- thWgt
  }
  if (!is.null(thisCall$model)) {
    thisCall$model <- update(as.formula(nextCall$model), thisCall$model)
  }
  nextCall[names(thisCall)] <- thisCall
  do.call("gls", nextCall)
}

Variogram.gls <-
  function(object, distance, form = ~1,
           resType = c("pearson", "response", "normalized"),
           data, na.action = na.fail, maxDist, length.out = 50,
           collapse = c("quantiles", "fixed", "none"), nint = 20, breaks,
           robust = FALSE, metric = c("euclidean", "maximum", "manhattan"))
{
  resType <- match.arg(resType)
  ## checking if object has a corSpatial element
  csT <- object$modelStruct$corStruct
  wchRows <- NULL
  if (missing(distance)) {
    if (missing(form) && inherits(csT, "corSpatial")) {
      distance <- getCovariate(csT)
      grps <- getGroups(object)
    } else {
      metric <- match.arg(metric)
      if (missing(data)) {
        data <- getData(object)
      }
      if (is.null(data)) {			# will try to construct
        allV <- all.vars(form)
        if (length(allV) > 0) {
          alist <- lapply(as.list(allV), as.name)
          names(alist) <- allV
          alist <- c(as.list(as.name("data.frame")), alist)
          mode(alist) <- "call"
          data <- eval(alist, sys.parent(1))
        } 
      }
      grpsF <- getGroupsFormula(form)
      grps <- NULL
      if (is.null(grpsF) || is.null(grps <- getGroups(data, grpsF))) {
        ## try to get from object
        grps <- getGroups(object)
      }
      covForm <- getCovariateFormula(form)
      if (length(all.vars(covForm)) > 0) {
        if (attr(terms(covForm), "intercept") == 1) {
          covForm <-
            eval(parse(text = paste("~", deparse(covForm[[2]]),"-1",sep="")))
        }
        covar <- model.frame(covForm, data, na.action = na.action)
        ## making sure grps is consistent
        wchRows <- !is.na(match(row.names(data), row.names(covar)))
        if (!is.null(grps)) {
          grps <- pruneLevels(grps[wchRows])
        }
        covar <- as.data.frame(unclass(model.matrix(covForm, covar)))
      } else {
        if (is.null(grps)) {
          covar <- 1:nrow(data)
        } else {
          covar <-
            data.frame(dist = unlist(tapply(rep(1, nrow(data)), grps, cumsum)))
        }
      }
      if (is.null(grps)) {
        distance <- dist(as.matrix(covar), metric = metric)
      } else {
        covar <- split(covar, grps)
        ## getting rid of 1-observation groups
        covar <- covar[sapply(covar, function(el) nrow(as.matrix(el))) > 1]
        distance <- lapply(covar,
                           function(el, metric) dist(as.matrix(el), metric),
                           metric = metric)
      }
    }
  }
  res <- resid(object, type = resType)
  if (!is.null(wchRows)) {
    res <- res[wchRows]
  }
  if (is.null(grps)) {
    val <- Variogram(res, distance)
  } else {
    res <- split(res, grps)
    res <- res[sapply(res, length) > 1] # no 1-observation groups
    levGrps <- levels(grps)
    val <- structure(vector("list", length(levGrps)), names = levGrps)
    for(i in levGrps) {
      val[[i]] <- Variogram(res[[i]], distance[[i]])
    }
    val <- do.call("rbind", val)
  }
  if (!missing(maxDist)) {
    val <- val[val$dist <= maxDist, ]
  }
  collapse <- match.arg(collapse)
  if (collapse != "none") {             # will collapse values
    dst <- val$dist
    udist <- sort(unique(dst))
    ludist <- length(udist)
    if (!missing(breaks)) {
      if (min(breaks) > udist[1]) {
        breaks <- c(udist[1], breaks)
      }
      if (max(breaks) < udist[2]) {
        breaks <- c(breaks, udist[2])
      }
      if (!missing(nint) && nint != (length(breaks) - 1)) {
        stop("Nint is not consistent with breaks.")
      }
      nint <- length(breaks) - 1
    }
    if (nint < ludist) {
      if (missing(breaks)) {
        if (collapse == "quantiles") {    # break into equal groups
          breaks <- unique(quantile(dst, seq(0, 1, 1/nint)))
        } else {                          # fixed length intervals
          breaks <- seq(udist[1], udist[length(udist)], length = nint + 1)
        }
      }
      cutDist <- cut(dst, breaks)
    } else {
      cutDist <- dst
    }
    val <- lapply(split(val, cutDist),
                  function(el, robust) {
                    nh <- nrow(el)
                    vrg <- el$variog
                    if (robust) {
                      vrg <- ((mean(vrg^0.25))^4)/(0.457+0.494/nh)
                    } else {
                      vrg <- mean(vrg)
                    }
                    dst <- median(el$dist)
                    data.frame(variog = vrg, dist = dst)
                  }, robust = robust)
    val <- do.call("rbind", as.list(val))
    val$n.pairs <- table(na.omit(cutDist))
  }
  row.names(val) <- 1:nrow(val)
  if (inherits(csT, "corSpatial") && resType != "normalized") {
    ## will keep model variogram
    if (resType == "pearson") {
      sig2 <- 1
    } else {
      sig2 <- object$sigma^2
    }
    attr(val, "modelVariog") <-
      Variogram(csT, sig2 = sig2, length.out = length.out)
  }
  attr(val, "collapse") <- collapse != "none"
  class(val) <- c("Variogram", "data.frame")
  val
}

###*### glsStruct - a model structure for gls fits

glsStruct <-
  ## constructor for glsStruct objects
  function(corStruct = NULL, varStruct = NULL)
{
  val <- list(corStruct = corStruct, varStruct = varStruct)
  val <- val[!sapply(val, is.null)]	# removing NULL components
  class(val) <- c("glsStruct", "modelStruct")
  val
}

##*## glsStruct methods for standard generics

fitted.glsStruct <-
  function(object, glsFit = attr(object, "glsFit"))
{
  glsFit[["fitted"]]
}

initialize.glsStruct <-
  function(object, data, control = list(singular.ok = FALSE,
                           qrTol = .Machine$single.eps))
{
  if (length(object)) {
    object[] <- lapply(object, initialize, data)
    theta <- lapply(object, coef)
    len <- unlist(lapply(theta, length))
    num <- seq(along = len)
    if (sum(len) > 0) {
      pmap <- outer(rep(num, len), num, "==")
    } else {
      pmap <- array(FALSE, c(1, length(len)))
    }
    dimnames(pmap) <- list(NULL, names(object))
    attr(object, "pmap") <- pmap
    attr(object, "glsFit") <- 
      glsEstimate(object, control = control)
    if (needUpdate(object)) {
      object <- update(object, data)
    } 
  }
  object
}

logLik.glsStruct <-
  function(object, Pars, conLin = attr(object, "conLin"))
{
  coef(object) <- Pars			# updating parameter values
  conLin <- recalc(object, conLin)	# updating conLin
  val <- .C("gls_loglik",
	    as.double(conLin[["Xy"]]),
	    as.integer(unlist(conLin[["dims"]])),
	    logLik = as.double(conLin[["logLik"]]),
	    double(1), NAOK = TRUE,
	    PACKAGE = "nlme")
  val[["logLik"]]
}

residuals.glsStruct <-
  function(object, glsFit = attr(object, "glsFit"))
{
  glsFit[["resid"]]
}

varWeights.glsStruct <-
  function(object)
{
  if (is.null(object$varStruct)) rep(1, attr(object, "conLin")$dims$N)
  else varWeights(object$varStruct)
}

## Auxiliary control functions

glsControl <-
  ## Control parameters for gls
  function(maxIter = 50, msMaxIter = 50, tolerance = 1e-6, msTol = 1e-7, 
	   msScale = lmeScale, msVerbose = FALSE, singular.ok = FALSE, 
	   qrTol = .Machine$single.eps, returnObject = FALSE,
	   apVar = TRUE, .relStep = (.Machine$double.eps)^(1/3),
           nlmStepMax = 100.0,
           minAbsParApVar = 0.05, natural = TRUE)
{
  list(maxIter = maxIter, msMaxIter = msMaxIter, tolerance = tolerance,
       msTol = msTol, msScale = msScale, msVerbose = msVerbose, 
       singular.ok = singular.ok, qrTol = qrTol, 
       returnObject = returnObject, apVar = apVar,
       minAbsParApVar = minAbsParApVar, .relStep = .relStep,
       nlmStepMax = nlmStepMax,
       natural = natural)
}

### local generics for objects inheriting from class lme




## Local Variables:
## mode:S
## End:

### $Id: gnls.q,v 1.5 1999/11/18 23:56:57 saikat Exp $
###
###  Fit a general nonlinear regression model with correlated and/or
###  heteroscedastic errors
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

gnls <- 
  function(model,
	   data = sys.frame(sys.parent()),
	   params, 
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  finiteDiffGrad <-
	 function(model, data, pars)
	 {
	   dframe <- data.frame(data, pars)
	   base <- eval(model, dframe)
	   nm <- colnames(pars)
	   grad <- array(base, c(length(base), length(nm)), list(NULL, nm))
	   ssize <- sqrt(.Machine$double.eps)
	   for (i in nm) {
	     diff <- pp <- pars[ , i]
	     diff[pp == 0] <- ssize
	     diff[pp != 0] <- pp[pp != 0] * ssize
	     dframe[[i]] <- pp + diff
	     grad[ , i] <- (base - eval(model, dframe))/diff
	     dframe[[i]] <- pp
	   }
	   grad
         }

  ## keeping the call
  Call <- match.call()
  ## assigning a new name to the "object" argument
  form <- model

  ## control parameters
  controlvals <- gnlsControl()
  if (!missing(control)) {
    if(!is.null(control$nlmStepMax) && control$nlmStepMax < 0) {
      warning("Negative control$nlmStepMax - using default value")
      control$nlmStepMax <- NULL
    }
    controlvals[names(control)] <- control
  }
  ##
  ## checking arguments
  ##
  if (!inherits(form, "formula"))
    stop("\"object\" must be a formula")
  if (length(form)!=3)
    stop("object formula must be of the form \"resp ~ pred\"")

  ##
  ## checking if self-starting formula is given
  ##
  if (missing(start)) {
    if (!is.null(attr(eval(form[[3]][[1]]), "initial"))) {
      nlsCall <- Call[c("","model","data")]
      nlsCall[[1]] <- as.name("nls")
      names(nlsCall)[2] <- "formula"
      ## checking if "data" is not equal to sys.frame(sys.parent())
      if (is.null(dim(data))) {
        stop(paste("\"data\" must be given explicitly to use \"nls\"",
                   "to get initial estimates"))
      }
      start <- coef(eval(nlsCall))
    } else {
      stop("No initial values for model parameters")
    }
  } else {
    start <- unlist(start)
  }
    
  gnlsModel <- call("-", form[[2]], form[[3]])
  ##
  ## save writing list(...) when only one element
  ##

  if (missing(params)) {
    if (is.null(pNams <- names(start))) {
      stop("Starting estimates must have names when \"params\" is missing")
    }
    params <- eval(parse(text = paste(paste(pNams, collapse = "+"), "1",
                           sep = "~")))
  }
  if (!is.list(params)) {
    params <- list(params)
  }
  val <- NULL
  for(i in seq(along = params)) {
    if (is.name(params[[i]][[2]])) {
      val <- c(val, list(params[[i]]))
    } else {
      ## multiple parameters on left hand side
      val <- c(val, eval(parse(text = paste("list(",
           paste(paste(all.vars(params[[i]][[2]]), deparse(params[[i]][[3]]),
                       sep = "~"), collapse=","),")"))))
    }
  }
  params <- as.list(val)
  pnames <- character(length(params))
  for (i in seq(along = params)) {
    this <- eval(params[[i]])
    if (!inherits(this, "formula"))
      stop ("params must be a formula or list of formulae")
    if (length(this) != 3)
      stop ("formulae in params must be of the form \"parameter ~ expr\".")
    if (!is.name(this[[2]]))
      stop ("formulae in params must be of the form \"parameter ~ expr\".")
    pnames[i] <- as.character(this[[2]])
  }
  names(params) <- pnames

  ##
  ##  If data is a pframe, copy the parameters in the frame to frame 1
  ##
  if (inherits(data, "pframe")) {
    pp <- parameters(data)
    for (i in names(pp)) {
      assign(i, pp[[i]])
    }
    attr(data,"parameters") <- NULL
    class(data) <- "data.frame"
  }

  ## check if correlation is present and has groups
  if (!is.null(correlation)) {
    groups <- getGroupsFormula(correlation)
  } else groups <- NULL
#  if (!is.null(correlation)) {
#    groups <- getGroupsFormula(correlation, asList = TRUE)
#    if (!is.null(groups)) {
#      if (length(groups) > 1) {
#	stop("Only single level of grouping allowed")
#      }
#      groups <- groups[[1]]
#    } else {
#      if (inherits(data, "groupedData")) { # will use as groups
#	groups <- getGroupsFormula(data, asList = TRUE)
#	if (length(groups) > 1) {	# ignore it
#	  groups <- NULL
#	} else {
#          groups <- groups[[1]]
#          attr(correlation, "formula") <- 
#            eval(parse(text = paste("~", 
#                         deparse(getCovariateFormula(formula(correlation))[[2]]),
#			 "|", deparse(groups[[2]]))))
#        }
#      }
#    }
#  } else groups <- NULL

  ## create an gnls structure containing the correlation and weights
  gnlsSt <- gnlsStruct(corStruct = correlation, varStruct = varFunc(weights))

  ## extract a data frame with enough information to evaluate
  ## form, params, random, groups, correlation, and weights
  mfArgs <- list(formula = asOneFormula(formula(gnlsSt), form, params,
                   groups, omit = c(pnames, "pi")),
		 data = data, na.action = na.action)
  if (!missing(subset)) {
    mfArgs[["subset"]] <- asOneSidedFormula(Call[["subset"]])[[2]]
  }
  dataMod <- do.call("model.frame", mfArgs)

  origOrder <- row.names(dataMod)	# preserve the original order
  ##
  ## Evaluating the groups expression, if needed
  ##  
  if (!is.null(groups)) {
    ## sort the model.frame by groups and get the matrices and parameters
    ## used in the estimation procedures
    ## always use innermost level of grouping
    groups <- eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|")))
    grps <- getGroups(dataMod, groups,
                      level = length(getGroupsFormula(groups, asList = TRUE)))
    ## ordering data by groups
    ord <- order(grps)	
    grps <- grps[ord]
    dataMod <- dataMod[ord, ,drop = FALSE]
    revOrder <- match(origOrder, row.names(dataMod)) # putting in orig. order
  } else grps <- NULL

  N <- dim(dataMod)[1]			# number of observations
  ##
  ## evaluating the naPattern expression, if any
  ##
  if (missing(naPattern)) naPat <- rep(TRUE, N)
  else naPat <- as.logical(eval(asOneSidedFormula(naPattern)[[2]], dataMod))
  origOrderShrunk <- origOrder[naPat]

  dataModShrunk <- dataMod[naPat, , drop=FALSE]
  yShrunk <- eval(form[[2]], dataModShrunk)
  if (!is.null(groups)) {
    ordShrunk <- ord[naPat]
    grpShrunk <- grps[naPat]
    revOrderShrunk <- match(origOrderShrunk, row.names(dataModShrunk))
  } else {
    grpShrunk <- NULL
  }

  ##
  ## defining list with parameter information
  ##
  contr <- list()
  plist <- vector("list", length(pnames))
  names(plist) <- pnames
  for (nm in pnames) {
    plist[[nm]] <- TRUE
    if (deparse(as.vector(params[[nm]][[3]])) != "1") {
      plist[[nm]] <-
        model.matrix(asOneSidedFormula(params[[nm]][[3]]),
                 model.frame(asOneSidedFormula(params[[nm]][[3]]), dataModShrunk))
      auxContr <- attr(plist[[nm]], "contr")
      contr <- c(contr, auxContr[is.na(match(names(auxContr), names(contr)))])
    } 
  }
  ##
  ## Params effects names
  ##
  pn <- character(0)
  currPos <- 0
  parAssign <- list()
  for(nm in pnames) {
    if (is.logical(p <- plist[[nm]])) {
      currPos <- currPos + 1
      currVal <- list(currPos)
      pn <- c(pn, nm)
      names(currVal) <- nm
      parAssign <- c(parAssign, currVal)
    } else {
      currVal <- attr(p, "assign")
      fTerms <- terms(asOneSidedFormula(params[[nm]][[3]]))
      namTerms <- attr(fTerms, "term.labels")
      if (attr(fTerms, "intercept") > 0) {
        namTerms <- c("(Intercept)", namTerms)
      }
      namTerms <- factor(currVal, labels = namTerms)
      currVal <- split(order(currVal), namTerms)
      names(currVal) <- paste(nm, names(currVal), sep = ".")
      parAssign <- c(parAssign, lapply(currVal,
                                       function(el, currPos) {
                                         el + currPos
                                       }, currPos = currPos))
      currPos <- currPos + length(unlist(currVal))
      pn <- c(pn, paste(nm, colnames(p), sep = "."))
    }
  }
  pLen <- length(pn)
  if (length(start) != pLen) 
    stop ("starting values for parameters are not the correct length")
  spar <- start
  names(spar) <- pn
  NReal <- sum(naPat)
  ##
  ## Creating the params map
  ##
  pmap <- list()
  n1 <- 1
  for(nm in pnames) {
    if (is.logical(p <- plist[[nm]])) {
      pmap[[nm]] <- n1
      n1 <- n1 + 1
    } else {
      pmap[[nm]] <- n1:(n1+ncol(p) - 1)
      n1 <- n1 + ncol(p) 
    }
  }

  ##
  ## defining the nlFrame
  ##
  nlEnv <- new.env()
  nlList <-
                            list(model = gnlsModel,
			    data = dataMod,
			    plist = plist,
			    beta = as.vector(spar),
			    X = array(0, c(NReal, pLen), list(NULL, pn)),
			    pmap = pmap,
                            N = NReal,
                            naPat = naPat,
			    .parameters = c("beta"),
                            finiteDiffGrad = finiteDiffGrad)
                       
  lapply(names(nlList), function(x, y, env) assign(x, y[[x]], envir = env),
         nlList, env = nlEnv)

  modelExpression <- ~{
    pars <- getParsGnls(plist, pmap, beta, N)
    res <- eval(model, data.frame(data, pars))
    if (!length(grad <- attr(res, "gradient"))) {
      grad <- finiteDiffGrad(model, data, pars)[naPat, , drop = FALSE]
    } else {
      grad <- grad[naPat, , drop = FALSE]
    }
    res <- res[naPat]
    for (nm in names(plist)) {
      gradnm <- grad[, nm]
      if (is.logical(p <- plist[[nm]])) {
        X[, pmap[[nm]]] <- gradnm
      } else {
        X[, pmap[[nm]]] <- gradnm * p
      }
    }
    result <- c(X, res)
    result[is.na(result)] <- 0
    result
  }

  modelResid <- ~eval(model, data.frame(data,
      getParsGnls(plist, pmap, beta, N)))[naPat]
  w <- eval(modelResid[[2]], envir = nlEnv)
  ## creating the condensed linear model
  Dims <- list(p = pLen, N = NReal, REML = FALSE)
  attr(gnlsSt, "conLin") <-
    list(Xy = array(w, c(NReal, 1), 
           list(row.names(dataModShrunk), deparse(form[[2]]))), dims = Dims,
         logLik = 0)
                
  ## additional attributes of gnlsSt
  attr(gnlsSt, "resp") <- yShrunk
  attr(gnlsSt, "model") <- modelResid
  attr(gnlsSt, "local") <- nlEnv
  attr(gnlsSt, "NReal") <- NReal
  ## initialization
  gnlsSt <- initialize(gnlsSt, dataModShrunk)
  parMap <- attr(gnlsSt, "pmap")

  numIter <- 0				# number of iterations
  nlsSettings <- c(controlvals$nlsMaxIter, controlvals$minScale,
                    controlvals$nlsTol, 0, 0, 0)
  nlModel <- nonlinModel(modelExpression, nlEnv)
  repeat {
  ## alternating algorithm
    numIter <- numIter + 1
    ## GLS step
    if (needUpdate(gnlsSt)) {             # updating varying weights
      gnlsSt <- update(gnlsSt, dataModShrunk)
    }
    if (length(oldPars <- coef(gnlsSt)) > 0) {
      aNlm <- nlm(f = function(gnlsPars) -logLik(gnlsSt, gnlsPars),
                  p = c(coef(gnlsSt)),
                  hessian = TRUE,
                  print = ifelse(controlvals$msVerbose, 2, 0),
                  stepmax = controlvals$nlmStepMax*max(sqrt(sum(coef(gnlsSt)^2)), 1.0),
                  check = FALSE)
      aConv <- coef(gnlsSt) <- aNlm$estimate
      convIter <- aNlm$iterations # undocumented in nlm!
      if (verbose) {
        cat("\n**Iteration", numIter)
        cat("\n")
        cat("GLS step: Objective:", format(aNlm$minimum),
            ", nlm iterations:", aNlm$iterations, "\n")
        print(gnlsSt)
      }
    } else {
      aConv <- oldPars <- NULL
    }

    ## NLS step
    if (is.null(correlation)) {
      cF <- 1.0
      cD <- 1
    } else {
      cF <- corFactor(gnlsSt$corStruct)
      cD <- Dim(gnlsSt$corStruct)
    }
    if (is.null(weights)) {
      vW <- 1.0
    } else {
      vW <- varWeights(gnlsSt$varStruct)
    }
    work <- .C("fit_gnls", 
	       thetaNLS = as.double(spar),
	       as.integer(unlist(Dims)),
	       as.double(cF),
	       as.double(vW),
               as.integer(unlist(cD)),
	       settings = as.double(nlsSettings),
	       additional = double(NReal),
	       as.integer(!is.null(correlation)),
	       as.integer(!is.null(weights)),
               nlModel,
	       NAOK = TRUE)
    if (work$settings[4] == 1) {
      convResult <- 2                 
      if (controlvals$returnObject) {
        warning("Step halving factor reduced below minimum in NLS step")
      } else {
        stop("Step halving factor reduced below minimum in NLS step")
      }
      break
    }
    oldPars <- c(spar, oldPars)
    spar[] <- work$thetaNLS
    if (length(coef(gnlsSt)) == 0 && work$set[5] < controlvals$nlsMaxIter) {
      break
    }
    attr(gnlsSt, "conLin")$Xy[] <- work$additional
    attr(gnlsSt, "conLin")$logLik <- 0
    if (verbose) {
      cat("\nNLS step: RSS = ", format(work$set[6]), "\n model parameters:")
      for (i in 1:pLen) cat(format(signif(spar[i]))," ")
      cat("\n iterations:",work$set[5],"\n")
    }
    aConv <- c(spar, aConv)

    conv <- abs((oldPars - aConv)/
                ifelse(abs(aConv) < controlvals$tolerance, 1, aConv))
    aConv <- c(max(conv[1:pLen]))
    names(aConv) <- "params"
    if (length(conv) > pLen) {
      conv <- conv[-(1:pLen)]
      for(i in names(gnlsSt)) {
        if (any(parMap[,i])) {
          aConv <- c(aConv, max(conv[parMap[,i]]))
          names(aConv)[length(aConv)] <- i
        }
      }
    }

    if (verbose) {
      cat("\nConvergence:\n")
      print(aConv)
    }

    if ((max(aConv) <= controlvals$tolerance) ||
        (aConv["params"] <= controlvals$tolerance && aNlm$iterations == 1)) {
      convResult <- 0
      break
    }
    if (numIter >= controlvals$maxIter) {
      convResult <- 1
      if (controlvals$returnObject) {
	warning("Maximum number of iterations reached without convergence")
	break
      } else {
	stop("Maximum number of iterations reached without convergence")
      }
    }
  }

  ## wraping up
  ww <- eval(modelExpression[[2]], envir = nlEnv)
  auxRes <- ww[NReal * pLen + (1:NReal)]
  attr(gnlsSt, "conLin")$Xy <- array(ww, c(NReal, pLen + 1))
  attr(gnlsSt, "conLin") <- recalc(gnlsSt)
  sigma <-
    sqrt(sum((attr(gnlsSt,"conLin")$Xy[,pLen+1])^2)/(NReal - pLen))
  varBeta <- qr(attr(gnlsSt, "conLin")$Xy[,1:pLen,drop=F])
  if (varBeta$rank < pLen) {
    stop(paste("Approx. covariance matrix for parameter estimates",
               "not of full rank"))
  }
  lsig <- log(sigma) + 0.5 * log(1 - pLen/NReal)
  attr(parAssign, "varBetaFact") <- varBeta <-
    sigma * t(backsolve(qr.R(varBeta), diag(pLen)))
  varBeta <- crossprod(varBeta)
  dimnames(varBeta) <- list(pn, pn)
  loglik <- - NReal * (1 + log(2 * pi) + 2 * lsig) / 2 +
    attr(gnlsSt, "conLin")$logLik
  ##
  ## fitted.values and residuals (in original order)
  ##
  Resid <- resid(gnlsSt)
  Fitted <- yShrunk - Resid
  attr(Resid, "std") <- sigma/(varWeights(gnlsSt))
  if (!is.null(groups)) {
    attr(Resid, "std") <- attr(Resid, "std")[revOrderShrunk]
    Resid[] <- Resid[revOrderShrunk]
    Fitted[] <- Fitted[revOrderShrunk]
    grpShrunk[] <- grpShrunk[revOrderShrunk]
  }
  ## getting the approximate var-cov of the parameters
  ## first making Xy into single column array again
  attr(gnlsSt, "conLin")$Xy <- array(auxRes, c(NReal, 1))
  if (controlvals$apVar) {
    apVar <- gnlsApVar(gnlsSt, lsig, .relStep = controlvals[[".relStep"]],
                       minAbsPar = controlvals[["minAbsParApVar"]])
  } else {
    apVar <- "Approximate variance-covariance matrix not available"
  }
  ## getting rid of condensed linear model and fit
  oClass <- class(gnlsSt)
  attributes(gnlsSt) <-
    attributes(gnlsSt)[!is.na(match(names(attributes(gnlsSt)),
                                    c("names","pmap")))]
  class(gnlsSt) <- oClass
  ##
  ## creating the  gnls object
  ##
  estOut <- list(modelStruct = gnlsSt,
		 dims = Dims,
                 contrasts = contr,
		 coefficients = spar,
		 varBeta = varBeta,
		 sigma = sigma,
		 apVar = apVar,
		 logLik = loglik,
		 numIter = numIter,
		 groups = grpShrunk,
		 call = Call,
                 method = "ML",
		 fitted = Fitted,
		 residuals = Resid,
		 plist = plist,
                 pmap = pmap,
                 parAssign = parAssign)
  if (inherits(data, "groupedData")) {
    ## saving labels and units for plots
    attr(estOut, "units") <- attr(data, "units")
    attr(estOut, "labels") <- attr(data, "labels")
  }
  class(estOut) <- c("gnls", "gls")
  estOut
}
	      
### Auxiliary functions used internally in gls and its methods

gnlsApVar <-
  function(gnlsSt, lsigma, conLin = attr(gnlsSt, "conLin"),
           .relStep = (.Machine$double.eps)^(1/3), minAbsPar = 0,
           natural = TRUE)
{
  ## calculate approximate variance-covariance matrix of all parameters
  ## except the coefficients
  fullGnlsLogLik <-
    function(Pars, object, conLin, N) {
      ## logLik as a function of sigma and coef(glsSt)
      npar <- length(Pars)
      lsigma <- Pars[npar]              # within-group std. dev.
      Pars <- Pars[-npar]
      coef(object) <- Pars
      conLin <- recalc(object, conLin)
      conLin[["logLik"]] - N * lsigma - sum(conLin$Xy^2)/(2*exp(2*lsigma))
    }
  if (length(gnlsCoef <- coef(gnlsSt)) > 0) {
    cSt <- gnlsSt[["corStruct"]]
    if (!is.null(cSt) && inherits(cSt, "corSymm") && natural) {
      cStNatPar <- coef(cSt, unconstrained = FALSE)
      class(cSt) <- c("corNatural", "corStruct")
      coef(cSt) <- log((cStNatPar + 1)/(1 - cStNatPar))
      gnlsSt[["corStruct"]] <- cSt
      gnlsCoef <- coef(gnlsSt)
    }
    dims <- conLin$dims
    N <- dims$N
    conLin[["logLik"]] <- 0               # making sure
    Pars <- c(gnlsCoef, lSigma = lsigma)
    val <- fdHess(Pars, fullGnlsLogLik, gnlsSt, conLin, N,
		  .relStep = .relStep, minAbsPar = minAbsPar)[["Hessian"]]
    if (all(eigen(val)$values < 0)) {
      ## negative definite - OK
      val <- solve(-val)
      nP <- names(Pars)
      dimnames(val) <- list(nP, nP)
      attr(val, "Pars") <- Pars
      attr(val, "natural") <- natural
      val
    } else {
      ## problem - solution is not a maximum
      "Non-positive definite approximate variance-covariance"
    }
  } else {
    NULL
  }
}

#gnlsApVar <-
#  function(gnlsSt, conLin = attr(gnlsSt, "conLin"),
#           .relStep = (.Machine$double.eps)^(1/3))
#{
#  ## calculate approximate variance-covariance matrix of all parameters
#  ## except the coefficients
#  fullGnlsLogLik <-
#    function(Pars, object, conLin, N) {
#      ## logLik as a function of sigma and coef(glsSt)
#      coef(object) <- Pars
#      conLin <- recalc(object, conLin)
#      conLin[["logLik"]] - N * log(sum(conLin$Xy^2)) / 2
#    }
#  if (length(gnlsCoef <- coef(gnlsSt)) > 0) {
#    dims <- conLin$dims
#    N <- dims$N
#    conLin[["logLik"]] <- 0               # making sure
#    val <- fdHess(gnlsCoef, fullGnlsLogLik, gnlsSt, conLin, N,
#		  .relStep = .relStep)[["Hessian"]]
#    if (all(eigen(val)$values < 0)) {
#      ## negative definite - OK
#      val <- solve(-val)
#      nP <- names(gnlsCoef)
#      dimnames(val) <- list(nP, nP)
#      attr(val, "Pars") <- gnlsCoef
#      val
#    } else {
#      ## problem - solution is not a maximum
#      "Non-positive definite approximate variance-covariance"
#    }
#  } else {
#    NULL
#  }
#}


###
### function used to calculate the parameters from 
### the params and random effects
###

getParsGnls <-
  function(plist, pmap, beta, N)
{
  pars <- array(0, c(N, length(plist)), list(NULL, names(plist)))
  for (nm in names(plist)) {
    if (is.logical(p <- plist[[nm]])) {
      pars[, nm] <- beta[pmap[[nm]]]
    } else {
      pars[, nm] <- p %*% beta[pmap[[nm]]]
    }
  }
  pars  
}
  
###
###  Methods for standard generics
###

coef.gnls <- function(object) object$coefficients

formula.gnls <- function(object) eval(object$call[["model"]])

getData.gnls <-
  function(object)
{
  mCall <- object$call
  data <- eval(mCall$data)
  if (is.null(data)) return(data)
  naPat <- eval(mCall$naPattern)
  if (!is.null(naPat)) {
    data <- data[eval(naPat[[2]], data), , drop = FALSE]
  }
  naAct <- eval(mCall$na.action)
  if (!is.null(naAct)) {
    data <- naAct(data)
  }
  subset <- mCall$subset
  if (!is.null(subset)) {
    subset <- eval(asOneSidedFormula(subset)[[2]], data)
    data <- data[subset, ]
  }
  return(data)
}


logLik.gnls <-
  function(object, REML = FALSE)
{
  if (REML) {
    stop("Cannot calculate REML log-likelihood for gnls objects")
  }
  p <- object$dims$p
  N <- object$dims$N
  val <- object[["logLik"]]
  attr(val, "nobs") <- attr(val, "nall") <- N 
  attr(val, "df") <- p + length(coef(object[["modelStruct"]])) + 1
  class(val) <- "logLik"
  val
}


predict.gnls <- 
  function(object, newdata, na.action = na.fail, naPattern = NULL)  
{
  ##
  ## method for predict() designed for objects inheriting from class gnls
  ##
  if (missing(newdata)) {		# will return fitted values
    return(fitted(object))
  }
  newdata <- data.frame(newdata, check.names = FALSE)
  mCall <- object$call

  mfArgs <- list(formula = asOneFormula(formula(object),
                   mCall$params, naPattern, 
                   omit = c(names(object$plist), "pi",
                     deparse(getResponseFormula(object)[[2]]))),
                 data = newdata, na.action = na.action)
  dataMod <- do.call("model.frame", mfArgs)

  ## making sure factor levels are the same as in contrasts
  contr <- object$contrasts
  for(i in names(dataMod)) {
    if (inherits(dataMod[,i], "factor") && !is.null(contr[[i]])) {
      levs <- levels(dataMod[,i])
      levsC <- dimnames(contr[[i]])[[1]]
      if (any(wch <- is.na(match(levs, levsC)))) {
        stop(paste("Levels", paste(levs[wch], collapse = ","),
                   "not allowed for", i))
      }
      attr(dataMod[,i], "contrasts") <- contr[[i]][levs, , drop = FALSE]
#      if (length(levs) < length(levsC)) {
#        if (inherits(dataMod[,i], "ordered")) {
#          dataMod[,i] <- ordered(as.character(dataMod[,i]), levels = levsC)
#        } else {
#          dataMod[,i] <- factor(as.character(dataMod[,i]), levels = levsC)
#        }
#      }
    }
  }
  N <- nrow(dataMod)
  ##
  ## evaluating the naPattern expression, if any
  ##
  if (is.null(naPattern)) naPat <- rep(TRUE, N)
  else naPat <- as.logical(eval(asOneSidedFormula(naPattern)[[2]], dataMod))

  ##
  ## Getting  the plist for the new data frame
  ##
  ##
  plist <- object$plist
  pnames <- names(plist)
  if (is.null(params <- eval(object$call$params))) {
    params <- eval(parse(text = paste(paste(pnames, collapse = "+"), "1",
                           sep = "~")))
  }    
  if (!is.list(params)) {
    params <- list(params)
  }
  val <- NULL
  for(i in seq(along = params)) {
    if (is.name(params[[i]][[2]])) {
      val <- c(val, list(params[[i]]))
    } else {
      ## multiple parameters on left hand side
      val <- c(val, eval(parse(text = paste("list(",
           paste(paste(all.vars(params[[i]][[2]]), deparse(params[[i]][[3]]),
                       sep = "~"), collapse=","),")"))))
    }
  }
  params <- val
  names(params) <- pnames
  prs <- coef(object)
  pn <- names(prs)
  for(nm in pnames) {
    if (!is.logical(plist[[nm]])) {
      plist[[nm]] <- model.matrix(asOneSidedFormula(params[[nm]][[3]]),
                model.frame(asOneSidedFormula(params[[nm]][[3]]), dataMod))
    }
  }
  modForm <- getCovariateFormula(object)[[2]]
  val <- eval(modForm, data.frame(dataMod,
              getParsGnls(plist, object$pmap, prs, N)))[naPat]
  lab <- "Predicted values"
  if (!is.null(aux <- attr(object, "units")$y)) {
    lab <- paste(lab, aux)
  }
  attr(val, "label") <- lab
  val
}

update.gnls <- 
  function(object, model, data = sys.frame(sys.parent()), params, start ,
           correlation = NULL, weights = NULL, subset,
           na.action = na.fail, naPattern, control = list(),
	   verbose = FALSE)
{
  thisCall <- as.list(match.call())[-(1:2)]
  nextCall <- as.list(object$call)[-1]
  if (!is.null(thisCall$model)) {
    thisCall$model <- update(formula(object), thisCall$model)
  } else {                              # same model
    if (is.null(thisCall$start)) {
      thisCall$start <- coef(object)
    }
  }
  if (is.na(match("correlation", names(thisCall))) &&
      !is.null(thCor <- object$modelStruct$corStruct)) {
    thisCall$correlation <- thCor
  }
  if (is.na(match("weights", names(thisCall))) &&
      !is.null(thWgt <- object$modelStruct$varStruct)) {
    thisCall$weights <- thWgt
  }
  nextCall[names(thisCall)] <- thisCall
  do.call("gnls", nextCall)
}

###*### gnlsStruct - a model structure for gnls fits

gnlsStruct <-
  ## constructor for gnlsStruct objects
  function(corStruct = NULL, varStruct = NULL)
{

  val <- list(corStruct = corStruct, varStruct = varStruct)
  val <- val[!sapply(val, is.null)]	# removing NULL components
#  attr(val, "settings") <- attr(val$reStruct, "settings")
#  attr(val, "resp") <- resp
#  attr(val, "model") <- model
#  attr(val, "local") <- local
#  attr(val, "N") <- N
#  attr(val, "naPat") <- naPat
  class(val) <- c("gnlsStruct", "glsStruct", "modelStruct")
  val
}

##*## gnlsStruct methods for standard generics

fitted.gnlsStruct <-
  function(object)
{
  attr(object, "resp") - resid(object)
}

initialize.gnlsStruct <-
  function(object, data)
{
  if (length(object)) {
    object[] <- lapply(object, initialize, data)
    theta <- lapply(object, coef)
    len <- unlist(lapply(theta, length))
    num <- seq(along = len)
    if (sum(len) > 0) {
      pmap <- outer(rep(num, len), num, "==")
    } else {
      pmap <- array(FALSE, c(1, length(len)))
    }
    dimnames(pmap) <- list(NULL, names(object))
    attr(object, "pmap") <- pmap
    if (needUpdate(object)) {
      object <- update(object, data)
    } 
  }
  object
}

logLik.gnlsStruct <-
  function(object, Pars, conLin = attr(object, "conLin"))
{
  coef(object) <- Pars			# updating parameter values
  conLin <- recalc(object, conLin)	# updating conLin
  conLin[["logLik"]] - conLin$dims$N * log(sum(conLin$Xy^2)) / 2
}


residuals.gnlsStruct <-
  function(object)
{
  c(eval(attr(object, "model")[[2]], envir = attr(object, "local")))
}

gnlsControl <-
  ## Set control values for iterations within gnls
  function(maxIter = 50, nlsMaxIter = 7, msMaxIter = 50,
	   minScale = 0.001, tolerance = 1e-6, nlsTol = 0.001,
           msTol = 1e-7, msScale = lmeScale,
           returnObject = FALSE, msVerbose = FALSE, gradHess = TRUE,
           apVar = TRUE, .relStep = (.Machine$double.eps)^(1/3),
           nlmStepMax = 100.0,
           minAbsParApVar = 0.05)
{
  list(maxIter = maxIter, nlsMaxIter = nlsMaxIter, msMaxIter = msMaxIter,
       minScale = minScale, tolerance = tolerance, nlsTol = nlsTol,
       msTol = msTol, msScale = msScale, returnObject = returnObject, 
       msVerbose = msVerbose, gradHess = gradHess, apVar = apVar,
       nlmStepMax = nlmStepMax,
       .relStep = .relStep, minAbsParApVar = minAbsParApVar)
}

### Local Variables:
### mode:S
### S-keep-dump-files: t
### End:
 
### $Id: groupedData.q,v 1.2 1999/11/17 22:09:19 saikat Exp $
###
###           groupedData - data frame with a grouping structure
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

groupedData <- 
  ## Constructor for the groupedData class.  Takes a formula and a frame
  ## The formula must be of the form "response ~ primary | groups",
  ## "respose ~ primary ~ groups1/groups2/.../groups_k",
  ## or "response ~ (primary1 | groups1) / ... / (primary|groups_k)"
  ## where groups_i evaluates to a factor in frame.
  function(formula, data = sys.parent(1), order.groups = TRUE,
	   FUN = function(x) max(x, na.rm = TRUE), outer = NULL,
           inner = NULL, labels = NULL, units = NULL)
{
  if (!(inherits(formula, "formula") && length(formula) == 3)) {
    stop("first argument to groupedData must be a two-sided formula")
  }
  if (is.null(grpForm <- getGroupsFormula(formula, asList = TRUE))) {
    stop("Right hand side of first argument must be a conditional expression")
  }
  
  mCall <- as.list(match.call())[-1]
  if (length(grpForm) == 1) {	
    ## single grouping variable
    do.call("nfGroupedData", mCall)
  } else {				        # multiple nesting
    do.call("nmGroupedData", mCall)
  }
}

nfGroupedData <- 
  ## Constructor for the nfGroupedData class.  Takes a formula and a frame
  ## The formula must be of the form "response ~ primary | groups"
  ## where groups evaluates to a factor in frame.
  function(formula, data = sys.parent(1), order.groups = TRUE,
	   FUN = function(x) max(x, na.rm = TRUE), outer = NULL,
           inner = NULL, labels = NULL, units = NULL)
{
  if (!(inherits(formula, "formula") && length(formula) == 3)) {
    stop("first argument to nfGroupedData must be a two-sided formula")
  }
  grpForm <- getGroupsFormula(formula, asList = TRUE)
  if (is.null(grpForm)) {
    stop("Right hand side of first argument must be a conditional expression")
  }
  if (length(grpForm) > 1) {
    stop("Only one level of grouping allowed")
  }
  ## create a data frame in which formula, inner, and outer can be evaluated
  if (missing(data)) {	
    vnames <- all.vars(asOneFormula(formula, inner, outer))
    alist <- lapply(as.list(vnames), as.name)
    names(alist) <- vnames
    alist <- c(as.list(as.name("data.frame")), alist)
    mode(alist) <- "call"
    data <- eval(alist, sys.parent(1))
  } else {
    if (!inherits(data, "data.frame")) {  
      stop("second argument to groupedData must inherit from data.frame")
    }
  }
  ## Although response and primary are not always used, they are
  ## evaluated here to verify that they can be evaluated.
  response <- getResponse(data, formula)
  primary <- getCovariate(data, formula)
  groupName <- names(grpForm)
  groups <- getGroups(data, formula)
  data[[groupName]] <- groups

  if (order.groups) {
    if (!inherits(groups, "ordered")) {
      if (is.null(outer)) {
        data[[groupName]] <-
          ordered(groups,
                  levels = names(sort(tapply(response, groups, FUN))))
      } else {
        ## split the data according to the 'outer' factors and
        ## obtain the order within each group
        outer <- asOneSidedFormula(outer)
        ## paste together all variables in outer with a character
        ## unlikely to be in a name	  
        combined <-
          do.call("paste", c(data[all.vars(outer), drop = FALSE], sep='\007'))  
        levs <-
          as.vector(unlist(lapply(split(data.frame(response = response,
                                                   groups = groups),
                                        combined),
                                  function(obj, func) {
                                    names(sort(tapply(obj$response,
                                                      obj$groups, func)))
                                  }, func = FUN)))
        data[[groupName]] <- ordered(groups, levels = levs)
      }
    }
  }
  attr(data, "formula") <- formula
  attr(data, "labels") <- labels
  attr(data, "units") <- units
  attr(data, "outer") <- outer
  attr(data, "inner") <- inner
  attr( data, "FUN" ) <- FUN 
  attr( data, "order.groups" ) <- order.groups
  dClass <-  unique(c("nfGroupedData", "groupedData", class(data)))
  if ((length(all.vars(getCovariateFormula(formula))) == 0) || 
      (data.class(primary) != "numeric")) {
    ## primary covariate is a factor or a "1"
    class(data) <- unique(c("nffGroupedData", dClass))
  } else {
    ## primary covariate is numeric
    class(data) <- unique(c("nfnGroupedData", dClass))
  }
  data
}

nmGroupedData <-
  ## Constructor for the nmGroupedData class.  Takes a formula and a frame
  ## The formula must be of the form 
  ## "respose ~ primary | groups1/groups2/.../groups_k",
  ## where groups_i evaluates to a factor in frame.
  function(formula, data = sys.parent(1), order.groups = TRUE,
	   FUN = function(x) max(x, na.rm = TRUE), outer = NULL,
           inner = NULL, labels = NULL, units = NULL)
{
  checkForList <- function(object, nams, expand = FALSE) {
    if (is.null(object)) return(object)
    if (is.list(object)) {
      if (is.null(names(object))) {
        names(object) <- nams[1:length(object)]
      }
      return(object)
    }
    if (expand) {
      object <- rep(list(object), length(nams))
      names(object) <- nams
      return(object)
    } 
    object <- list(object)
    names(object) <- nams[length(nams)]
    object
  }
  if (!(inherits(formula, "formula") && length(formula) == 3)) {
    stop("first argument to nmGroupedData must be a two-sided formula")
  }
  grpForm <- getGroupsFormula(formula, asList = TRUE)
  if (is.null(grpForm)) {
    stop("Right hand side of first argument must be a conditional expression")
  }
  if (length(grpForm) == 1) {           # single group
    mCall <- match.call()[-1]
    do.call("nfGroupedData", mCall)
  }

  grpNames <- names(grpForm)
  names(grpNames) <- grpNames
  ## ckecking if arguments are lists
  order.groups <- checkForList(order.groups, grpNames, TRUE)
  outer <- checkForList(outer, grpNames)
  inner <- checkForList(inner, grpNames)

  ## create a data frame in which formula, outer, and inner can be evaluated  
  if (missing(data)) {		
    vnames <- all.vars(asOneFormula(formula, outer, inner))
    alist <- lapply(as.list(vnames), as.name)
    names(alist) <- vnames
    alist <- c(as.list(as.name("data.frame")), alist)
    mode(alist) <- "call"
    data <- eval(alist, sys.parent(1))
  } else {
    if (!inherits(data, "data.frame")) {  
      stop("second argument to groupedData must inherit from data.frame")
    }
  }
  ## Although response and primary are not always used, they are
  ## evaluated here to verify that they can be evaluated.
  response <- getResponse(data, formula)
  primary <- getCovariate(data, formula)
  groups <- getGroups(data, formula)

  attr(data, "formula") <- formula
  attr(data, "formulaList") <- grpForm
  attr(data, "labels") <- labels
  attr(data, "units") <- units
  attr(data, "inner") <- inner
  attr(data, "outer") <- outer
  attr(data, "order.groups") <- order.groups
  attr(data, "FUN") <- FUN
  class(data) <- unique(c("nmGroupedData", "groupedData", class(data)))
  data
}

###*# Methods for standard generics

as.data.frame.groupedData <-
  function(x, row.names = NULL, optional = FALSE)
{
  attributes(x) <- attributes(x)[c("names", "row.names")]
  class(x) <- "data.frame"
  NextMethod()
}

collapse.groupedData <-
  function(object, collapseLevel = Q, displayLevel = collapseLevel,
           outer = NULL, inner = NULL, preserve = NULL, FUN = mean,
           subset = NULL)
{
  form <- formula(object)
  grpForm <- getGroupsFormula(form, asList = TRUE)
  grpNames <- names(grpForm)
  names(grpNames) <- grpNames
  Q <- length(grpForm)                  # number of levels
  if (Q == 1) {                         # no collapsing
    if (!missing(subset)) {
      warning("Subset ignored with single grouping factor")
    }
    return(object)
  }
  groups <- getGroups(object, form, level = 1:Q)
  if (!is.null(subset)) {
    ## choosing some levels of grouping factors
    if (!is.list(subset)) {
      stop("\"Subset\" must be a list")
    }
    if (!any(is.na(match(names(subset), 1:Q)))) {
      ## subset names given as integers
      names(subset) <- grpNames[names(subset)]
    }
    if (any(is.na(match(names(subset), grpNames)))) {
      stop("Undefined group declared in \"subset\"")
    }
    auxSubset <- rep(TRUE, dim(object)[1])
    for(i in names(subset)) {
      auxSubset <- auxSubset & as.logical(match(groups[[i]], subset[[i]], 0))
    }
    object <- object[auxSubset, , drop = FALSE]
    groups <- groups[auxSubset, , drop = FALSE]
    groups[] <- lapply(groups, pruneLevels)
  }
  if (length(displayLevel) != 1) {
    stop("Only one display level allowed")
  }
  if (is.null(grpForm[[displayLevel]])) {
    stop(paste("Undefined display level",displayLevel,"for", 
	       substitute(object)))
  }
  attribs <- attributes(object)
  ord <- attribs[["order.groups"]][[displayLevel]]
  if (is.logical(outer)) {
    outer <- attribs[["outer"]][[displayLevel]]
  }
  if (is.logical(inner)) {
    inner <- attribs[["inner"]][[displayLevel]]
  }
  form[[3]][[3]] <- grpForm[[displayLevel]][[2]]
  args <- list(formula = form,
	       order.groups = ord,
	       FUN = attribs[["FUN"]],
	       outer = outer,
	       inner = inner,
	       labels = attribs[["labels"]],
	       units = attribs[["units"]])
  dlevel <- if (is.character(displayLevel)) { # as the level name
              match(displayLevel, grpNames)
	    } else {                    # as the level number
	      displayLevel
	    }
  if (dlevel < Q) {			# may need to collapse object
    if (is.null(grpForm[[collapseLevel]])) {
      stop(paste("Undefined collapsing level", collapseLevel,
		 "for", substitute(object)))
    }
    clevel <- if (is.character(collapseLevel)) {
      match(collapseLevel, grpNames)
    } else {
      collapseLevel
    }
    if (clevel < dlevel) {
      clevel <- dlevel
      warning(paste("Collapsing level cannot be smaller than display level;",
		    "setting it to the display level"))
    }
    if ((dlevel < clevel) || (clevel < Q)) { 
      collapseGroups <-
        do.call("paste", c(lapply(groups[, 1:clevel, drop = FALSE ],
                                  as.character), sep = "\007"))
      if (dlevel < clevel) {            # may need innerGroups
	object[[".collapseGroups"]] <- as.factor(collapseGroups)
      }
      if (!is.null(preserve)) {
        if (!(inherits(preserve, "formula") && length(preserve) == 2)) {
          stop("\"Preserve\" must be a two-sided formula")
        }
        collapseGroups <- paste(collapseGroups, eval(preserve[[2]], object),
                                sep = "\007")
      }
      collapseGroups <- paste(collapseGroups, getCovariate(object),
                              sep = "\007")
      collapseGroups <- ordered(collapseGroups, 
                                levels = unique(as.character(collapseGroups)))
      if (length(levels(collapseGroups)) < dim(object)[1]) {
        ## collapsing the object
        object <- gsummary(object, groups = collapseGroups, FUN = FUN)
        row.names(object) <- 1:dim(object)[1]
        ## need to recalculate groups --- fix from JCP
        groups <- getGroups(object, grpForm, level = 1:Q)
      }
    }
  }
  object <- as.data.frame(object)
  if (dlevel == 1) {			# no outer groups
    args[["data"]] <- object
    value <- do.call("nfGroupedData", args)
  } else {
    ## need to establish an appropriate ordering
    namesDgrp <- names(groups)
    for(i in 2:Q) {
      groups[, i] <- paste(as.character(groups[, i - 1]),
                           as.character(groups[, i]), sep = "/")
      namesDgrp[i] <- paste(namesDgrp[i-1], namesDgrp[i], sep = "/")
    }
    displayGroups <- groups[, dlevel]
    isOrd <- unlist(lapply(groups, is.ordered))[1:dlevel]
    ordOrig <- unlist(attribs[["order.groups"]][1:dlevel]) & !isOrd
    if (any(ordOrig)) {
      groups[ordOrig] <- lapply(groups[ordOrig], function(el, y, func) {
	ordered(el, levels = names(sort(tapply(y, el, func))))
      }, y = getResponse(object, form), func = attribs[["FUN"]])
    }
    if (!is.null(outer)) {
      outFact <- do.call("paste", c(lapply(object[, all.vars(outer)],
					 as.character), sep = "\007"))
      groups <- c(list(outFact), groups)
    } 
    displayGroups <- ordered(displayGroups,
      levels = unique(as.character(displayGroups[do.call("order", groups)])))
    form[[3]][[3]] <- as.name(".groups")
    object[[".groups"]] <- displayGroups
    args[["formula"]] <- form
    args[["data"]] <- object
    value <- do.call("nfGroupedData", args)
  }
  if (match(".collapseGroups", names(object), 0)) {
    groups <- eval(form[[3]][[3]], value)
    rnams <- unlist(split(1:nrow(value), groups))
    cGroups <- unlist(lapply(split(value[[".collapseGroups"]], groups),
                             function(el) as.integer(pruneLevels(el))))
    value[[".collapseGroups"]] <- cGroups[order(rnams)]
    attr(value, "innerGroups") <- ~.collapseGroups
  }
  if (dlevel > 1 && !is.na(match(".groups", names(value)))) { 
    attr(value[,".groups"], "label") <- namesDgrp[dlevel]
  }
  value
}

formula.groupedData <-
  function(object) eval(attr(object, "formula"))

plot.nfnGroupedData <-
  function(x, outer = NULL, inner = NULL, innerGroups = NULL,
           xlab = paste(attr(x, "labels")$x, attr(x, "units")$x),
           ylab = paste(attr(x, "labels")$y, attr(x, "units")$y),
           strip = function(...) strip.default(..., style = 1),
           aspect = "xy",
           panel = function(x, y) {
             if (grid) panel.grid()
             panel.xyplot(x, y)
             y.avg <- tapply(y, x, mean) # lines through average y
             y.avg <- y.avg[!is.na(y.avg)]
             if (length(y.avg) > 0) {
               xvals <- as.numeric(names(y.avg))
               ord <- order(xvals)
               panel.xyplot(xvals[ord], y.avg[ord], type = "l")
             }
           }, key = TRUE, grid = TRUE, ...)
{
  labels <- list(xlab = xlab, ylab =  ylab)
  labels <- labels[unlist(lapply(labels, length)) > 0]
  args <- c(list(formula = attr(x, "formula"), data = x, strip = strip,
		 aspect = aspect, panel = panel), labels)
  if (length(outer) > 0) {
    if (is.logical(outer) && outer) {	# get the default outer formula
      outer <- attr(x, "outer")
    }
    args[["formula"]][[3]][[3]] <- asOneSidedFormula(outer)[[2]]
    if (length(innerGroups) == 0) {
      innerGroups <- getGroupsFormula(x)
    }
  } 
  if ((length(innerGroups) > 0) && (length(inner) == 0)) {
    inner <- innerGroups
    innerGroups <- NULL
  }
  if (length(inner) > 0) {
    if (is.logical(inner) && inner) {	# get the default inner formula
      inner <- attr(x, "inner")
    }
    args[["subscripts"]] <- T
    trll.set <- trellis.par.get("superpose.line")[c("lty", "col")]
    if (length(innerGroups) == 0) {
      args[["groups"]] <- asOneSidedFormula(inner)[[2]]
      if (missing(inner)) {
        Inner <- NULL
        trll.lty <- trll.set[["lty"]][1]
        trll.col <- trll.set[["col"]][1]
        assign("trll.lty", trll.lty)
        assign("trll.col", trll.col)
        args[["panel"]] <- function(x, y, subscripts, groups)
          {
            panel.grid()
            panel.xyplot(x, y)
            panel.superpose(x, y, subscripts, groups, type = "l",
                            col = trll.col, lty = trll.lty)
          }
      } else {
        Inner <- as.factor(eval(asOneSidedFormula(inner)[[2]], x))
        levInn <- levels(Inner)
        args[["panel"]] <- function(x, y, subscripts, groups)
          {
            panel.grid()
            panel.xyplot(x, y)
            panel.superpose(x, y, subscripts, groups, type = "l")
          }
      }        
    } else {				#inner and innerGroups
      args[["groups"]] <- asOneSidedFormula(innerGroups)[[2]]
      Inner <- as.factor(eval(asOneSidedFormula(inner)[[2]], x))
      levInn <- levels(Inner)
      Inner <- (as.integer(Inner) - 1) %% length(trll.set[["lty"]]) + 1
      trll.lty <- trll.set[["lty"]][Inner]
      trll.col <- trll.set[["col"]][Inner]
      assign("trll.lty", trll.lty)
      assign("trll.col", trll.col)
      args[["panel"]] <- function(x, y, subscripts, groups)
	{
	  panel.grid()
	  panel.xyplot(x, y)
          aux <- match(unique(groups), groups)
          panel.superpose(x, y, subscripts, groups, type = "l",
			  col = trll.col[aux],
			  lty = trll.lty[aux])
	}
    }
  } else {
    Inner <- NULL
  }
  if(is.logical(key)) {
    if(key && (!is.null(Inner) && (lInn <- length(levInn)) > 1)) {
      lInn <- min(c(lInn, length(trll.set[["lty"]])))
      args[["key"]] <- 
	list(lines = Rows(trellis.par.get("superpose.line"), 1:lInn),
	     text = list(levels = levInn), columns = lInn)
    }
  } else {
    args[["key"]] <- key
  }
  dots <- list(...)
  args[names(dots)] <- dots
  assign("grid", grid)
  do.call("xyplot", args)
}

plot.nffGroupedData <-
  function(x, outer = NULL, inner = NULL, innerGroups = NULL,
           xlab = paste(attr(x, "labels")$y, attr(x, "units")$y),
           ylab = groupLabel,
           strip = function(...) strip.default(..., style = 1),
           panel = function(x, y) {
             dot.line <- trellis.par.get("dot.line")
             panel.abline(h = y, lwd = dot.line$lwd,
                          lty = dot.line$lty, col = dot.line$col)
             panel.dotplot(x, y)
           }, key = length(inner) > 0, grid, ...)
{
  groupExpr <- deparse(getGroupsFormula(x)[[2]])
  if (is.null(groupLabel <- attr(x[, groupExpr], "label"))) {
    groupLabel <- groupExpr
  }
  labels <- list(xlab = xlab, ylab = ylab)
  labels <- labels[unlist(lapply(labels, length)) > 0]
  if (length(outer) > 0) {
    if (is.logical(outer) && outer) {	# get the default outer formula
      form <- formula(paste(groupExpr,
                            "~", deparse(getResponseFormula(x)[[2]]),"|",
			     deparse(attr(x, "outer")[[2]])))
    } else {
      form <-  formula(paste(groupExpr,
			    "~", deparse(getResponseFormula(x)[[2]]),"|",
			     deparse(outer[[2]])))
    }
  } else {
    form <- formula(paste(groupExpr, "~",
                          deparse(getResponseFormula(x)[[2]])))
  }
  args <- c(list(formula = form, data = x, strip = strip, panel = panel),
            labels)
  if ((length(innerGroups) > 0) && (length(inner) == 0)) {
    inner <- innerGroups
    innerGroups <- NULL
  }
  if (length(inner) == 0) {
    covForm <- getCovariateFormula(x)
    if (length(all.vars(covForm)) > 0) {# non-trivial covariate
      inner <- covForm
    }
  }
  if (length(inner) > 0) {
    if (is.logical(inner) && inner) {	# get the default inner formula
      inner <- attr(x, "inner")
    }
    args[["subscripts"]] <- TRUE
    args[["groups"]] <- asOneSidedFormula(inner)[[2]]
    args[["panel"]] <- function(x, y, subscripts, groups)
      {
	dot.line <- trellis.par.get("dot.line")
	panel.abline(h = y, lwd = dot.line$lwd,
		     lty = dot.line$lty, col = dot.line$col)
	panel.superpose(x, y, subscripts, groups)
      }
  } 
  if(is.logical(key) && key && (length(inner) > 0)) {
    Inner <- eval(inner[[2]], x)
    levInn <- levels(as.factor(Inner))
    lInn <- length(levInn)
    lInn <- min(c(lInn, length(trellis.par.get("superpose.symbol")$pch)))
    args[["key"]] <- 
      list(points = Rows(trellis.par.get("superpose.symbol"), 1:lInn),
	     text = list(levels = levInn), columns = lInn)
  }
  dots <- list(...)
  args[names(dots)] <- dots
  do.call("dotplot", args)
}
    
plot.nmGroupedData <- 
  function(x, collapseLevel = Q, displayLevel = collapseLevel, 
	   outer = NULL, inner = NULL, preserve = NULL, FUN = mean,
           subset = NULL, key = TRUE, grid = TRUE, ...)
{
  args <- list(outer = outer, inner = inner, key = key, grid = grid, ...)
  Q <- length(getGroupsFormula(x, asList = TRUE))
  if (is.null(preserve) && (collapseLevel < Q) && (!is.null(inner))) {
    if (is.logical(inner)) {
      preserve <- attr(x, "inner")[[displayLevel]]
    } else {
      preserve <- inner
    }
  }
  x <- collapse(x, collapseLevel, displayLevel, outer, inner,
		preserve, FUN, subset)
  args[["innerGroups"]] <- attr(x, "innerGroups")
  args[["x"]] <- x
  do.call("plot", args)
}

print.groupedData <-
  function(x, ...)
{
  cat("Grouped Data: ")
  print(attr(x, "formula"))
  print.data.frame(x, ...)
}

update.groupedData <-
  function(object, formula, data, order.groups, FUN, outer, inner,
           labels, units)
  
{
  args <- as.list( attributes( object ) )
  args <- args[is.na(match(names(args),
                       c("names", "row.names", "class", "formulaList")))]
  thisCall <- as.list(match.call())[-(1:2)]
  args[names(thisCall)] <- thisCall
  if (is.null(args[["data"]])) args[["data"]] <- as.data.frame(object)
  do.call("groupedData", args)
}

"[.groupedData" <-
  function(x, i, j, drop = if (missing(i)) TRUE else length(cols) == 1)
{
  oAttr <- attributes(x)
  x <- as.data.frame(x)
  data <- NextMethod()
  if (!inherits(data, "data.frame")) return(data)
  allV <- all.vars(asOneFormula(oAttr[["formula"]], oAttr[["inner"]],
                                oAttr[["outer"]]))
  ## check if any columns used in formulas were deleted
  if( any( is.na( match( allV, names(data) ) ) ) ) { # return data frame
    cols <- ncol(data)
    return( data[, 1:ncol(data), drop = drop] )
  }
  args <- as.list(oAttr)
  args <- args[ is.na( match( names( args ), c( "names", "row.names" ) ) ) ]
  if (nrow(x) == nrow(data)) {		# only columns deleted
    attributes(data) <- c( attributes( data ), args )
    return( data )
  }
  ## pruning the levels of factors
  whichFact <- unlist(lapply(data, is.factor))
  data[whichFact] <- lapply(data[whichFact], pruneLevels)
  args <- c(args[!is.na(match(names( args ), c("formula", "order.groups",
            "FUN", "outer", "inner", "labels", "units")))], list(data = data))
  do.call("groupedData", args)
}

isBalanced.groupedData <-
  function(object, countOnly = FALSE, level) 
{
  if (missing(level)) {
    level <- length(getGroupsFormula(object, asList = TRUE))
  }
  if ( countOnly ) {
    return( length( unique( table( getGroups(object, level = level) ) ) ) == 1 )
  }
  length(unique(table(getCovariate(object),
                      getGroups(object, level = level)))) == 1
}

asTable.groupedData <-
  function(object) 
{
  if (length(getGroupsFormula(object, asList = TRUE)) > 1) {
    stop("asTable cannot be used with multilevel grouped data")
  }
  tab <- table( getGroups(object), getCovariate(object) )
  if (1 != length(unique(tab)))
    stop("asTable can only be used with balanced groupedData objects")
  tab[] <- getResponse(object)[order(getCovariate(object),getGroups(object))]
  tab
}

balancedGrouped <- 
  function(form, data, labels = NULL, units = NULL)
{
  form <- as.formula( form )
  data <- t( as.matrix( data ) )
  dn <- dimnames( data )
  if ( all( !is.na( as.numeric( dn[[1]] ) ) ) ) {
    dn[[1]] <- as.numeric( dn[[1]] )
  }
  names(dn) <- c( as.character(getCovariateFormula(form)[[2]]),
                  as.character(getGroupsFormula(form)[[2]]) )
  frm <- do.call("expand.grid", dn)
  frm[[ as.character(getResponseFormula(form)[[2]]) ]] <- as.vector( data )
  do.call("groupedData", list(form, data = frm, labels = labels, units = units ))
}

### Local variables:
### mode: S
### End:


## $Id: lmList.q,v 1.2 1999/11/04 16:46:39 saikat Exp $
###
###                  Create a list of lm objects
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

###*# Constructors

lmList <- 
  ## a list of lm objects from a formula or a groupedData object
  function(object, data, level, subset, na.action = na.fail, pool = TRUE)
  UseMethod("lmList")

lmList.groupedData <-
  function(object, data, level, subset, na.action = na.fail, pool = TRUE)
{
  ### object will provide the formula, the data, and the groups
  form <- formula(object)
  args <- as.list(match.call())[-1]
  args[["object"]] <- as.vector(eval(parse(text = paste(deparse(form[[2]]),
                                             "~", deparse(form[[3]][[2]])))))
  if (!missing(data)) {
    args[["data"]] <- substitute(object)
  } else {
    args <- as.list(c(args, list(data = substitute(object))))
  }
  do.call("lmList.formula", args)
}

lmList.formula <- 
  function(object, data, level, subset, na.action = na.fail, pool = TRUE)
{
  Call <- match.call()
  if (!missing(subset)) {
    data <-
      data[eval(asOneSidedFormula(Call[["subset"]])[[2]], data),, drop = FALSE]
  }
  if (!inherits(data, "data.frame")) data <- as.data.frame(data)
  data <- na.action(data)
  if (is.null(grpForm <- getGroupsFormula(object))) {
    if (inherits(data, "groupedData")) {
      if (missing(level))
        level <- length(getGroupsFormula(data, asList = TRUE))
      else if (length(level) > 1) {
	stop("Multiple levels not allowed")
      }
      groups <- pruneLevels(getGroups(data, level = level))
      grpForm <- getGroupsFormula(data)
      Call$object <-
        as.vector(eval(parse(text=paste(deparse(as.vector(Call$object)),
                               deparse(grpForm[[2]]), sep = "|"))))
      
    } else {
      stop ("data must be a groupedData object if groups argument is missing")
    }
  } else {
    if (missing(level))
      level <- length(getGroupsFormula(object, asList = TRUE))
    else if (length(level) > 1) {
      stop("Multiple levels not allowed")
    }
    groups <- pruneLevels(getGroups(data, form = grpForm, level = level))
    object <- eval(parse(text=paste(deparse(getResponseFormula(object)[[2]]),
                       deparse(getCovariateFormula(object)[[2]]), sep = "~")))
  }
  val <- lapply(split(data, groups),
		function(dat, form, na.action)
		{
                  lm(formula = form, data = dat, na.action = na.action)
		},
		form = object, na.action = na.action)
  if (inherits(data, "groupedData")) {
    ## saving labels and units for plots
    attr(val, "units") <- attr(data, "units")
    attr(val, "labels") <- attr(data, "labels")
  }

  attr(val, "dims") <- list(N = nrow(data), M = length(val))
  attr(val,"call") <- Call
  attr(val, "groupsForm") <- grpForm
  attr(val,"groups") <- ordered(groups, levels = names(val))
  attr(val, "origOrder") <- match(unique(as.character(groups)), names(val))
  attr(val, "level") <- level
  attr(val, "pool") <- pool
  class(val) <- "lmList"
  val
}  

###*# Methods for standard generics

augPred.lmList <- 
  function(object, primary = NULL, minimum = min(primary), 
	   maximum = max(primary), length.out = 51, ...)
{
  data <- eval(attr(object, "call")[["data"]])
  if (!inherits(data, "data.frame")) {
    stop(paste("Data in", substitute(object),
               "call must evaluate to a data frame"))
  }
  if(is.null(primary)) {
    if (!inherits(data, "groupedData")) {
      stop(paste(sys.call()[[1]],
      "without \"primary\" can only be used with fits of groupedData objects"))
    }
    primary <- getCovariate(data)
    prName <- deparse(getCovariateFormula(data)[[2]])
  } else{
    primary <- asOneSidedFormula(primary)[[2]]
    prName <- deparse(primary)
    primary <- eval(primary, data)
  }
  newprimary <- seq(from = minimum, to = maximum, length.out = length.out)
  groups <- getGroups(object)
  grName <- deparse(getGroupsFormula(object)[[2]])
  ugroups <- unique(groups)
  value <- data.frame(rep(newprimary, length(ugroups)),
		      rep(ugroups, rep(length(newprimary), length(ugroups))))
  names(value) <- c(prName, grName)
  ## recovering other variables in data that may be needed for predictions
  ## varying variables will be replaced by their means
  summData <- gsummary(data, groups = groups)
  if (any(toAdd <- is.na(match(names(summData), names(value))))) {
    summData <- summData[, toAdd, drop = FALSE]
  }
  value[, names(summData)] <- summData[value[, 2], ]
  pred <- c(predict(object, value, asList = FALSE))
  newvals <- cbind(value[, 1:2], pred)
  names(newvals)[3] <- respName <-
    deparse(getResponseFormula(object)[[2]])
  orig <- data.frame(primary, groups, getResponse(object))
  names(orig) <- names(newvals)
  value <- rbind(orig, newvals)
  attributes(value[, 2]) <- attributes(groups)
  value[, ".type"] <- ordered(c(rep("original", nrow(data)),
				rep("predicted", nrow(newvals))), 
			      levels = c("predicted", "original"))
  labs <- list(x = prName, y = respName)
  unts <- list(x = "", y = "")
  if(inherits(data, "groupedData")) {
    labs[names(attr(data, "labels"))] <- attr(data, "labels")
    unts[names(attr(data, "units"))] <- attr(data, "units")
    attr(value, "units") <- attr(data, "units")
  } 
  attr(value, "labels") <- labs
  attr(value, "units") <- unts
  attr(value, "formula") <- 
      eval(parse(text = paste(respName, "~", prName, "|", grName)))
  class(value) <- c("augPred", class(value))
  value
}

coef.lmList <-
  ## Extract the coefficients and form a  data.frame if possible
  function(object, augFrame = FALSE, data = NULL,
           which = NULL, FUN = mean, omitGroupingFactor = TRUE)
{
  coefs <- lapply(object, coef)
  non.null <- !unlist(lapply(coefs, is.null))
  if (sum(non.null) > 0) {
    template <- coefs[non.null][[1]]
    if (is.numeric(template)) {
      co <- matrix(template,
		      ncol = length(template),
		      nrow = length(coefs),
		      byrow = TRUE,
		      dimnames = list(names(object), names(template)))
      for (i in names(object)) {
	co[i,] <- if (is.null(coefs[[i]])) { NA } else coefs[[i]]
      }
      coefs <- as.data.frame(co)
      effectNames <- names(coefs)
      if(augFrame) {
        if (is.null(data)) {
          data <- getData(object)
        }
        data <- as.data.frame(data)
        if (is.null(which)) {
          which <- 1:ncol(data)
        }
	data <- data[, which, drop = FALSE]
	## eliminating columns with same names as effects
	data <- data[, is.na(match(names(data), effectNames)), drop = FALSE]
        data <- gsummary(data, FUN = FUN, groups = getGroups(object))
	if (omitGroupingFactor) {
	  data <- data[, is.na(match(names(data),
                   names(getGroupsFormula(object, asList = TRUE)))),
                       drop = FALSE]
	}
	if (length(data) > 0) {
	  coefs <- cbind(coefs, data[row.names(coefs),,drop = FALSE])
	}
      }
      attr(coefs, "level") <- attr(object, "level")
      attr(coefs, "label") <- "Coefficients"
      attr(coefs, "effectNames") <- effectNames
      attr(coefs, "standardized") <- F
      attr(coefs, "grpNames") <- deparse(getGroupsFormula(object)[[2]])
      class(coefs) <- c("coef.lmList", "ranef.lmList", class(coefs))
    }
  }
  coefs
}

fitted.lmList <- 
  function(object, subset = NULL, asList = FALSE)
{
  if(!is.null(subset)) {
    if(is.character(subset)) {
      if (any(is.na(match(subset, names(object))))) {
        stop("Non-existent groups requested in \"subset\".")
      }
    } else {
      if (is.integer(subset)) {
        if (any(is.na(match(subset, 1:length(object))))) {
          stop("Non-existent groups requested in \"subset\".")
        }
      } else {
        stop("Subset can only be character or integer")
      }
    }
    oclass <- class(object)
    oatt <- attr(object, "call")
    object <- object[subset]
    attr(object, "call") <- oatt
    class(object) <- oclass
  }
  val <- lapply(object, fitted)
  if(!asList) {				#convert to array
    ngrps <- table(getGroups(object))[names(object)]
    if(any(aux <- sapply(object, is.null))) {
      for(i in names(ngrps[aux])) {
	val[[i]] <- rep(NA, ngrps[i])
      }
    }
    val <- val[attr(object, "origOrder")] # putting in original order
    namVal <- names(val)
    val <- unlist(val)
    names(val) <- rep(namVal, ngrps)
  }
  lab <- "Fitted values"
  if (!is.null(aux <- attr(object, "units")$y)) {
    lab <- paste(lab, aux)
  }
  attr(val, "label") <- lab
  val
}

fixef.lmList <-
  function(object)
{
  coeff <- coef(object)
  if(is.matrix(coeff) || is.data.frame(coeff)) {
    return(apply(coeff, 2, mean, na.rm = TRUE))
  }
  NULL
}

formula.lmList <-
  function(object) eval(attr(object, "call")[["object"]])

getData.lmList <-
  function(object)
{
  mCall <- attr(object, "call")
  data <- eval(mCall$data)
  if (is.null(data)) return(data)
  naAct <- eval(mCall$na.action)
  if (!is.null(naAct)) {
    data <- naAct(data)
  }
  subset <- mCall$subset
  if (!is.null(subset)) {
    subset <- eval(asOneSidedFormula(subset)[[2]], data)
    data <- data[subset, ]
  }
  return(data)
}

getGroups.lmList <-  function(object, form, level, data, sep)
  attr(object, "groups")

getGroupsFormula.lmList <-
  function(object, asList = FALSE, sep)
{
  val <- attr(object, "groupsForm")
  getGroupsFormula(eval(parse(text=paste("~1",deparse(val[[2]]),sep="|"))),
		   asList = asList)
}

getResponse.lmList <-
  function(object, form)
{
  fitted(object) + resid(object)
}

intervals.lmList <-
  function(object, level = 0.95, pool = attr(object, "pool"))
{
  smry <- summary(object, pool = pool)
  coeff <- coef(smry)
  out <- coeff[ , 1:3 , ]
  dn <- dimnames(out)
  dimnames(out) <-
    if(is.null(dn))
      list(NULL, c("lower", "est.", "upper"))
    else {
      dn[[2]] <- c("lower", "est.", "upper")
      dn
    }
  mult <- sqrt(qf(level, 1, smry$df.residual))
  out[ , "est.", ] <- coeff[ , "Estimate",  ]
  out[ , "lower", ] <- out[ , "est.", ] - mult * coeff[ , "Std. Error", ]
  out[ , "upper", ] <- out[ , "est.", ] + mult * coeff[ , "Std. Error", ]
  attr(out, "groupsName") <- deparse(attr(object, "groupsForm")[[2]])
  class(out) <- "intervals.lmList"
  out
}

logLik.lmList <-
  function(object, REML = FALSE, pool = attr(object, "pool"))
{
  if(any(unlist(lapply(object, is.null)))) {
    stop("Log-likelihood not available with NULL fits.")
  }
  if(pool) {
    aux <- apply(sapply(object, function(el) {
                   res <- resid(el)
		   p <- el$rank
		   n <- length(res)
		   if (is.null(w <- el$weights)) w <- rep(1, n)
		   else {
		     excl <- w == 0
		     if (any(excl)) {
		       res <- res[!excl]
		       n <- length(res)
		       w <- w[!excl]
		     }
		   }
		   c(n, sum(w * res^2), p, sum(log(w)),
		     sum(log(abs(diag(el$R)[1:p]))))
		 }), 1, sum)
    N <- aux[1] - REML * aux[3]
    val <- (aux[4] - N * (log(2 * pi) + 1 - log(N) + log(aux[2])))/2 - 
      REML * aux[5]
    attr(val, "nall") <- aux[1]
    attr(val, "nobs") <- N
    attr(val, "df") <- aux[3] + 1
  } else {
    aux <- lapply(object, logLik, REML)
    val <- sum(unlist(aux))
    attr(val, "nobs") <- sum(sapply(aux, function(x) attr(x, "nobs")))
    attr(val, "df") <- sum(sapply(aux, function(x) attr(x, "df")))
  }
  class(val) <- "logLik"
  val
}

pairs.lmList <- 
  function(object, form = ~ coef(.), label, id = NULL, idLabels = NULL, 
	   grid = FALSE, ...)
{
  ## scatter plot matrix plots, generally based on coef or random.effects
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }
  if (length(form) != 2) {
    stop("\"Form\" must be a one-sided formula")
  }
  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL

  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()

  ## covariate - must be present as a data.frame
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], list(. = object)) # only function of "."
  if (!inherits(.x, "data.frame")) {
    stop("Covariate must be a data frame")
  }
  if (!is.null(effNams <- attr(.x, "effectNames"))) {
    .x <- .x[, effNams, drop = FALSE]
  }
  ## eliminating constant effects
  isFixed <- unlist(lapply(.x, function(el) length(unique(el)) == 1))
  .x <- .x[, !isFixed, drop = FALSE]
  nc <- ncol(.x)
  if (nc == 1) {
    stop("Cannot do pairs of just one variable")
  }
  if (!missing(label)) {
    names(.x) <- labels
  }
  if (nc == 2) {
    ## will use xyplot
    argForm <- .y ~ .x
    argData <- .x
    names(argData) <- c(".x", ".y")
    if (is.null(args$xlab)) {
      args$xlab <- names(.x)[1]
    }
    if (is.null(args$ylab)) {
      args$ylab <- names(.x)[2]
    }
  } else {				# splom
    argForm <- ~ .x
    argData <- list(.x = .x)
  }
  
  auxData <- list()
  ## groups - need not be present
  grpsF <- getGroupsFormula(form)
  if (!is.null(grpsF)) {
    gr <- splitFormula(grpsF, sep = "*")
    for(i in 1:length(gr)) {
      auxData[[deparse(gr[[i]][[2]])]] <- eval(gr[[i]][[2]], data)
    }
    if (length(argForm) == 2)
      argForm <- eval(parse(text = paste("~ .x |", deparse(grpsF[[2]]))))
    else argForm <- eval(parse(text = paste(".y ~ .x |", deparse(grpsF[[2]]))))
  }
  
  ## id and idLabels - need not be present
  if (!is.null(id)) {			# identify points in plot
    N <- attr(object, "dims")$N
    id <- 
      switch(mode(id),
	     numeric = {
	       if ((id <= 0) || (id >= 1)) {
		 stop("Id must be between 0 and 1")
	       }
	       aux <- as.matrix(na.omit(ranef(object)))
	       auxV <- t(chol(var(aux)))
	       aux <- as.logical(apply((solve(auxV, t(aux)))^2, 2, sum) >
				 qchisq(1 - id, dim(aux)[2]))
	       aux
	     },
	     call = eval(asOneSidedFormula(id)[[2]], data),
	     stop("\"Id\" can only be a formula or numeric.")
	     )
    if (length(id) == N) {
      ## id as a formula evaluated in data
      auxData[[".id"]] <- id
    }

    if (is.null(idLabels)) {
      idLabels <- row.names(.x)
    } else {
      if (mode(idLabels) == "call") {
	idLabels <-
	  as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
      } else if (is.vector(idLabels)) {
	if (length(idLabels <- unlist(idLabels)) != N) {
	  stop("\"IdLabels\" of incorrect length")
	} 
	idLabels <- as.character(idLabels)
      } else {
	stop("\"IdLabels\" can only be a formula or a vector")
      }
    }
    if (length(idLabels) == N) {
      ## idLabels as a formula evaluated in data
      auxData[[".Lid"]] <- idLabels
    }
  }

  if (length(auxData)) {		# need collapsing
    auxData <- gsummary(data.frame(auxData), 
			groups = getGroups(object))
    auxData <- auxData[row.names(.x), , drop = FALSE]
    if (!is.null(auxData[[".g"]])) {
      argData[[".g"]] <- auxData[[".g"]]
    }

    if (!is.null(auxData[[".id"]])) {
      id <- auxData[[".id"]]
    }

    if (!is.null(auxData[[".Lid"]])) {
      idLabels <- auxData[[".Lid"]]
    }
    wchDat <- is.na(match(names(auxData), c(".id", ".idLabels")))
    if (any(wchDat)) {
      argData <- cbind(argData, auxData[, wchDat, drop = FALSE])
      
    }
  }

  assign("id", as.logical(as.character(id)) )
  assign("idLabels", as.character(idLabels))
  assign("grid", grid)

  ## adding to args list
  args <- c(args, formula = list(argForm), data = list(argData))
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  ## defining the type of plot
  if (length(argForm) == 3) {		# xyplot
    plotFun <- "xyplot"
    args <- c(args, 
	      panel = list(function(x, y, subscripts, ...) 
		  {
                    dots <- list(...)
		    if (grid) panel.grid()
		    panel.xyplot(x, y)
                    if (!all(is.na(aux <- id[subscripts])) &&
                        !is.null(aux) && any(aux)) {
		      text(x[aux], y[aux], idLabels[subscripts][aux],
                           cex = dots$cex, adj = dots$adj)
		    }
		  }))
  } else {				# splom
    plotFun <- "splom"
    args <- c(args, 
	      panel = list(function(x, y, subscripts, ...)
		  {
                    dots <- list(...)
		    if (grid) panel.grid()
		    panel.xyplot(x, y)
                    if (!all(is.na(aux <- id[subscripts])) &&
                        !is.null(aux) && any(aux)) {
		      text(x[aux], y[aux], idLabels[subscripts][aux],
                           cex = dots$cex, adj = dots$adj)
		    }
		  }))
  }
  do.call(plotFun, args)
}

plot.intervals.lmList <-
  function(object, ...)
{
  dims <- dim(object)
  dn <- dimnames(object)
  ## changed definition of what to ordered to preserve order of parameters
  tt <- data.frame(group = ordered(rep(dn[[1]], dims[2] * dims[3]),
		       levels = dn[[1]]),
		   intervals = as.vector(object),
		   what = ordered(rep(dn[[3]],
		       rep(dims[1] * dims[2], dims[3])), levels = dn[[3]]))
  strip <- list(...)[["strip"]]
  if ( is.null( strip ) ) {
    strip <- function(...) strip.default(..., style = 1)
  }
  xlab <- list(...)[["xlab"]]
  if ( is.null( xlab ) ) {
    xlab <- ""
  }

  ylab <- list(...)[["ylab"]]
  if ( is.null( ylab ) ) {
    ylab <- attr(object, "groupsName")
  }
  dotplot(group ~ intervals | what,
	  data = tt,
	  scales = list(x=list(relation="free")),
	  strip = strip,
	  xlab = xlab, ylab = ylab,
	  panel = function(x, y, pch = dot.symbol$pch,
	      col = dot.symbol$col, cex = dot.symbol$cex,
	      font = dot.symbol$font, ...)
	  {
	    ok <- !is.na(x) & !is.na(y)
	    yy <- y[ok]
	    xx <- x[ok]
	    dot.symbol <- trellis.par.get("dot.symbol")
	    dot.line <- trellis.par.get("dot.line")
	    abline(h = yy, lwd = dot.line$lwd, lty = dot.line$lty, col = 
		   dot.line$col)
	    points(xx, yy, pch = "|", col = col, cex = cex, font = font, ...)
	    lower <- tapply(xx, yy, min)
	    upper <- tapply(xx, yy, max)
	    nams <- as.numeric(names(lower))
	    segments(lower, nams, upper, nams, col = 1, lty = 1, lwd =
		     if(dot.line$lwd) {
		       dot.line$lwd
		     } else {
		       1
		     })
	  }, ...)
}

plot.ranef.lmList <-
  function(object, form = NULL, grid = TRUE, control, ...)   
{
  fArgs <- as.list(match.call())[-1]
  do.call("plot.ranef.lme", fArgs)
}

plot.lmList <- 
  function(object, form = resid(., type = "pool") ~ fitted(.), abline, 
	   id = NULL, idLabels = NULL,  grid, ...)  
  ## Diagnostic plots based on residuals and/or fitted values
{
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }

  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL

  if (inherits(data, "groupedData")) {	# save labels and units, if present
    ff <- formula(data)
    rF <- deparse(getResponseFormula(ff)[[2]])
    cF <- deparse(getCovariateFormula(ff)[[2]])
    lbs <- attr(data, "labels")
    unts <- attr(data, "units")
    if (!is.null(lbs$x)) cL <- paste(lbs$x, unts$x) else cF <- NULL
    if (!is.null(lbs$y)) rL <- paste(lbs$y, unts$y) else rF <- NULL
  } else {
    rF <- rC <- NULL
  }

  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()
  ## appending object to data
  data <- as.list(c(as.list(data), . = list(object)))

  ## covariate - must always be present
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], data)
  if (!is.numeric(.x)) {
    stop("Covariate must be numeric")
  }
  argForm <- ~ .x
  argData <- data.frame(.x = .x)
  if (is.null(xlab <- attr(.x, "label"))) {
    xlab <- deparse(covF[[2]])
    if (!is.null(cF) && (xlab == cF)) xlab <- cL
    else if (!is.null(rF) && (xlab == rF)) xlab <- rL
  }
  if (is.null(args$xlab)) args$xlab <- xlab
      
  ## response - need not be present
  respF <- getResponseFormula(form)
  if (!is.null(respF)) {
    .y <- eval(respF[[2]], data)
    if (is.null(ylab <- attr(.y, "label"))) {
      ylab <- deparse(respF[[2]])
      if (!is.null(cF) && (ylab == cF)) ylab <- cL
      else if (!is.null(rF) && (ylab == rF)) ylab <- rL
    }
    argForm <- .y ~ .x
    argData[, ".y"] <- .y
    if (is.null(args$ylab)) args$ylab <- ylab
  }

  ## groups - need not be present
  grpsF <- getGroupsFormula(form)
  if (!is.null(grpsF)) {
    gr <- splitFormula(grpsF, sep = "*")
    for(i in 1:length(gr)) {
      argData[[deparse(gr[[i]][[2]])]] <- eval(gr[[i]][[2]], data)
    }
    if (length(argForm) == 2)
      argForm <- eval(parse(text = paste("~ .x |", deparse(grpsF[[2]]))))
    else argForm <- eval(parse(text = paste(".y ~ .x |", deparse(grpsF[[2]]))))
  }
  ## adding to args list
  args <- c(args, formula = list(argForm), data = list(argData))
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  if (!is.null(id)) {			# identify points in plot
    id <- 
      switch(mode(id),
	     numeric = {
	       if ((id <= 0) || (id >= 1)) {
		 stop("Id must be between 0 and 1")
	       }
	       as.logical(abs(resid(object, type = "pooled")) > -qnorm(id / 2))
	     },
	     call = eval(asOneSidedFormula(id)[[2]], data),
	     stop("\"Id\" can only be a formula or numeric.")
	     )
    if (is.null(idLabels)) {
      idLabels <- getGroups(object)
      if (length(idLabels) == 0) idLabels <- 1:object$dims$N
      idLabels <- as.character(idLabels)
    } else {
      if (mode(idLabels) == "call") {
	idLabels <-
	  as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
      } else if (is.vector(idLabels)) {
	if (length(idLabels <- unlist(idLabels)) != length(id)) {
	  stop("\"IdLabels\" of incorrect length")
	} 
	idLabels <- as.character(idLabels)
      } else {
	stop("\"IdLabels\" can only be a formula or a vector")
      }
    }
  }

  ## defining abline, if needed
  if (missing(abline)) {
    if (missing(form)) {		# r ~ f
      abline <- c(0, 0)
    } else {
      abline <- NULL
    }
  }

  assign("id", id )
  assign("idLabels", idLabels)
  assign("abl", abline)

  ## defining the type of plot
  if (length(argForm) == 3) {
    if (is.numeric(.y)) {		# xyplot
      plotFun <- "xyplot"
      args <- c(args, 
		panel = list(function(x, y, subscripts, ...) 
		    {
                      dots <- list(...)
		      if (grid) panel.grid()
		      panel.xyplot(x, y)
                      if (!all(is.na(aux <- id[subscripts])) &&
                          !is.null(aux) && any(aux)) {
			text(x[aux], y[aux], idLabels[subscripts][aux],
                             cex = dots$cex, adj = dots$adj)
		      }
		      if (!is.null(abl)) {
			panel.abline(abl, ...)
		      }
		    }))
    } else {				# assume factor or character
      plotFun <- "bwplot"
      args <- c(args, 
		panel = list(function(x, y, ...) 
		    {
		      if (grid) panel.grid()
		      panel.bwplot(x, y)
		      if (!is.null(abl)) {
			panel.abline(v = abl[1], ...)
		      }
		    }))
    }
  } else {
    plotFun <- "histogram"
    args <- c(args, 
	      panel = list(function(x, y, ...) 
		  {
		    if (grid) panel.grid()
		    panel.histogram(x, y)
		    if (!is.null(abl)) {
		      panel.abline(v = abl[1], ...)
		    }
		  }))
  }
  ## defining grid
  if (missing(grid)) {
    if (plotFun == "xyplot") grid <- T
    else grid <- FALSE
  }
  assign("grid", grid)

  do.call(plotFun, args)
}

predict.lmList <- 
  function(object, newdata, subset = NULL, pool = attr(object, "pool"), 
	   asList = FALSE, se.fit = FALSE)
{
  if(missing(newdata)) {
    if (!se.fit) return(fitted(object, subset, asList))
    myData <- getData(object)
    grps <- getGroups(object)
    myData <- split(myData, grps)
    newdata <- NULL
    sameData <- FALSE
  } else {
    newdata <- as.data.frame(newdata)
    sameData <- TRUE
    ## checking if same newdata for all groups
    formGrps <- getGroupsFormula(object)
    if(all(match(all.vars(formGrps), names(newdata), 0))) {
      ## newdata contains groups definition
      grps <- getGroups(newdata, getGroupsFormula(object, asList = TRUE), 
			level = attr(object, "level"))
      grps <- pruneLevels(grps)
      subset <- as.character(unique(grps))
      if(any(is.na(match(subset, names(object))))) {
	stop("Non-existent group in \"newdata\".")
      }
      myData <- split(newdata, grps)
      newdata <- NULL
      sameData <- FALSE
    }
  }				       
  if(!is.null(subset)) {
    if(any(is.na(match(subset, names(object))))) {
      stop("Non-existent group requested in \"subset\".")
    }
    oclass <- class(object)
    oatt <- attr(object, "call")
    object <- object[subset]
    attr(object, "call") <- oatt
    class(object) <- oclass
    if(is.null(newdata)) {
      myData <- myData[subset]
    }
  }
  nmGrps <- names(object)
  noNull <- !sapply(object, is.null)
  val <- vector("list", length(nmGrps))
  names(val) <- nmGrps
  if(!sameData) {
    if(!se.fit) {
      for(i in nmGrps[noNull]) {
        val[[i]] <- predict(object[[i]], myData[[i]])
      }
    } else {
      if(pool) {
	poolSD <- pooledSD(object)
      }
      for(i in nmGrps[noNull]) {
	aux <- predict(object[[i]], myData[[i]], se.fit = TRUE)
	if(pool) {
	  val[[i]] <- data.frame(fit = aux$fit,
				 se.fit = aux$se.fit*poolSD/aux$res)
	} else {
	  val[[i]] <- data.frame(fit = aux$fit, se.fit = aux$se.fit)
	}
      }
    }
  } else {
    if(pool) {
      poolSD <- pooledSD(object)
      val[noNull] <- 
	lapply(object[noNull], 
	       function(el, newdata, se.fit, poolSD) {
		 aux <- predict(el, newdata, se.fit = se.fit)
		 if(se.fit) {
		   data.frame(fit = aux$fit,
			      se.fit = aux$se.fit*poolSD/aux$res)
		 } else {
		   aux
		 }
	       }, newdata = newdata, se.fit = se.fit, poolSD = poolSD)
    } else {
      val[noNull] <- 
	lapply(object[noNull], 
	       function(el, newdata, se.fit) {
		 aux <- predict(el, newdata, se.fit = se.fit)
		 if(se.fit) {
		   data.frame(fit = aux$fit, se.fit = aux$se.fit)
		 } else {
		   aux
		 }
	       }, newdata = newdata, se.fit = se.fit)
    }
  }
  if(!asList) {				#convert to array
    if(is.null(newdata)) {
      ngrps <- table(grps)[names(object)]
    } else {
      ngrps <- rep(dim(newdata)[1], length(object))
      names(ngrps) <- names(object)
    }
    if(any(aux <- sapply(object, is.null))) {
      for(i in names(ngrps[aux])) {
	aux1 <- rep(NA, ngrps[i])
	if(se.fit) {
	  val[[i]] <- data.frame(fit = aux1, se.fit = aux1)
	} else {
	  val[[i]] <- aux1
	}
      }
    }
    if(se.fit) {
      val <- do.call("rbind", val)
      val[, as.character(getGroupsFormula(object)[[2]])] <-
	rep(names(ngrps), ngrps)
      val <- val[, c(3,1,2)]
      row.names(val) <- 1:nrow(val)
    } else {
      val <- unlist(val)
      names(val) <- rep(names(ngrps), ngrps)
      attr(val, "label") <- "Predicted values"
      if (!is.null(aux <- attr(object, "units")$y)) {
        attr(val, "label") <- paste(attr(val, "label"), aux)
      }
    }
  }
  val
}

print.intervals.lmList <-
  function(x, ...)
{
  x <- unclass(x)
  attr(x, "groupsName") <- NULL
  print(x, ...)
}
  
print.lmList <- 
  function(x, pool = attr(x, "pool"), ...)
{
  mCall <- attr(x, "call")
  cat("Call:\n")
  form <- formula(x)
  cat("  Model:", deparse(getResponseFormula(form)[[2]]),
      "~", deparse(getCovariateFormula(form)[[2]]), "|",
      deparse(getGroupsFormula(x)[[2]]), "\n")
  if (!is.null(mCall$level)) {
    cat(" Level:", mCall$level, "\n")
  }
  cat("   Data:", deparse(mCall$data),"\n\n")
  cat("Coefficients:\n")
  invisible(print(coef(x)))
  if(pool) {
    cat("\n")
    poolSD <- pooledSD(x)
    dfRes <- attr(poolSD, "df")
    RSE <- c(poolSD)
    cat("Degrees of freedom: ", length(unlist(lapply(x, fitted))),
	" total; ", dfRes, " residual\n", sep = "")
    cat("Residual standard error:", format(RSE))
    cat("\n")
  }
}

print.summary.lmList <-
  function(x, ...)
{
  cat("Call:\n")
  form <- formula(x)
  cat("  Model:", deparse(getResponseFormula(form)[[2]]),
      "~", deparse(getCovariateFormula(form)[[2]]), "|",
      deparse(attr(x, "groupsForm")[[2]]), "\n")
  if (!is.null(x$call$level)) {
    cat(" Level:", x$call$level, "\n")
  }
  cat("   Data:", deparse(x$call$data),"\n\n")
  cat("Coefficients:\n")
  for(i in dimnames(coef(x))[[3]]) {
    cat("  ",i,"\n")
    print(coef(x)[,,i])
  }
  if(x$pool) {
    cat("\n")
    cat("Residual standard error:", format(x$RSE), "on",
	x$df.residual, "degrees of freedom\n")
  }
  cat("\n")
}

qqnorm.lmList <-
  function(object, form = ~ resid(., type = "pooled"), abline = NULL,
           id = NULL, idLabels = NULL, grid = FALSE, resType = "pool", ...)
  ## normal probability plots for residuals and random effects 
{
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }
  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL
  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()
  ## appending object to data
  data <- as.list(c(as.list(data), . = list(object)))
  
  ## covariate - must always be present
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], data)
  labs <- attr(.x, "label")
  if (inherits(.x, "ranef.lmList")) {      # random effects
    type <- "reff"
  } else {
    if (!is.null(labs) && ((labs == "Standardized residuals") ||
                           (substring(labs, 1, 9) == "Residuals"))) {
      type <- "res"                     # residuals
    } else {
      stop("Only residuals and random effects allowed")
    }
  }
  if (is.null(args$xlab)) args$xlab <- labs
  if (is.null(args$ylab)) args$ylab <- "Quantiles of standard normal"
  if(type == "res") {			# residuals
    fData <- qqnorm(.x, plot.it = FALSE)
    data[[".y"]] <- fData$x
    data[[".x"]] <- fData$y
    dform <- ".y ~ .x"
    if (!is.null(grp <- getGroupsFormula(form))) {
      dform <- paste(dform, deparse(grp[[2]]), sep = "|")
    }
    if (!is.null(id)) {			# identify points in plot
      id <- 
        switch(mode(id),
               numeric = {
                 if ((id <= 0) || (id >= 1)) {
                   stop("Id must be between 0 and 1")
                 }
                 as.logical(abs(resid(object, type=resType))
                            > -qnorm(id / 2))
               },
               call = eval(asOneSidedFormula(id)[[2]], data),
               stop("\"Id\" can only be a formula or numeric.")
               )
      if (is.null(idLabels)) {
        idLabels <- getGroups(object)
        if (length(idLabels) == 0) idLabels <- 1:object$dims$N
        idLabels <- as.character(idLabels)
      } else {
        if (mode(idLabels) == "call") {
          idLabels <-
            as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
        } else if (is.vector(idLabels)) {
          if (length(idLabels <- unlist(idLabels)) != length(id)) {
            stop("\"IdLabels\" of incorrect length")
          } 
          idLabels <- as.character(idLabels)
        } else {
          stop("\"IdLabels\" can only be a formula or a vector")
        }
      }
    }
  } else {				# random.effects
    level <- attr(.x, "level")
    std <- attr(.x, "standardized")
    if (!is.null(effNams <- attr(.x, "effectNames"))) {
      .x <- .x[, effNams, drop = FALSE]
    }
    nc <- ncol(.x)
    nr <- nrow(.x)
    fData <- lapply(as.data.frame(.x), qqnorm, plot.it = FALSE)
    fData <- data.frame(.x = unlist(lapply(fData, function(x) x[["y"]])),
			.y = unlist(lapply(fData, function(x) x[["x"]])),
			.g = ordered(rep(names(fData),rep(nr, nc)),
                          levels = names(fData)))
    dform <- ".y ~ .x | .g"
    if (!is.null(grp <- getGroupsFormula(form))) {
      dform <- paste(dform, deparse(grp[[2]]), sep = "*")
      auxData <- data[is.na(match(names(data), "."))]
    } else {
      auxData <- list()
    }
    ## id and idLabels - need not be present
    if (!is.null(id)) {			# identify points in plot
      N <- object$dims$N
      id <- 
        switch(mode(id),
               numeric = {
                 if ((id <= 0) || (id >= 1)) {
                   stop("Id must be between 0 and 1")
                 }
                 aux <- ranef(object, standard = TRUE)
                 as.logical(abs(c(unlist(aux))) > -qnorm(id / 2))
               },
               call = eval(asOneSidedFormula(id)[[2]], data),
               stop("\"Id\" can only be a formula or numeric.")
               )
      if (length(id) == N) {
        ## id as a formula evaluated in data
        auxData[[".id"]] <- id
      }
      
      if (is.null(idLabels)) {
        idLabels <- rep(row.names(.x), nc)
      } else {
        if (mode(idLabels) == "call") {
          idLabels <-
            as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
        } else if (is.vector(idLabels)) {
          if (length(idLabels <- unlist(idLabels)) != N) {
            stop("\"IdLabels\" of incorrect length")
          } 
          idLabels <- as.character(idLabels)
        } else {
          stop("\"IdLabels\" can only be a formula or a vector")
        }
      }
      if (length(idLabels) == N) {
        ## idLabels as a formula evaluated in data
        auxData[[".Lid"]] <- idLabels
      }
    }

    if (length(auxData)) {		# need collapsing
      auxData <- gsummary(data.frame(auxData), 
                          groups = getGroups(object, level = level))
      auxData <- auxData[row.names(.x), , drop = FALSE]

      if (!is.null(auxData[[".id"]])) {
        id <- rep(auxData[[".id"]], nc)
      }
      
      if (!is.null(auxData[[".Lid"]])) {
        idLabels <- rep(auxData[[".Lid"]], nc)
      }
      data <- cbind(fData, do.call("rbind", rep(list(auxData), nc)))
    } else {
      data <- fData
    }
  }
  assign("id", if (is.null(id)) NULL else as.logical(as.character(id)),
         frame = 1)
  assign("idLabels", as.character(idLabels))
  assign("grid", grid)
  assign("abl", abline)
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  args <- c(list(formula = eval(parse(text = dform)),
                 data = substitute(data),
                 panel = function(x, y, subscripts, ...){
                   dots <- list(...)
                   if (grid) panel.grid()
                   panel.xyplot(x, y, ...)
                   if (!all(is.na(aux <- id[subscripts])) &&
                       !is.null(aux) && any(aux)) {
                     text(x[aux], y[aux], idLabels[subscripts][aux],
                          cex = dots$cex, adj = dots$adj)
                   }
                   if (!is.null(abl)) panel.abline(abl, ...)
                 }), args)
  if(type == "reff" && !std) {
    args[["scales"]] <- list(x = list(relation = "free"))
  }
  do.call("xyplot", args)
}
  
ranef.lmList <-
  ##  Extracts the random effects from an lmList object.
  ##  If aug.frame is true, the returned data frame is augmented with a
  ##  values from the original data object, if available.  The variables
  ##  in the original data are collapsed over the cluster variable by the
  ##  function fun.
  function(object, augFrame = FALSE, data = NULL,
           which = NULL, FUN = mean, standard = FALSE,
           omitGroupingFactor = TRUE)
{
  val <- coef(object, augFrame, data, which, FUN, omitGroupingFactor)
  effNames <- attr(val, "effectNames")
  effs <- val[, effNames, drop = FALSE]
  effs <-
    as.data.frame(lapply(effs, function(el) el - mean(el, na.rm = TRUE)))
  
  if(standard) {
    stdEff <- unlist(lapply(effs, function(el) sqrt(var(el[!is.na(el)]))))
    effs <- as.data.frame(as.matrix(effs) %*% diag(1/stdEff))
    attr(val, "label") <- "Standardized random effects"
  } else {
    attr(val, "label") <- "Random effects"
  }
  val[, effNames] <- effs
  attr(val, "standardized") <- standard
  class(val) <- unique(c("ranef.lmList", class(val)[-1]))
  val
}

residuals.lmList <- 
  function(object, type = c("response", "pearson", "pooled.pearson"),
	   subset = NULL, asList = FALSE)
{
  type <- match.arg(type)
  if(type == "pooled.pearson") {
    poolSD <- pooledSD(object)
  }
  if(!is.null(subset)) {
    if(is.character(subset)) {
      if (any(is.na(match(subset, names(object))))) {
        stop("Non-existent groups requested in \"subset\".")
      }
    } else {
      if (is.integer(subset)) {
        if (any(is.na(match(subset, 1:length(object))))) {
          stop("Non-existent groups requested in \"subset\".")
        }
      } else {
        stop("Subset can only be character or integer")
      }
    }
    oclass <- class(object)
    oatt <- attr(object, "call")
    object <- object[subset]
    attr(object, "call") <- oatt
    class(object) <- oclass
  }
  val <- 
    switch(type,
	   pooled.pearson = {
	     lapply(object, function(el, pSD) {
	       if(!is.null(el)) resid(el)/pSD
	       else NULL
	     }, pSD = poolSD)
	   },
	   pearson = lapply(object, function(el) {
	     if(!is.null(el)) {
	       aux <- resid(el)
	       aux/sqrt(sum(aux^2)/(length(aux) - length(coef(el))))
	     } else {
	       NULL
	     }
	   }),
	   response = lapply(object, function(el) {
	     if(!is.null(el)) resid(el)
	     else NULL
	   })
	   )
  if(!asList) {				#convert to array
    ngrps <- table(getGroups(object))[names(object)]
    if(any(aux <- sapply(object, is.null))) {
      for(i in names(ngrps[aux])) {
	val[[i]] <- rep(NA, ngrps[i])
      }
    }
    val <- val[attr(object, "origOrder")] # putting in original order
    namVal <- names(val)
    val <- unlist(val)
    names(val) <- rep(namVal, ngrps)
  }
  if (type == "response") {
    lab <- "Residuals"
    if (!is.null(aux <- attr(object, "units")$y)) {
      lab <- paste(lab, aux)
    }
  } else lab <- "Standardized residuals"
  attr(val, "label") <- lab
  val
}
	     
summary.lmList <-
  function(object, pool = attr(object, "pool"))
{
  to.3d.array <-
    ## Convert the list to a 3d array watching for null elements
    function(lst, template)
      {
	if (!is.matrix(template)) {
	  return(lst)
	}
	val <- aperm(array(unlist(lapply(lst, function(el, template)
 					 if(is.null(el)) { template }
					 else { el }, template = template)),
			   c(dim(template), length(lst)),
			   c(dimnames(template), list(names(lst)))),
		     c(3, 2, 1))
	val[unlist(lapply(lst, is.null)), , ] <- NA
	val	
      }
  to.2d.array <-
    ## Convert the list to a 2d array watching for null elements
    function(lst, template)
      {
	if(is.null(template)) {
	  return(lst)
	}
	template <- as.vector(template)
	val <- t(array(unlist(lapply(lst, function(el, template)
				     if(is.null(el)) { template }
				     else { el }, template = template)),
		       c(length(template), length(lst)),
		       list(names(template), names(lst))))
	val[unlist(lapply(lst, is.null)), ] <- NA
	val
      }
  ## Create a summary by applying summary to each component of the list
  sum.lst <- lapply(object, function(el) if(is.null(el)) {NULL}
                                         else {summary(el)})  
  nonNull <- !unlist(lapply(sum.lst, is.null))
  if(!any(nonNull)) {
    return(NULL)
  }
  template <- sum.lst[[match(TRUE, nonNull)]]
  val <- list()
  for (i in names(template)) {
    val[[i]] <- lapply(sum.lst, "[[", i)
    class(val[[i]]) <- "listof"
  }
  ## re-arrange the matrices into 3d arrays
  for(i in c("parameters", "cov.unscaled", "correlation", "coefficients")) {
    if(length(val[[i]])) {
      val[[i]] <- to.3d.array(val[[i]], template[[i]])
    }
  }
  ## re-arrange the vectors into 2d arrays
  for(i in c("df", "fstatistic")) {
    val[[i]] <- to.2d.array(val[[i]], template[[i]])
  }
  ## re-arrange the scalars into vectors
  for(i in c("sigma", "r.squared")) {
    ##    val[[i]] <- unlist(val[[i]]) - this deletes NULL components
    val[[i]] <- c(to.2d.array(val[[i]], template[[i]]))
  }
  ## select those attributes that do not vary with groups
  for(i in c("terms", "formula")) {
    val[[i]] <- template[[i]]
  }
  val[["call"]] <- attr(object, "call")
  if(inherits(object, "nlsList")) {
    names(val[["call"]]["model"]) <- "object"
  }
  val[["pool"]] <- pool
  if(pool) {
    poolSD <- pooledSD(object)
    dfRes <- attr(poolSD, "df")
    RSE <- c(poolSD)
    corRSE <- RSE/val$sigma
    if(inherits(object, "nlsList")) {
      pname <- "parameters"
    } else {
      pname <- "coefficients"
    }
    val[[pname]][,2,] <- val[[pname]][,2,] * corRSE
    val[[pname]][,3,] <- val[[pname]][,3,] / corRSE
    if(!inherits(object, "nlsList")) {
      val[[pname]][,4,] <- 2*(1-pt(abs(val[[pname]][,3,]), dfRes))
    }
    val[["df.residual"]] <- dfRes
    val[["RSE"]] <- RSE
  }
  attr(val, "groupsForm") <- attr(object, "groupsForm")
  class(val) <- "summary.lmList"
  val
}

update.lmList <-
  function(object, formula, data, level, subset, na.action, pool)
{
  thisCall <- as.list(match.call())[-(1:2)]
  if (!missing(formula)) {
    names(thisCall)[match(names(thisCall), "formula")] <- "object"
  }
  nextCall <- as.list(attr(object, "call")[-1])
  nextCall[names(thisCall)] <- thisCall
  if (!is.null(thisCall$object)) {
    nextCall$object <- update(as.formula(nextCall$object), nextCall$object)
  }
  do.call("lmList", nextCall)
}

### Local variables:
### mode: S
### End:
### $Id: lme.q,v 1.6 1999/11/18 23:56:57 saikat Exp $
###
###            Fit a general linear mixed effects model
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

lme <- 
  ## fits general linear mixed effects model by maximum likelihood, or
  ## residual maximum likelihood using Newton-Raphson algorithm.
  function(fixed,
	   data = sys.frame(sys.parent()),
	   random,
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   method = c("REML", "ML"), 
	   na.action = na.fail, 
	   control = list())
  UseMethod("lme")

lme.groupedData <- 
  function(fixed,
	   data = sys.frame(sys.parent()),
	   random,
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   method = c("REML", "ML"), 
	   na.action = na.fail, 
	   control = list())
{
  args <- as.list(match.call())[-1]
  names(args)[1] <- "data"
  form <- getResponseFormula(fixed)
  form[[3]] <- getCovariateFormula(fixed)[[2]]
  do.call("lme", c(list(fixed = form), args))
}

lme.lmList <- 
  function(fixed,
	   data = sys.frame(sys.parent()),
	   random,
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   method = c("REML", "ML"), 
	   na.action = na.fail, 
	   control = list())
{
  if (length(grpForm <- getGroupsFormula(fixed, asList = TRUE)) > 1) {
    stop("Can only fit lmList objects with single grouping variable")
  }
  this.call <- as.list(match.call())[-1]
  ## warn "data" is passed to this function
  if (!is.na(match("data", names(this.call)))) {
    warning("lme.lmList will redefine \"data\"")
  }
  ## add object, data, and groups from the call that created object
  last.call <- as.list(attr(fixed, "call"))[-1]
  whichLast <- match(c("object", "data", "na.action"), names(last.call))
  whichLast <- whichLast[!is.na(whichLast)]
  last.call <- last.call[whichLast]
  names(last.call)[match(names(last.call), "object")] <- "fixed"
  this.call[names(last.call)] <- last.call
  this.call$fixed <-
    as.vector(eval(parse(text=paste(deparse(getResponseFormula(fixed)[[2]]),
                   deparse(getCovariateFormula(fixed)[[2]]), sep="~"))))
  if (missing(random)) {
    random <- eval(as.call(this.call[["fixed"]][-2]))
  }
  random <- reStruct(random, data = NULL)
  mData <- this.call[["data"]]
  if (is.null(mData)) {			# will try to construct
    allV <- all.vars(formula(random))
    if (length(allV) > 0) {
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      mData <- eval(alist, sys.parent(1))
    }
  } else {
    if (mode(mData) == "name" || mode(mData) == "call") {
      mData <- eval(mData)
    } 
  }

  reSt <- reStruct(random, data = mData) # getting random effects names
  names(reSt) <- names(grpForm)
  if (length(reSt) > 1) {
    stop("Can only fit lmList objects with single grouping variable")
  }
  rNames <- Names(reSt[[1]])
  if (all(match(rNames, names(cf <- na.omit(coef(fixed))), 0))) {
    if (isInitialized(reSt)) {
      warning("Initial value for reStruct overwritten in lme.lmList")
    }
    madRes <- mad(resid(fixed), na.rm = TRUE)
    madRan <- unlist(lapply(cf, mad, na.rm = TRUE)[rNames])
    names(madRan) <- rNames
    matrix(reSt) <- diag((madRan/madRes)^2, ncol = length(rNames))
  }
  this.call[["random"]] <- reSt
  val <- do.call("lme.formula", this.call)
  val$origCall <- match.call()
  val
}

lme.formula <- 
  function(fixed,
	   data = sys.frame(sys.parent()),
	   random = pdSymm( eval( as.call( fixed[ -2 ] ) ) ),
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   method = c("REML", "ML"), 
	   na.action = na.fail, 
	   control = list())
{
  Call <- match.call()

  ## control parameters
  controlvals <- lmeControl()
  if (!missing(control)) {
    if(!is.null(control$nlmStepMax) && control$nlmStepMax < 0) {
      warning("Negative control$nlmStepMax - using default value")
      control$nlmStepMax <- NULL
    }
    controlvals[names(control)] <- control
  }

  ##
  ## checking arguments
  ##
  if (!inherits(fixed, "formula") || length(fixed) != 3) {
    stop("\nFixed-effects model must be a formula of the form \"resp ~ pred\"")
  }
  method <- match.arg(method)
  REML <- method == "REML"
  reSt <- reStruct(random, REML = REML, data = NULL)
  groups <- getGroupsFormula(reSt)
  if (is.null(groups)) {
    if (inherits(data, "groupedData")) {
      groups <- getGroupsFormula(data)
      namGrp <- rev(names(getGroupsFormula(data, asList = TRUE)))
      Q <- length(namGrp)
      if (length(reSt) != Q) { # may need to repeat reSt
	if (length(reSt) != 1) {
	  stop("Incompatible lengths for \"random\" and grouping factors")
	}
        randL <- vector("list", Q)
        names(randL) <- rev(namGrp)
        for(i in 1:Q) randL[[i]] <- random
        randL <- as.list(randL)
	reSt <- reStruct(randL, REML = REML, data = NULL)
      } else {
	names(reSt) <- namGrp
      }
    } else {
      ## will assume single group
      groups <- ~ 1
      names(reSt) <- "1"
    }
  }
  ## check if corStruct is present and assign groups to its formula,
  ## if necessary
  if (!is.null(correlation)) {
    if(!is.null(corGrpsForm <- getGroupsFormula(correlation, asList = TRUE))) {
      corGrpsForm <- unlist(lapply(corGrpsForm,
                                   function(el) deparse(el[[2]]))) 
      corQ <- length(corGrpsForm)
      lmeGrpsForm <- unlist(lapply(splitFormula(groups),
                        function(el) deparse(el[[2]])))
      lmeQ <- length(lmeGrpsForm)
      if (corQ <= lmeQ) {
        if (any(corGrpsForm != lmeGrpsForm[1:corQ])) {
          stop(paste("Incompatible formulas for groups in \"random\"",
                     "and \"correlation\""))
        }
        if (corQ < lmeQ) {
          warning(paste("Cannot use smaller level of grouping for",
                        "\"correlation\" than for \"random\". Replacing",
                        "the former with the latter."))
          attr(correlation, "formula") <- 
            eval(parse(text = paste("~", 
                    deparse(getCovariateFormula(formula(correlation))[[2]]),
                         "|", deparse(groups[[2]]))))
        }
      } else {
        if (any(lmeGrpsForm != corGrpsForm[1:lmeQ])) {
          stop(paste("Incompatible formulas for groups in \"random\"",
                     "and \"correlation\""))
        }
      }
    } else {
      ## using the same grouping as in random
      attr(correlation, "formula") <- 
        eval(parse(text = paste("~", 
		     deparse(getCovariateFormula(formula(correlation))[[2]]),
		     "|", deparse(groups[[2]]))))
      corQ <- lmeQ <- 1
    }
    } else {
    corQ <- lmeQ <- 1
  }
  ## create an lme structure containing the random effects model and plug-ins
  lmeSt <- lmeStruct(reStruct = reSt, corStruct = correlation, 
		     varStruct = varFunc(weights))

  ## extract a data frame with enough information to evaluate
  ## fixed, groups, reStruct, corStruct, and varStruct
  mfArgs <- list(formula = asOneFormula(formula(lmeSt), fixed, groups),
		 data = data, na.action = na.action)
  if (!missing(subset)) {
    mfArgs[["subset"]] <- asOneSidedFormula(Call[["subset"]])[[2]]
  }
  dataMix <- do.call("model.frame", mfArgs)
  origOrder <- row.names(dataMix)	# preserve the original order
  ## sort the model.frame by groups and get the matrices and parameters
  ## used in the estimation procedures
  grps <- getGroups(dataMix, groups)
  ## ordering data by groups
  if (inherits(grps, "factor")) {	# single level
    ord <- order(grps)	#"order" treats a single named argument peculiarly
    grps <- data.frame(grps)
    row.names(grps) <- origOrder
    names(grps) <- as.character(deparse((groups[[2]])))
  } else {
    ord <- do.call("order", grps)
    ## making group levels unique
    for(i in 2:ncol(grps)) {
      grps[, i] <-
        as.factor(paste(as.character(grps[, i-1]), as.character(grps[,i]),
                        sep = "/"))
      NULL
    }
  }
  if (corQ > lmeQ) {
    ## may have to reorder by the correlation groups
    ord <- do.call("order", getGroups(dataMix,
                                 getGroupsFormula(correlation)))
  }
  grps <- grps[ord, , drop = FALSE]
  dataMix <- dataMix[ord, ,drop = FALSE]
  revOrder <- match(origOrder, row.names(dataMix)) # putting in orig. order

  ## obtaining basic model matrices
  N <- nrow(grps)
  Z <- model.matrix(reSt, dataMix)
  ncols <- attr(Z, "ncols")
  Names(lmeSt$reStruct) <- attr(Z, "nams")
  ## keeping the contrasts for later use in predict
  contr <- attr(Z, "contr")
  X <- model.frame(fixed, dataMix)
  auxContr <- lapply(X, function(el) 
		     if (inherits(el, "factor") &&
                         length(levels(el)) > 1) contrasts(el))
  contr <- c(contr, auxContr[is.na(match(names(auxContr), names(contr)))])
  contr <- contr[!unlist(lapply(contr, is.null))]
  X <- model.matrix(fixed, X)
  y <- eval(fixed[[2]], dataMix)
  ncols <- c(ncols, dim(X)[2], 1)
  Q <- ncol(grps)
  ## creating the condensed linear model
  attr(lmeSt, "conLin") <-
    list(Xy = array(c(Z, X, y), c(N, sum(ncols)), 
	     list(row.names(dataMix), c(colnames(Z), colnames(X),
					deparse(fixed[[2]])))),
	 dims = MEdims(grps, ncols), logLik = 0)
  ## checking if enough observations per group to estimate ranef
  tmpDims <- attr(lmeSt, "conLin")$dims
  if (max(tmpDims$ZXlen[[1]]) < tmpDims$qvec[1]) {
    warning(paste("Fewer observations than random effects in all level",
                  Q,"groups"))
  }
  ## degrees of freedom for testing fixed effects
  fixDF <- getFixDF(X, grps, attr(lmeSt, "conLin")$dims$ngrps,
                    terms = terms(fixed))
  ## initialization
  lmeSt <- initialize(lmeSt, dataMix, grps, control = controlvals)
  parMap <- attr(lmeSt, "pmap")
  ## Checking possibility of single decomposition
  if (length(lmeSt) == 1)  {	# reStruct only, can do one decomposition
    ## need to save conLin for calculating fitted values and residuals
    oldConLin <- attr(lmeSt, "conLin")
    decomp <- TRUE
    attr(lmeSt, "conLin") <- MEdecomp(attr(lmeSt, "conLin"))
  } else decomp <- FALSE
  ##
  ## getting the linear mixed effects fit object,
  ## possibly iterating for variance functions
  ##
  numIter <- 0
  repeat {
    oldPars <- coef(lmeSt)
      aNlm <- nlm(f = function(lmePars) -logLik(lmeSt, lmePars),
                  p = c(coef(lmeSt)),
                  hessian = TRUE,
                  print = ifelse(controlvals$msVerbose, 2, 0),
                  stepmax = controlvals$nlmStepMax*max(sqrt(sum(coef(lmeSt)^2)), 1.0),
                  check = FALSE)
      numIter0 <- NULL
      coef(lmeSt) <- aNlm$estimate
    attr(lmeSt, "lmeFit") <- MEestimate(lmeSt, grps)
    ## checking if any updating is needed
    if (!needUpdate(lmeSt)) break
    ## updating the fit information
    numIter <- numIter + 1
    lmeSt <- update(lmeSt, dataMix)
    ## calculating the convergence criterion
    aConv <- coef(lmeSt)
    conv <- abs((oldPars - aConv)/ifelse(aConv == 0, 1, aConv))
    aConv <- NULL
    for(i in names(lmeSt)) {
      if (any(parMap[,i])) {
	aConv <- c(aConv, max(conv[parMap[,i]]))
	names(aConv)[length(aConv)] <- i
      }
    }
    if (max(aConv) <= controlvals$tolerance) {
      break
    }
    if (numIter > controlvals$maxIter) {
      stop("Maximum number of iterations reached without convergence.")
    }
  }

  ## wrapping up
  lmeFit <- attr(lmeSt, "lmeFit")
  names(lmeFit$beta) <- namBeta <- colnames(X)
  attr(fixDF, "varFixFact") <- varFix <- lmeFit$sigma * lmeFit$varFix 
  varFix <- crossprod(varFix)
  dimnames(varFix) <- list(namBeta, namBeta)
  ##
  ## fitted.values and residuals (in original order)
  ##
  Fitted <- fitted(lmeSt, level = 0:Q, 
		   conLin = if (decomp) {
		     oldConLin 
		   } else {
		     attr(lmeSt, "conLin")
		   })[revOrder, , drop = FALSE]
  Resid <- y[revOrder] - Fitted
  attr(Resid, "std") <- lmeFit$sigma/(varWeights(lmeSt)[revOrder])
  ## putting groups back in original order
  grps <- grps[revOrder, , drop = FALSE]
  ## making random effects estimates consistently ordered
#  for(i in names(lmeSt$reStruct)) {
#    lmeFit$b[[i]] <- lmeFit$b[[i]][unique(as.character(grps[, i])),, drop = F]
#    NULL
#  }
  ## inverting back reStruct 
  lmeSt$reStruct <- solve(lmeSt$reStruct)
  ## saving part of dims
  dims <- attr(lmeSt, "conLin")$dims[c("N", "Q", "qvec", "ngrps", "ncol")]
  ## getting the approximate var-cov of the parameters 
  if (controlvals$apVar) {
    apVar <- lmeApVar(lmeSt, lmeFit$sigma, 
		      .relStep = controlvals[[".relStep"]],
                      minAbsPar = controlvals[["minAbsParApVar"]],
		      natural = controlvals[["natural"]])
  } else {
    apVar <- "Approximate variance-covariance matrix not available"
  }
  ## getting rid of condensed linear model and fit
  attr(lmeSt, "conLin") <- NULL
  attr(lmeSt, "lmeFit") <- NULL
  ##
  ## creating the  lme object
  ##
  estOut <- list(modelStruct = lmeSt,
		 dims = dims,
		 contrasts = contr,
		 coefficients = list(
		     fixed = lmeFit$beta,
		     random = lmeFit$b),
		 varFix = varFix,
		 sigma = lmeFit$sigma,
		 apVar = apVar,
		 logLik = lmeFit$logLik,
		 numIter = if (needUpdate(lmeSt)) numIter
		   else numIter0,
		 groups = grps,
		 call = Call,
		 method = method,
		 fitted = Fitted,
		 residuals = Resid,
                 fixDF = fixDF)
  if (inherits(data, "groupedData")) {
    ## saving labels and units for plots
    attr(estOut, "units") <- attr(data, "units")
    attr(estOut, "labels") <- attr(data, "labels")
  }
  class(estOut) <- "lme"
  estOut
}

### Auxiliary functions used internally in lme and its methods

getFixDF <-
  function(X, grps, ngrps, assign = attr(X, "assign"), terms)
{
  ## calculates degrees of freedom for fixed effects Wald tests
  if (!is.list(assign)) {               # in R
    namTerms <- attr(terms, "term.labels")
    if (attr(terms, "intercept") > 0) {
      namTerms <- c("(Intercept)", namTerms)
    }
    namTerms <- factor(assign, labels = namTerms)
    assign <- split(order(assign), namTerms)
  }
  N <- nrow(X)
  p <- ncol(X)
  Q <- ncol(grps)
  Qp1 <- Q + 1
  namX <- colnames(X)
  ngrps <- rev(ngrps)[-(1:2)]
  stratNam <- c(names(ngrps), "Residual")
  dfX <- dfTerms <- c(ngrps, N) - c(0, ngrps)
  names(dfX) <- names(dfTerms) <- stratNam
  valX <- double(p)
  names(valX) <- namX
  namTerms <- names(assign)
  valTerms <- double(length(assign))
  names(valTerms) <- namTerms
  if (any(notIntX <- apply(X, 2, function(el) any(el != el[1])))) {
        ## percentage of groups for which columns of X are inner
    innP <- array(c(rep(1, p),
                    .C("inner_perc_table",
                       as.double(X),
                       as.integer(unlist(grps)),
                       as.integer(p),
                       as.integer(Q),
                       as.integer(N),
                       val = double(p * Q),
                       PACKAGE = "nlme")[["val"]]), c(p, Qp1),
                  list(namX, stratNam))
    ## strata in which columns of X are estimated
    ## ignoring fractional inner percentages for now
    stratX <- stratNam[apply(innP, 1, function(el, index) max(index[el > 0]),
                             index = 1:Qp1)]
    ## strata in which terms are estimated
    notIntTerms <- unlist(lapply(assign,
                                 function(el, notIntX) {
                                   any(notIntX[el])
                                 }, notIntX = notIntX))
    stratTerms <- stratNam[unlist(lapply(assign,
                          function(el, stratX, stratNam) {
                            max(match(stratX[el], stratNam))
                          },
                       stratX = stratX, stratNam = stratNam))][notIntTerms]
    stratX <- stratX[notIntX]
    xDF <- table(stratX)
    dfX[names(xDF)] <- dfX[names(xDF)] - xDF
    if (!all(notIntX)) {                # correcting df for intercept
      dfX[1] <- dfX[1] - 1
    } else {
      dfX[-1] <- dfX[-1] + 1
    }
    valX[notIntX] <- dfX[stratX]
    ## number of parameters in each term
    pTerms <- unlist(lapply(assign, length))[notIntTerms]
    tDF <- tapply(pTerms, stratTerms, sum)
    dfTerms[names(tDF)] <- dfTerms[names(tDF)] - tDF
    if (!all(notIntTerms)) {
      dfTerms[1] <- dfTerms[1] - 1
    } else {
      dfTerms[-1] <- dfTerms[-1] + 1
    }
    valTerms[notIntTerms] <- dfTerms[stratTerms]
  } else {
    notIntTerms <- unlist(lapply(assign,
                                 function(el, notIntX) {
                                   any(notIntX[el])
                                 }, notIntX = notIntX))
  }    
  if (!all(notIntX)) {  #intercept included
    valX[!notIntX] <- max(dfX)
    if (!all(notIntTerms)) {
      valTerms[!notIntTerms] <- max(dfTerms)
    }
  }
  val <- list(X = valX, terms = valTerms)
  attr(val, "assign") <- assign
  val
}

lmeApVar <-
  function(lmeSt, sigma, conLin = attr(lmeSt, "conLin"),
           .relStep = (.Machine$double.eps)^(1/3), minAbsPar = 0,
           natural = TRUE)
{
  ## calculate approximate variance-covariance matrix of all parameters
  ## except the fixed effects. By default, uses natural parametrization for
  ## for pdSymm matrices
  fullLmeLogLik <-
    function(Pars, object, conLin, dims, N, settings) {
      ## logLik as a function of sigma and coef(lmeSt)
      npar <- length(Pars)
      sigma <- exp(Pars[npar])              # within-group std. dev.
      Pars <- Pars[-npar]
      coef(object) <- Pars
      if ((lO <- length(object)) > 1) {
	for(i in lO:2) {
	  conLin <- recalc(object[[i]], conLin)
	  NULL
	}
      }
      val <- .C("mixed_loglik",
		as.double(conLin$Xy),
		as.integer(unlist(dims)),
		as.double(sigma * unlist(pdFactor(solve(object$reStruct)))),
		as.integer(settings),
		logLik = double(1),
		lRSS = double(1),
		PACKAGE = "nlme")[c("logLik", "lRSS")]
      aux <- (exp(val[["lRSS"]])/sigma)^2
      conLin[["logLik"]] + val[["logLik"]] + (N * log(aux) - aux)/2
    }
  dims <- conLin$dims
  sett <- attr(lmeSt, "settings")
  N <- dims$N - sett[1] * dims$ncol[dims$Q + 1]
  sett[2:3] <- c(1, 0)			# asDelta = TRUE and no grad/Hess
  conLin[["logLik"]] <- 0               # making sure
  sig2 <- sigma * sigma
  reSt <- lmeSt[["reStruct"]]
  for(i in seq(along = reSt)) {
    matrix(reSt[[i]]) <- as.double(sig2) * pdMatrix(reSt[[i]])
    if (inherits(reSt[[i]], "pdSymm") && natural) {
      reSt[[i]] <- pdNatural(reSt[[i]])
    }
    if (inherits(reSt[[i]], "pdBlocked") && natural) {
      for(j in seq(along = reSt[[i]])) {
        if (inherits(reSt[[i]][[j]], "pdSymm")) {
          reSt[[i]][[j]] <- pdNatural(reSt[[i]][[j]])
        }
      }
    }
  }
  lmeSt[["reStruct"]] <- reSt
  cSt <- lmeSt[["corStruct"]]
  if (!is.null(cSt) && inherits(cSt, "corSymm") && natural) {
    cStNatPar <- coef(cSt, unconstrained = FALSE)
    class(cSt) <- c("corNatural", "corStruct")
    coef(cSt) <- log((cStNatPar + 1)/(1 - cStNatPar))
    lmeSt[["corStruct"]] <- cSt
  }
  Pars <- c(coef(lmeSt), lSigma = log(sigma))
  val <- fdHess(Pars, fullLmeLogLik, lmeSt, conLin, dims, N, sett,
		.relStep = .relStep, minAbsPar = minAbsPar)[["Hessian"]]
  if (all(eigen(val)$values < 0)) {
    ## negative definite - OK
    val <- solve(-val)
    nP <- names(Pars)
    dimnames(val) <- list(nP, nP)
    attr(val, "Pars") <- Pars
    attr(val, "natural") <- natural
    val
  } else {
    ## problem - solution is not a maximum
    "Non-positive definite approximate variance-covariance"
  }
}

MEdecomp <-
 function(conLin)
  ## decompose a condensed linear model.  Returns another condensed 
  ## linear model 
{
  dims <- conLin$dims
  if (dims[["StrRows"]] >= dims[["ZXrows"]]) {
    ## no pint in doing the decomposition
    return(conLin)
  }
  dc <- array(.C("mixed_decomp", 
		 as.double(conLin$Xy), 
		 as.integer(unlist(dims)),
		 PACKAGE = "nlme")[[1]], 
	      c(dims$StrRows, dims$ZXcols))
  dims$ZXrows <- dims$StrRows
  dims$ZXoff <- dims$DecOff
  dims$ZXlen <- dims$DecLen
  conLin[c("Xy", "dims")] <- list(Xy = dc, dims = dims)
  conLin
}

MEEM <-
  function(object, conLin, niter = 0)
  ## perform niter iterations of the EM algorithm for conLin 
  ## assumes that object is in precision form
{
  if (niter > 0) {
    dd <- conLin$dims
    pdCl <- attr(object, "settings")[-(1:3)]
    pdCl[pdCl == -1] <- 0
    precvec <- unlist(pdFactor(object))
    zz <- .C("mixed_EM",
	     as.double(conLin$Xy),
	     as.integer(unlist(dd)),
	     precvec = as.double(precvec),
	     as.integer(niter),
	     as.integer(pdCl),
	     as.integer(attr(object, "settings")[1]),
	     double(1),
	     double(length(precvec)),
	     double(1),
	     PACKAGE = "nlme")[["precvec"]]
    Prec <- vector("list", length(object))
    names(Prec) <- names(object)
    for (i in seq(along = object)) {
      len <- dd$qvec[i]^2
      matrix(object[[i]]) <-
        crossprod(matrix(zz[1:len + dd$DmOff[i]], ncol = dd$qvec[i]))
    }
  }
  object
}

MEestimate <-
  function(object, groups, conLin = attr(object, "conLin"))
{
  dd <- conLin$dims
  nc <- dd$ncol
  REML <- attr(object$reStruct, "settings")[1]
  Q <- dd$Q
  rConLin <- recalc(object, conLin)
  zz <- .C("mixed_estimate",
	   as.double(rConLin$Xy),
	   as.integer(unlist(dd)),
	   as.double(unlist(pdFactor(object$reStruct))),
	   as.integer(REML),
	   double(1),
	   estimates = double(dd$StrRows * dd$ZXcols),
	   as.logical(FALSE),
	   PACKAGE = "nlme")[["estimates"]]
  estimates <- array(zz, c(dd$StrRows, dd$ZXcols))
  resp <- estimates[ , dd$ZXcols]
  reSt <- object$reStruct
  nam <- names(reSt)
  val <- vector(mode = "list", length = Q)
  names(val) <- nam
  start <- dd$StrRows * c(0, cumsum(nc))
  for (i in seq(along = reSt)) {
    val[[i]] <- 
      matrix(resp[as.vector(outer(1:(nc[i]), dd$SToff[[i]] - start[i], "+"))],
	     ncol = nc[i], byrow = TRUE, 
	     dimnames = list(unique(as.character(groups[, nam[i]])),
		 Names(reSt[[i]])))
    NULL
  }
  p <- nc[Q + 1]
  N <- dd$N - REML * p
  dimE <- dim(estimates)
  list(logLik = N * (log(N) - (1 + log(2 * pi)))/2 + rConLin$logLik, 
       b = rev(val), 
       beta = resp[dimE[1] - (p:1)],
       sigma = abs(resp[dimE[1]])/sqrt(N),
       varFix = t(solve(estimates[dimE[1]-(p:1), dimE[2]-(p:1), drop = FALSE])))
}

MEdims <-
  function(groups, ncols)
{
  ## define constants used in matrix decompositions and log-lik calculations
  ## first need some local functions
  lengths <-
    ## returns the group lengths from a vector of last rows in the group
    function(lstrow) diff(c(0, lstrow))
  offsets <-
    ## converts total number of columns(N), columns per level(ncols), and
    ## a list of group lengths to offsets in C arrays
    function(N, ncols, lstrow, triangle = FALSE)
  {
    pop <- function(x) x[-length(x)]
    cstart <- c(0, cumsum(N * ncols))
    for (i in seq(along = lstrow)) {
      lstrow[[i]] <- cstart[i] +
        if (triangle) {
          lstrow[[i]] - ncols[i]        # storage offsets style
        } else {
          pop(c(0, lstrow[[i]]))        # decomposition style
        }
    }
    lstrow
  }
  Q <- ncol(groups)                     # number of levels
  N <- nrow(groups)                     # number of observations
  ## 'isLast' indicates if the row is the last row in the group at that level.
  ## this version propagates changes from outer groups to inner groups
#  isLast <- (array(unlist(lapply(c(rev(as.list(groups)),
#                                 list(X = rep(0, N), y = rep(0, N))),
#                                function(x) c(0 != diff(codes(x)), TRUE))),
#                  c(N, Q+2), list(NULL, c(rev(names(groups)), "X", "y")))
#             %*% (row(diag(Q+2)) >= col(diag(Q+2)))) != 0
  ## this version does not propagate changes from outer to inner.
  isLast <- array(FALSE, dim(groups) + c(0, 2),
                  list(NULL, c(rev(names(groups)), "X", "y")))
  for(i in 1:Q) {
    isLast[, Q + 1 - i] <- c(0 != diff(codes(groups[[i]])), TRUE)
  }
  isLast[N,  ] <- TRUE
  lastRow <- apply(isLast, 2, function(x) seq(along = x)[x])
  if(!is.list(lastRow)) {
    nm <- names(lastRow)
    lastRow <- as.list(lastRow)
    names(lastRow) <- nm
  }
  
  isLast <- t(isLast)
  strSizes <- cumsum(ncols * isLast) * isLast # required storage sizes
  lastStr <- apply(t(strSizes), 2, function(x) x[x != 0])
  if(!is.list(lastStr)) {
    nm <- names(lastStr)
    lastStr <- as.list(lastStr)
    names(lastStr) <- nm
  }
  strRows <- max(lastStr[[length(lastStr)]])
  lastBlock <- vector("list", Q)
  names(lastBlock) <- rownames(strSizes)[1:Q]
  for(i in 1:Q) lastBlock[[i]] <- c(strSizes[i, -N], strRows)
  maxStr <- do.call("pmax", lastBlock)
  for(i in 1:Q) lastBlock[[i]] <- maxStr[as.logical(lastBlock[[i]])]
  lastBlock <- c(lastBlock, list(X = strRows, y = strRows))
  list(N = N,                   # total number of rows in data
       ZXrows = N,              # no. of rows in array
       ZXcols = sum(ncols),     # no. of columns in array
       Q = Q,                   # no. of levels of random effects
       StrRows = strRows,       # no. of rows required for storage
       qvec = ncols * c(rep(1, Q), 0, 0), # lengths of random effects
                                        # no. of groups at each level
       ngrps = c(unlist(lapply(lastRow, length), N, N)),
                                        # offsets into DmHalf array by level
       DmOff = (c(0, cumsum(ncols^2)))[1:(Q+2)],
       ncol = ncols,            # no. of columns decomposed per level
                                        # no. of columns rotated per level
       nrot = (rev(c(0, cumsum(rev(ncols)))))[-1],
       ZXoff = offsets(N, ncols, lastRow), # offsets into ZXy
       ZXlen = lapply(lastRow, lengths), # lengths of ZXy groups
                                        # storage array offsets
       SToff = offsets(strRows, ncols, lastStr, triangle = TRUE),
                                        # decomposition offsets
       DecOff = offsets(strRows, ncols, lastBlock),
                                        # decomposition lengths
       DecLen = lapply(lastBlock, lengths)
       )
}

### Methods for standard generics

ACF.lme <-
  function(object, maxLag, 
           resType = c("pearson", "response", "normalized"), ...)
{
  resType <- match.arg(resType)
  res <- resid(object, type = resType, asList = TRUE)
  if(missing(maxLag)) {
    maxLag <- min(c(maxL <- max(sapply(res, length)) - 1, 
                    as.integer(10 * log10(maxL + 1))))
  }
  val <- lapply(res,
                function(el, maxLag) {
                  N <- maxLag + 1
                  tt <- double(N)
                  nn <- integer(N)
                  N <- min(c(N, n <- length(el)))
                  nn[1:N] <- n + 1 - 1:N
                  ## el <- el - mean(el)
                  for(i in 1:N) {
                    tt[i] <- sum(el[1:(n-i+1)] * el[i:n])
                  }
                  array(c(tt,nn), c(length(tt), 2))
                }, maxLag = maxLag)
  val0 <- apply(sapply(val, function(x) x[,2]), 1, sum)
  val1 <- apply(sapply(val, function(x) x[,1]), 1, sum)/val0
  val2 <- val1/val1[1]
  z <- data.frame(lag = 0:maxLag, ACF = val2)
  attr(z, "n.used") <- val0
  class(z) <- c("ACF", "data.frame")
  z
}


anova.lme <- 
  function(object, ..., test = TRUE, type = c("sequential", "marginal"),
           adjustSigma = TRUE, Terms, L, verbose = FALSE)

{
  ## returns the likelihood ratio statistics, the AIC, and the BIC
  dots <- list(...)
  if ((rt <- (length(dots) + 1)) == 1) {    ## just one object 
    if (!inherits(object,"lme")) {
      stop("Object must inherit from class \"lme\" ")
    }
    vFix <- attr(object$fixDF, "varFixFact")
    if (object$method == "ML" && adjustSigma == TRUE) {
      ## using REML-like estimate of sigma under ML
      vFix <- sqrt(object$dims$N/(object$dims$N - ncol(vFix))) * vFix
    }
    c0 <- solve(t(vFix), fixef(object))
    assign <- attr(object$fixDF, "assign")
    nTerms <- length(assign)
    if (missing(Terms) && missing(L)) {
      ## returns the F.table (Wald) for the fixed effects
      type <- match.arg(type)
      Fval <- Pval <- double(nTerms)
      nDF <- integer(nTerms)
      dDF <- object$fixDF$terms
      for(i in 1:nTerms) {
        nDF[i] <- length(assign[[i]])
        if (type == "sequential") {       # type I SS
          c0i <- c0[assign[[i]]]
        } else {
          c0i <- c(qr.qty(qr(vFix[, assign[[i]], drop = FALSE]), c0))[1:nDF[i]]
        }
        Fval[i] <- sum(c0i^2)/nDF[i]
        Pval[i] <- 1 - pf(Fval[i], nDF[i], dDF[i])
      }
      ##
      ## fixed effects F-values, df, and p-values
      ##
      aod <- data.frame(nDF, dDF, Fval, Pval)
      dimnames(aod) <- 
        list(names(assign),c("numDF","denDF","F-value", "p-value"))
      attr(aod,"rt") <- rt
    } else {
      nX <- length(unlist(assign))
      if (missing(L)) {                 # terms is given
        if (is.numeric(Terms) && all(Terms == as.integer(Terms))) {
          if (min(Terms) < 1 || max(Terms) > nTerms) {
            stop(paste("Terms must be between 1 and", nTerms))
          }
        } else {
          if (is.character(Terms)) {
            if (any(noMatch <- is.na(match(Terms, names(assign))))) {
              stop(paste("Term(s)", paste(Terms[noMatch], collapse = ", "),
                         "not matched"))
            }
          } else {
            stop("Terms can only be integers or characters")
          }
        }
        dDF <- unique(object$fixDF$terms[Terms])
        if (length(dDF) > 1) {
          stop("Terms must all have the same denominator DF")
        }
        lab <-
          paste("F-test for:",paste(names(assign[Terms]),collapse=", "),"\n")
        L <- diag(nX)[unlist(assign[Terms]),,drop=FALSE]
      } else {
        L <- as.matrix(L)
        if (ncol(L) == 1) L <- t(L)     # single linear combination
        nrowL <- nrow(L)
        ncolL <- ncol(L)
        if (ncol(L) > nX) {
          stop(paste("L must have at most",nX,"columns"))
        }
        dmsL1 <- rownames(L)
        L0 <- array(0, c(nrowL, nX), list(NULL, names(object$fixDF$X)))
        if (is.null(dmsL2 <- colnames(L))) {
          ## assume same order as effects
          L0[, 1:ncolL] <- L
        } else {
          if (any(noMatch <- is.na(match(dmsL2, colnames(L0))))) {
            stop(paste("Effects",paste(dmsL2[noMatch],collapse=", "),
                       "not matched"))
          }
          L0[, dmsL2] <- L
        }
        L <- L0[noZeroRowL <- as.logical((L0 != 0) %*% rep(1, nX)), , drop = FALSE]
        nrowL <- nrow(L)
        if (is.null(dmsL1)) {
          dmsL1 <- 1:nrowL
        } else {
          dmsL1 <- dmsL1[noZeroRowL]
        }
        rownames(L) <- dmsL1
        dDF <-
         unique(object$fixDF$X[noZeroColL <-
                               as.logical(c(rep(1,nrowL) %*% (L != 0)))])
        if (length(dDF) > 1) {
          stop("L may only involve fixed effects with the same denominator DF")
        }
        lab <- "F-test for linear combination(s)\n"
      }
      nDF <- sum(svd(L)$d > 0)
      c0 <- c(qr.qty(qr(vFix %*% t(L)), c0))[1:nDF]
      Fval <- sum(c0^2)/nDF
      Pval <- 1 - pf(Fval, nDF, dDF)
      aod <- data.frame(nDF, dDF, Fval, Pval)
      names(aod) <- c("numDF", "denDF", "F-value", "p-value")
      attr(aod, "rt") <- rt
      attr(aod, "label") <- lab
      if (!missing(L)) {
        if (nrow(L) > 1) attr(aod, "L") <- L[, noZeroColL, drop = F]
        else attr(aod, "L") <- L[, noZeroColL]
      }
    }
  }
             
  ##
  ## Otherwise construct the likelihood ratio and information table
  ## objects in ... may inherit from gls, gnls, lm, lmList, lme,
  ## nlme, nlsList, and nls
  ##
  else {
    ancall <- sys.call()
    ancall$verbose <- ancall$test <- NULL
    object <- list(object, ...)
    termsClass <- unlist(lapply(object, data.class))
    if(!all(match(termsClass, c("gls", "gnls", "lm", "lmList", "lme","nlme","nlsList","nls"), 0))) {
      stop(paste("Objects must inherit from classes \"gls\", \"gnls\"",
               "\"lm\",\"lmList\", \"lme\",\"nlme\",\"nlsList\", or \"nls\""))
    }
    resp <- unlist(lapply(object, 
		  function(el) deparse(getResponseFormula(el)[[2]])))
    ## checking if responses are the same
    subs <- as.logical(match(resp, resp[1], FALSE))
    if (!all(subs))
      warning(paste("Some fitted objects deleted because", 
		    "response differs from the first model"))
    if (sum(subs) == 1)
      stop("First model has a different response from the rest")
    object <- object[subs]
    rt <- length(object)
    termsModel <- lapply(object, function(el) formula(el)[-2])
    estMeth <- unlist(lapply(object, 
			     function(el) {
			       val <- el[["method"]]
			       if (is.null(val)) val <- NA
			       val
			     }))
    ## checking consistency of estimation methods
    if(length(uEst <- unique(estMeth[estMeth != "NA"])) > 1) {
      stop("All fitted objects must have the same estimation method.")
    }
    estMeth[is.na(estMeth)] <- uEst
    ## checking if all models have same fixed effects when estMeth = "REML"
    REML <- uEst == "REML"
    if(REML) {
      aux <- unlist(lapply(termsModel, 
                           function(el) {
                             aux <- terms(el)
                             val <- paste(sort(attr(aux, "term.labels")),
                                          collapse = "&")
                             if (attr(aux, "intercept") == 1) {
                               val <- paste(val, "(Intercept)", sep = "&")
                             }
                             val
                           }))
      if(length(unique(aux)) > 1) {
        warning(paste("Fitted objects with different fixed effects.",
                      "REML comparisons are not meaningful."))
      }
    }
    termsCall <-
      lapply(object, function(el) {
        if (is.null(val <- el$call)) {
          if (is.null(val <- attr(el, "call"))) {
            stop("Objects must have a \"call\" component or attribute.")
          }
        }
        val
      })
    termsCall <- unlist(lapply(termsCall,
			       function(el) paste(deparse(el), collapse ="")))

    aux <- lapply(object, logLik, REML)
    if (length(unique(unlist(lapply(aux, function(el) attr(el, "nall")))))>1){
      stop("All fitted objects must use the same number of observations")
    }
    dfModel <- unlist(lapply(aux, function(el) attr(el, "df")))
    logLik <- unlist(lapply(aux, function(el) c(el)))
    AIC <- unlist(lapply(aux, AIC))
    BIC <- unlist(lapply(aux, BIC))
    aod <- data.frame(call = termsCall,
		      Model = (1:rt),
		      df = dfModel, 
		      AIC = AIC,
		      BIC = BIC,
		      logLik = logLik,
		      check.names = FALSE)
    if (test) {
      ddf <-  diff(dfModel)
      if (sum(abs(ddf)) > 0) {
	effects <- rep("", rt)
	for(i in 2:rt) {
	  if (ddf[i-1] != 0) {
	    effects[i] <- paste(i - 1, i, sep = " vs ")
	  }
	}
	pval <- rep(NA, rt - 1)
	ldf <- as.logical(ddf)
	lratio <- 2 * abs(diff(logLik))
	lratio[!ldf] <- NA
	pval[ldf] <- 1 - pchisq(lratio[ldf],abs(ddf[ldf]))
	aod <- data.frame(aod,
			  Test = effects, 
			  "L.Ratio" = c(NA, lratio),  
			  "p-value" = c(NA, pval),
			  check.names = FALSE)
      }
    }
    row.names(aod) <- unlist(lapply(as.list(ancall[-1]), deparse))
    attr(aod, "rt") <- rt
    attr(aod, "verbose") <- verbose
  }
  class(aod) <- c("anova.lme", "data.frame")
  aod
}

augPred.lme <- 
  function(object, primary = NULL, minimum = min(primary), 
	   maximum = max(primary), length.out = 51, level = Q, ...)
{
  data <- eval(object$call$data)
  if (!inherits(data, "data.frame")) {
    stop(paste("Data in", substitute(object),
               "call must evaluate to a data frame"))
  }
  if(is.null(primary)) {
    if (!inherits(data, "groupedData")) {
      stop(paste(sys.call()[[1]],
      "without \"primary\" can only be used with fits of groupedData objects"))
    }
    primary <- getCovariate(data)
    prName <- deparse(getCovariateFormula(data)[[2]])
  } else{
    primary <- asOneSidedFormula(primary)[[2]]
    prName <- deparse(primary)
    primary <- eval(primary, data)
  }
  newprimary <- seq(from = minimum, to = maximum, length.out = length.out)

  Q <- object$dims$Q                    # number of levels
  if (is.null(level)) level <- Q
  nL <- length(level)                   # number of requested levels
  maxLev <- max(c(level, 1))
  groups <- getGroups(object, level = maxLev)
  if (!is.ordered(groups)) {
    groups <- ordered(groups, levels = unique(as.character(groups)))
  }
  grName <- ".groups"
  ugroups <- unique(groups)
  value <- data.frame(rep(rep(newprimary, length(ugroups)), nL),
		      rep(rep(ugroups, rep(length(newprimary),
                                           length(ugroups))), nL))
  names(value) <- c(prName, grName)
  ## recovering other variables in data that may be needed for predictions
  ## varying variables will be replaced by their means
  summData <- gsummary(data, groups = groups)
  if (any(toAdd <- is.na(match(names(summData), names(value))))) {
    summData <- summData[, toAdd, drop = FALSE]
  }
  value[, names(summData)] <- summData[value[, 2], ]
  pred <- predict(object, value[1:(nrow(value)/nL), , drop = FALSE], level = level)

  if (nL > 1) {                         # multiple levels
    pred <- pred[, ncol(pred) - (nL - 1):0] # eliminating groups
    predNames <- rep(names(pred), rep(nrow(pred), nL))
    pred <- c(unlist(pred))
  } else {
    predNames <- rep("predicted", nrow(value))
  }
  newvals <- cbind(value[, 1:2], pred)
  names(newvals)[3] <- respName <-
    deparse(getResponseFormula(object)[[2]])
  orig <- data.frame(primary, groups, getResponse(object))
  names(orig) <- names(newvals)
  value <- rbind(orig, newvals)
  attributes(value[, 2]) <- attributes(groups)
  value[, ".type"] <- ordered(c(rep("original", nrow(data)), predNames),
                              levels = c(unique(predNames), "original"))
  labs <- list(x = prName, y = respName)
  unts <- list(x = "", y = "")
  if(inherits(data, "groupedData")) {
    labs[names(attr(data, "labels"))] <- attr(data, "labels")
    unts[names(attr(data, "units"))] <- attr(data, "units")
    attr(value, "units") <- attr(data, "units")
  } 
  attr(value, "labels") <- labs
  attr(value, "units") <- unts
  attr(value, "formula") <- 
      eval(parse(text = paste(respName, "~", prName, "|", grName)))
  class(value) <- c("augPred", class(value))
  value
}

coef.lme <-
  function(object, augFrame = FALSE, level = Q, data, which = 1:ncol(data),
	   FUN = mean, omitGroupingFactor = TRUE, subset = NULL)
{
  Q <- object$dims$Q
  if (length(level) > 1) {
    stop("Only single level allowed")
  }
  fixed <- fixef(object)
  p <- length(fixed)
  value <- ranef(object, level = 1:level)
  grps <- object[["groups"]]
  if (Q > 1) {
    grpNames <- t(array(rep(rev(names(grps)), Q), c(Q, Q)))
    grpNames[lower.tri(grpNames)] <- ""
    grpNames <- 
      rev(apply(grpNames, 1,
                function(x) paste(x[x != ""], collapse = " %in% ")))[level]
  } else {
    grpNames <- names(grps)
  }
  grps <- grps[, 1:level, drop = FALSE]
  grps <- gsummary(grps, groups = grps[, level])
  if (level == 1) value <- list(value)
  effNams <- unlist(lapply(value, names))
  grps <- grps[row.names(value[[level]]), , drop = FALSE]
  M <- nrow(grps)
  effNams <- unique(c(names(fixed), effNams))
  effs <- array(0, c(M, length(effNams)), 
		list(row.names(grps), effNams))

  effs[, names(fixed)] <- array(rep(fixed, rep(M, p)),	c(M, p))
  for (i in 1:level) {
    nami <- names(value[[i]])
    effs[, nami] <- as.matrix(effs[, nami] + value[[i]][as.character(grps[, i]), ])
  }
  
  if (augFrame) {			# can only do that for last level
    if (missing(data)) {
      data <- getData(object)
    }
    data <- as.data.frame(data)
    data <- data[, which, drop = FALSE]
    value <- ranef(object, TRUE, level, data, FUN = FUN,
			    omitGroupingFactor = omitGroupingFactor,
                            subset = subset)
    whichKeep <- is.na(match(names(value), effNams))
    if (any(whichKeep)) {
      effs <- cbind(effs, value[, whichKeep, drop = FALSE])
    }
  }
  effs <- as.data.frame(effs)
  attr(effs, "level") <- level
  attr(effs, "label") <- "Coefficients"
  attr(effs, "effectNames") <- effNams
  attr(effs, "standardized") <- F
  attr(effs, "grpNames") <- grpNames
  class(effs) <- unique(c("coef.lme", "ranef.lme", class(effs)))
  effs
}

fitted.lme <- 
  function(object, level = Q, asList = FALSE)
{
  Q <- object$dims$Q
  val <- object[["fitted"]]
  if (is.character(level)) {		# levels must be given consistently
    nlevel <- match(level, names(val))
    if (any(aux <- is.na(nlevel))) {
      stop(paste("Nonexistent level(s)", level[aux]))
    } 
    level <- nlevel
  } else {				# assuming integers
    level <- 1 + level
  }
  val <- val[, level]
  if (length(level) == 1) {
    grps <- as.character(object[["groups"]][, max(c(1, level - 1))])
    if (asList) {
      val <- as.list(split(val, ordered(grps, levels = unique(grps))))
    } else {
      names(val) <- grps
    }
    lab <- "Fitted values"
    if (!is.null(aux <- attr(object, "units")$y)) {
      lab <- paste(lab, aux)
    }
    attr(val, "label") <- lab
  }
  val
}

formula.lme <- function(object) eval(object$call$fixed)

fixef.lme <-
  function(object) object$coefficients$fixed

getGroups.lme <-
  function(object, form, level = Q, data, sep)
{
  Q <- object$dims$Q
  val <- object[["groups"]][, level]
  if (length(level) == 1) {		# single group
    attr(val, "label") <- names(object[["groups"]])[level]
  }
  val
}

getGroupsFormula.lme <-
  function(object, asList = FALSE, sep)
{
  getGroupsFormula(object$modelStruct$reStruct, asList)
}

getResponse.lme <-
  function(object, form)
{
  val <- resid(object) + fitted(object)
  if (is.null(lab <- attr(object, "labels")$y)) {
    lab <- deparse(getResponseFormula(object)[[2]])
  }
  if (!is.null(aux <- attr(object, "units")$y)) {
    lab <- paste(lab, aux)
  }
  attr(val, "label") <- lab
  val
}

intervals.lme <-
  function(object, level = 0.95, which = c("all", "var-cov", "fixed"))
{
  which <- match.arg(which)
  val <- list()
  if (which != "var-cov") {		# fixed effects included
    est <- fixef(object)
    len <- -qt((1-level)/2, object$fixDF$X) * sqrt(diag(object$varFix))
    vfix <- array(c(est - len, est, est + len), c(length(est), 3),
                  list(names(est), c("lower", "est.", "upper")))
    attr(vfix, "label") <- "Fixed effects:"
    val <- list(fixed = vfix)
  }
  if (which != "fixed") {		# variance-covariance included
    if (is.character(aV <- object$apVar)) {
      stop(paste("Cannot get confidence intervals on var-cov components:",
		 aV))
    }
    est <- attr(aV, "Pars")
    nP <- length(est)
    len <- -qnorm((1-level)/2) * sqrt(diag(aV))
    origInt <-                          # intervals in unconstrained parameters
      array(c(est - len, est, est + len),
	    c(nP, 3), list(names(est), c("lower", "est.", "upper")))

    lmeSt <- object$modelStruct
    if (!all(whichKeep <- apply(attr(lmeSt, "pmap"), 2, any))) {
      ## need to deleted components with fixed coefficients
      aux <- lmeSt[whichKeep]
      class(aux) <- class(lmeSt)
      attr(aux, "settings") <- attr(lmeSt, "settings")
      attr(aux, "pmap") <- attr(lmeSt, "pmap")[, whichKeep, drop = F]
      lmeSt <- aux
    }
    cSt <- lmeSt[["corStruct"]]
    if (!is.null(cSt) && inherits(cSt, "corSymm") && attr(aV, "natural")) {
      ## converting to corNatural
      class(cSt) <- c("corNatural", "corStruct")
      lmeSt[["corStruct"]] <- cSt
    }
    pmap <- attr(lmeSt, "pmap")
    namL <- names(lmeSt)
    natInt <- vector("list", length(namL) + 1) # list of intervals in natural pars
    names(natInt) <- c(namL, "sigma")
    natInt <- as.list(natInt)
    ## intervals for sigma are stored separately and dropped from origInt
    vsig <- exp(origInt[nP,])
    attr(vsig, "label") <- "Within-group standard error:"
    natInt[["sigma"]] <- vsig
    origInt <- origInt[-nP,, drop = FALSE]

    if (attr(aV, "natural")) {          # convert any pdSymm's to pdNatural's
      for(i in seq(along = lmeSt$reStruct)) {
	if (inherits(lmeSt$reStruct[[i]], "pdSymm")) {
	  lmeSt$reStruct[[i]] <- pdNatural(lmeSt$reStruct[[i]])
	} else {
          if (inherits(lmeSt$reStruct[[i]], "pdBlocked")) {
            for(j in seq(along = lmeSt$reStruct[[i]])) {
              if (inherits(lmeSt$reStruct[[i]][[j]], "pdSymm")) {
                lmeSt$reStruct[[i]][[j]] <- pdNatural(lmeSt$reStruct[[i]][[j]])
              }
            }
          }
        }
      }
    }
    rownames(origInt) <-           # re-express names if necessary
      namP <- names(coef(lmeSt, unconstrained = FALSE))
    for(i in 1:3) {                     # re-express intervals in constrained pars
      coef(lmeSt) <- origInt[,i]
      origInt[,i] <- coef(lmeSt, unconstrained = FALSE)
    }
    for(i in namL) {
      natInt[[i]] <- origInt[ pmap[ , i ], , drop = FALSE ]
      switch(i,
             reStruct = {
               plen <- attr( lmeSt$reStruct, "plen" )
               natInt[[i]] <-
               natInt[[i]] <-
                 rev(as.matrix( split( as.data.frame( natInt[[i]] ),
                                      rep( seq(along = plen), plen ))))
               names(natInt[[i]]) <- rev(names(plen))
               for (j in names(plen)) {
                 dimnames(natInt[[i]][[j]])[[1]] <-
                   names( coef( lmeSt[[i]][[j]], unconstrained = FALSE ) )
               }
             },
             corStruct =,
             varStruct = {
               dimnames(natInt[[i]])[[1]] <-
                 names(coef(lmeSt[[i]], unconstrained = FALSE))
             }
             )
      attr(natInt[[i]], "label") <-
	switch(i,
	       reStruct = "Random Effects:",
	       corStruct = "Correlation structure:",
	       varStruct = "Variance function:",
	       paste(i,":",sep=""))
    }
    val <- c(val, natInt)
  }
  attr(val, "level") <- level
  class(val) <- "intervals.lme"
  val
}					  

logLik.lme <-
  function(object, REML)
{
  p <- object$dims$ncol[object$dims$Q + 1]
  N <- object$dims$N
  Np <- N - p
  estM <- object$method
  if (missing(REML)) REML <- estM == "REML"
  val <- object[["logLik"]]
  if (REML && (estM == "ML")) {			# have to correct logLik
    val <- val + (p * (log(2 * pi) + 1) + (N - p) * log(1 - p/N) +
		  sum(log(abs(svd(object$varFix)$d)))) / 2
  }
  if (!REML && (estM == "REML")) {	# have to correct logLik
    val <- val - (p * (log(2*pi) + 1) + N * log(1 - p/N) +
		  sum(log(abs(svd(object$varFix)$d)))) / 2
  }
  attr(val, "nall") <- N
  attr(val, "nobs") <- N - REML * p
  attr(val, "df") <- p + length(coef(object[["modelStruct"]])) + 1
  class(val) <- "logLik"
  val
}

pairs.lme <- 
  function(object, form = ~coef(.), label, id = NULL, idLabels = NULL, 
	   grid = FALSE, ...)
{
  ## scatter plot matrix plots, generally based on coef or ranef
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }
  if (length(form) != 2) {
    stop("\"Form\" must be a one-sided formula")
  }
  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL

  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()

  ## covariate - must be present as a data.frame
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], list(. = object)) # only function of "."
  if (!inherits(.x, "data.frame")) {
    stop("Covariate must be a data frame")
  }
  level <- attr(.x, "level")
  if (!is.null(effNams <- attr(.x, "effectNames"))) {
    .x <- .x[, effNams, drop = FALSE]
  }
  ## eliminating constant effects
  isFixed <- unlist(lapply(.x, function(el) length(unique(el)) == 1))
  .x <- .x[, !isFixed, drop = FALSE]
  nc <- ncol(.x)
  if (nc == 1) {
    stop("Cannot do pairs of just one variable")
  }
  if (!missing(label)) {
    names(.x) <- label
  }
  if (nc == 2) {
    ## will use xyplot
    argForm <- .y ~ .x
    argData <- .x
    names(argData) <- c(".x", ".y")
    if (is.null(args$xlab)) {
      args$xlab <- names(.x)[1]
    }
    if (is.null(args$ylab)) {
      args$ylab <- names(.x)[2]
    }
  } else {				# splom
    argForm <- ~ .x
    argData <- list(.x = .x)
  }
  
  auxData <- list()
  ## groups - need not be present
  grpsF <- getGroupsFormula(form)
  if (!is.null(grpsF)) {
    gr <- splitFormula(grpsF, sep = "*")
    for(i in 1:length(gr)) {
      auxGr <- all.vars(gr[[i]])
      for(j in auxGr) {
        auxData[[j]] <- eval(as.name(j), data)
      }
    }
    if (length(argForm) == 2)
      argForm <- eval(parse(text = paste("~ .x |", deparse(grpsF[[2]]))))
    else argForm <- eval(parse(text = paste(".y ~ .x |", deparse(grpsF[[2]]))))
  }
  ## id and idLabels - need not be present
  if (!is.null(id)) {			# identify points in plot
    N <- object$dims$N
    id <- 
      switch(mode(id),
	     numeric = {
	       if ((id <= 0) || (id >= 1)) {
		 stop("Id must be between 0 and 1")
	       }
	       if (is.null(level)) {
	 stop("Covariate must have a level attribute, when groups are present")
       }
	       aux <- t(as.matrix(ranef(object, level = level)))
	       aux <- as.logical(apply(
	(solve(t(pdMatrix(object$modelStruct$reStruct, fact = TRUE)[[level]]),
		 aux)/object$sigma)^2, 2, sum) > qchisq(1 - id, dim(aux)[1]))
	       aux
	     },
	     call = eval(asOneSidedFormula(id)[[2]], data),
	     stop("\"Id\" can only be a formula or numeric.")
	     )
    if (length(id) == N) {
      ## id as a formula evaluated in data
      if (is.null(level)) {
	stop("Covariate must have a level attribute, when id is a formula")
      }
      auxData[[".id"]] <- id
    }

    if (is.null(idLabels)) {
      idLabels <- row.names(.x)
    } else {
      if (mode(idLabels) == "call") {
	idLabels <-
	  as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
      } else if (is.vector(idLabels)) {
	if (length(idLabels <- unlist(idLabels)) != N) {
	  stop("\"IdLabels\" of incorrect length")
	} 
	idLabels <- as.character(idLabels)
      } else {
	stop("\"IdLabels\" can only be a formula or a vector")
      }
    }
    if (length(idLabels) == N) {
      ## idLabels as a formula evaluated in data
      if (is.null(level)) {
      stop("Covariate must have a level attribute, when idLabels is a formula")
      }
      auxData[[".Lid"]] <- idLabels
    }
  }

  if (length(auxData)) {		# need collapsing
    auxData <- gsummary(as.data.frame(auxData), 
			groups = getGroups(object, level = level))
    auxData <- auxData[row.names(.x), , drop = FALSE]

    if (!is.null(auxData[[".id"]])) {
      id <- auxData[[".id"]]
    }

    if (!is.null(auxData[[".Lid"]])) {
      idLabels <- auxData[[".Lid"]]
    }
    wchDat <- is.na(match(names(auxData), c(".id", ".idLabels")))
    if (any(wchDat)) {
      argData <- c(argData, as.list(auxData[, wchDat, drop = FALSE]))
    }
  }

  assign("id", as.logical(as.character(id)) , where = 1)
  assign("idLabels", as.character(idLabels), where = 1)
  assign("grid", grid, where = 1)
  ## adding to args list
  args <- c(list(formula = argForm, data = argData), args)
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  ## defining the type of plot
  if (length(argForm) == 3) {		# xyplot
    plotFun <- "xyplot"
    if (is.null(args$panel)) {
      args <- c(args, 
                panel = list(function(x, y, subscripts, ...) 
		  {
                    dots <- list(...)
		    if (grid) panel.grid()
		    panel.xyplot(x, y, ...)
                    if (!all(is.na(aux <- id[subscripts])) &&
                        !is.null(aux) && any(aux)) {
		      text(x[aux], y[aux], idLabels[subscripts][aux],
                           cex = dots$cex, adj = dots$adj)
		    }
		  }))
    }
  } else {				# splom
    plotFun <- "splom"
    if (is.null(args$panel)) {
      args <- c(args, 
                panel = list(function(x, y, subscripts, ...)
		  {
                    dots <- list(...)
		    if (grid) panel.grid()
		    panel.xyplot(x, y, ...)
                    if (!all(is.na(aux <- id[subscripts])) &&
                        !is.null(aux) && any(aux)) {
		      text(x[aux], y[aux], idLabels[subscripts][aux],
                           cex = dots$cex, adj = dots$adj)
                    }
		  }))
    }
  }
  do.call(plotFun, as.list(args))
}

plot.ranef.lme <-
  function(object, form = NULL, omitFixed = TRUE, level = Q,
           grid = TRUE, control, ...)
{
  plotControl <-
    function(drawLine = TRUE, span.loess = 2/3, degree.loess = 1,
             cex.axis = 0.8, srt.axis = 0, mgp.axis = c(2, 0.5, 0))
    {
      list(drawLine = drawLine,
           span.loess = span.loess,
           degree.loess = degree.loess,
           cex.axis = cex.axis,
           srt.axis = srt.axis,
           mgp.axis = mgp.axis)
    }
  panel.bwplot2 <-
    function(x, y, box.ratio = 1, font = box.dot$font, pch = box.dot$pch,
             cex = box.dot$cex, col = box.dot$col, drawLine = TRUE, levs,
             cex.axis = 0.8, srt.axis = 0, mgp.axis = c(2, 0.5, 0), ...)
    {
      ok <- !is.na(x) & !is.na(y)
      x <- x[ok]
      y <- y[ok]
      x.unique <- sort(unique(x))
      width <- box.ratio/(1 + box.ratio)
      w <- width/2
      e <- par("cxy")[2]
      for(X in x.unique) {
        Y <- y[x == X]
        q <- quantile(Y, c(0.75, 0.5, 0.25))
        iqr <- q[1] - q[3]
        d <- q[c(1, 3)] + c(1, -1) * 1.5 * iqr
        up.w <- max(Y[Y <= d[1]], q[1])
        lo.w <- min(Y[Y >= d[2]], q[3])
        outliers <- Y[Y < lo.w | Y > up.w]
        Y <- c(up.w, q, lo.w)
        median.value <- list(x = X, y = Y[3])
        Box <- list(x1 = X + c( - w,  - w, w, w), 
                    y1 = Y[c(2, 4, 4, 2)], 
                    x2 = X + c( - w, w, w,  - w),
                    y2 = Y[c(4, 4, 2, 2)])
        e <- par("cxy")[2]
        e.l <- min(e, (Y[4] - Y[5])/2)	
        ## prevent lower staple ends from touching box
        e.u <- min(e, (Y[1] - Y[2])/2)	
        ## prevent upper staple ends from touching box
        staple.ends <- 
          list(x1 = c(rep(X - w, 2), rep(X + w, 2)),
               y1 = rep(c(Y[5], max(Y[1] - e.u, Y[2])), 2), 
               x2 = c(rep(X - w, 2), rep(X + w, 2)), 
               y2 = rep(c(min(Y[5] + e.l, Y[4]), Y[1]), 2))
        staple.body <- list(x1 = rep(X - w, 2), y1 = Y[c(1, 5)], 
                            x2 = rep(X + w, 2), y2 = Y[c(1, 5)])
        dotted.line <- list(x1 = c(X, X), y1 = Y[c(1, 4)], 
                            x2 = c(X, X), y2 = Y[c(2, 5)])
        box.umbrella <- trellis.par.get("box.umbrella")
        box.dot <- trellis.par.get("box.dot")
        box.dot.par <- c(list(pch = pch, cex = cex, col = col, font = 
                              font), ...)
        do.call("segments", c(staple.ends, box.umbrella))
        do.call("segments", c(staple.body, box.umbrella))
        do.call("segments", c(dotted.line, box.umbrella))
        do.call("segments", c(Box, trellis.par.get("box.rectangle")))
        do.call("points", c(median.value, box.dot.par))
        if(length(outliers) > 0) {
          outliers <- list(x = rep(X, length(outliers)), y = outliers)
          do.call("points", c(outliers, trellis.par.get("plot.symbol")))
        }
      }
      if (drawLine) {
        nX <- length(x.unique)
        aux <- (1:nX)[as.logical(1 - is.na(match(x.unique, 1:nX)))[1:nX]]
        lines(x.unique[aux], tapply(y, x, median)[aux], lwd = 0.5)
      }
      if (!missing(levs)) {
        axis(1, at = x.unique, labels = levs, srt = srt.axis, cex = cex.axis,
             mgp = mgp.axis, ...)
      }
    }

  pControl <- plotControl()
  if (!missing(control)) {
    pControl[names(control)] <- control
  }
  if (!inherits(object, "data.frame")) {
    ## must be a list of data frames
    Q <- length(object)
    if (length(level) > 1) {
      stop("Only single level allowed.")
    }
    oAttr <- attributes(object)[c("label", "standardized", "namsEff")]
    object <- object[[level]]
    oAttr$namsEff <- oAttr$namsEff[level]
    attributes(object)[c("label", "standardized", "namsEff")] <- oAttr
  }
  if (omitFixed) {			# eliminating constant effects
    isFixed <- unlist(lapply(object, function(el) length(unique(el)) == 1))
    if (any(isFixed)) {
      oattr <- attributes(object)
      oattr <- oattr[names(oattr) != "names"]
      object <- object[, !isFixed, drop = FALSE]
      oattr$effectNames <- oattr$effectNames[!is.na(match(oattr$effectNames,
							  names(object)))]
      attributes(object)[names(oattr)] <- oattr
    }
  }

  eNames <- attr(object, "effectNames")
  if (is.null(form) || (inherits(form, "formula") && length(form) == 2)) {
    eLen <- length(eNames)
    argData <- data.frame(.pars = as.vector(unlist(object[, eNames])), 
                      .enames = ordered(rep(eNames, rep(nrow(object), eLen)),
                        level = eNames))
    for(i in names(object)[is.na(match(names(object), eNames))]) {
      argData[[i]] <- rep(object[[i]], eLen)
    }
    argForm <- .groups ~ .pars | .enames
    argData[[".groups"]] <- rep(row.names(object), eLen)
    if (inherits(form, "formula")) {
      onames <- all.vars(form)
      if (any(whichNA <- is.na(match(onames, names(argData))))) {
        stop(paste(paste(onames[whichNA], collapse = ", "),
                   "not available for plotting"))
      }
      argData[[".groups"]] <- 
        as.character(argData[[as.character(onames[1])]])
      if (length(onames) > 1) {
        for(i in onames[-1]) {
          argData[[".groups"]] <- 
            paste(as.character(argData[[".groups"]]),
                  as.character(argData[[i]]))
        }
      }
    }
    argData[[".groups"]] <- ordered(argData[[".groups"]], 
                                    levels = unique(argData[[".groups"]]))
    args <- list(formula = argForm, data = argData, ...)
    if (is.null(args$xlab)) {
      args$xlab <- attr(object, "label")
    }
    if (is.null(args$ylab)) {
      if (is.null(form)) {
        args$ylab <- attr(object, "grpNames")
      } else {
        args$ylab <- deparse(form[[2]])
      }
    }
    if (is.null(args$scales)) {
      if (!is.null(attr(object, "standardized")) &&
          !attr(object, "standardized")) {
        args$scales <- list(x = list(relation = "free"))
      }
    }
    if (is.null(args$strip)) {
      args$strip <- function(...) strip.default(..., style = 1)
    }
    do.call("dotplot", as.list(args))
  } else {
    if (!inherits(form, "formula")) {
      stop("Form must be a formula, when not NULL.")
    }
    reName <- form[[2]]
    if (length(reName) != 1 &&
        substring(deparse(reName),
                  nchar(deparse(reName)) - 10) != "(Intercept)") {
      stop("Only single effects allowed in left side of form.")
    }
    reName <- deparse(reName)
    if (is.na(match(reName, eNames))) {
      stop(paste(reName,"is not a valid effect name"))
    }
    vNames <- all.vars(form[[3]])       # variable names
    if (any(!is.na(match(vNames, eNames)))) {
      stop("No effects allowed in right side of formula")
    }
    if (any(whichNA <- is.na(match(vNames, names(object))))) {
      stop(paste(paste(vNames[whichNA], collapse = ", "),
                 "not available for plotting"))
    }
    nV <- length(vNames)                # number of variables
    nG <- nrow(object)                  # number of groups
    reVal <- numeric(0)
    vNam <- character(0)
    vVal <- numeric(0)
    vType <- character(nV)
    names(vType) <- vNames
    vLevs <- vector("list", nV)
    names(vLevs) <- vNames
    aux <- object[, reName]
    for(i in 1:nV) {
      obj <- object[, vNames[i]]
      if (inherits(obj, "factor") ||
          is.character(obj)) {
        obj <- as.factor(obj)
        vLevs[[i]] <- levels(obj)
        vType[i] <- "factor"
        reVal <- c(reVal, c(NA, NA, aux))
        vVal <- c(vVal, c(0.5, length(levels(obj)) + 0.5, as.integer(obj)))
        vNam <- c(vNam, rep(vNames[i], nG + 2))
      } else {                          # numeric
        vType[i] <- "numeric"
        reVal <- c(reVal, aux)
        vVal <- c(vVal, obj)
        vNam <- c(vNam, rep(vNames[i], nG))
      }
    }
    argData <- data.frame(y = reVal, x = vVal,
                          g = ordered(vNam, levels = vNames))
    assign(".vNam", vNam, where = 1)
    assign(".vType", vType, where = 1)
    assign(".vLevs", vLevs, where = 1)
    assign(".grid", grid, where = 1)
    assign(".drawLine", pControl$drawLine, where = 1)
    assign(".span", pControl$span.loess, where = 1)
    assign(".degree", pControl$degree.loess, where = 1)
    assign("panel.bwplot2", panel.bwplot2, where = 1)
    assign(".cex", pControl$cex.axis, where = 1)
    assign(".srt", pControl$srt.axis, where = 1)
    assign(".mgp", pControl$mgp.axis, where = 1)    
    dots <- list(...)
    ylab <- dots$ylab
    if (is.null(ylab)) {
      ylab <- reName
    }
    strip <- dots$strip
    if (is.null(strip)) {
      strip <- function(...) strip.default(..., style = 1)
    }

    xyplot(y ~ x | g, data = argData, subscripts = TRUE,
           scales = list(x = list(relation = "free", tck = 0,
                           labels = FALSE)), 
           panel = function(x, y, subscripts, ...) {
             vN <- .vNam[subscripts][1]
             if (.grid) panel.grid()
             if (.vType[vN] == "numeric") {
               panel.xyplot(x, y, ...)
               if (.drawLine) {
                 panel.loess(x, y, span = .span, degree = .degree)
               }
               axis(1, cex = .cex, mgp = .mgp)
             } else {
               panel.bwplot2(x, y, levs = .vLevs[vN], drawLine = .drawLine,
                             cex.axis = .cex, srt.axis = .srt,
                             mgp.axis = .mgp, ...)
             }
           }, xlab = "", ylab = ylab, strip = strip, ...)
  }    
}

predict.lme <- 
  function(object, newdata, level = Q, asList = FALSE, na.action = na.fail)  
{
  ##
  ## method for predict() designed for objects inheriting from class lme
  ##
  Q <- object$dims$Q
  if (missing(newdata)) {		# will return fitted values
    val <- fitted(object, level, asList)
    if (length(level) == 1) return(val)
    return(data.frame(object[["groups"]][,level[level != 0], drop = FALSE],
		      predict = val))
  }
  maxQ <- max(level)			# maximum level for predictions
  mCall <- object$call
  fixed <- eval(as.call(mCall[["fixed"]][-2]))
  newdata <- as.data.frame(newdata)

  if (maxQ > 0) {			# predictions with random effects
    reSt <- object$modelStruct$reStruct[Q - (maxQ - 1):0]
    lmeSt <- lmeStruct(reStruct = reSt)
    groups <- getGroupsFormula(reSt)
    if (any(is.na(match(all.vars(groups), names(newdata))))) {
      ## groups cannot be evaluated in newdata
      stop("Cannot evaluate groups for desired levels on \"newdata\"")
    }
  } else {
    reSt <- NULL
  }

  mfArgs <- list(formula = asOneFormula(formula(reSt), fixed),
		 data = newdata, na.action = na.action)
  dataMix <- do.call("model.frame", mfArgs)
  origOrder <- row.names(dataMix)	# preserve the original order
  whichRows <- match(origOrder, row.names(newdata))
  
  if (maxQ > 0) {
    ## sort the model.frame by groups and get the matrices and parameters
    ## used in the estimation procedures
    grps <- getGroups(newdata, 
	      eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|"))))
    ## ordering data by groups
    if (inherits(grps, "factor")) {	# single level
      grps <- pruneLevels(grps[whichRows])
      oGrps <- data.frame(grps)
      ## checking if there are missing groups
      if (any(naGrps <- is.na(grps))) {
	grps[naGrps] <- levels(grps)[1]	# input with existing level
      }
      ord <- order(grps)     #"order" treats a single named argument peculiarly
      grps <- data.frame(grps)
      row.names(grps) <- origOrder
      names(grps) <- names(oGrps) <- as.character(deparse((groups[[2]])))
    } else {
      grps <- oGrps <- 
	do.call("data.frame", lapply(grps[whichRows, ], pruneLevels))
      ## checking for missing groups
      if (any(naGrps <- is.na(grps))) {
	## need to input missing groups
	for(i in names(grps)) {
	  grps[naGrps[, i], i] <- levels(grps[,i])[1]
	}
	naGrps <- t(apply(naGrps, 1, cumsum)) # propagating NAs
      }
      ord <- do.call("order", grps)
      ## making group levels unique
      grps[, 1] <- pruneLevels(grps[, 1])
      for(i in 2:ncol(grps)) {
	grps[, i] <-
          as.factor(paste(as.character(grps[, i-1]), as.character(grps[,i]),
                          sep = "/"))
	NULL
      }
    }
    naGrps <- cbind(FALSE, naGrps)[ord, , drop = FALSE]
    grps <- grps[ord, , drop = FALSE]
    dataMix <- dataMix[ord, ,drop = FALSE]
  }
  ## making sure factor levels are the same as in contrasts
  contr <- object$contrasts
  for(i in names(dataMix)) {
    if (inherits(dataMix[,i], "factor") && !is.null(contr[[i]])) {
      levs <- levels(dataMix[,i])
      levsC <- dimnames(contr[[i]])[[1]]
      if (any(wch <- is.na(match(levs, levsC)))) {
        stop(paste("Levels", paste(levs[wch], collapse = ","),
                   "not allowed for", i))
      }
#      if (length(levs) < length(levsC)) {
#        if (inherits(dataMix[,i], "ordered")) {
#          dataMix[,i] <- ordered(as.character(dataMix[,i]), levels = levsC)
#        } else {
#          dataMix[,i] <- factor(as.character(dataMix[,i]), levels = levsC)
#        }
#      }
      attr(dataMix[,i], "contrasts") <- contr[[i]][levs, , drop = FALSE]
    }
  }
  if (maxQ > 0) {
    revOrder <- match(origOrder, row.names(dataMix)) # putting in orig. order
#    Z <- model.matrix(reSt, dataMix, contr)
    Z <- model.matrix(reSt, dataMix)
    ncols <- attr(Z, "ncols")
    Names(lmeSt$reStruct) <- attr(Z, "nams")
  } 
  N <- nrow(dataMix)
  if (length(all.vars(fixed)) > 0) {
#    X <- model.matrix(fixed, model.frame(fixed, dataMix), contr) 
    X <- model.matrix(fixed, model.frame(fixed, dataMix))
  } else {
    X <- array(1, c(N, 1), list(row.names(dataMix), "(Intercept)"))
  }
  if (maxQ == 0) {
    ## only population predictions
    val <- c(X %*% fixef(object))
    attr(val, "label") <- "Predicted values"
    return(val)
  }
  
  ncols <- c(ncols, dim(X)[2], 1)
  ## creating the condensed linear model
  attr(lmeSt, "conLin") <-
    list(Xy = array(c(Z, X, double(N)), c(N, sum(ncols)), 
	     list(row.names(dataMix), c(colnames(Z), colnames(X),
					"resp"))),
	 dims = MEdims(grps, ncols))
  ## Getting the appropriate BLUPs of the random effects
  re <- object$coefficients$random[1:maxQ]
  for(i in names(re)) {
    ugrps <- unique(as.character(grps[, i]))
    val <- array(NA, c(length(ugrps), ncol(re[[i]])),
		 list(ugrps, dimnames(re[[i]])[[2]]))
    mGrps <- match(ugrps, dimnames(re[[i]])[[1]])
    mGrps <- mGrps[!is.na(mGrps)]
    re[[i]] <- re[[i]][mGrps, , drop = FALSE]
    val[dimnames(re[[i]])[[1]], ] <- re[[i]]
    re[[i]] <- val
  }
  
  attr(lmeSt, "lmeFit") <- list(beta = fixef(object), b = re)
  val <- fitted(lmeSt, level = 0:maxQ)
  val[as.logical(naGrps)] <- NA			# setting missing groups to NA
  ## putting back in original order and extracting levels
  val <- val[revOrder, level + 1]		# predictions
  if (maxQ > 1) {                      # making groups unique
    for(i in 2:maxQ) {
      oGrps[, i] <-
        as.factor(paste(as.character(oGrps[,i-1]), as.character(oGrps[,i]),
                        sep = "/"))
    }
  }
  if (length(level) == 1) {
    grps <- as.character(oGrps[, level])
    if (asList) {
      val <- split(val, ordered(grps, levels = unique(grps)))
    } else {
      names(val) <- grps
    }
    attr(val, "label") <- "Predicted values"
    if (!is.null(aux <- attr(object, "units")$y)) {
      attr(val, "label") <- paste(attr(val, "label"), aux)
    }
    return(val)
  } else {
    val <- data.frame(oGrps, predict = data.frame(val))
  }
  val
}

print.anova.lme <-
  function(x, verbose = attr(x, "verbose"))
{
  if ((rt <- attr(x,"rt")) == 1) {
    if (!is.null(lab <- attr(x, "label"))) {
      cat(lab)
      if (!is.null(L <- attr(x, "L"))) {
        print(zapsmall(L))
      }
    }
    pval <- format(round(x[, "p-value"],4))
    pval[as.double(pval) == 0] <- "<.0001"
    x[, "F-value"] <- format(zapsmall(x[, "F-value"]))
    x[, "p-value"] <- pval
    print(as.data.frame(x))
  } else {
    if (verbose) {
      cat("Call:\n")
      objNams <- row.names(x)
      for(i in 1:rt) {
	cat(" ",objNams[i],":\n", sep ="")
	cat(" ",as.character(x[i,"call"]),"\n")
      }
      cat("\n")
    }
    x <- as.data.frame(x[,-1])
    for(i in names(x)) {
      xx <- x[[i]]
      if (i == "p-value") {
        xx <- round(xx, 4)
        xna <- is.na(xx)
        xx[!xna] <- format(xx[!xna])
        xx[as.double(xx) == 0] <- "<.0001"
        xx[xna] <- ""
      } else {
        if (match(i, c("AIC", "BIC", "logLik", "L.Ratio"), 0)) {
          xna <- is.na(xx)
          xx <- zapsmall(xx)
          xx[xna] <- 0
          xx <- format(xx)
          xx[xna] <- ""
        }
      }
      x[[i]] <- xx
    }
    invisible(print(as.data.frame(x)))
  }
}

print.intervals.lme <-
  function(x, ...)
{
  cat(paste("Approximate ", attr(x, "level") * 100,
	    "% confidence intervals\n", sep = ""))
  for(i in names(x)) {
    aux <- x[[i]]
    cat("\n ",attr(aux, "label"), "\n", sep = "")
    if (i == "reStruct") {
      for(j in names(aux)) {
	cat("  Level:", j, "\n")
	print(as.matrix(aux[[j]]), ...)
      }
    } else {
      if (i == "sigma") print(c(aux), ...)
      else print.matrix(aux, ...)
    }
  }
}

print.lme <- 
  function(x, ...)
{
  dd <- x$dims
  if (inherits(x, "nlme")) {	# nlme object
    cat( "Nonlinear mixed-effects model fit by " )
    cat( ifelse( x$method == "REML", "REML\n", "maximum likelihood\n") )
    cat("  Model:", deparse(as.vector(x$call$model)),"\n")
  } else {				# lme objects
    cat( "Linear mixed-effects model fit by " )
    cat( ifelse( x$method == "REML", "REML\n", "maximum likelihood\n") )
  }    
  cat("  Data:", deparse( x$call$data ), "\n")
  if (!is.null(x$call$subset)) {
    cat("  Subset:", deparse(asOneSidedFormula(x$call$subset)[[2]]),"\n")
  }
  cat("  Log-", ifelse(x$method == "REML", "restricted-", ""),
             "likelihood: ", format(x$logLik), "\n", sep = "")
  fixF <- x$call$fixed
  if (inherits(fixF, "formula") || is.call(fixF)) {
    cat("  Fixed:", deparse(as.vector(x$call$fixed)), "\n")
  } else {
    cat("  Fixed:", deparse(lapply(fixF, function(el)
                                   as.name(deparse(as.vector(el))))), "\n")
  }
  print(fixef(x))
  cat("\n")
  print(summary(x$modelStruct), sigma = x$sigma)
  cat("Number of Observations:", dd[["N"]])
  cat("\nNumber of Groups: ")
  Ngrps <- dd$ngrps[1:dd$Q]
  if ((lNgrps <- length(Ngrps)) == 1) {	# single nesting
    cat(Ngrps,"\n")
  } else {				# multiple nesting
    sNgrps <- 1:lNgrps
    aux <- rep(names(Ngrps), sNgrps)
    aux <- split(aux, array(rep(sNgrps, lNgrps), 
			    c(lNgrps, lNgrps))[!lower.tri(diag(lNgrps))])
    names(Ngrps) <- unlist(lapply(aux, paste, collapse = " %in% "))
    cat("\n")
    print(rev(Ngrps))
  }
}

print.ranef.lme <-
  function(x, ...)
{
  if (!inherits(x[[1]], "data.frame")) {
    print.data.frame(x, ...)
  } else {                              # list
    for(i in seq(along = x)) {
      cat("Level:", attr(x, "grpNames")[i],"\n")
      print.data.frame(x[[i]])
      if (i < length(x)) cat("\n")
    }
  }
  invisible(0)
}

print.summary.lme <-
  function(x, verbose = FALSE, ...)
{
  dd <- x$dims
  verbose <- verbose || attr(x, "verbose")
  if (inherits(x, "nlme")) {	# nlme object
    cat( "Nonlinear mixed-effects model fit by " )
    cat( ifelse( x$method == "REML", "REML\n", "maximum likelihood\n") )
    cat("  Model:", deparse(as.vector(x$call$model)),"\n")
  } else {				# lme objects
    cat( "Linear mixed-effects model fit by " )
    cat( ifelse( x$method == "REML", "REML\n", "maximum likelihood\n") )
  }    
  method <- x$method
  cat(" Data:", deparse( x$call$data ), "\n")
  if (!is.null(x$call$subset)) {
    cat("  Subset:", deparse(asOneSidedFormula(x$call$subset)[[2]]),"\n")
  }
  print( data.frame( AIC = x$AIC, BIC = x$BIC, logLik = x$logLik, row.names = " ") )
  if (verbose) { cat("Convergence at iteration:",x$numIter,"\n") }
  cat("\n")
  print(summary(x$modelStruct), sigma = x$sigma, 
	reEstimates = x$coef$random, verbose = verbose)
  cat("Fixed effects: ")
  fixF <- x$call$fixed
  if (inherits(fixF, "formula") || is.call(fixF)) {
    cat(deparse(as.vector(x$call$fixed)), "\n")
  } else {
    cat(deparse(lapply(fixF, function(el) as.name(deparse(as.vector(el))))),
        "\n")
  }
  ## fixed effects t-table and correlations
  xtTab <- as.data.frame(x$tTable)
  wchPval <- match("p-value", names(xtTab))
  for(i in names(xtTab)[-wchPval]) {
    xtTab[, i] <- format(zapsmall(xtTab[, i]))
  }
  xtTab[,wchPval] <- format(round(xtTab[,wchPval], 4))
  if (any(wchLv <- (as.double(levels(xtTab[, wchPval])) == 0))) {
    levels(xtTab[, wchPval])[wchLv] <- "<.0001"
  }
  row.names(xtTab) <- dimnames(x$tTable)[[1]]
  print(xtTab)
  if (nrow(x$tTable) > 1) {
    corr <- x$corFixed
    class(corr) <- "correlation"
    print(corr,
	  title = " Correlation:",
	  ...)
  }
  cat("\nStandardized Within-Group Residuals:\n")
  print(x$residuals)
  cat("\nNumber of Observations:",x$dims[["N"]])
  cat("\nNumber of Groups: ")
  Ngrps <- dd$ngrps[1:dd$Q]
  if ((lNgrps <- length(Ngrps)) == 1) {	# single nesting
    cat(Ngrps,"\n")
  } else {				# multiple nesting
    sNgrps <- 1:lNgrps
    aux <- rep(names(Ngrps), sNgrps)
    aux <- split(aux, array(rep(sNgrps, lNgrps), 
			    c(lNgrps, lNgrps))[!lower.tri(diag(lNgrps))])
    names(Ngrps) <- unlist(lapply(aux, paste, collapse = " %in% "))
    cat("\n")
    print(rev(Ngrps))
  }
}

qqnorm.lme <-
  function(object, form = ~ resid(., type = "p"), abline = NULL,
           id = NULL, idLabels = NULL, grid = FALSE, ...)
  ## normal probability plots for residuals and random effects 
{
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }
  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL
  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()
  ## appending object to data
  data <- as.list(c(as.list(data), . = list(object)))

  ## covariate - must always be present
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], data)
  labs <- attr(.x, "label")
  if (inherits(.x, "ranef.lme")) {      # random effects
    type <- "reff"
  } else {
    if (!is.null(labs) && ((labs == "Standardized residuals") ||
                           (labs == "Normalized residuals") ||
                           (substring(labs, 1, 9) == "Residuals"))) {
      type <- "res"                     # residuals
    } else {
      stop("Only residuals and random effects allowed")
    }
  }
  if (is.null(args$xlab)) args$xlab <- labs
  if (is.null(args$ylab)) args$ylab <- "Quantiles of standard normal"
  if(type == "res") {			# residuals
    fData <- qqnorm(.x, plot.it = FALSE)
    data[[".y"]] <- fData$x
    data[[".x"]] <- fData$y
    dform <- ".y ~ .x"
    if (!is.null(grp <- getGroupsFormula(form))) {
      dform <- paste(dform, deparse(grp[[2]]), sep = "|")
    }
    if (!is.null(id)) {			# identify points in plot
      id <- 
        switch(mode(id),
               numeric = {
                 if ((id <= 0) || (id >= 1)) {
                   stop("Id must be between 0 and 1")
                 }
                 if (labs == "Normalized residuals") {
                   as.logical(abs(resid(object, type="normalized"))
                              > -qnorm(id / 2))
                 } else {
                   as.logical(abs(resid(object, type="pearson"))
                              > -qnorm(id / 2))
                 }
               },
               call = eval(asOneSidedFormula(id)[[2]], data),
               stop("\"Id\" can only be a formula or numeric.")
               )
      if (is.null(idLabels)) {
        idLabels <- getGroups(object)
        if (length(idLabels) == 0) idLabels <- 1:object$dims$N
        idLabels <- as.character(idLabels)
      } else {
        if (mode(idLabels) == "call") {
          idLabels <-
            as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
        } else if (is.vector(idLabels)) {
          if (length(idLabels <- unlist(idLabels)) != length(id)) {
            stop("\"IdLabels\" of incorrect length")
          } 
          idLabels <- as.character(idLabels)
        } else {
          stop("\"IdLabels\" can only be a formula or a vector")
        }
      }
    }
  } else {				# random.effects
    level <- attr(.x, "level")
    std <- attr(.x, "standardized")
    if (!is.null(effNams <- attr(.x, "effectNames"))) {
      .x <- .x[, effNams, drop = FALSE]
    }
    nc <- ncol(.x)
    nr <- nrow(.x)
    fData <- lapply(as.data.frame(.x), qqnorm, plot.it = FALSE)
    fData <- data.frame(.x = unlist(lapply(fData, function(x) x[["y"]])),
			.y = unlist(lapply(fData, function(x) x[["x"]])),
			.g = ordered(rep(names(fData),rep(nr, nc)),
                          levels = names(fData)))
    dform <- ".y ~ .x | .g"
    if (!is.null(grp <- getGroupsFormula(form))) {
      dform <- paste(dform, deparse(grp[[2]]), sep = "*")
      auxData <- data[is.na(match(names(data), "."))]
    } else {
      auxData <- list()
    }
    ## id and idLabels - need not be present
    if (!is.null(id)) {			# identify points in plot
      N <- object$dims$N
      id <- 
        switch(mode(id),
               numeric = {
                 if ((id <= 0) || (id >= 1)) {
                   stop("Id must be between 0 and 1")
                 }
                 aux <- ranef(object, level = level, standard = TRUE)
                 as.logical(abs(c(unlist(aux))) > -qnorm(id / 2))
               },
               call = eval(asOneSidedFormula(id)[[2]], data),
               stop("\"Id\" can only be a formula or numeric.")
               )
      if (length(id) == N) {
        ## id as a formula evaluated in data
        auxData[[".id"]] <- id
      }
      
      if (is.null(idLabels)) {
        idLabels <- rep(row.names(.x), nc)
      } else {
        if (mode(idLabels) == "call") {
          idLabels <-
            as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
        } else if (is.vector(idLabels)) {
          if (length(idLabels <- unlist(idLabels)) != N) {
            stop("\"IdLabels\" of incorrect length")
          } 
          idLabels <- as.character(idLabels)
        } else {
          stop("\"IdLabels\" can only be a formula or a vector")
        }
      }
      if (length(idLabels) == N) {
        ## idLabels as a formula evaluated in data
        auxData[[".Lid"]] <- idLabels
      }
    }

    if (length(auxData)) {		# need collapsing
      auxData <- gsummary(as.data.frame(auxData), 
                          groups = getGroups(object, level = level))
      auxData <- auxData[row.names(.x), , drop = FALSE]

      if (!is.null(auxData[[".id"]])) {
        id <- rep(auxData[[".id"]], nc)
      }
      
      if (!is.null(auxData[[".Lid"]])) {
        idLabels <- rep(auxData[[".Lid"]], nc)
      }
      data <- cbind(fData, do.call("rbind", rep(list(auxData), nc)))
    } else {
      data <- fData
    }
  }
  assign("id", if (is.null(id)) NULL else as.logical(as.character(id)),
         where = 1)
  assign("idLabels", as.character(idLabels), where = 1)
  assign("grid", grid, where = 1)
  assign("abl", abline, where = 1)
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  args <- c(list(formula = eval(parse(text = dform)),
                 data = substitute(data)), args)
  if (is.null(args$panel)) {
    args <- c(list(panel = function(x, y, subscripts, ...){
      dots <- list(...)
      if (grid) panel.grid()
      panel.xyplot(x, y, ...)
      if (!all(is.na(aux <- id[subscripts])) &&
          !is.null(aux) && any(aux)) {
        text(x[aux], y[aux], idLabels[subscripts][aux],
             cex = dots$cex, adj = dots$adj)
      }
      if (!is.null(abl)) panel.abline(abl, ...)
    }), args)
  }
  if(type == "reff" && !std) {
    args[["scales"]] <- list(x = list(relation = "free"))
  }
  do.call("xyplot", as.list(args))
}

ranef.lme <-
  ##  Extracts the random effects from an lme object.
  ##  If aug.frame is true, the returned data frame is augmented with a
  ##  values from the original data object, if available.  The variables
  ##  in the original data are collapsed over the cluster variable by the
  ##  function fun.
function(object, augFrame = FALSE, level = 1:Q, data, which = 1:ncol(data), 
	 FUN = mean, standard = FALSE , omitGroupingFactor = TRUE,
         subset = NULL)
{
  Q <- object$dims$Q
  effects <- object$coefficients$random
  if (Q > 1) {
    grpNames <- t(array(rep(rev(names(effects)), Q), c(Q, Q)))
    grpNames[lower.tri(grpNames)] <- ""
    grpNames <- 
      rev(apply(grpNames, 1, function(x) paste(x[x != ""], collapse = " %in% ")))
  } else {
    grpNames <- names(effects)
  }
  effects <- effects[level]
  grpNames <- grpNames[level]
  if (standard) {
    for (i in names(effects)) {
      effects[[i]] <- 
	t(t(effects[[i]]) / (object$sigma * 
		     sqrt(diag(as.matrix(object$modelStruct$reStruct[[i]])))))
    }
  }
  effects <- lapply(effects, as.data.frame)
  if (augFrame) {
    if (length(level) > 1) {
      stop("Augmentation of random effects only available for single level")
    }
    effects <- effects[[1]]
    effectNames <- names(effects)
    if (missing(data)) {
      data <- getData(object)
    }
    data <- as.data.frame(data)
    if (is.null(subset)) {              # nlme case
      subset <- eval(object$call[["naPattern"]])
    } else {
      subset <- asOneSidedFormula(as.list(match.call())[["subset"]])
    }
    if (!is.null(subset)) {
      subset <- eval(subset[[2]], data)
      data <- data[subset,  ,drop=FALSE]
    }
    data <- data[, which, drop = FALSE]
    ## eliminating columns with same names as effects
    data <- data[, is.na(match(names(data), effectNames)), drop = FALSE]
    grps <- as.character(object[["groups"]][, level])
    data <- gsummary(data, FUN = FUN, groups = grps)
    if (omitGroupingFactor) {
      data <- 	
	data[, is.na(match(names(data), names(object$modelStruct$reStruct))), 
	      drop = FALSE]
    }
    if (length(data) > 0) {
      effects <- cbind(effects, data[row.names(effects),, drop = FALSE])
    }
    attr(effects, "effectNames") <- effectNames
  } else {
    effects <- lapply(effects,
                      function(el) {
                        attr(el, "effectNames") <- names(el)
                        el
                      })
    if (length(level) == 1) effects <- effects[[1]]
  }
  attr(effects, "label") <- 
    if (standard) {
      "Standardized random effects"
    } else {
      "Random effects"
    }
  attr(effects, "level") <- max(level)
  attr(effects, "standardized") <- standard
  attr(effects, "grpNames") <- grpNames
  class(effects) <- c("ranef.lme", class(effects))
  effects
}

residuals.lme <- 
  function(object, level = Q, type = c("response", "pearson", "normalized"),
           asList = FALSE)
	  
{
  type <- match.arg(type)
  Q <- object$dims$Q
  val <- object[["residuals"]]
  if (is.character(level)) {		# levels must be given consistently
    nlevel <- match(level, names(val))
    if (any(aux <- is.na(nlevel))) {
      stop(paste("Nonexistent level(s)", level[aux]))
    } 
    level <- nlevel
  } else {				# assuming integers
    level <- 1 + level
  }
  if (type != "response") {		# standardize
    ## have to standardize properly for when corStruct neq NULL
    val <- val[, level]/attr(val, "std")
  } else {
    val <- val[, level]
  }
  if (type == "normalized") {
    if (!is.null(cSt <- object$modelStruct$corStruct)) {
      ## normalize according to inv-trans factor
      val <- recalc(cSt, list(Xy = as.matrix(val)))$Xy[, 1:length(level)]
    } else {                            # will just standardized
      type <- "pearson"
    }
  }
  if (length(level) == 1) {
    grps <- as.character(object[["groups"]][, max(c(1, level - 1))])
    if (asList) {
      val <- as.list(split(val, ordered(grps, levels = unique(grps))))
    } else {
      names(val) <- grps
    }
    attr(val, "label") <-
      switch(type,
             response = {
               lab <- "Residuals"
               if (!is.null(aux <- attr(object, "units")$y)) {
                 lab <- paste(lab, aux)
               }
               lab
             },
             pearson = "Standardized residuals",
             normalized = "Normalized residuals"
             )
  }
  val
}

summary.lme <- function(object, adjustSigma = TRUE, verbose = FALSE)
{
  ##  variance-covariance estimates for fixed effects
  fixed <- fixef(object)
  stdFixed <- sqrt(diag(as.matrix(object$varFix)))
  object$corFixed <- array(t(object$varFix/stdFixed)/stdFixed,
                           dim(object$varFix), list(names(fixed),names(fixed)))
  if (object$method == "ML" && adjustSigma == TRUE) {
    stdFixed <-
      sqrt(object$dims$N/(object$dims$N - length(stdFixed))) * stdFixed
  }
  ## fixed effects coefficients, std. deviations and t-ratios
  ##
  tTable <- data.frame(fixed, stdFixed, object$fixDF[["X"]],
                       fixed/stdFixed, fixed)
  dimnames(tTable)<-
    list(names(fixed),c("Value", "Std.Error", "DF", "t-value", "p-value"))
  tTable[, "p-value"] <- 2 * pt(-abs(tTable[,"t-value"]), tTable[,"DF"])
  object$tTable <- as.matrix(tTable)
  ##
  ## residuals
  ##
  resd <- resid(object, type = "pearson")
  if (length(resd) > 5) {
    resd <- quantile(resd)
    names(resd) <- c("Min","Q1","Med","Q3","Max")
  }
  object$residuals <- resd
  ##
  ## generating the final object
  ##
  aux <- logLik(object)
  object$BIC <- BIC(aux)
  object$AIC <- AIC(aux)
  attr(object, "oClass") <- class(object)
  attr(object, "verbose") <- verbose
  class(object) <- c("summary.lme", class(object))

  object
}

update.lme <-
  function(object, fixed, data, random, correlation, weights, subset,
           method, na.action, control)
{
  thisCall <- as.list(match.call())[-(1:2)]
  if (is.null(nextCall <- object$origCall) ||
      !is.null(thisCall$fixed) ||
      is.null(thisCall$random)) {
    nextCall <- object$call
  }
  nextCall <- as.list(nextCall)[-1]
  if (is.null(thisCall$random)  && is.null(thisCall$subset)) {
    ## no changes in ranef model and no subsetting
    thisCall$random <- object$modelStruct$reStruct
  }
  if (is.na(match("correlation", names(thisCall))) &&
      !is.null(thCor <- object$modelStruct$corStruct)) {
    thisCall$correlation <- thCor
  }
  if (is.na(match("weights", names(thisCall))) &&
      !is.null(thWgt <- object$modelStruct$varStruct)) {
    thisCall$weights <- thWgt
  }
    argNams <- unique( c(names(nextCall), names(thisCall)) )
    args <- vector("list", length(argNams))
    names(args) <- argNams
    args[ names(nextCall) ] <- nextCall
    nextCall <- args
  if (!is.null(thisCall$fixed)) {
    thisCall$fixed <- update(as.formula(nextCall$fixed), thisCall$fixed)
  }
  nextCall[names(thisCall)] <- thisCall
  do.call("lme", nextCall)
}

Variogram.lme <-
  function(object, distance, form = ~1,
           resType = c("pearson", "response", "normalized"), 
           data, na.action = na.fail, maxDist, length.out = 50,
           collapse = c("quantiles", "fixed", "none"), nint = 20, breaks,
           robust = FALSE, metric = c("euclidean", "maximum", "manhattan"))
{
  resType <- match.arg(resType)
  Q <- object$dims$Q
  grps <- getGroups(object, level = Q)
  ## checking if object has a corSpatial element
  csT <- object$modelStruct$corStruct
  wchRows <- NULL
  if (missing(distance)) {
    if (missing(form) && inherits(csT, "corSpatial")) {
      distance <- getCovariate(csT)
    } else {
      metric <- match.arg(metric)
      if (missing(data)) {
        data <- getData(object)
      }
      if (is.null(data)) {			# will try to construct
        allV <- all.vars(form)
        if (length(allV) > 0) {
          alist <- lapply(as.list(allV), as.name)
          names(alist) <- allV
          alist <- c(as.list(as.name("data.frame")), alist)
          mode(alist) <- "call"
          data <- eval(alist, sys.parent(1))
        } 
      } 
      covForm <- getCovariateFormula(form)
      if (length(all.vars(covForm)) > 0) {
        if (attr(terms(covForm), "intercept") == 1) {
          covForm <-
            eval(parse(text = paste("~", deparse(covForm[[2]]),"-1",sep="")))
        }
        covar <- model.frame(covForm, data, na.action = na.action)
        ## making sure grps is consistent
        wchRows <- !is.na(match(row.names(data), row.names(covar)))
        grps <- pruneLevels(grps[wchRows])
        covar <- as.data.frame(unclass(model.matrix(covForm, covar)))
      } else {
        covar <-
          data.frame(dist = unlist(tapply(rep(1, nrow(data)), grps, cumsum)))
      }
      covar <- split(covar, grps)
      ## getting rid of 1-observation groups
      covar <- covar[sapply(covar, function(el) nrow(as.matrix(el))) > 1]
      distance <- lapply(covar,
                         function(el, metric) dist(as.matrix(el), metric),
                         metric = metric)
    }
  }
  res <- resid(object, type = resType)
  if (!is.null(wchRows)) {
    res <- res[wchRows]
  }
  res <- split(res, grps)
  res <- res[sapply(res, length) > 1] # no 1-observation groups
  levGrps <- levels(grps)
  val <- vector("list", length(levGrps))
  names(val) <- levGrps
  for(i in levGrps) {
    val[[i]] <- Variogram(res[[i]], distance[[i]])
  }
  val <- do.call("rbind", val)
  if (!missing(maxDist)) {
    val <- val[val$dist <= maxDist, ]
  }
  collapse <- match.arg(collapse)
  if (collapse != "none") {             # will collapse values
    dst <- val$dist
    udist <- sort(unique(dst))
    ludist <- length(udist)
    if (!missing(breaks)) {
      if (min(breaks) > udist[1]) {
        breaks <- c(udist[1], breaks)
      }
      if (max(breaks) < udist[2]) {
        breaks <- c(breaks, udist[2])
      }
      if (!missing(nint) && nint != (length(breaks) - 1)) {
        stop("Nint is not consistent with breaks.")
      }
      nint <- length(breaks) - 1
    }
    if (nint < ludist) {
      if (missing(breaks)) {
        if (collapse == "quantiles") {    # break into equal groups
          breaks <- unique(quantile(dst, seq(0, 1, 1/nint)))
        } else {                          # fixed length intervals
          breaks <- seq(udist[1], udist[length(udist)], length = nint + 1)
        }
      } 
      cutDist <- cut(dst, breaks)
    } else {
      cutDist <- dst
    }
    val <- lapply(split(val, cutDist),
                  function(el, robust) {
                    nh <- nrow(el)
                    vrg <- el$variog
                    if (robust) {
                      vrg <- ((mean(vrg^0.25))^4)/(0.457+0.494/nh)
                    } else {
                      vrg <- mean(vrg)
                    }
                    dst <- median(el$dist)
                    data.frame(variog = vrg, dist = dst)
                  }, robust = robust)
    val <- do.call("rbind", val)
    val <- na.omit(val)                 # getting rid of NAs
    val$n.pairs <- table(na.omit(cutDist))
  }
  row.names(val) <- 1:nrow(val)
  if (inherits(csT, "corSpatial") && resType != "normalized") {
    ## will keep model variogram
    if (resType == "pearson") {
      sig2 <- 1
    } else {
      sig2 <- object$sigma^2
    }
    attr(val, "modelVariog") <-
      Variogram(csT, sig2 = sig2, length.out = length.out)
  }
  attr(val, "collapse") <- collapse != "none"
  class(val) <- c("Variogram", "data.frame")
  val
}

###*### lmeStruct - a model structure for lme fits

lmeStruct <-
  ## constructor for lmeStruct objects
  function(reStruct, corStruct = NULL, varStruct = NULL)
{

  val <- list(reStruct = reStruct, corStruct = corStruct,
              varStruct = varStruct)
  val <- val[!sapply(val, is.null)]	# removing NULL components
  attr(val, "settings") <- attr(val$reStruct, "settings")
  class(val) <- c("lmeStruct", "modelStruct")
  val
}

##*## lmeStruct methods for standard generics

fitted.lmeStruct <-
  function(object, level = Q, conLin = attr(object, "conLin"),
           lmeFit = attr(object, "lmeFit"))
{
  if (is.null(conLin)) {
    stop("No condensed linear model")
  }
  if (is.null(lmeFit)) {
    stop("No fitted lme object")
  } 
  dd <- conLin$dims
  Q <- dd$Q
  Qp1 <- Q + 1
  nc <- dd$ncol
  fit <- array(0, c(dd$N, Qp1), 
       list(dimnames(conLin$Xy)[[1]], c("fixed", rev(names(object$reStruct)))))
  ZXstart <- rev(cumsum(c(1, nc[1:Q])))
  ZXend <- rev(cumsum(nc[1:Qp1]))
  ZXlen <- dd$ZXlen[Q:1]
  ZXngrps <- dd$ngrps[Q:1]
  ZXb <- lmeFit$b
  nc <- nc[Q:1]

  fit[, "fixed"] <-			# population fitted values
    conLin$Xy[, ZXstart[1]: ZXend[1], drop = FALSE] %*% lmeFit$beta

  for(i in 1:Q) {
    j <- i + 1
    fit[, j] <- fit[, i] + 
      (conLin$Xy[, ZXstart[j]:ZXend[j], drop = FALSE] * 
       ZXb[[i]][rep(1:ZXngrps[i], ZXlen[[i]]),,drop = FALSE]) %*% rep(1, nc[i])
  }
  fit[, level + 1]
}

initialize.lmeStruct <-
  function(object, data, groups, conLin = attr(object, "conLin"), 
	   control= list(niterEM = 20, gradHess = TRUE))
{
  object[] <- lapply(object, initialize, data, conLin, control)
  theta <- lapply(object, coef)
  len <- unlist(lapply(theta, length))
  num <- seq(along = len)
  if (sum(len) > 0) {
    pmap <- outer(rep(num, len), num, "==")
  } else {
    pmap <- array(FALSE, c(1, length(len)))
  }
  dimnames(pmap) <- list(NULL, names(object))
  attr(object, "pmap") <- pmap
  if (length(object) == 1  &&           # only reStruct
      all(attr(object, "settings")[-(1:3)] >= 0) && # known pdMat class
      control[["gradHess"]]) { 
    ## can use numerical derivatives
    attr(object, "settings")[2:3] <- c(0, 1)
    class(object) <- c("lmeStructInt", class(object))
  }
  if (needUpdate(object)) {
    attr(object, "lmeFit") <- MEestimate(object, groups)
    update(object, data)
  } else {
    object
  }
}

logLik.lmeStruct <-
  function(object, Pars, conLin = attr(object, "conLin"))
{
  coef(object) <- Pars			# updating parameter values
  recalc(object, conLin)[["logLik"]]	# updating conLin
}

logLik.lmeStructInt <-
  function(object, Pars, conLin = attr(object, "conLin"))
{
  ## logLik for objects with reStruct parameters only, with 
  ## internally defined class
  q <- length(Pars)
  aux <- .C("mixed_loglik",
	    as.double(conLin[["Xy"]]),
	    as.integer(unlist(conLin$dims)),
	    as.double(Pars),
	    as.integer(attr(object, "settings")),
	    val = double(1 + q * (q + 1)),
	    double(1),
	    PACKAGE = "nlme")[["val"]]
  val <- aux[1]
  attr(val, "gradient") <- -aux[1 + (1:q)]
  attr(val, "hessian") <- -array(aux[-(1:(q+1))], c(q, q))
  val
}

residuals.lmeStruct <-
  function(object, level = Q, conLin = attr(object, "conLin"),
           lmeFit = attr(object, "lmeFit"))
{
  Q <- conLin$dims$Q
  conLin$Xy[, conLin$dims$ZXcols] - fitted(object, level, conLin, lmeFit)
}

varWeights.lmeStruct <-
  function(object)
{
  if (is.null(object$varStruct)) rep(1, attr(object, "conLin")$dims$N)
  else varWeights(object$varStruct)
}

## Auxiliary control functions

lmeScale <- function(start) 
# 
# function used to set the scale inside ms(), for lme() and nlme()
# calls
#
{
  scale <- abs(start)
  nonzero <- scale > 0
  if (any(nonzero)) {
    scale[nonzero] <- 1/scale[nonzero]
    scale[!nonzero] <- median(scale[nonzero])
  }
  else {
    scale <- rep(1, length(scale))
  }
  scale
}

lmeControl <-
  ## Control parameters for lme
  function(maxIter = 50, msMaxIter = 50, tolerance = 1e-6, niterEM = 25,
	   msTol = 1e-7, msScale = lmeScale, msVerbose = FALSE,
           returnObject = FALSE, gradHess = TRUE, apVar = TRUE, 
	   .relStep = (.Machine$double.eps)^(1/3), minAbsParApVar = 0.05, 
           nlmStepMax = 100.0,
           natural = TRUE)
{
  list(maxIter = maxIter, msMaxIter = msMaxIter, tolerance = tolerance,
       niterEM = niterEM, msTol = msTol, msScale = msScale,
       msVerbose = msVerbose, returnObject = returnObject,
       gradHess = gradHess , apVar = apVar, .relStep = .relStep,
       nlmStepMax = nlmStepMax,
       minAbsParApVar = minAbsParApVar, natural = natural)
}

## Local Variables:
## mode:S
## End:

### $Id: modelStruct.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###         modelStruct - a virtual class of model structures
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

### Constructor
### There is no constructor function for this class (i.e. no function
### called modelStruct) because the class is virtual.
### Objects inheriting from this class are required to have a "conLin"
### (condensed linear model) attribute and a "pmap" (parameter map) 
### attribute

###*# Methods for standard generics

coef.modelStruct <-
  function(object, unconstrained = TRUE)
{
  unlist(lapply(object, coef, unconstrained))
}

"coef<-.modelStruct" <-
  function(object, value)
{
  value <- as.numeric(value)
  parMap <- attr(object, "pmap")
  for(i in names(object)) {
    if (any(parMap[,i])) {
      coef(object[[i]]) <- value[parMap[,i]]
    }
  }
  object
}

formula.modelStruct <-
  function(object)
{
  lapply(object, formula)
}

needUpdate.modelStruct <-
  function(object) any(unlist(lapply(object, needUpdate)))

print.modelStruct <- 
  function(x, ...)
{
  for(i in names(x)) {
    if ((length(aux <- coef(x[[i]]))) > 0) {
      cat(paste(i, " parameters:\n"))
      print(aux)
    }
  }
}

print.summary.modelStruct <-
  function(x, ...) 
{
  lapply(x, print, ...)
}

recalc.modelStruct <-
  function(object, conLin = attr(object, "conLin"))
{
  for(i in rev(seq(along = object))) {
    conLin <- recalc(object[[i]], conLin)
    NULL
  }
  conLin
}

summary.modelStruct <- 
  function(object)
{
  value <- lapply(object, summary)
  class(value) <- "summary.modelStruct"
  value
}
## will not work as it is. fitted needs more than one argument!
update.modelStruct <-
  function(object, data)
{
  if (needUpdate(object)) {
    object[] <- lapply(object, update, c(list("." = object), as.list(data)))
  }
  object
}

### Local Variables:
### mode:S
### End:

## $Id: newFunc.q,v 1.3 1999/11/17 22:09:19 saikat Exp $
###
###       Functions that are used in several parts of the nlme library 
###                 but do not belong to any specific part
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

allCoef <-
  ## Combines different coefficient vectors into one vector, keeping track
  ## of which coefficients came from which object
  function(..., extract = coef)
{
  dots <- list(...)
  theta <- lapply(dots, extract)
  len <- unlist(lapply(theta, length))
  num <- seq(along = len)
  if (sum(len) > 0) {
    which <- outer(rep(num, len), num, "==")
  } else {
    which <- array(FALSE, c(1, length(len)))
  }
  cnames <- unlist(as.list(sys.call()[-1]))
  dimnames(which) <- list(NULL, cnames[cnames != substitute(extract)])
  theta <- unlist(theta)
  attr(theta, "map") <- which
  theta
}

allVarsRec <-
  ## Recursive version of all.vars
  function(object)
{
  if (is.list(object)) {
    unlist(lapply(object, allVarsRec))
  } else {
    all.vars(object)
  }
}

asOneFormula <- 
  ## Constructs a linear formula with all the variables used in a 
  ## list of formulas, except for the names in omit
  function(..., omit = c(".", "pi"))
{
  names <- unique(allVarsRec((list(...))))
  names <- names[is.na(match(names, omit))]
  if (length(names)) {
    eval(parse(text = paste("~", paste(names, collapse = "+")))[[1]])
  } else NULL
}

compareFits <- 
  ## compares coeffificients from different fitted objects
  function(object1, object2, which = 1:ncol(object1)) 
{
  dn1 <- dimnames(object1)
  dn2 <- dimnames(object2)
  aux <- rep(NA, length(dn1[[1]]))
  if (any(aux1 <- is.na(match(dn2[[2]], dn1[[2]])))) {
    object1[,dn2[[2]][aux1]] <- aux
  }
  if (any(aux1 <- is.na(match(dn1[[2]], dn2[[2]])))) {
    object2[,dn1[[2]][aux1]] <- aux
  }
  dn1 <- dimnames(object1)
  c1 <- deparse(substitute(object1))
  c2 <- deparse(substitute(object2))
  if (any(sort(dn1[[1]]) != sort(dn2[[1]]))) {
    stop("Objects must have coefficients with same row names")
  }
  ## putting object2 in same order
  object2 <- object2[dn1[[1]], dn1[[2]], drop = FALSE]	
  object1 <- object1[, which, drop = FALSE]
  object2 <- object2[, which, drop = FALSE]
  dn1 <- dimnames(object1)
  dm1 <- dim(object1)
  out <- array(0, c(dm1[1], 2, dm1[2]), list(dn1[[1]], c(c1,c2), dn1[[2]]))
  for(i in dn1[[2]]) {
    out[,,i] <- cbind(object1[[i]], object2[[i]])
  }
  class(out) <- "compareFits"
  out
}

contr.SAS<-
  function(n, contrasts = TRUE)
  ## similar to contr.treatment but dropping last column, not first column
{
  if (is.numeric(n) && length(n) == 1)
    levs <- 1:n
  else {
    levs <- n
    n <- length(n)
  }
  contr <- array(0, c(n, n), list(levs, levs))
  contr[seq(1, n^2, n + 1)] <- 1
  if (contrasts) {
    if (n < 2)
      stop(paste("Contrasts not defined for", n - 1, "degrees of freedom"))
    contr <- contr[,  - n, drop = FALSE]
  }
  contr
}

fdHess <- function(pars, fun, ..., .relStep = (.Machine$double.eps)^(1/3),
                   minAbsPar = 0)
  ## Use a Koschal design to establish a second order model for the response
{
  pars <- as.numeric(pars)
  npar <- length(pars)
  incr <- ifelse( abs(pars) <= minAbsPar, minAbsPar * .relStep,
                 abs(pars) * .relStep )
  baseInd <- diag(npar)
  frac <- c(1, incr, incr^2)
  cols <- list(0, baseInd, -baseInd)
  for ( i in seq( along = pars )[ -npar ] ) {
    cols <- c( cols, list( baseInd[ , i ] + baseInd[ , -(1:i) ] ) )
    frac <- c( frac, incr[ i ] * incr[ -(1:i) ] )
  }
  indMat <- do.call( "cbind", cols)
  shifted <- pars + incr * indMat
  indMat <- t(indMat)
  Xcols <- list(1, indMat, indMat^2)
  for ( i in seq( along = pars )[ - npar ] ) {
    Xcols <- c( Xcols, list( indMat[ , i ] * indMat[ , -(1:i) ] ) )
  }
  coefs <- solve( do.call( "cbind", Xcols ) , apply(shifted, 2, fun, ...) )/frac
  Hess <- diag( coefs[ 1 + npar + seq( along = pars ) ], ncol = npar )
  Hess[ row( Hess ) > col ( Hess ) ] <- coefs[ -(1:(1 + 2 * npar)) ]
  list( mean = coefs[ 1 ], gradient = coefs[ 1 + seq( along = pars ) ],
       Hessian = ( Hess + t(Hess) ) )
}

gapply <-
  ## Apply a function to the subframes of a data.frame 
  ## If "apply" were generic, this would be the method for groupedData
  function(object, which, FUN, form = formula(object), level,
           groups = getGroups(object, form, level), ...) 
{
  if (!inherits(object, "data.frame")) {
    stop("Object must inherit from data.frame")
  }
  ## Apply a function to the subframes of a groupedData object
  if (missing(groups)) {                # formula and level are required
    if (!inherits(form, "formula")) {
      stop("\"Form\" must be a formula")
    }
    if (is.null(grpForm <- getGroupsFormula(form, asList = TRUE))) {
      ## will use right hand side of form as groups formula
      grpForm <- splitFormula(asOneSidedFormula(form[[length(form)]]))
    }
    if (missing(level)) level <- length(grpForm)
    else if (length(level) != 1) {
      stop("Only one level allowed in gapply")
    }
    groups <- groups                    # forcing evaluation
  }
  if (!missing(which)) {
    switch(mode(which),
           character = {
             wchNot <- is.na(match(which, names(object)))
             if (any(wchNot)) {
               stop(paste(paste(which[wchNot], collapse = ","),
                          "not matched"))
             }
           },
           numeric = {
             if (any(is.na(match(which, 1:ncol(object))))) {
               stop("Which must be between 1 and", ncol(object))
             }
           },
           stop("Which can only be character or integer.")
           )
    object <- object[, which, drop = FALSE]
  }
  val <- lapply(split(object, groups), FUN, ...)
  if (is.atomic(val[[1]]) && length(val[[1]]) == 1) {
    val <- unlist(val)
  }
  val
}

getCovariateFormula <-
  function(object)
{
  ## Return the primary covariate formula as a one sided formula
  form <- formula(object)
  if (!(inherits(form, "formula"))) {
    stop("\"Form\" must be a formula")
  }
  form <- form[[length(form)]]
  if (length(form) == 3 && form[[1]] == as.name("|")){ # conditional expression
    form <- form[[2]]
  }
  eval(parse(text = paste("~", deparse(form))))
}

getResponseFormula <-
  function(object)
{
  ## Return the response formula as a one sided formula
  form <- formula(object)
  if (!(inherits(form, "formula") && (length(form) == 3))) {
    stop("\"Form\" must be a two sided formula")
  }
  eval(parse(text = paste("~", deparse(form[[2]]))))
}

gsummary <-
  ## Summarize an object according to the levels of a grouping factor
  ##
  function(object, FUN = function(x) mean(x, na.rm = TRUE),
           omitGroupingFactor = FALSE, 
	   form = formula(object), level, 
	   groups = getGroups(object, form , level), 
	   invariantsOnly = FALSE, ...)
{
  if (!inherits(object, "data.frame")) {
    stop("Object must inherit from data.frame")
  }
  if (missing(groups)) {                # formula and level are required
    if (!inherits(form, "formula")) {
      stop("\"Form\" must be a formula")
    }
    if (is.null(grpForm <- getGroupsFormula(form, asList = TRUE))) {
      ## will use right hand side of form as groups formula
      grpForm <- splitFormula(asOneSidedFormula(form[[length(form)]]))
    }
    if (missing(level)) level <- length(grpForm)
    else if (length(level) != 1) {
      stop("Only one level allowed in gsummary")
    }
  }
  gunique <- unique(groups)
  firstInGroup <- match(gunique, groups)
  asFirst <- firstInGroup[match(groups, gunique)]
  value <- as.data.frame(object[firstInGroup, , drop = FALSE])
  row.names(value) <- as.character(gunique)
  value <- value[as.character(sort(gunique)), , drop = FALSE]
  varying <- unlist(lapply(object, 
			   function(column, frst) {
			     aux <- as.character(column)
			     any(aux != aux[frst])
			   },
			   frst = asFirst))
  if (any(varying) && (!invariantsOnly)) { # varying wanted
    Mode <- function(x) {
      aux <- table(x)
      names(aux)[match(max(aux), aux)]
    }
    if (data.class(FUN) == "function") {	# single function given
      FUN <- list(numeric = FUN, ordered = Mode, factor = Mode)
    } else {
      if (!(is.list(FUN) && 
	   all(sapply(FUN, data.class) == "function"))) {
	stop("FUN can only be a function or a list of functions")
      }
      auxFUN <- list(numeric = mean, ordered = Mode, factor = Mode)
      aux <- names(auxFUN)[is.na(match(names(auxFUN), names(FUN)))]
      if (length(aux) > 0) FUN[aux] <- auxFUN[aux]
    }
    for(nm in names(object)[varying]) {
      dClass <- data.class(object[[nm]])
      if (dClass == "numeric") {
	value[[nm]] <- as.vector(tapply(object[[nm]], groups, FUN[["numeric"]],...))
      } else {
	value[[nm]] <- 
	  as.vector(tapply(as.character(object[[nm]]), groups, FUN[[dClass]]))
        if (inherits(object[,nm], "ordered")) {
          value[[nm]] <- pruneLevels(ordered(value[,nm],
                                            levels = levels(object[,nm])))
        } else {
          value[[nm]] <- pruneLevels(factor(value[,nm],
                                           levels = levels(object[,nm])))
        }
      }
    }
  } else {				# invariants only
    value <- value[, !varying, drop = FALSE]
  }
  if (omitGroupingFactor) {
    if (is.null(form)) {
      stop("Cannot omit grouping factor without \"form\"")
    }
    grpForm <- getGroupsFormula(form, asList = TRUE)
    if (missing(level)) level <- length(grpForm)
    grpNames <- names(grpForm)[level]
    whichKeep <- is.na(match(names(value), grpNames))
    if (any(whichKeep)) {
      value <- value[ , whichKeep, drop = FALSE]
    } else {
      return(NULL);
    }
  }
  value
}

pooledSD <-
  function(object)
{
  if (!inherits(object, "lmList")) {
    stop("Object must inherit from class \"lmList\"")
  }
  aux <- apply(sapply(object, 
		      function(el) {
			if (is.null(el)) {
			  c(0,0)
			} else {
			  aux <- resid(el)
			  c(sum(aux^2), length(aux) - length(coef(el)))
			}
		      }), 1, sum)
  if (aux[2] == 0) {
    stop("No degrees of freedom for estimating std. dev.")
  }
  val <- sqrt(aux[1]/aux[2])
  attr(val, "df") <- aux[2]
  val
}

splitFormula <-
  ## split, on the nm call, the rhs of a formula into a list of subformulas
  function(form, sep = "/")
{
  if (inherits(form, "formula") ||
      mode(form) == "call" && form[[1]] == as.name("~"))
    return(splitFormula(form[[length(form)]], sep = sep))
  if (mode(form) == "call" && form[[1]] == as.name(sep))
    return(do.call("c", lapply(as.list(form[-1]), splitFormula, sep = sep)))
  if (mode(form) == "(") return(splitFormula(form[[2]], sep = sep))
  if (length(form) < 1) return(NULL)
  list(asOneSidedFormula(form))
}

##*## phenoModel - one-compartment open model with intravenous
##*##   administration and first-order elimination for the Phenobarbital data

phenoModel <- 
  function(Subject, time, dose, lCl, lV)
{
  .C("nlme_one_comp_first",
     as.integer(length(time)),
     resp = as.double(dose),
     as.double(cbind(Subject, time, dose, exp(lV), exp(lCl))),
     NAOK = T, PACKAGE = "nlme")$resp
}

##*## quinModel - one-compartment open model with first order
##*##   absorption for the Quinidine data

quinModel <- 
  function(Subject, time, conc, dose, interval, lV, lKa, lCl)
{
  .C("nlme_one_comp_open",
     as.integer(length(time)),
     resp = as.double(dose),
     as.double(cbind(Subject, time, conc, dose, interval,
                     exp(lV), exp(lKa), exp(lCl - lV))),
     NAOK = T, PACKAGE = "nlme")$resp
}


##
## fake version of xyplot using coplot just so some of the plots from the
## library can be drawn

xyplot <- function (formula, data = list(), groups = NULL, ..., subset = TRUE) 
{
  args <- as.list(match.call())[-1]
  do.call("coplot", c(args[match(c("formula", "data", "xlab", "ylab", "panel"), 
                     names(args), 0)], list(show.given = FALSE) ) )
}

## Local Variables:
## mode:S
## End:

### $Id: newGenerics.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###    New generics used with corStruct, varFunc, groupedData, and reStruct
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

ACF <-
  ## autocorrelation function - needed not exist if acf were generic
  function(object, maxLag, ...) UseMethod("ACF")

AIC <-
  ## Return the object's value of the Aikaike Information Criterion
  function(object, ...) UseMethod("AIC")

BIC <-
  ## Return the object's value of the Bayesian Information Criterion
  function(object, ...) UseMethod("BIC")

asTable <-
  ## Return the object in a tabular form
  function(object) UseMethod("asTable")

augPred <-
  ## Return the data used to fit the model augmented with the predictions
  function(object, primary = NULL, minimum = min(primary),
           maximum = max(primary), length.out = 51, ...) UseMethod("augPred") 

"coef<-" <- "coefficients<-" <-
  ## Assignment of the unconstrained parameter
  function(object, value) UseMethod("coef<-")

collapse <- 
  ## collapse a data frame according to a factor, or several nested factors 
  function(object, ...) UseMethod("collapse")

comparePred <-
  ## compare predictions from different fitted objects
  function(object1, object2, primary = NULL, 
	   minimum = min(primary), maximum = max(primary),
	   length.out = 51, level = NULL, ...) UseMethod("comparePred")

"covariate<-" <-
  ## Assignment of the primary covariate
  function(object, value) UseMethod("covariate<-")

Dim <-
  ## Extract dimensions of an object. Not needed if "dims" were generic
  function(object, ...) UseMethod("Dim")

fixed.effects <-
  ## Generic extractor for estimates of fixed effects
  function(object, ...) UseMethod("fixef")

fixef <-
  ## Short form for generic extractor for estimates of fixed effects
  function(object, ...) UseMethod("fixef")

getCovariate <-
  ## Return the primary covariate associated with object according to form
  function(object, form = formula(object), data) 
    UseMethod("getCovariate")

getData <-
  ## Return the data.frame used to fit an object, if any was given in
  ## the call that produced it
  function(object) UseMethod("getData")

getGroups <-
  ## Return the groups associated with object according to form.
  function(object, form = formula(object), level, data, sep = "/") 
    UseMethod("getGroups")

getGroupsFormula <- 
  ## Return the formula(s) for the groups associated with object.
  ## The result is a one-sided formula unless asList is TRUE in which case
  ## it is a list of formulas, one for each level.
  function(object, asList = FALSE, sep = "/")
    UseMethod("getGroupsFormula")

getResponse <-
  ## Return the response associated with object according to form.
  function(object, form = formula(object))
    UseMethod("getResponse")

isBalanced <-
  ## Check for balance, especially in a groupedData object
  function(object, countOnly = FALSE, level) UseMethod("isBalanced")

isInitialized <-
  ## Determine if the object has been assigned a value
  function(object) UseMethod("isInitialized")

initialize <-
  ## Initialize  objects
  function(object, data, ...) UseMethod("initialize")

intervals <- 
  ## generate confidence intervals for the parameters in object
  function(object, level = 0.95, ...) UseMethod("intervals")

logDet <-
  ## Returns the negative of the sum of the logarithm of the determinant
  function(object, ...) UseMethod("logDet")

"matrix<-" <-
  ## Assignment of the matrix in an object representing special types of matrices
  function(object, value) UseMethod("matrix<-")

Names <-
  ## Extract names of an object. Not needed if "names" were generic
  function(object, ...) UseMethod("Names")

"Names<-" <-
  ## Assignment of names. Not needed if "names<-" were generic
  function(object, ..., value) UseMethod("Names<-")

needUpdate <-
  ## Checks if model plug-in needs to be updated after an estimation cycle
  function(object) UseMethod("needUpdate")

pruneLevels <-
  ## Returns the factor with the levels attribute truncated to only those
  ## levels occuring in the factor
  function(object) UseMethod("pruneLevels")

random.effects <-
  ## Generic function for extracting the random effects
  ## If aug.frame is true, the returned data frame is augmented with 
  ## values from the original data object, if available.  The variables
  ## in the original data are collapsed over the groups variable by the
  ## function fun.
  function(object, ...) UseMethod("ranef")

ranef <-
  ## Short form for generic function for extracting the random effects
  function(object, ...) UseMethod("ranef")

recalc <-
  ## Recalculate condensed linear object, according to model plug-in
  function(object, conLin, ...) UseMethod("recalc")

Variogram <-
  ## calculates variogram of a vector according to a distance matrix
  function(object, distance, ...)
  UseMethod("Variogram")

### Local variables:
### mode: S
### End:

### $Id: newMethods.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###      Methods for generics from newGenerics.q for some standard classes
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


##*## Methods for some of the generics in newGenerics.q for standard classes

AIC.logLik <-
  ## AIC for logLik objects
  function(object)
{
  -2 * (c(object) - attr(object, "df"))
}

AIC.lm <- AIC.nls <- 
  ## AIC for various fitted objects
  function(object, ...) 
{
  if((rt <- nargs()) > 1) {
    object <- list(object, ...)
    val <- lapply(object, logLik)
    val <- 
      as.data.frame(t(sapply(val, function(el) c(attr(el, "df"), AIC(el)))))
    names(val) <- c("df", "AIC")
    row.names(val) <- as.character(match.call()[-1])
    val
  } else {
    AIC(logLik(object))
  }
}

BIC.logLik <-
  ## BIC for logLik objects
  function(object)
{
  -2 * (c(object) - attr(object, "df") * log(attr(object, "nobs"))/2)
}

BIC.lm <- BIC.nls <- 
  ## BIC for various fitted objects
  function(object, ...) 
{
  if((rt <- nargs()) > 1) {
    object <- list(object, ...)
    val <- lapply(object, logLik)
    val <- 
      as.data.frame(t(sapply(val, function(el) c(attr(el, "df"), BIC(el)))))
    names(val) <- c("df", "BIC")
    row.names(val) <- as.character(match.call()[-1])
    val
  } else {
    BIC(logLik(object))
  }
}

Dim.default <- function(object) dim(object)

getCovariate.data.frame <-
  function(object, form = formula(object), data)
{
  ## Return the primary covariate
  if (!(inherits(form, "formula"))) {
    stop("\"Form\" must be a formula")
  }
  aux <- getCovariateFormula(form)
  if (length(all.vars(aux)) > 0) {
    eval(aux[[2]], object)
  } else {
    rep(1, dim(object)[1])
  }
}

getData.nls <-
  function(object)
{
  mCall <- object$call
  data <- eval(mCall$data)
  if (is.null(data)) return(data)
  naAct <- eval(mCall$na.action)
  if (!is.null(naAct)) {
    data <- naAct(data)
  }
  subset <- mCall$subset
  if (!is.null(subset)) {
    subset <- eval(asOneSidedFormula(subset)[[2]], data)
    data <- data[subset, ]
  }
  data
}

getGroups.data.frame <-
  ## Return the groups associated with object according to form for level
  function(object, form = formula(object), level, data, sep = "/")
{
  if (!missing(data)) {
    stop( "data argument to data.frame method for getGroups doesn't make sense" )
  }
  if (inherits(form, "formula")) {
    grpForm <- getGroupsFormula(form, asList = TRUE, sep = sep)
    if (is.null(grpForm)) {
      ## will use right hand side of form as the group formula
      grpForm <- splitFormula(asOneSidedFormula(form[[length(form)]]),
                              sep = sep)
      names(grpForm) <-
        unlist( lapply( grpForm, function(el) deparse( el[[ length(el) ]] ) ) )
    }
    if (any(unlist(lapply(grpForm,
#                          function(el) length(el[[length(el)]]))) != 1)) {
                          function(el) length(all.vars(el)))) != 1)) {
      stop("Invalid formula for groups")
    }
    form <- grpForm
  } else if (data.class(form) == "list") {
    if (!all(unlist(lapply(form, function(el) inherits(el, "formula"))))) {
      stop("Form must have all components as formulas") 
    }
  } else {
    stop("Form can only be a formula, or a list of formulas")
  }
  vlist <- lapply(form,
                  function(x, dat, N) {
                    val <- eval(x[[length(x)]], dat)
                    if (length(val) == 1) {             # repeat groups
                      return(as.factor(rep(val, N)))
                    } else {
                      return(pruneLevels(as.factor(val)))
                    }
                  }, dat = object, N = nrow(object))
  if (length(vlist) == 1) return(vlist[[1]]) # ignore level - only one choice
  ## make the list into a data frame with appropriate names
  value <- do.call("data.frame", vlist)
  if (missing(level)) return(value)
  if (is.character(level)) {
    nlevel <- match(level, names(flist))
    if (any(aux <- is.na(nlevel))) {
      stop(paste("Level of", level[aux],"does not match formula \"",
		 deparse(as.vector(form)), "\""))
    }
  } else {
    nlevel <- as.numeric(level)
    if (any(aux <- is.na(match(nlevel, 1:ncol(value))))) { 
      stop(paste("level of ", level[aux]," does not match formula \"", 
	       deparse(as.vector(form)), "\""))
    }
  }
  if (length(nlevel) > 1)  return(value[, nlevel]) # multicolumn selection
  if (nlevel == 1)         return(value[, 1])     # no need to do more work
  value <- value[, 1:nlevel]
  val <- as.factor(do.call("paste", c(lapply(as.list(value),
					     as.character), sep = sep)))
  if (inherits(value[, 1], "ordered")) {
    value <- value[do.call("order", value),]
    aux <- unique(do.call("paste", c(lapply(as.list(value), 
					    as.character), sep = sep)))
    return(ordered(val, aux))
  } else {
    return(ordered(val, unique(as.character(val))))
  }
}

getResponse.data.frame <-
  function(object, form = formula(object))
{
  ## Return the response, the evaluation of the left hand side of a formula
  ## on object
  if (!(inherits(form, "formula") && (length(form) == 3))) {
    stop("\"Form\" must be a two sided formula")
  }
  eval(form[[2]], object)
}

getGroupsFormula.default <-
  ## Return the formula(s) for the groups associated with object.
  ## The result is a one-sided formula unless asList is TRUE in which case
  ## it is a list of formulas, one for each level.
  function(object, asList = FALSE, sep = "/")
{
  form <- formula(object)
  if (!inherits(form, "formula")){
    stop("\"Form\" argument must be a formula")
  }
  form <- form[[length(form)]]
  if (!((length(form) == 3) && (form[[1]] == as.name("|")))) {
    ## no conditioning expression
    return(NULL)
  } 
  ## val <- list( asOneSidedFormula( form[[ 3 ]] ) )
  val <- splitFormula(asOneSidedFormula(form[[3]]), sep = sep)
  names(val) <- unlist(lapply(val, function(el) deparse(el[[2]])))
#  if (!missing(level)) {
#    if (length(level) == 1) {
#      return(val[[level]])
#    } else {
#      val <- val[level]
#    }
#  } 
  if (asList) as.list(val)
  else as.formula(eval(parse(text = paste("~",  paste(names(val),
                               collapse = sep)))))
}

logLik.lm <-
  ## log-likelihood for lm objects
  function(object, REML = FALSE)
{
  res <- resid(object)
  p <- object$rank
  N <- length(res) 
  if(is.null(w <- object$weights)) {	
    w <- rep(1, N)
  } else {
    excl <- w == 0			# eliminating zero weights
    if (any(excl)) {
      res <- res[!excl]
      N <- length(res)
      w <- w[!excl]
    }
  }
  
  N <- N - p * REML
  val <- (sum(log(w)) -N * (log(2 * pi) + 1 - log(N) +
           log(sum(w*res^2))))/2 -
             REML * sum(log(abs(diag(object$qr$qr)[1:p])))
  attr(val, "nall") <- N + REML * p
  attr(val, "df") <- p + 1
  attr(val, "nobs") <- N
  class(val) <- "logLik"
  val
}

Names.formula <-
  function(object, data = list(), exclude = c("pi", "."))
{
  if (!is.list(data)) { return(NULL) }  # no data to evaluate variable names
  allV <- all.vars(object)
  allV <- allV[is.na(match(allV, exclude))]

  if (length(allV) == 0) {
    if (attr(terms(object), "intercept")) { return("(Intercept)") }
    return(NULL)
  }

  if (any(is.na(match(allV, names(data))))) { return(NULL) }
  dimnames(model.matrix(object, model.frame(object, data)))[[2]]
}

Names.listForm <-
  function(object, data = list(), exclude = c("pi", "."))
{
  pnames <- as.character(unlist(lapply(object, "[[", 2)))
  nams <- lapply(object, function(el, data, exclude) {
    Names(getCovariateFormula(el), data, exclude)
    }, data = data, exclude = exclude)
  if (is.null(nams[[1]])) return(NULL)
  val <- c()
  for(i in seq(along = object)) {
    if ((length(nams[[i]]) == 1) && (nams[[i]] == "(Intercept)")) {
      val <- c(val, pnames[i])
    } else {
      val <- c(val, paste(pnames[i], nams[[i]], sep = "."))
    }
  }
  val
}

needUpdate.default <-
  function(object)
{
  val <- attr(object, "needUpdate")
  if (is.null(val) || !val) FALSE
  else TRUE
}

pairs.compareFits <-
  function(object, subset, key = TRUE, ...)
{

  if(!missing(subset)) {
    object <- object[subset,,]
  }
  dims <- dim(object)
  if(dims[3] == 1) {
    stop("At least two coefficients are needed.")
  }
  dn <- dimnames(object)
  coefs <- array(c(object), c(dims[1]*dims[2], dims[3]),
		 list(rep(dn[[1]], dims[2]), dn[[3]]))
  if(dims[3] > 2) {			# splom
    tt <- list(coefs = coefs,
	       grp = ordered(rep(dn[[2]], rep(dims[1], dims[2])), 
		   levels  = dn[[2]]))
    args <- list(formula = ~ coefs,
		  data = tt,
		  groups = tt$grp,
		  panel = function(x, y, subscripts, groups, ...)
		  {
		    panel.superpose(x, y, subscripts, groups)
		    aux <- groups[subscripts]
		    aux <- aux == unique(aux)[1]
		    segments(x[aux], y[aux], x[!aux], y[!aux], 
			     lty = 2, lwd = 0.5)
		  })
  } else {
    tt <- list(x = coefs[,1], y = coefs[,2],
	       grp = ordered(rep(dn[[2]], rep(dims[1], dims[2])),
		   levels = dn[[2]]))
    args <- list(formula = y ~ x,
		  data = tt,
		  groups = tt$grp,
		  panel = function(x, y, subscripts, groups, ...)
		  {
		    panel.grid()
		    panel.superpose(x, y, subscripts, groups)
		    aux <- groups[subscripts]
		    aux <- aux == unique(aux)[1]
		    segments(x[aux], y[aux], x[!aux], y[!aux], 
			     lty = 2, lwd = 0.5)
		  }, xlab = dn[[3]][1], ylab = dn[[3]][2])
  }
  dots <- list(...)
  args[names(dots)] <- dots
  if(is.logical(key)) {
    if(key && length(unique(tt$grp)) > 1) {
      args[["key"]] <- 
	list(points = Rows(trellis.par.get("superpose.symbol"), 1:2),
	     text = list(levels = levels(tt$grp)), columns = 2)
    }
  } else {
    args[["key"]] <- key
  }
  if(dims[3] > 2) do.call("splom", args) else do.call("xyplot", args)
}

plot.nls <-
  function(object, form = resid(., type = "pearson") ~ fitted(.), abline, 
	   id = NULL, idLabels = NULL, idResType = c("pearson", "normalized"),
           grid, ...)  
  ## Diagnostic plots based on residuals and/or fitted values
{
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }
  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL
  if (inherits(data, "groupedData")) {	# save labels and units, if present
    ff <- formula(data)
    rF <- deparse(getResponseFormula(ff)[[2]])
    cF <- deparse(getCovariateFormula(ff)[[2]])
    lbs <- attr(data, "labels")
    unts <- attr(data, "units")
    if (!is.null(lbs$x)) cL <- paste(lbs$x, unts$x) else cF <- NULL
    if (!is.null(lbs$y)) rL <- paste(lbs$y, unts$y) else rF <- NULL
  } else {
    rF <- cF <- NULL
  }

  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()
  ## appending object to data
  data <- as.list(c(as.list(data), . = list(object)))
  ## covariate - must always be present
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], data)
  if (!is.numeric(.x)) {
    stop("Covariate must be numeric")
  }
  argForm <- ~ .x
  argData <- data.frame(.x = .x)
  if (is.null(xlab <- attr(.x, "label"))) {
    xlab <- deparse(covF[[2]])
    if (!is.null(cF) && (xlab == cF)) xlab <- cL  #### BUG!!!!
    else if (!is.null(rF) && (xlab == rF)) xlab <- rL
  }
  if (is.null(args$xlab)) args$xlab <- xlab
      
  ## response - need not be present
  respF <- getResponseFormula(form)
  if (!is.null(respF)) {
    .y <- eval(respF[[2]], data)
    if (is.null(ylab <- attr(.y, "label"))) {
      ylab <- deparse(respF[[2]])
      if (!is.null(cF) && (ylab == cF)) ylab <- cL
      else if (!is.null(rF) && (ylab == rF)) ylab <- rL
    }
    argForm <- .y ~ .x
    argData[, ".y"] <- .y
    if (is.null(args$ylab)) args$ylab <- ylab
  }

  ## groups - need not be present
  grpsF <- getGroupsFormula(form)
  if (!is.null(grpsF)) {
    gr <- splitFormula(grpsF, sep = "*")
    for(i in 1:length(gr)) {
      auxGr <- all.vars(gr[[i]])
      for(j in auxGr) {
        argData[[j]] <- eval(as.name(j), data)
      }
    }
    if (length(argForm) == 2)
      argForm <- eval(parse(text = paste("~ .x |", deparse(grpsF[[2]]))))
    else argForm <- eval(parse(text = paste(".y ~ .x |", deparse(grpsF[[2]]))))
  }
  ## adding to args list
  args <- c(args, formula = list(argForm), data = list(argData))
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  if (!is.null(id)) {			# identify points in plot
    idResType <- match.arg(idResType)
    id <- 
      switch(mode(id),
	     numeric = {
	       if ((id <= 0) || (id >= 1)) {
		 stop("Id must be between 0 and 1")
	       }
	       as.logical(abs(resid(object, type = idResType)) >
                          -qnorm(id / 2))
	     },
	     call = eval(asOneSidedFormula(id)[[2]], data),
	     stop("\"Id\" can only be a formula or numeric.")
	     )
    if (is.null(idLabels)) {
      idLabels <- getGroups(object)
      if (length(idLabels) == 0) idLabels <- 1:object$dims$N
      idLabels <- as.character(idLabels)
    } else {
      if (mode(idLabels) == "call") {
	idLabels <-
	  as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
      } else if (is.vector(idLabels)) {
	if (length(idLabels <- unlist(idLabels)) != length(id)) {
	  stop("\"IdLabels\" of incorrect length")
	} 
	idLabels <- as.character(idLabels)
      } else {
	stop("\"IdLabels\" can only be a formula or a vector")
      }
    }
  }

  ## defining abline, if needed
  if (missing(abline)) {
    if (missing(form)) {		# r ~ f
      abline <- c(0, 0)
    } else {
      abline <- NULL
    }
  } 

  assign("id", id , where = 1)
  assign("idLabels", idLabels, where = 1)
  assign("abl", abline, where = 1)

  ## defining the type of plot
  if (length(argForm) == 3) {
    if (is.numeric(.y)) {		# xyplot
      plotFun <- "xyplot"
      if (is.null(args$panel)) {
        args <- c(args, 
                  panel = list(function(x, y, subscripts, ...) 
		    {
                      dots <- list(...)
		      if (grid) panel.grid()
		      panel.xyplot(x, y, ...)
                      if (!all(is.na(aux <- id[subscripts])) &&
                          !is.null(aux) && any(aux)) {
			text(x[aux], y[aux], idLabels[subscripts][aux],
                             cex = dots$cex, adj = dots$adj)
		      }
		      if (!is.null(abl)) {
			panel.abline(abl, ...)
		      }
		    }))
      }
    } else {				# assume factor or character
      plotFun <- "bwplot"
      if (is.null(args$panel)) {
        args <- c(args, 
                  panel = list(function(x, y, ...) 
		    {
		      if (grid) panel.grid()
		      panel.bwplot(x, y, ...)
		      if (!is.null(abl)) {
			panel.abline(v = abl[1], ...)
		      }
		    }))
      }
    }
  } else {
    plotFun <- "histogram"
    if (is.null(args$panel)) {
      args <- c(args, 
                panel = list(function(x, y, ...) 
		  {
		    if (grid) panel.grid()
		    panel.histogram(x, y, ...)
		    if (!is.null(abl)) {
		      panel.abline(v = abl[1], ...)
		    }
		  }))
    }
  }

  ## defining grid
  if (missing(grid)) {
    if (plotFun == "xyplot") grid <- TRUE
    else grid <- FALSE
  }
  assign("grid", grid, where = 1)
  do.call(plotFun, as.list(args))
}
  
pruneLevels.factor <-
  function(object)
{
  levs <- levels(object)
  factor(as.character(object),
         levels = levs[!is.na(match(levs, as.character(object)))])
}

pruneLevels.ordered <-
  function(object)
{
  levs <- levels(object)
  ordered(as.character(object),
          levels = levs[!is.na(match(levs, as.character(object)))])
}  

##*## Plot method for ACF objects
plot.ACF <-
  function(object, alpha = 0, xlab = "Lag", ylab = "Autocorrelation",
           grid = FALSE, ...)
{
  ylim <- range(object$ACF)
  if (alpha) {
    assign("stdv",  qnorm(1-alpha/2)/sqrt(attr(object,"n.used")),
           frame = 1)
    stMax <- max(stdv)
    ylim <- c(min(c(-stMax, ylim[1])), max(c(ylim[2], stMax)))
  }
  assign("alpha", as.logical(alpha))
  assign("grid", grid)
  xyplot(ACF ~ lag, object, ylim = ylim,
         panel = function(x, y) {
           if (grid) panel.grid()
           panel.xyplot(x, y, type = "h")
           panel.abline(0, 0)
           if (alpha) {
             lines(x, stdv, lty = 2)
             lines(x, -stdv, lty = 2)
           }
         }, xlab = xlab, ylab = ylab, ...)
}

plot.augPred <-
  function(x, key = TRUE, grid = FALSE, ...)
{
  labels <- list(xlab = paste(attr(x, "labels")$x, attr(x, "units")$x),
		 ylab = paste(attr(x, "labels")$y, attr(x, "units")$y))
  labels <- labels[unlist(lapply(labels, function(el) length(el) > 0))]
  args <- c(list(formula = attr(x, "formula"),
		 groups = as.name(".type"),
		 data = x,
		 strip = function(...) strip.default(..., style = 1),
		 panel = if (length(levels(x[[".type"]])) == 2) {
                   ## single prediction level
                   function(x, y, subscripts, groups, ...) {
                     if (grid) panel.grid()
                     orig <- groups[subscripts] == "original"
                     panel.xyplot(x[orig], y[orig], ...)
                     panel.xyplot(x[!orig], y[!orig], ..., type = "l")
                   }
                 } else {             # multiple prediction levels
                   function(x, y, subscripts, groups, ...) {
                     if (grid) panel.grid()
                     orig <- groups[subscripts] == "original"
                     panel.xyplot(x[orig], y[orig], ...)
                     panel.superpose(x[!orig], y[!orig], subscripts[!orig],
                                     groups, ..., type = "l")
                   }
                 }), labels)
  ## perhaps include key argument allowing logical values
  dots <- list(...)
  args[names(dots)] <- dots
  if (is.logical(key) && key) {
    levs <- levels(x[[".type"]])
    if ((lLev <- length(levs)) > 2) {	# more than one levels
      lLev <- lLev - 1
      levs <- levs[1:lLev]
      aux <- !is.na(match(substring(levs, 1, 8), "predict."))
      if (sum(aux) > 0) {
	levs[aux] <- substring(levs[aux], 9)
      }
      args[["key"]] <- 
	list(lines = c(Rows(trellis.par.get("superpose.line"), 1:lLev),
		       list(size = rep(3, lLev))),
	     text = list(levels = levs), columns = lLev)
    } 
  } else {
    args[["key"]] <- key
  }
  assign("grid", grid)
  do.call("xyplot", args)
}

plot.compareFits <-
  function(object, subset, key = TRUE, mark = NULL, ...)
{

  if(!missing(subset)) {
    object <- object[subset,,]
  }
  dims <- dim(object)
  dn <- dimnames(object)
  assign("mark", rep(mark, rep(dims[1] * dims[2], dims[3])))
  tt <- data.frame(group = ordered(rep(dn[[1]], dims[2] * dims[3]),
		       levels = dn[[1]]),
		   coefs = as.vector(object),
		   what = ordered(rep(dn[[3]],
		       rep(dims[1] * dims[2], dims[3])), levels = dn[[3]]),
		   grp = ordered(rep(rep(dn[[2]], rep(dims[1], dims[2])), 
		       dims[3]), levels = dn[[2]]))
  args <- list(formula = group ~ coefs | what,
	       data = tt,
	       scales = list(x=list(relation="free")),
	       strip = function(...) strip.default(..., style = 1),
	       xlab = "",
	       groups = tt$grp,
	       panel = function(x, y, subscripts, groups, ...)
	       {
		 dot.line <- trellis.par.get("dot.line")
		 panel.abline(h = y, lwd = dot.line$lwd, 
			      lty = dot.line$lty, col = dot.line$col)
		 if(!is.null(mark)) {
		   panel.abline(v = mark[subscripts][1], lty = 2)
		 }
		 panel.superpose(x, y, subscripts, groups)
	       })
  dots <- list(...)
  args[names(dots)] <- dots
  if(is.logical(key)) {
    if(key && length(unique(tt$grp)) > 1) {
      args[["key"]] <- 
	list(points = Rows(trellis.par.get("superpose.symbol"), 1:2),
	     text = list(levels = levels(tt$grp)), columns = 2)
    }
  } else {
    args[["key"]] <- key
  }
  do.call("dotplot", args)
}

plot.Variogram <-
  function(object, smooth, showModel, sigma = NULL, span = 0.6,
           xlab = "Distance", ylab = "Semivariogram", type = "p", ylim,
           grid = FALSE, ...)
{
  trlLin <- trellis.par.get("superpose.line")
  coll <- attr(object, "collapse")
  modVrg <- attr(object, "modelVariog")
  lineT <- 1
  if (!is.na(match(type, c("l","o","b")))) {
    lineT <- lineT + 1
  }
  if (missing(showModel)) {
    showModel <- !is.null(modVrg)
  }
  if (showModel) {
    if (is.null(modVrg)) {
      stop("No model variogram available, with showModel = TRUE")
    }
    assign("ltyM", trlLin$lty[lineT])
    assign("colM", trlLin$col[lineT])
    assign("modVrg", modVrg)
    lineT <- lineT + 1
  }
  if (missing(smooth)) {
    smooth <- !showModel 
  }
  if (smooth) {
    assign("ltyS", trlLin$lty[lineT])
    assign("colS", trlLin$col[lineT])
  }
  assign("smooth", smooth)
  assign("showModel", showModel)
  assign("span", span)
  assign("type", type)
  assign("sigma", sigma)
  assign("grid", grid)
  if (missing(ylim)) {
    ylim <- c(0, max(object$variog))
  }
  xyplot(variog ~ dist, object, ylim = ylim, 
         panel = function(x, y, ...) {
           if (grid) panel.grid()
           panel.xyplot(x, y, type = type, ...)
           if (showModel) {
             panel.xyplot(modVrg$dist, modVrg$variog, type = "l",
                          col = colM, lty = ltyM, ...)
           }
           if (smooth) {
             panel.loess(x, y, span = span, col = colS, lty = ltyS, ...)
           }
           if (!is.null(sigma)) {
             panel.abline(c(sigma, 0), lty = 2)
           }
         }, xlab = xlab, ylab = ylab, ...)
}

print.compareFits <-
  function(x, ...)
{			# Will need to be changed for S4!
  print(unclass(x), ...)
}

print.correlation <-
  ## Print only the lower triangle of a correlation matrix
  function(x, title = " Correlation:", rdig = 3, ...)
{
  p <- dim(x)[2]
  if (p > 1) {
    cat(title, "\n")
    ll <- lower.tri(x)
    x[ll] <- format(round(x[ll], digits = rdig))
    x[!ll] <- ""
    if (!is.null(colnames(x))) {
      colnames(x) <- abbreviate(colnames(x), minlength = rdig + 3)
    }
    print(x[-1,  - p, drop = FALSE], ..., quote = FALSE)
  }
  invisible(x)
}

print.logLik <- 
  function(x, ...) print(c(x), ...)

qqnorm.nls <-
  function(object, form = ~ resid(., type = "p"), abline = NULL,
           id = NULL, idLabels = NULL, grid = FALSE, ...)
  ## normal probability plots for residuals
{
  if (!inherits(form, "formula")) {
    stop("\"Form\" must be a formula")
  }
  ## constructing data 
  allV <- all.vars(asOneFormula(form, id, idLabels))
  allV <- allV[is.na(match(allV,c("T","F","TRUE","FALSE")))]
  if (length(allV) > 0) {
    data <- getData(object)
    if (is.null(data)) {		# try to construct data
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      data <- eval(alist, sys.parent(1))
    } else {
      if (any(naV <- is.na(match(allV, names(data))))) {
	stop(paste(allV[naV], "not found in data"))
      }
    }
  } else data <- NULL
  ## argument list
  dots <- list(...)
  if (length(dots) > 0) args <- dots
  else args <- list()
  ## appending object to data
  data <- as.list(c(as.list(data), . = list(object)))

  ## covariate - must always be present
  covF <- getCovariateFormula(form)
  .x <- eval(covF[[2]], data)
  labs <- attr(.x, "label")
  if (is.null(labs) || ((labs != "Standardized residuals") &&
                        (labs != "Normalized residuals") &&
                        (substring(labs, 1, 9) != "Residuals"))) {
    stop("Only residuals allowed")
  }
  if (is.null(args$xlab)) args$xlab <- labs
  if (is.null(args$ylab)) args$ylab <- "Quantiles of standard normal"
  fData <- qqnorm(.x, plot.it = FALSE)
  data[[".y"]] <- fData$x
  data[[".x"]] <- fData$y
  dform <- ".y ~ .x"
  if (!is.null(grp <- getGroupsFormula(form))) {
    dform <- paste(dform, deparse(grp[[2]]), sep = "|")
  }
  if (!is.null(id)) {			# identify points in plot
    id <- 
      switch(mode(id),
             numeric = {
               if ((id <= 0) || (id >= 1)) {
                 stop("Id must be between 0 and 1")
               }
               if (labs == "Normalized residuals") {
                 as.logical(abs(resid(object, type="normalized"))
                            > -qnorm(id / 2))
               } else {
                 as.logical(abs(resid(object, type="pearson"))
                            > -qnorm(id / 2))
               }
             },
             call = eval(asOneSidedFormula(id)[[2]], data),
             stop("\"Id\" can only be a formula or numeric.")
             )
    if (is.null(idLabels)) {
      idLabels <- getGroups(object)
      if (length(idLabels) == 0) idLabels <- 1:object$dims$N
      idLabels <- as.character(idLabels)
    } else {
      if (mode(idLabels) == "call") {
        idLabels <-
          as.character(eval(asOneSidedFormula(idLabels)[[2]], data))
      } else if (is.vector(idLabels)) {
        if (length(idLabels <- unlist(idLabels)) != length(id)) {
          stop("\"IdLabels\" of incorrect length")
        } 
        idLabels <- as.character(idLabels)
      } else {
        stop("\"IdLabels\" can only be a formula or a vector")
      }
    }
  }
  assign("id", if (is.null(id)) NULL else as.logical(as.character(id)),
         frame = 1)
  assign("idLabels", as.character(idLabels))
  assign("grid", grid)
  assign("abl", abline)
  if (is.null(args$strip)) {
    args$strip <- function(...) strip.default(..., style = 1)
  }
  if (is.null(args$cex)) args$cex <- par("cex")
  if (is.null(args$adj)) args$adj <- par("adj")

  args <- c(list(formula = eval(parse(text = dform)),
                 data = substitute(data)),
                 args)
  if (is.null(args$panel)) {
    args <- c(list(panel = function(x, y, subscripts, ...){
      dots <- list(...)
      if (grid) panel.grid()
      panel.xyplot(x, y, ...)
      if (!all(is.na(aux <- id[subscripts])) &&
          !is.null(aux) && any(aux)) {
        text(x[aux], y[aux], idLabels[subscripts][aux],
             cex = dots$cex, adj = dots$adj)
      }
      if (!is.null(abl)) panel.abline(abl, ...)
    }), args)
  }
  do.call("xyplot", args)
}

Variogram.default <-
  function(object, distance)
{
  ld <- length(distance)
  lo <- length(object)
  if (ld != round(lo*(lo-1)/2)) {
    stop("Distance and object have incompatible lengths")
  }
  val <- outer(object, object, function(x,y) ((x - y)^2)/2)
  val <- val[lower.tri(val)]
  val <- data.frame(variog = val, dist = distance)
  class(val) <- c("Variogram", "data.frame")
  val
}

## Local Variables:
## mode:S
## End:
require(nls)

nonlinModel <- function( modelExpression, env,
                        paramNames = get(".parameters", envir = env)) {
  modelExpression <- modelExpression[[2]]
  thisEnv <- environment()
  offset <- 0
  ind <- vector("list", length(paramNames))
  names(ind) <- paramNames
  for( i in paramNames ) {
    ind[[ i ]] <- offset + seq( along = get(i, envir = env))
    offset <- offset + length( get(i, envir = env) )
  }
  modelValue <- eval(modelExpression, env)
  on.exit(remove(i, offset, paramNames))
  function( newPars) {
    if(!missing(newPars)) {
      for( i in names(ind) ) {
        assign( i, clearNames(newPars[ ind[[i]] ]), envir = env)
      }
      assign("modelValue", eval(modelExpression, env),
             envir = thisEnv)
    }
    modelValue
  }
}

### $Id: nlme.q,v 1.5 1999/11/18 23:56:57 saikat Exp $
###
###            Fit a general nonlinear mixed effects model
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

nlme <- 
  function(model,
	   data = sys.frame(sys.parent()),
	   fixed, 
	   random = fixed,
           groups,
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   method = c("ML", "REML"), 
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  UseMethod("nlme")
}

nlme.nlsList <- 
  function(model,
	   data = sys.frame(sys.parent()),
	   fixed, 
	   random = fixed,
           groups,
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   method = c("ML", "REML"), 
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  thisCall <- as.list(match.call())[-1]
  ## checking the use of arguments defined within the function
  if (any(!is.na(match(names(thisCall),
		       c("fixed", "data", "start"))))) {
    warning(paste("nlme.nlsList will redefine \"fixed\"",
		  "\"data\", and \"start\""))
  }
  method <- match.arg(method)
  REML <- method == "REML"
  ## add model, data, and optionally groups from the call that created model
  last.call <- as.list(attr(model, "call"))[-1]
  last.call$control <- NULL
  last.call$pool <- NULL
  ## was
  ## last.call <- last.call[is.na(match(names(last.call), "control"))]
  thisCall[names(last.call)] <- last.call
  thisModel <- last.call[["model"]]
  thisCall[["model"]] <-
    eval(parse(text=paste(deparse(getResponseFormula(thisModel)[[2]]),
                 deparse(getCovariateFormula(thisModel)[[2]]),sep="~")))
  ## create "fixed" and "start"
  cf <- na.omit(coef(model))
  start <- list(fixed = unlist(lapply(cf, median, na.rm = TRUE)))
  pnames <- names(start$fixed) <- names(cf)
  thisCall[["fixed"]] <- lapply(as.list(pnames), function(el)
                                 eval(parse(text = paste(el, 1, sep = "~"))))
  if (missing(random)) {
    random <- thisCall[["fixed"]]
  }
  reSt <- reStruct(random, data = NULL)
  if (missing(groups)) {
    thisCall[["groups"]] <- groups <- getGroupsFormula(model)
  }
  if (length(reSt) > 1 || length(groups[[2]]) > 1) {
    stop("Can only fit nlsList objects with single grouping variable")
  }
  ranForm <- formula(reSt)[[1]]
  if (!is.list(ranForm)) {
    ranForm <- list(ranForm)
  }
  mData <- thisCall[["data"]]
  if (is.null(mData)) {			# will try to construct
    allV <- unique(unlist(lapply(ranForm, function(el) all.vars(el[[3]]))))
    if (length(allV) > 0) {
      alist <- lapply(as.list(allV), as.name)
      names(alist) <- allV
      alist <- c(as.list(as.name("data.frame")), alist)
      mode(alist) <- "call"
      mData <- eval(alist, sys.parent(1))
    }
  } else {
    if (mode(mData) == "name" || mode(mData) == "call") {
      mData <- eval(mData)
    } 
  }
  reSt <- reStruct(random, REML = REML, data = mData)
  names(reSt) <- deparse(groups[[2]])
  ## convert list of "name" objects to "character" vector
  rnames <- sapply(lapply(ranForm, "[[", 2), deparse)
  ## if the random effects are a subset of the coefficients,
  ## construct initial estimates for their var-cov matrix
  if (all(match(rnames, pnames, 0))) {
    madRes <- mad(resid(model), na.rm = TRUE)
    madRan <- unlist(lapply(cf, mad, na.rm = TRUE))
    madRan <- madRan[rnames]
    if (isInitialized(reSt)) {
      warning("Initial value for reStruct overwritten in nlme.nlsList")
    }
    matrix(reSt) <- diag((madRan/madRes)^2, ncol = length(rnames))
  }
  thisCall[["start"]] <- start
  thisCall[["random"]] <- reSt
  val <- do.call("nlme.formula", thisCall)
  val$origCall <- match.call()
  val
}


nlme.formula <- 
  function(model,
	   data = sys.frame(sys.parent()),
	   fixed, 
	   random,
           groups,
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   method = c("ML", "REML"), 
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  ## This is the method that actually does the fitting
  finiteDiffGrad <-
	 function(model, data, pars)
	 {
	   dframe <- data.frame(data, pars)
	   base <- eval(model, dframe)
	   nm <- colnames(pars)
	   grad <- array(base, c(length(base), length(nm)), list(NULL, nm))
	   ssize <- sqrt(.Machine$double.eps)
	   for (i in nm) {
	     diff <- pp <- pars[ , i]
	     diff[pp == 0] <- ssize
	     diff[pp != 0] <- pp[pp != 0] * ssize
	     dframe[[i]] <- pp + diff
	     grad[ , i] <- (base - eval(model, dframe))/diff
	     dframe[[i]] <- pp
	   }
	   grad
         }

  ## keeping the call
  Call <- match.call()

  ## control parameters
  controlvals <- nlmeControl()
  if (!missing(control)) {
    if(!is.null(control$nlmStepMax) && control$nlmStepMax < 0) {
      warning("Negative control$nlmStepMax - using default value")
      control$nlmStepMax <- NULL
    }
    controlvals[names(control)] <- control
  }
  ##
  ## checking arguments
  ##
  if (!inherits(model, "formula"))
    stop("\"model\" must be a formula")
  if (length(model)!=3)
    stop("model formula must be of the form \"resp ~ pred\"")

  method <- match.arg(method)
  REML <- method == "REML"
  if (missing(random)) {
    random <- fixed
  }
  reSt <- reStruct(random, REML = REML, data = NULL)
  if (missing(groups)) {
    groups <- getGroupsFormula(reSt)
  }
  if (is.null(groups)) {
    if (inherits(data, "groupedData")) {
      groups <- getGroupsFormula(data)
      namGrp <- rev(names(getGroupsFormula(data, asList = TRUE)))
      Q <- length(namGrp)
      if (length(reSt) != Q) { # may need to repeat reSt
	if (length(reSt) != 1) {
	  stop("Incompatible lengths for \"random\" and grouping factors")
	}
        randL <- vector("list", Q)
        names(randL) <- rev(namGrp)
        for(i in 1:Q) randL[[i]] <- random
        reSt <- reStruct(randL, REML = REML, data = NULL)
      }
    } else {
      ## will assume single group
      groups <- ~ 1
      names(reSt) <- namGrp <- "1"
      
    }
  } else {
    namGrp <- rev(names(getGroupsFormula(eval(parse(text =
                                   paste("~1", deparse(groups[[2]]),sep="|"))),
                        asList = TRUE)))
  }
  names(reSt) <- namGrp
  ##
  ## checking if self-starting formula is given
  ##
  if (missing(start) && !is.null(attr(eval(model[[3]][[1]]), "initial"))) {
    nlmeCall <- Call
    nlsLCall <- nlmeCall[c("","model","data","groups")]
    nlsLCall[[1]] <- as.name("nlsList")
    names(nlsLCall)[2] <- "model"
    for(i in c("data", "groups", "start")) {
      nlmeCall[[i]] <- NULL
    }
    nlmeCall[[1]] <- as.name("nlme.nlsList")
    ## checking if "data" is not equal to sys.frame(sys.parent())
    if (is.null(dim(data))) {
      stop("\"data\" must be given explicitly to use \"nlsList()\"")
    }
    nlsLObj <- eval(nlsLCall)
    nlmeCall[["model"]] <- as.name("nlsLObj")
    nlmeCall <- as.call(nlmeCall)
    val <- eval(nlmeCall)
    val$origCall <- NULL
    return(val)
  }
  if (is.numeric(start)) {               # assume it is the fixed effects
    start <- list(fixed = start)
  }
  nlmeModel <- call("-", model[[2]], model[[3]])
  ##
  ## save writing list(...) when only one element
  ##

  if (!is.list(fixed)) {
    fixed <- list(fixed)
  }
  val <- NULL
  for(i in seq(along = fixed)) {
    if (is.name(fixed[[i]][[2]])) {
      val <- c(val, list(fixed[[i]]))
    } else {
      ## multiple parameters on left hand side
      val <- c(val, eval(parse(text = paste("list(",
           paste(paste(all.vars(fixed[[i]][[2]]), deparse(fixed[[i]][[3]]),
                       sep = "~"), collapse=","),")"))))
    }
  }
  fixed <- as.list(val)
  fnames <- character(length(fixed))
  for (i in seq(along = fixed)) {
    this <- eval(fixed[[i]])
    if (!inherits(this, "formula"))
      stop ("fixed must be a formula or list of formulae")
    if (length(this) != 3)
      stop ("formulae in fixed must be of the form \"parameter ~ expr\".")
    if (!is.name(this[[2]]))
      stop ("formulae in fixed must be of the form \"parameter ~ expr\".")
    fnames[i] <- as.character(this[[2]])
  }
  names(fixed) <- fnames

  ranForm <- formula(reSt)              # random effects formula(s) 
  Q <- length(ranForm)                  # number of groups
  names(ranForm) <- namGrp 
  rnames <- vector("list", Q)
  names(rnames) <- namGrp
  for(i in 1:Q) {
    rnames[[i]] <- character(length(ranForm[[i]]))
    for (j in seq(along = ranForm[[i]])) {
      this <- eval(ranForm[[i]][[j]])
      if (!inherits(this, "formula"))
        stop ("random formula must be a formula or list of formulae")
      if (length(this) != 3)
        stop ("formulae in random must be of the form \"parameter ~ expr\".")
      if (!is.name(this[[2]]))
        stop ("formulae in random must be of the form \"parameter ~ expr\".")
      rnames[[i]][j] <- deparse(this[[2]])
    }
    names(ranForm[[i]]) <- rnames[[i]]
  }
  ## all parameter names
  pnames <- unique(c(fnames, unlist(rnames)))
  ##
  ##  If data is a pframe, copy the parameters in the frame to frame 1
  ##
  if (inherits(data, "pframe")) {
    pp <- parameters(data)
    for (i in names(pp)) {
      assign(i, pp[[i]])
    }
    attr(data,"parameters") <- NULL
    class(data) <- "data.frame"
  }

  ## check if corStruct is present and assign groups to its formula,
  ## if necessary
  if (!is.null(correlation)) {
    if(!is.null(corGrpsForm <- getGroupsFormula(correlation, asList = TRUE))) {
      corGrpsForm <- unlist(lapply(corGrpsForm,
                                   function(el) deparse(el[[2]]))) 
      corQ <- length(corGrpsForm)
      lmeGrpsForm <- unlist(lapply(splitFormula(groups),
                        function(el) deparse(el[[2]])))
      lmeQ <- length(lmeGrpsForm)
      if (corQ <= lmeQ) {
        if (any(corGrpsForm != lmeGrpsForm[1:corQ])) {
          stop(paste("Incompatible formulas for groups in \"random\"",
                     "and \"correlation\""))
        }
        if (corQ < lmeQ) {
          warning(paste("Cannot use smaller level of grouping for",
                        "\"correlation\" than for \"random\". Replacing",
                        "the former with the latter."))
          attr(correlation, "formula") <- 
            eval(parse(text = paste("~", 
                    deparse(getCovariateFormula(formula(correlation))[[2]]),
                         "|", deparse(groups[[2]]))))
        }
      } else {
        if (any(lmeGrpsForm != corGrpsForm[1:lmeQ])) {
          stop(paste("Incompatible formulas for groups in \"random\"",
                     "and \"correlation\""))
        }
      }
    } else {
      ## using the same grouping as in random
      attr(correlation, "formula") <- 
        eval(parse(text = paste("~", 
		     deparse(getCovariateFormula(formula(correlation))[[2]]),
		     "|", deparse(groups[[2]]))))
      corQ <- lmeQ <- 1
    }
    } else {
    corQ <- lmeQ <- 1
  }
  ## create an nlme structure containing the random effects model and plug-ins
  nlmeSt <- nlmeStruct(reStruct = reSt, corStruct = correlation, 
                       varStruct = varFunc(weights))

  ## extract a data frame with enough information to evaluate
  ## form, fixed, random, groups, correlation, and weights
  mfArgs <- list(formula = asOneFormula(formula(nlmeSt), model, fixed,
                   groups, omit = c(pnames, "pi")),
		 data = data, na.action = na.action)
  if (!missing(subset)) {
    mfArgs[["subset"]] <- asOneSidedFormula(Call[["subset"]])[[2]]
  }
  dataMix <- do.call("model.frame", mfArgs)

  origOrder <- row.names(dataMix)	# preserve the original order
  ##
  ## Evaluating the groups expression
  ##  
  grps <- getGroups(dataMix, 
	     eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|"))))
  N <- dim(dataMix)[1]			# number of observations
  ##
  ## evaluating the naPattern expression, if any
  ##
  if (missing(naPattern)) naPat <- rep(TRUE, N)
  else naPat <- as.logical(eval(asOneSidedFormula(naPattern)[[2]], dataMix))
  origOrderShrunk <- origOrder[naPat]

  ## ordering data by groups
  if (inherits(grps, "factor")) {	# single level
    ord <- order(grps)	#"order" treats a single named argument peculiarly
    grps <- data.frame(grps)
    row.names(grps) <- origOrder
    names(grps) <- as.character(deparse((groups[[2]])))
  } else {
    ord <- do.call("order", grps)
    ## making group levels unique
    for(i in 2:ncol(grps)) {
      grps[, i] <-
        as.factor(paste(as.character(grps[, i-1]), as.character(grps[,i]),
                        sep = "/"))
      NULL
    }
  }
  if (corQ > lmeQ) {
    ## may have to reorder by the correlation groups
    ord <- do.call("order", getGroups(dataMix,
                                 getGroupsFormula(correlation)))
  }
  grps <- grps[ord, , drop = FALSE]
  dataMix <- dataMix[ord, ,drop = FALSE]
  revOrder <- match(origOrder, row.names(dataMix)) # putting in orig. order
  naPat <- naPat[ord]			# ordered naPat
  dataMixShrunk <- dataMix[naPat, , drop=FALSE]
  ordShrunk <- ord[naPat]
  grpShrunk <- grps[naPat,, drop = FALSE]
  revOrderShrunk <- match(origOrderShrunk, row.names(dataMixShrunk))
  yShrunk <- eval(model[[2]], dataMixShrunk)

  ##
  ## defining list with parameter information
  ##
  contr <- list()
  plist <- vector("list", length(pnames))
  names(plist) <- pnames
  for (nm in pnames) {
    this <- list(fixed = !is.null(fixed[[nm]]),
                 random = as.list(lapply(ranForm, function(el, nm)
                   !is.null(el[[nm]]), nm = nm)))
    if (this[["fixed"]]) {
      if (fixed[[nm]][[3]] != "1") {
	this[["fixed"]] <-
          model.matrix(asOneSidedFormula(fixed[[nm]][[3]]),
                  model.frame(asOneSidedFormula(fixed[[nm]][[3]]), dataMix))
        auxContr <- attr(this[["fixed"]], "contr")
        contr <- c(contr, auxContr[is.na(match(names(auxContr), names(contr)))])
      }
    }
    if (any(unlist(this[["random"]]))) {
      for(i in 1:Q) {
        wch <- (1:length(rnames[[i]]))[!is.na(match(rnames[[i]], nm))]
        if (length(wch) == 1) {           # only one formula for nm at level i
          if (ranForm[[i]][[nm]][[3]] != "1") {
            this[["random"]][[i]] <-
              model.matrix(asOneSidedFormula(ranForm[[i]][[nm]][[3]]),
                        model.frame(asOneSidedFormula(ranForm[[i]][[nm]][[3]]),
                                    dataMix))
            auxContr <- attr(this[["random"]][[i]], "contr")
            contr <-
              c(contr, auxContr[is.na(match(names(auxContr), names(contr)))])
          }
        } else if (length(wch) > 0) {    # multiple formulas
          this[["random"]][[i]] <-
            as.list(lapply(ranForm[[i]][wch], function(el, data) {
              if (el[[3]] == "1") TRUE
              else model.matrix(asOneSidedFormula(el[[3]]),
                                model.frame(asOneSidedFormula(el[[3]]), data))
            }, data = dataMix))
          for(j in seq(along = this[["random"]][[i]])) {
            if (is.matrix(this[["random"]][[i]][[j]])) {
              auxContr <- attr(this[["random"]][[i]][[j]], "contr")
              contr <-
                c(contr, auxContr[is.na(match(names(auxContr), names(contr)))])
            }
          }
        }
      }
    }
    plist[[nm]] <- this
  }
  if (is.null(sfix <- start$fixed))
    stop ("start must have a component called \"fixed\"")
  ##
  ## Fixed effects names
  ##
  fn <- character(0)
  currPos <- 0
  fixAssign <- list()
  for(nm in fnames) {
    if (is.logical(f <- plist[[nm]]$fixed)) {
      currPos <- currPos + 1
      currVal <- list(currPos)
      if (all(unlist(lapply(plist[[nm]]$random, is.logical)))) {
        fn <- c(fn, nm)
        names(currVal) <- nm
      } else {
        aux <- paste(nm, "(Intercept)", sep=".")
        fn <- c(fn, aux)
        names(currVal) <- aux
      }
      fixAssign <- c(fixAssign, currVal)
    } else {
      currVal <- attr(f, "assign")
      fTerms <- terms(asOneSidedFormula(fixed[[nm]][[3]]))
      namTerms <- attr(fTerms, "term.labels")
      if (attr(fTerms, "intercept") > 0) {
        namTerms <- c("(Intercept)", namTerms)
      }
      namTerms <- factor(currVal, labels = namTerms)
      currVal <- split(order(currVal), namTerms)
      names(currVal) <- paste(nm, names(currVal), sep = ".")
      fixAssign <- c(fixAssign, lapply(currVal,
                                 function(el, currPos) {
                                   el + currPos
                                 }, currPos = currPos))
      currPos <- currPos + length(unlist(currVal))
      fn <- c(fn, paste(nm, colnames(f), sep = "."))
    }
  }
  fLen <- length(fn)
  if (length(sfix) != fLen) 
    stop ("starting values for the fixed component are not the correct length")
  names(sfix) <- fn
  ##
  ## Random effects names
  ##
  rn <- wchRnames <- vector("list", Q)
  names(rn) <- names(wchRnames) <- namGrp
  for(i in 1:Q) {
    rn[[i]] <- character(0)
    uRnames <- unique(rnames[[i]])
    wchRnames[[i]] <- integer(length(uRnames))
    names(wchRnames[[i]]) <- uRnames
    for(j in seq(along = rnames[[i]])) {
      nm <- rnames[[i]][j]
      wchRnames[[i]][nm] <- wchRnames[[i]][nm] + 1
      r <- plist[[nm]]$random[[i]]
      if (data.class(r) == "list") r <- r[[wchRnames[[i]][nm]]]
      if (is.logical(r)) {
        if (r) { 
          if (is.logical(plist[[nm]]$fixed)) {
            rn[[i]] <- c(rn[[i]], nm) 
          } else {
            rn[[i]] <- c(rn[[i]], paste(nm,"(Intercept)",sep="."))
          }
        }
      } else {
        rn[[i]] <- c(rn[[i]], paste(nm, colnames(r), sep = ".")) 
      }
    }
  }
  Names(nlmeSt$reStruct) <- rn
  rNam <- unlist(rn)                    # unlisted names of random effects
  rlength<- unlist(lapply(rn, length))   # number of random effects per stratum
  rLen <- sum(rlength)                  # total number of random effects
  pLen <- rLen + fLen                # total number of parameters
  ncols <- c(rlength, fLen, 1)
  Dims <- MEdims(grpShrunk, ncols)
  if (max(Dims$ZXlen[[1]]) < Dims$qvec[1]) {
    warning(paste("Fewer observations than random effects in all level",
                  Q,"groups"))
  }
  sran <- vector("list", Q)
  names(sran) <- namGrp
  if (!is.null(sran0 <- start$random)) {
    if (inherits(sran0, "data.frame")) {
      sran0 <- list(as.matrix(sran0))
    } else {
      if (!is.list(sran0)) {
        if (!is.matrix(sran0)) {
          stop("Starting values for random effects should be a list, or a matrix")
        }
        sran0 <- list(as.matrix(sran0))
      }
    }
    if (is.null(namSran <- names(sran0))) {
      if (length(sran) != Q) {
        stop(paste("List with starting values for random effects must have names",
                   "or be of length", Q))
      }
      names(sran0) <- rev(namGrp)        # assume given in outer-inner order
    } else {
      if (any(noMatch <- is.na(match(namSran, namGrp)))) {
        stop(paste("Group names not matched in starting values",
                   "for random effects:", paste(namSran[noMatch], collapse=", ")))
      }
    }
  }
  for(i in 1:Q) {
    if (is.null(sran[[i]] <- sran0[[namGrp[i]]])) {
      sran[[i]] <- array(0, c(rlength[i], Dims$ngrps[i]),
                  list(rn[[i]], unique(as.character(grps[, Q-i+1]))))
    } else {
      if (!is.matrix(sran[[i]]))
        stop (paste("starting values for the random components should be",
                    "a list of matrices"))
      dimsran <- dim(sran[[i]])
      if (dimsran[1] != Dims$ngrps[i]) {
        stop (paste("number of rows in starting values for random component",
                  "at level", namGrp[i], "should be", Dims$ngrps[i]))
      }
      if (dimsran[2] != rlength[i]) {
        stop (paste("number of columns in starting values for",
                    "random component at level", namGrp[i],
                    "should be", rlength[i]))
      }
      dnamesran <- dimnames(sran[[i]])
      if (is.null(dnamesran[[1]])) {
        stop("starting values for random effects must include group levels")
      } else {
        levGrps <- unique(as.character(grps[, Q-i+1]))
        if(!all(sort(dnamesran[[1]]) == sort(levGrps))) {
          stop (paste("groups levels mismatch in random and starting values",
                      "for random at level", namGrp[i]))
        }
        sran[[i]] <- sran[[i]][levGrps, , drop = FALSE]
      }
        
      if (!is.null(dnamesran[[2]])) {
        if(!all(sort(dnamesran[[2]]) == sort(rn[[i]]))) {
          ## first try to resolve it
          for(j in 1:rlength[i]) {
            if (is.na(match(dnamesran[[2]][j], rn[[i]]))) {
              if (!is.na(mDn <- match(paste(dnamesran[[2]][j],
                                       "(Intercept)", sep="."), rn[[i]]))) {
                dnamesran[[2]][j] <- rn[[i]][mDn]
              } else {
                if (!is.na(mDn <- match(dnamesran[[2]][j],
                           paste(rn[[i]], "(Intercept)", sep = ".")))) {
                  dnamesran[[2]][j] <- rn[[i]][mDn]
                } else {
                  stop (paste("names mismatch in random and starting values",
                              "for random at level", namGrp[i]))
                }
              }
            }
          }
          dimnames(sran[[i]]) <- dnamesran
        }
        sran[[i]] <- sran[[i]][, rn[[i]], drop = FALSE]
      } else {
        dimnames(sran[[i]])[[2]] <- rn[[i]]
      }
      sran[[i]] <- t(sran[[i]])
    }
  }
  names(sran) <- namGrp
  nPars <- length(unlist(sran)) + fLen  # total number of PNLS parameters
  ##
  ##   defining values of constants used in calculations
  ##
  NReal <- sum(naPat)
  ##
  ## Creating the fixed and random effects maps
  ##
  fmap <- list()
  n1 <- 1
  for(nm in fnames) {
    if (is.logical(f <- plist[[nm]]$fixed)) {
      fmap[[nm]] <- n1
      n1 <- n1 + 1
    } else {
      fmap[[nm]] <- n1:(n1+ncol(f) - 1)
      n1 <- n1 + ncol(f) 
    }
  }
  rmap <- rmapRel <- vector("list", Q)
  names(rmap) <- names(rmapRel) <- namGrp
  n1 <- 1
  startRan <- 0
  for(i in 1:Q) {
    wchRnames[[i]][] <- 0
    rmap[[i]] <- rmapRel[[i]] <- list()
    for(nm in rnames[[i]]) {
      wchRnames[[i]][nm] <- wchRnames[[i]][nm] + 1
      r <- plist[[nm]]$random[[i]]
      if (data.class(r) == "list") {
        r <- r[[wchRnames[[i]][nm]]]
      }
      if (is.logical(r)) {
        val <- n1
        n1 <- n1 + 1
      } else {
        val <- n1:(n1+ncol(r) - 1)
        n1 <- n1 + ncol(r) 
      }
      if (is.null(rmap[[i]][[nm]])) {
        rmap[[i]][[nm]] <- val
        rmapRel[[i]][[nm]] <- val - startRan
      } else {
        rmap[[i]][[nm]] <- c(rmap[[i]][[nm]], list(val))
        rmapRel[[i]][[nm]] <- c(rmapRel[[i]][[nm]], list(val - startRan))
      }
    }
    startRan <- startRan + ncols[i]
  }

  ##
  ## defining the nlFrame
  ##
  grpsRev <- rev(lapply(grps, as.character))
  bmap <- c(0, cumsum(unlist(lapply(sran, function(el) length(as.vector(el))))))
  nlEnv <- new.env()
  nlList <-
                            list(model = nlmeModel,
			    data = dataMix,
			    groups = grpsRev,
			    plist = plist,
			    beta = as.vector(sfix),
                            bvec = unlist(sran),
			    b = sran,
			    X = array(0, c(N, fLen),
			      list(NULL, fn)),
			    Z = array(0, c(N, rLen),
                              list(NULL, rNam)),
			    fmap = fmap,
			    rmap = rmap,
                            rmapRel = rmapRel,
                            bmap = bmap,
                            level = Q,
                            N = N,
                            Q = Q,
                            naPat = naPat,
			    .parameters = c("bvec", "beta"),
                            finiteDiffGrad = finiteDiffGrad)
                       
  lapply(names(nlList), function(x, y, env) assign(x, y[[x]], envir = env),
         nlList, env = nlEnv)
                       
  modelExpression <- ~{
    pars <- getParsNlme(plist, fmap, rmapRel, bmap, groups, beta, bvec, b, level, N)
    res <- eval(model, data.frame(data, pars))
    if (!length(grad <- attr(res, "gradient"))) {
      grad <- finiteDiffGrad(model, data, pars)
    }
    for (nm in names(plist)) {
      gradnm <- grad[, nm]
      if (is.logical(f <- plist[[nm]]$fixed)) {
        if (f) {
          X[, fmap[[nm]]] <- gradnm
        }
      } else {
        X[, fmap[[nm]]] <- gradnm * f
      }
      for(i in 1:Q) {
        if (is.logical(r <- plist[[nm]]$random[[i]])) {
          if (r) {
            Z[, rmap[[i]][[nm]]] <- gradnm
          }
        } else {
          if (data.class(rmap[[i]][[nm]]) != "list") {
            Z[, rmap[[i]][[nm]]] <- gradnm * r
          } else {
            for(j in seq(along = rmap[[i]][[nm]])) {
              if (is.logical(rr <- r[[j]])) {
                Z[, rmap[[i]][[nm]][[j]]] <- gradnm
              } else {
                Z[, rmap[[i]][[nm]][[j]]] <- gradnm * rr
              }
            }
          }
        }
      }
    }
    result <- c(Z[naPat, ], X[naPat, ], res[naPat])
    result[is.na(result)] <- 0
    result
  }

  modelResid <- ~eval(model, data.frame(data,
      getParsNlme(plist, fmap, rmapRel, bmap, groups, beta, bvec, b, level, N)))[naPat]
  ww <- eval(modelExpression[[2]], envir = nlEnv)
  w <- ww[NReal * pLen + (1:NReal)]
  ZX <- array(ww[1:(NReal*pLen)], c(NReal, pLen),
              list(row.names(dataMixShrunk), c(rNam, fn)))
  w <- w + as.vector(ZX[, rLen + (1:fLen), drop = FALSE] %*% sfix)
  if (!is.null(start$random)) {
    startRan <- 0
    for(i in 1:Q) {
      w <- w + as.vector((ZX[, startRan + 1:ncols[i], drop = FALSE] * 
                  t(sran[[i]])[as.character(grpShrunk[, Q-i+1]),,drop = FALSE]) %*%
                         rep(1, ncols[i]))
      startRan <- startRan + ncols[i]
    }
  }
  ## creating the condensed linear model
  attr(nlmeSt, "conLin") <-
    list(Xy = array(c(ZX, w), c(NReal, sum(ncols)), 
	     list(row.names(dataMixShrunk), c(colnames(ZX),
					deparse(model[[2]])))),
	 dims = Dims, logLik = 0)
                
  ## additional attributes of nlmeSt
  attr(nlmeSt, "resp") <- yShrunk
  attr(nlmeSt, "model") <- modelResid
  attr(nlmeSt, "local") <- nlEnv
  attr(nlmeSt, "NReal") <- NReal
  ## initialization
  nlmeSt <- initialize(nlmeSt, dataMixShrunk, grpShrunk,
                       control = controlvals)
  parMap <- attr(nlmeSt, "pmap")

  if (length(coef(nlmeSt)) == length(coef(nlmeSt$reStruct)) &&
      !needUpdate(nlmeSt))  {	# can do one decomposition
    ## need to save conLin for calculating updating between steps
    oldConLin <- attr(nlmeSt, "conLin")
    decomp <- TRUE
  } else decomp <- FALSE

  numIter <- 0				# number of iterations
  pnlsSettings <- c(controlvals$pnlsMaxIter, controlvals$minScale,
                    controlvals$pnlsTol, 0, 0, 0)
  nlModel <- nonlinModel(modelExpression, nlEnv)
  repeat {
  ## alternating algorithm
    numIter <- numIter + 1
    ## LME step
    if (needUpdate(nlmeSt)) {             # updating varying weights
      nlmeSt <- update(nlmeSt, dataMixShrunk)
    }
    if (decomp) {
      attr(nlmeSt, "conLin") <- MEdecomp(oldConLin)
    }
    oldPars <- coef(nlmeSt)
    aNlm <- nlm(f = function(nlmePars) -logLik(nlmeSt, nlmePars),
                p = c(coef(nlmeSt)),
                hessian = TRUE,
                print = ifelse(controlvals$msVerbose, 2, 0),
                stepmax = controlvals$nlmStepMax*max(sqrt(sum(coef(nlmeSt)^2)),
                  1.0),
                check.analyticals=FALSE)
    aConv <- coef(nlmeSt) <- aNlm$estimate
    convIter <- aNlm$iterations # undocumented in nlm!
    nlmeFit <- attr(nlmeSt, "lmeFit") <- MEestimate(nlmeSt, grpShrunk)
    if (verbose) {
      cat("\n**Iteration", numIter)
      cat("\n")
      cat("LME step: Loglik:", format(nlmeFit$logLik),
          ", nlm iterations:", aNlm$iterations, "\n")
      print(nlmeSt)
    }

    ## PNLS step
    if (is.null(correlation)) {
      cF <- 1.0
      cD <- 1
    } else {
      cF <- corFactor(nlmeSt$corStruct)
      cD <- Dim(nlmeSt$corStruct)
    }
    if (is.null(weights)) {
      vW <- 1.0
    } else {
      vW <- varWeights(nlmeSt$varStruct)
    }
    work <- .C("fit_nlme", 
	       thetaPNLS = as.double(c(as.vector(unlist(sran)), sfix)),
               as.double(pdFactor(nlmeSt$reStruct)),
               as.integer(unlist(rev(grpShrunk))),
	       as.integer(unlist(Dims)),
	       as.double(cF),
	       as.double(vW),
               as.integer(unlist(cD)),
	       settings = as.double(pnlsSettings),
	       additional = double(NReal * (pLen + 1)),
	       as.integer(!is.null(correlation)),
	       as.integer(!is.null(weights)),
               nlModel,
	       NAOK = TRUE)
    if (work$settings[4] == 1) {
      convResult <- 2                 
      if (controlvals$returnObject) {
        warning("Step halving factor reduced below minimum in PNLS step")
      } else {
        stop("Step halving factor reduced below minimum in PNLS step")
      }
#      break
    }
    oldPars <- c(sfix, oldPars)
    for(i in 1:Q) sran[[i]][] <- work$thetaPNLS[(bmap[i]+1):bmap[i+1]]
    sfix[] <- work$thetaPNLS[nPars + 1 - (fLen:1)]
    if (verbose) {
      cat("\nPNLS step: RSS = ", format(work$set[6]), "\n fixed effects:")
      for (i in 1:fLen) cat(format(signif(sfix[i]))," ")
      cat("\n iterations:",work$set[5],"\n")
    }
    aConv <- c(sfix, aConv)
    w[] <- work$additional[(NReal * pLen) + 1:NReal]
    ZX[] <- work$additional[1:(NReal * pLen)]
    w <- w + as.vector(ZX[, rLen + (1:fLen), drop = FALSE] %*% sfix)
    startRan <- 0
    for(i in 1:Q) {
      w <- w + as.vector((ZX[, startRan + 1:ncols[i], drop = FALSE] * 
                 t(sran[[i]])[as.character(grpShrunk[, Q-i+1]),,drop = FALSE]) %*%
                         rep(1, ncols[i]))
      startRan <- startRan + ncols[i]
    }
    if (decomp) {
      oldConLin$Xy[] <- c(ZX, w)
      oldConLin$logLik <- 0
    } else {
      attr(nlmeSt, "conLin")$Xy[] <- c(ZX, w)
      attr(nlmeSt, "conLin")$logLik <- 0
    }

    conv <- abs((oldPars - aConv)/
                ifelse(abs(aConv) < controlvals$tolerance, 1, aConv))
    aConv <- c(max(conv[1:fLen]))
    names(aConv) <- "fixed"
    conv <- conv[-(1:fLen)]
    for(i in names(nlmeSt)) {
      if (any(parMap[,i])) {
	aConv <- c(aConv, max(conv[parMap[,i]]))
	names(aConv)[length(aConv)] <- i
      }
    }

    if (verbose) {
      cat("\nConvergence:\n")
      print(aConv)
    }

    if ((max(aConv) <= controlvals$tolerance) ||
        (aConv["fixed"] <= controlvals$tolerance && aNlm$iterations == 1)) {
      convResult <- 0
      break
    }
    if (numIter >= controlvals$maxIter) {
      convResult <- 1
      if (controlvals$returnObject) {
	warning("Maximum number of iterations reached without convergence")
	break
      } else {
	stop("Maximum number of iterations reached without convergence")
      }
    }
  }

  ## wraping up
  if (decomp) {
    nlmeFit <- MEestimate(nlmeSt, grpShrunk, oldConLin)
  } else {
    nlmeFit <- MEestimate(nlmeSt, grpShrunk)
  }
  ## degrees of freedom for fixed effects tests
  fixDF <- getFixDF(ZX[, rLen + (1:fLen), drop = FALSE],
                    grpShrunk, attr(nlmeSt, "conLin")$dims$ngrps, fixAssign)

  attr(fixDF, "varFixFact") <- nlmeFit$sigma * nlmeFit$varFix 
  varFix <- crossprod(nlmeFit$sigma * nlmeFit$varFix)
  dimnames(varFix) <- list(fn, fn)
  ##
  ## fitted.values and residuals (in original order)
  ##
  if (decomp) {
    Resid <- resid(nlmeSt, level = 0:Q, oldConLin)[revOrderShrunk, ]
  } else {
    Resid <- resid(nlmeSt, level = 0:Q)[revOrderShrunk, ]
  }
  Fitted <- yShrunk[revOrderShrunk] - Resid
  grpShrunk <- grpShrunk[revOrderShrunk, , drop = FALSE]
  attr(Resid, "std") <- nlmeFit$sigma/(varWeights(nlmeSt)[revOrderShrunk])
  ## inverting back reStruct 
  nlmeSt$reStruct <- solve(nlmeSt$reStruct)
  ## saving part of dims
  dims <- attr(nlmeSt, "conLin")$dims[c("N", "Q", "qvec", "ngrps", "ncol")]
  ## getting the approximate var-cov of the parameters 
  if (controlvals$apVar) {
    apVar <- lmeApVar(nlmeSt, nlmeFit$sigma, 
		      .relStep = controlvals[[".relStep"]],
                      minAbsPar = controlvals[["minAbsParApVar"]],
     		      natural = controlvals[["natural"]])
  } else {
    apVar <- "Approximate variance-covariance matrix not available"
  }
  ## putting sran in the right format
  sran <- lapply(sran, t)
  ## getting rid of condensed linear model, fit, and other attributes
  oClass <- class(nlmeSt)
  attributes(nlmeSt) <- attributes(nlmeSt)[c("names", "class", "pmap")]
  class(nlmeSt) <- oClass
  ##
  ## creating the  nlme object
  ##
  estOut <- list(modelStruct = nlmeSt,
		 dims = dims,
                 contrasts = contr,
		 coefficients = list(fixed = sfix, random = rev(sran)),
		 varFix = varFix,
		 sigma = nlmeFit$sigma,
		 apVar = apVar,
		 logLik = nlmeFit$logLik,
		 numIter = numIter,
		 groups = grpShrunk,
		 call = Call,
		 method = method,
		 fitted = Fitted,
		 residuals = Resid,
		 plist = plist,
                 map = list(fmap=fmap,rmap=rmap,rmapRel=rmapRel,bmap=bmap),
                 fixDF = fixDF)
  if (inherits(data, "groupedData")) {
    ## saving labels and units for plots
    attr(estOut, "units") <- attr(data, "units")
    attr(estOut, "labels") <- attr(data, "labels")
  }
  class(estOut) <- c("nlme","lme")
  estOut
}
	      
###
### function used to calculate the parameters from 
### the fixed and random effects
###

getParsNlme <-
  function(plist, fmap, rmapRel, bmap, groups, beta, bvec, b, level, N)
{
  pars <- array(0, c(N, length(plist)), list(NULL, names(plist)))
  for (nm in names(plist)) {
    if (is.logical(f <- plist[[nm]]$fixed)) {
      if (f) {
        pars[, nm] <- beta[fmap[[nm]]]
      }
    } else {
      pars[, nm] <- f %*% beta[fmap[[nm]]]
    }
    if (level > 0) {
      Q <- length(groups)
      for(i in (Q - level + 1):Q) {
        b[[i]][] <- bvec[(bmap[i] + 1):bmap[i+1]]
        if (is.logical(r <- plist[[nm]]$random[[i]])) {
          if (r) {
            pars[, nm] <- pars[, nm] + b[[i]][rmapRel[[i]][[nm]], groups[[i]]]
          }
        } else {
          if (data.class(r) != "list") {
            pars[,nm] <- pars[,nm] +
              (r * t(b[[i]])[groups[[i]], rmapRel[[i]][[nm]], drop = FALSE]) %*%
                rep(1, ncol(r))
          } else {
            for(j in seq(along = rmapRel[[i]][[nm]])) {
              if (is.logical(rr <- r[[j]])) {
                pars[, nm] <- pars[, nm] +
                  b[[i]][rmapRel[[i]][[nm]][[j]], groups[[i]]]
              } else {
                pars[,nm] <- pars[,nm] +
                  (rr * t(b[[i]])[groups[[i]], rmapRel[[i]][[nm]][[j]],
                                  drop = FALSE]) %*% rep(1, ncol(rr))
              }
            }
          }
        }
      }
    }
  }
  pars  
}
  
###
###  Methods for standard generics
###

formula.nlme <- function(object) eval(object$call[["model"]])

predict.nlme <- 
  function(object, newdata, level = Q, asList = FALSE, na.action = na.fail,
	   naPattern = NULL)  
{
  ##
  ## method for predict() designed for objects inheriting from class nlme
  ##
  Q <- object$dims$Q
  if (missing(newdata)) {		# will return fitted values
    val <- fitted(object, level, asList)
    if (length(level) == 1) return(val)
    return(data.frame(object[["groups"]][,level[level != 0], drop = FALSE],
		      predict = val))
  }
  maxQ <- max(level)
  nlev <- length(level)
  newdata <- as.data.frame(newdata)
  mCall <- object$call
  if (maxQ > 0) {			# predictions with random effects
    whichQ <- Q - (maxQ-1):0
    reSt <- object$modelStruct$reStruct[whichQ]
    nlmeSt <- nlmeStruct(reStruct = reSt)
    groups <- getGroupsFormula(reSt)
    if (any(is.na(match(all.vars(groups), names(newdata))))) {
      ## groups cannot be evaluated in newdata
      stop("Cannot evaluate groups for desired levels on \"newdata\"")
    }
  } else {
    reSt <- NULL
  }

  mfArgs <- list(formula = asOneFormula(formula(object),
                   mCall$fixed, formula(reSt), naPattern, 
                   omit = c(names(object$plist), "pi",
                     deparse(getResponseFormula(object)[[2]]))),
                 data = newdata, na.action = na.action)
  dataMix <- do.call("model.frame", mfArgs)
  origOrder <- row.names(dataMix)	# preserve the original order
  whichRows <- match(origOrder, row.names(newdata))

  if (maxQ > 0) {
    ## sort the model.frame by groups and get the matrices and parameters
    ## used in the estimation procedures
    grps <- getGroups(newdata, 
	      eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|"))))
    ## ordering data by groups
    if (inherits(grps, "factor")) {	# single level
      grps <- pruneLevels(grps[whichRows])
      oGrps <- data.frame(grps)
      ## checking if there are missing groups
      if (any(naGrps <- is.na(grps))) {
	grps[naGrps] <- levels(grps)[1]	# input with existing level
      }
      ord <- order(grps)     #"order" treats a single named argument peculiarly
      grps <- data.frame(grps)
      row.names(grps) <- origOrder
      names(grps) <- names(oGrps) <- as.character(deparse((groups[[2]])))
    } else {
      grps <- oGrps <- 
	do.call("data.frame", lapply(grps[whichRows, ], pruneLevels))
      ## checking for missing groups
      if (any(naGrps <- is.na(grps))) {
	## need to input missing groups
	for(i in names(grps)) {
	  grps[naGrps[, i], i] <- levels(grps[,i])[1]
	}
	naGrps <- t(apply(naGrps, 1, cumsum)) # propagating NAs
      }
      ord <- do.call("order", grps)
      ## making group levels unique
      grps[, 1] <- pruneLevels(grps[, 1])
      for(i in 2:ncol(grps)) {
	grps[, i] <-
          as.factor(paste(as.character(grps[, i-1]), as.character(grps[,i]),
                          sep = "/"))
	NULL
      }
    }
    if (match(0, level, nomatch = 0)) {
      naGrps <- cbind(FALSE, naGrps)
    }
    naGrps <- as.matrix(naGrps)[ord, , drop = FALSE]
    grps <- grps[ord, , drop = FALSE]
    dataMix <- dataMix[ord, ,drop = FALSE]
    revOrder <- match(origOrder, row.names(dataMix)) # putting in orig. order
  }
  ## making sure factor levels are the same as in contrasts
  contr <- object$contrasts
  for(i in names(dataMix)) {
    if (inherits(dataMix[,i], "factor") && !is.null(contr[[i]])) {
      levs <- levels(dataMix[,i])
      levsC <- dimnames(contr[[i]])[[1]]
      if (any(wch <- is.na(match(levs, levsC)))) {
        stop(paste("Levels", paste(levs[wch], collapse = ","),
                   "not allowed for", i))
      }
      attr(dataMix[,i], "contrasts") <- contr[[i]][levs, , drop = FALSE]
#      if (length(levs) < length(levsC)) {
#        if (inherits(dataMix[,i], "ordered")) {
#          dataMix[,i] <- ordered(as.character(dataMix[,i]), levels = levsC)
#        } else {
#          dataMix[,i] <- factor(as.character(dataMix[,i]), levels = levsC)
#        }
#      }
    }
  }

  N <- nrow(dataMix)
  ##
  ## evaluating the naPattern expression, if any
  ##
  if (is.null(naPattern)) naPat <- rep(TRUE, N)
  else naPat <- as.logical(eval(asOneSidedFormula(naPattern)[[2]], dataMix))

  ##
  ## Getting  the plist for the new data frame
  ##
  ##
  plist <- object$plist
  fixed <- eval(object$call$fixed)
  if (!is.list(fixed)) {
    fixed <- list(fixed)
  }
  val <- NULL
  for(i in seq(along = fixed)) {
    if (is.name(fixed[[i]][[2]])) {
      val <- c(val, list(fixed[[i]]))
    } else {
      ## multiple parameters on left hand side
      val <- c(val, eval(parse(text = paste("list(",
           paste(paste(all.vars(fixed[[i]][[2]]), deparse(fixed[[i]][[3]]),
                       sep = "~"), collapse=","),")"))))
    }
  }
  fixed <- val
  fnames <- unlist(lapply(fixed, function(el) deparse(el[[2]])))
  names(fixed) <- fnames
  fix <- fixef(object)
  fn <- names(fix)
  for(nm in fnames) {
    if (!is.logical(plist[[nm]]$fixed)) {
      plist[[nm]]$fixed <- model.matrix(asOneSidedFormula(fixed[[nm]][[3]]),
                 model.frame(asOneSidedFormula(fixed[[nm]][[3]]), dataMix))
    }
  }

  if (maxQ > 0) {
    grpsRev <- lapply(rev(grps), as.character)
    ranForm <- formula(reSt)[whichQ]
    namGrp <- names(ranForm)
    rnames <- lapply(ranForm, function(el)
                     unlist(lapply(el, function(el1) deparse(el1[[2]]))))
    for(i in 1:length(ranForm)) {
      names(ranForm[[i]]) <- rnames[[i]]
    }
    ran <- ranef(object)
    if(is.data.frame(ran)) {
      ran <- list(ran)
    } else {
      ran <- rev(ran)
    }
    rn <- lapply(ran[whichQ], names)
    ran <- lapply(ran, t)
    ranVec <- unlist(ran)
    for(nm in names(plist)) {
      for(i in namGrp) {
        if (!is.logical(plist[[nm]]$random[[i]])) {
          wch <- (1:length(rnames[[i]]))[!is.na(match(rnames[[i]], nm))]
          if (length(wch) == 1) {         # only one formula for nm
            plist[[nm]]$random[[i]] <-
              model.matrix(asOneSidedFormula(ranForm[[i]][[nm]][[3]]),
                 model.frame(asOneSidedFormula(ranForm[[i]][[nm]][[3]]),
                             dataMix))
          } else {                        # multiple formulae
            plist[[nm]]$random[[i]] <- lapply(ranForm[[i]][wch],
                           function(el, data) {
                             if (el[[3]] == "1") {
                               TRUE
                             } else {
                               val <- model.matrix(asOneSidedFormula(el[[3]]),
                                       model.frame(asOneSidedFormula(el[[3]]),
                                                   data))
                               val

                             }
                           }, data = dataMix)
          }
        }
      }
    }
  } else {
    namGrp <- ""
    grpsRev <- ranVec <- ran <- NULL
  }
  val <- vector("list", nlev)
  names(val) <- c("fixed", rev(namGrp))[level + 1]
  modForm <- getCovariateFormula(object)[[2]]
  for(i in 1:nlev) {
    val[[i]] <- eval(modForm, data.frame(dataMix,
                  getParsNlme(plist, object$map$fmap, object$map$rmapRel,
                          object$map$bmap, grpsRev, fix, ranVec, ran,
                          level[i], N)))[naPat]
  }
  val <- as.data.frame(val)

  if (maxQ > 0) {
    val <- val[revOrder, , drop = FALSE]
    if (any(naGrps)) {
      val[naGrps] <- NA
    }
  }
  ## putting back in original order 
  if (maxQ > 1) {                      # making groups unique
    for(i in 2:maxQ) {
      oGrps[, i] <- paste(as.character(oGrps[,i-1]), as.character(oGrps[,i]),
                          sep = "/")
    }
  }
  if (length(level) == 1) {
    val <- val[,1]
    if (level > 0) {
      grps <- as.character(oGrps[, level])
      if (asList) {
        val <- split(val, ordered(grps, levels = unique(grps)))
      } else {
        names(val) <- grps
      }
    }
    lab <- "Predicted values"
    if (!is.null(aux <- attr(object, "units")$y)) {
      lab <- paste(lab, aux)
    }
    attr(val, "label") <- lab
  } else {
    val <- data.frame(oGrps, predict = val)
  }
  val
}

update.nlme <- 
  function(object, model, data, fixed, random, groups, start, correlation,
           weights, subset, method, na.action, naPattern, control, verbose)
{
  thisCall <- as.list(match.call())[-(1:2)]
  if (!is.null(thisCall$start) && is.numeric(start)) {
    thisCall$start <- list(fixed = start)
  }
  if (!is.null(nextCall <- object$origCall) &&
      (is.null(thisCall$fixed) && !is.null(thisCall$random))) {
    nextCall <- as.list(nextCall)[-1]
  } else {    
    nextCall <- as.list(object$call)[-1]
    if (is.null(thisCall$fixed)) {        # no changes in fixef model
      if (is.null(thisCall$start)) {
        thisCall$start <- list(fixed = fixef(object))
      } else {
        if (is.null(thisCall$start$fixed)) {
          thisCall$start$fixed <- fixef(object)
        }
      }
    }
    if (!is.null(thisCall$start$random)) {  # making start random NULL
      thisCall$start$random <- NULL
    }
    if (is.null(thisCall$random) && is.null(thisCall$subset)) {
      ## no changes in ranef model and no subsetting
      thisCall$random <- object$modelStruct$reStruct
    }
  }
  if (!is.null(thisCall$model)) {
    thisCall$model <- update(formula(object), thisCall$model)
  }
  if (is.na(match("correlation", names(thisCall))) &&
      !is.null(thCor <- object$modelStruct$corStruct)) {
    thisCall$correlation <- thCor
  }
  if (is.na(match("weights", names(thisCall))) &&
      !is.null(thWgt <- object$modelStruct$varStruct)) {
    thisCall$weights <- thWgt
  }
  nextCall[names(thisCall)] <- thisCall
  do.call("nlme", nextCall)
}

###*### nlmeStruct - a model structure for nlme fits

nlmeStruct <-
  ## constructor for nlmeStruct objects
  function(reStruct, corStruct = NULL, varStruct = NULL, resp = NULL,
           model = NULL, local = NULL, N = NULL, naPat = NULL)
{

  val <- list(reStruct = reStruct, corStruct = corStruct,
              varStruct = varStruct)
  val <- val[!sapply(val, is.null)]	# removing NULL components
  attr(val, "settings") <- attr(val$reStruct, "settings")
  attr(val, "resp") <- resp
  attr(val, "model") <- model
  attr(val, "local") <- local
  attr(val, "N") <- N
  attr(val, "naPat") <- naPat
  class(val) <- c("nlmeStruct", "lmeStruct", "modelStruct")
  val
}

##*## nlmeStruct methods for standard generics

fitted.nlmeStruct <-
  function(object, level = Q,  conLin = attr(object, "conLin"), ...)
{
  Q <- attr(object, "conLin")$dims[["Q"]]
  attr(object, "resp") - resid(object, level, conLin)
}


residuals.nlmeStruct <-
  function(object, level = Q, conLin = attr(object, "conLin"), ...)
{
  Q <- conLin$dims[["Q"]]
  loc <- attr(object, "local")
  oLev <- get("level", envir = loc)
  on.exit(assign("level", oLev, envir = loc))
  dn <- c("fixed", rev(names(object$reStruct)))[level + 1]
  val <- array(0, c(attr(object, "NReal"), length(level)), 
       list(dimnames(conLin$Xy)[[1]], dn))
  for(i in 1:length(level)) {
    assign("level", level[i], envir = loc, immediate = TRUE)
    val[, i] <- c(eval(attr(object, "model")[[2]], envir = loc))
  }
  val
}

nlmeControl <-
  ## Set control values for iterations within nlme
  function(maxIter = 50, pnlsMaxIter = 7, msMaxIter = 50,
	   minScale = 0.001, tolerance = 1e-5, niterEM = 25,
           pnlsTol = 0.001, msTol = 0.000001, msScale = lmeScale,
           returnObject = FALSE, msVerbose = FALSE, gradHess = TRUE,
           apVar = TRUE, .relStep = (.Machine$double.eps)^(1/3),
           nlmStepMax = 100.0,
           minAbsParApVar = 0.05, natural = TRUE)
{
  list(maxIter = maxIter, pnlsMaxIter = pnlsMaxIter, msMaxIter = msMaxIter,
       minScale = minScale, tolerance = tolerance, niterEM = niterEM,
       pnlsTol = pnlsTol, msTol = msTol, msScale = msScale,
       returnObject = returnObject, msVerbose = msVerbose,
       gradHess = gradHess, apVar = apVar, .relStep = .relStep,
       nlmStepMax = nlmStepMax,
       minAbsParApVar = minAbsParApVar, natural = natural)
}

### Local Variables:
### mode:S
### S-keep-dump-files: t
### End:
 
### $Id: nlsList.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###                  Create a list of nls objects
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

nlsList <- 
  ## A list of nls objects
  function(model, data, start, control, level, subset, na.action = na.fail,
           pool = TRUE) UseMethod("nlsList")

nlsList.selfStart <-
  function (model, data, start, control, level, subset, na.action = na.fail, 
            pool = TRUE) 
{
  mCall <- as.list(match.call())[-1]
  if (!inherits(data, "groupedData")) {
    stop("second argument must be a groupedData object")
  }
  marg <- substitute(model)
  if (mode(marg) != "name") {
    stop("cannot use an anonymous function for the model")
  }
					# Build up a call to the model function
  m <- call(as.character(marg))
  args <- lapply(names(formals(eval(marg))), as.name)
  args[[1]] <- getCovariateFormula(data)[[2]]
  m[1 + seq(along = args)] <- args
  form <- formula(data)
  form[[3]][[2]] <- m
  mCall$model <- form
  do.call("nlsList.formula", mCall)
}

nlsList.formula <-
  function(model, data, start = NULL, control, level, subset,
           na.action = na.fail, pool = TRUE)
{
  Call <- match.call()
  if (!missing(subset)) {
    data <-
      data[eval(asOneSidedFormula(Call[["subset"]])[[2]], data),, drop = FALSE]
  }
  if (!inherits(data, "data.frame")) data <- as.data.frame(data)
  data <- na.action(data)
  if (is.null(grpForm <- getGroupsFormula(model))) {
    if (inherits(data, "groupedData")) {
      if (missing(level)) level <- length(getGroupsFormula(data, asList = TRUE))
      else if (length(level) > 1) {
	stop("Multiple levels not allowed")
      }
      groups <- pruneLevels(getGroups(data, level = level))
      grpForm <- getGroupsFormula(data)
    } else {
      stop (paste("Data must be a groupedData object if formula",
                  "does not include groups"))
    }
  } else {
    if (missing(level)) {
      level <- length(getGroupsFormula(model, asList = TRUE))
    } else if (length(level) > 1) {
      stop("Multiple levels not allowed")
    }
    model <- eval(parse(text = paste(deparse(model[[2]]),
                        deparse(getCovariateFormula(model)[[2]]), sep = "~")))
    groups <- pruneLevels(getGroups(data, form = grpForm, level = level))
  }
  if (is.null(start) && is.null(attr(data, "parameters"))) {
    ## no starting values
    ## checking for old-style selfStart functions
    FUN <- eval(model[[3]][[1]])
    if (is.function(FUN) &&
        (is.null(class(FUN)) || class(FUN) != "selfStart") &&
        !is.null(attr(FUN, "initial"))) {
      stop(paste("old-style self-starting model functions\n",
                 "are no longer supported.\n",
                 "New selfStart functions are available.\n",
                 "Use\n",
                 "  SSfpl instead of fpl,\n",
                 "  SSfol instead of first.order.log,\n",
                 "  SSbiexp instead of biexp,\n",
                 "  SSlogis instead of logistic.\n",
                 "If writing your own selfStart model, see\n",
                 "  \"help(selfStart)\"\n",
                 "for the new form of the \"initial\" attribute.", sep="" ))
    }
  }
  
  controlvals <- nls.control()
  if(!missing(control)) {
    controlvals[names(control)] <- control
  }
  val <- lapply(split(data, groups),
		function(dat, formula, start, control, first = TRUE)
		{
		  restart(first)
		  if(first) {
		    first <- FALSE
		    data <- as.data.frame(dat)
                    if (is.null(start)) {
                      nls(formula = formula, data = data, control = control)
                    } else {
                      nls(formula = formula, data = data, start = start,
                          control = control)
                    }
		  }
		  else {
		    NULL
		  }
		}, formula = model, start = start, control = controlvals)
  if (inherits(data, "groupedData")) {
    ## saving labels and units for plots
    attr(val, "units") <- attr(data, "units")
    attr(val, "labels") <- attr(data, "labels")
    attr(val, "outer") <- attr(data, "outer")
  }
  attr(val, "dims") <- list(N = nrow(data), M = length(val))
  attr(val, "call") <- Call
  attr(val,"groups") <- ordered(groups, levels = names(val))
  attr(val, "origOrder") <- match(unique(as.character(groups)), names(val))
  attr(val, "pool") <- pool
  attr(val, "groupsForm") <- grpForm
  class(val) <- c("nlsList", "lmList")
  val
}

###*# Methods for standard generics

coef.summary.nlsList <-
  function(object, ...) object$parameters

formula.nlsList <-
  function(object) eval(attr(object, "call")[["model"]])

summary.nlsList <-
  function(object, ...)
{
  val <- NextMethod("summary")
  class(val) <- c("summary.nlsList", class(val))
  val
}

update.nlsList <-
  function(object, model, data, start, control, level, subset, na.action, 
	   pool)
{
  thisCall <- as.list(match.call())[-(1:2)]
  if (!missing(model)) {
    names(thisCall)[match(names(thisCall), "model")] <- "object"
  }
  nextCall <- as.list(attr(object, "call")[-1])
  nextCall[names(thisCall)] <- thisCall
  do.call("nlsList", nextCall)
}

### Local variables:
### mode: S
### End:
### $Id: pdMat.q,v 1.2 1999/11/17 22:09:19 saikat Exp $
###
###              Classes of positive-definite matrices
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

##*## Generics that should be implemented for any pdMat class

pdConstruct <-
  ## a virtual constructor for these objects
  function(object, value, ...) UseMethod("pdConstruct")

pdFactor <-
  function(object) UseMethod("pdFactor")

pdMatrix <-
  ## extractor for the pd, correlation, or square-root factor matrix
  function(object, factor = FALSE) UseMethod("pdMatrix")

##*## pdMat - a virtual class of positive definite matrices

###*#  constructor for the virtual class

pdMat <- 
  function(value = numeric(0), form = NULL, nam = NULL, 
	   data = sys.frame(sys.parent()), pdClass = "pdSymm")
{
  if (inherits(value, "pdMat")) {	# nothing to construct
    pdClass <- class(value)
  }
  object <- numeric(0)
  class(object) <- unique(c(pdClass, "pdMat"))
  pdConstruct(object, value, form, nam, data)
}

###*# Methods for local generics

corMatrix.pdMat <-
  function(object)
{
  if (!isInitialized(object)) {
    stop("Cannot access the matrix of uninitialized objects")
  }
  Var <- pdMatrix(object)
  if (length(unlist(dimnames(Var))) == 0) {
    aux <- paste("V", 1:(Dim(Var)[2]), sep = "")
    dimnames(Var) <- list(aux, aux)
  }
  dd <- dim(Var)
  dn <- dimnames(Var)
  stdDev <- sqrt(diag(Var))
  names(stdDev) <- colnames(Var)
  value <- array(t(Var/stdDev)/stdDev, dd, dn)
  attr(value, "stdDev") <- stdDev
  value
}

pdConstruct.pdMat <-
  function(object, value = numeric(0), form = formula(object), 
	   nam = Names(object), data = sys.frame(sys.parent()))
{
  if (inherits(value, "pdMat")) {	# constructing from another pdMat
    if (length(form) == 0) {
      form <- formula(value)
    }
    if (length(nam) == 0) {
      nam <- Names(value)
    }
    if (isInitialized(value)) {
      return(pdConstruct(object, as.matrix(value), form, nam, data))
    } else {
      return(pdConstruct(object, form = form, nam = nam, data = data))
    }
  }
  if (length(value) > 0) {
    if (inherits(value, "formula") || data.class(value) == "call") {	
      ## constructing from a formula
      if (!is.null(form)) {
	warning("Ignoring argument \"form\"")
      }
      form <- formula(value)
      if (length(form) == 3) {          #two-sided case - nlme
        form <- list(form)
      }
    } else if (is.character(value)) {	# constructing from character array
      if (length(nam) > 0) {
	warning("Ignoring argument \"nam\"")
      }
      nam <- value
    } else if (is.matrix(value)) {	# constructing from a pd matrix
      vdim <- dim(value)
      if (length(vdim) != 2 || diff(vdim) != 0) {
        stop("\"value\" must be a square matrix")
      }
      if (length(unlist(vnam <- dimnames(value))) > 0) {
        vnam <- unique(unlist(vnam))
        if (length(vnam) != vdim[1]) {
          stop("dimnames of value must match or be NULL")
        }
        dimnames(value) <- list(vnam, vnam)
        if (length(nam) > 0) {          # check consistency
	  if (any(is.na(match(nam, vnam))) || any(is.na(match(vnam, nam)))) {
	    stop(paste("Names of \"value\" are not consistent",
		       "with \"nam\" argument"))
	  }
	  value <- value[nam, nam, drop = FALSE]
	} else {
	  nam <- vnam
	}
      }
      form <- form                      # avoid problems with lazy evaluation
      nam <- nam
      object <- chol((value + t(value))/2) # ensure it is positive-definite
      attr(object, "dimnames") <- NULL
      attr(object, "rank") <- NULL
    } else if (is.numeric(value)) {	# constructing from the parameter
      value <- as.numeric(value)
      attributes(value) <- attributes(object)
      object <- value
    } else if (data.class(value) == "list") {
      ## constructing from a list of two-sided formulae - nlme case
      if (!is.null(form)) {
	warning("Ignoring argument \"form\"")
      }
      form <- value
    } else {
      stop(paste(deparse(object), "is not a valid object for \"pdMat\""))
    }
  }

  if (!is.null(form)) {
    if (inherits(form, "formula") && length(form) == 3) {#two-sided case - nlme
      form <- list(form)
    }
    if (is.list(form)) {   # list of formulae
      if (any(!unlist(lapply(form,
                             function(el) {
                               inherits(el, "formula") && length(el) == 3
                             })))) {
        stop("All elements of \"form\" list must be two-sided formulas")
      }
      val <- list()
      for(i in seq(along = form)) {
        if (is.name(form[[i]][[2]])) {
          val <- c(val, list(form[[i]]))
        } else {
          val <- c(val, eval(parse(text = paste("list(",
            paste(paste(all.vars(form[[i]][[2]]), deparse(form[[i]][[3]]),
                        sep = "~"), collapse=","),")"))))
        }
      }
      form <- val
      class(form) <- "listForm"
      namesForm <- Names(form, data)
    } else {
      if (inherits(form, "formula")) {
        namesForm <- Names(asOneSidedFormula(form), data)
        namesForm1 <- NULL
      } else {
        stop("\"form\" can only be a formula or a list of formulae")
      }
    }
    if (length(namesForm) > 0) {
      if (length(nam) == 0) {             # getting names from formula
        nam <- namesForm
      } else {				# checking consistency with names
        if (any(noMatch <- is.na(match(nam, namesForm)))) {
          err <- TRUE
          namCopy <- nam
          indNoMatch <- (1:length(nam))[noMatch]
          if (any(wch1 <- (nchar(nam) > 12))) {
            ## possibly names with .(Intercept) in value
            wch1 <- substring(nam, nchar(nam)-10) == "(Intercept)"
            if (any(wch1)) {
              namCopy[indNoMatch[wch1]] <-
                substring(nam[wch1], 1, nchar(nam[wch1]) - 12)
              noMatch[wch1] <- FALSE
              indNoMatch <- indNoMatch[!wch1]  # possibly not matched
            }
          }
          if (sum(noMatch) > 0) {
            ## still no matches - try adding .(Intercept)
            namCopy[indNoMatch] <-
              paste(namCopy[indNoMatch], "(Intercept)", sep = ".")
          }
          ## try matching modified value
          if (!any(is.na(match(namCopy, namesForm)))) {
            err <- FALSE
          }
          if (err) stop("\"form\" not consistent with \"nam\"")
        }
      }
    }
  }

  if (is.matrix(object)) {	# initialized as matrix, check consistency
    if (length(nam) > 0 && (length(nam) != dim(object)[2])) {
      stop(paste("Length of nam not consistent with dimensions",
		 "of initial value"))
    }
  }
  attr(object, "formula") <- form    
  attr(object, "Dimnames") <- list(nam, nam)
  object
}

pdFactor.pdMat <-
  function(object) 
{
  c(qr.R(qr(pdMatrix(object))))
}

pdMatrix.pdMat <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot access the matrix of uninitialized objects")
  }
  if (factor) {
    stop(paste("No default method for extracting the square",
               "root of a pdMat object"))
  } else {
    crossprod(pdMatrix(object, factor = TRUE))
  }
}

###*# Methods for standard generics

as.matrix.pdMat <-
  function(x) pdMatrix(x)

coef.pdMat <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained || !isInitialized(object)) {
    as.vector(object)
  } else {
    stop("Don't know how to obtain constrained coefficients")
  }
}

"coef<-.pdMat" <-
  function(object, value)
{
  value <- as.numeric(value)
  if (isInitialized(object)) {
    if (length(value) != length(object)) {
      stop("Cannot change the length of the parameter after initialization")
    }
  } else {
    return(pdConstruct(object, value))
  }
  class(value) <- class(object)
  attributes(value) <- attributes(object)
  value
}

Dim.pdMat <-
  function(object)
{
  if ((val <- length(Names(object))) > 0) {
    return(c(val, val))
  } else if (isInitialized(object)) {
    return(dim(as.matrix(object)))
  } 
  stop(paste("Cannot access the number of columns of",
	     "uninitialized objects without names."))
}

formula.pdMat <-
  function(object, asList) eval(attr(object, "formula"))

isInitialized.pdMat <-
  function(object)
{
  length(object) > 0
}

logDet.pdMat <-
  function(object)
{
  if (!isInitialized(object)) {
    stop(paste("Cannot extract the log of the determinant",
	       "from an uninitialized object"))
  }
  sum(log(svd(pdMatrix(object, factor = TRUE))$d))
}

"matrix<-.pdMat" <-
  function(object, value)
{
  value <- as.matrix(value)
  ## check for consistency of dimensions when object is initialized
  if (isInitialized(object) && any(dim(value) != Dim(object))) {
    stop("Cannot change dimensions on an initialized pdMat object")
  }
  pdConstruct(object, value)
}

Names.pdMat <-
  function(object)
{
  as.character(attr(object, "Dimnames")[[2]])
}

"Names<-.pdMat" <-
  function(object, ..., value)
{
  if (is.null(value)) {
    attr(object, "Dimnames") <- NULL
    return(object)
  } else {
    value <- as.character(value)
    if (length(dn <- Names(object)) == 0) {
      if (isInitialized(object)) {	# object is initialized without names
	if (length(value) != (aux <- Dim(object)[2])) {
	  stop(paste("Length of names should be", aux))
	}
      }
      attr(object, "Dimnames") <- list(value, value)
      return(object)
    }
    if (length(dn) != length(value)) {
      stop(paste("Length of names should be", length(dn)))
    }
    err <- FALSE
    if (any(noMatch <- is.na(match(value, dn)))) {
      err <- TRUE
      ## checking nlme case
      valueCopy <- value
      indNoMatch <- (1:length(value))[noMatch]
      nam1 <- value[noMatch]            # no matching names
      if (any(wch1 <- (nchar(nam1) > 12))) {
        ## possibly names with .(Intercept) in value
        wch1 <- substring(nam1, nchar(nam1)-10) == "(Intercept)"
        if (any(wch1)) {
          valueCopy[indNoMatch[wch1]] <-
            substring(nam1[wch1], 1, nchar(nam1[wch1]) - 12)
          noMatch[wch1] <- FALSE
          indNoMatch <- indNoMatch[!wch1]  # possibly not matched
        }
      }
      if (sum(noMatch) > 0) {
        ## still no matches - try adding .(Intercept)
        valueCopy[indNoMatch] <-
          paste(valueCopy[indNoMatch], "(Intercept)", sep = ".")
      }
      ## try matching modified value
      indMatch <- match(valueCopy, dn)
      if (!any(is.na(indMatch))) {      # all match
        attr(object, "Dimnames") <- list(value, value)
        if ((length(indMatch)) > 1 && any(diff(indMatch) != 1) &&
            isInitialized(object)) { # permutation
          auxMat <- as.matrix(object)[indMatch, indMatch, drop = FALSE]
          dimnames(auxMat) <- list(value, value)
          return(pdConstruct(object, auxMat))
        }
        return(object)
      }
    }
    if (err) {
      stop(paste("Names being assigned do not correspond to a permutation",
                 "of previous names", sep = "\n"))
    }
    indMatch <- match(value, dn)
    if ((length(indMatch) == 1) || all(diff(indMatch) == 1)) {
      return(object)
    }
    ## must be a permutation of names
    attr(object, "Dimnames") <- list(value, value)
    if (isInitialized(object)) {
      auxMat <- as.matrix(object)[indMatch, indMatch, drop = FALSE]
      dimnames(auxMat) <- list(value, value)
      return(pdConstruct(object, auxMat))
    }
    object
  }
}    

"plot.pdMat"<-
  function(x, nseg = 50, levels = 1, center = rep(0, length(stdDev)),
	   additional, ...)
{
  corr <- corMatrix(x)
  stdDev <- attr(corr, "stdDev")
  attr(corr, "stdDev") <- NULL
  assign(".corr", corr)
  assign(".angles", seq(-pi, pi, length = nseg + 1))
  assign(".cosines", cos(.angles))
  nlev <- length(levels)
  dataMat <- array(aperm(outer(rbind(-stdDev, stdDev), levels), c(1, 3, 2)),
		   dim = c(nlev * 2, length(stdDev)),
		   dimnames = list(NULL, names(stdDev)))
  groups <- rep(1:nlev, rep(2, nlev))
  dataMat <- t(t(dataMat) + center)
  if (!missing(additional)) {
    additional <- as.matrix(additional)
    dataMat <- rbind(dataMat, additional)
    groups <- c(groups, rep(0, nrow(additional)))
  }
  splom(~ dataMat, panel = function(x, y, subscripts, groups, ...) {
    groups <- groups[subscripts]	# should be a no-op but
    if (any(g0 <- groups == 0)) {	# plot as points
      panel.xyplot(x[g0], y[g0], ..., type = "p")
    }
    g1 <- groups == 1			# plot the center points
    panel.xyplot(mean(x[g1]), mean(y[g1]), ..., type = "p", pch = 3)
    p <- ncol(.corr)
    laggedCos <- cos(.angles + acos(.corr[round(mean(x[g1])*p + 0.5), 
					  round(mean(y[g1])*p + 0.5)]))
    xylist <- lapply(split(data.frame(x = x[!g0], y = y[!g0]), groups[!g0]),
		     function(el, lagged) {
		       if (nrow(el) != 2) {
			 stop("x-y data to splom got botched somehow")
		       }
		       sumDif <- array(c(1,1,1,-1)/2, c(2,2)) %*% as.matrix(el)
		       list(x = sumDif[1,1] + .cosines * sumDif[2,1],
			    y = sumDif[1,2] + lagged * sumDif[2,2])
		     }, lagged = laggedCos)
    gg <- rep(seq(along = xylist), rep(length(.angles), length(xylist)))
    panel.superpose(unlist(lapply(xylist, "[[", "x")),
		    unlist(lapply(xylist, "[[", "y")),
		    subscripts = seq(along = gg), groups = gg, ..., type = "l")
  }, subscripts = TRUE, groups = groups)
}

print.pdMat <-
  function(x, ...)
{
  if (isInitialized(x)) {
    cat("Positive definite matrix structure of class", class(x)[1], "representing\n")
    print(invisible(as.matrix(x)), ...)
  } else {
    cat("Uninitialized positive definite matrix structure of class ", class(x)[1], 
	".\n", sep = "")
  }
}

print.summary.pdMat <-
  function(x, sigma = 1, rdig = 3, Level = NULL, resid = FALSE, ...)
  ## resid = TRUE causes an extra row to be added
{
  if (!is.list(x)) {
    if (!(is.null(form <- attr(x, "formula")))) {
      cat(paste(" Formula: "))
      if (inherits(form, "formula")) {
        cat(deparse(as.vector(form)))
        if (!is.null(Level)) { cat( paste( " |", Level ) ) }
      } else {
        if (length(form) == 1) {
          cat(deparse(as.vector(form[[1]])))
          if (!is.null(Level)) { cat( paste( " |", Level ) ) }
        } else {
          cat(deparse(lapply(form,
                             function(el) as.name(deparse(as.vector(el))))))
          cat("\n Level:", Level)
        }
      }
      cat( "\n" )
    }
    if (ncol(x) == 1) {
      if (resid) {
        print(array(sigma * c(attr(x, "stdDev"), 1), c(1, 2),
                    list("StdDev:",
                         c(names(attr(x, "stdDev")), "Residual"))), ... )
      } else {
        print(array(sigma * attr(x, "stdDev"), c(1,1),
                    list("StdDev:", names(attr(x, "stdDev")))), ... )
      }
    } else {
      cat(paste(" Structure: ", attr(x, "structName"), "\n", sep = ""))
      if (attr(x, "noCorrelation") | (1 >= (p <- dim(x)[2]))) {
        if (resid) {
          print(array(sigma * c(attr(x, "stdDev"), 1), c(1, p + 1),
                      list("StdDev:",
                           c(names(attr(x, "stdDev")), "Residual"))), ...)
        } else {
          print(array(sigma * attr(x, "stdDev"), c(1, p),
                      list("StdDev:", names(attr(x, "stdDev")))), ...)
        }
      } else {                          # we essentially do print.correlation here
        ll <- lower.tri(x)
        stdDev <- attr(x, "stdDev")
        x[ll] <- format(round(x[ll], digits = rdig), ...)
        x[!ll] <- ""
        xx <- array("", dim(x),
                    list(names(attr(x, "stdDev")),
                         c("StdDev", "Corr", rep("", p - 2))))
        xx[, 1] <- format(sigma * attr(x, "stdDev"))
        xx[-1, -1] <- x[ -1, -p ]
        if (!is.null(colnames(x))) {
          xx[1, -1] <- abbreviate(colnames(x)[ -p ], minlength = rdig + 3)
        }
        if (resid) {
          x <- array("", dim(xx) + c(1, 0),
                     list(c(rownames(xx), "Residual"), colnames(xx)))
          x[ 1:p, ] <- xx
          x[ , 1 ] <- format(sigma * c(stdDev, 1))
          xx <- x
        }
        print( xx, ..., quote = FALSE )
      }
    }
  } else {				# composite structure
    cat(paste(" Composite Structure: ", attr(x, "structName"), "\n", sep =""))
    elName <- attr(x, "elementName")
    compNames <- names(x)
    for (i in seq(along = x)) {
      cat(paste("\n ", elName, " ", i, ": ", compNames[i], "\n", sep = ""))
      print.summary.pdMat(x[[i]], sigma = sigma, Level = Level,
                          resid = resid && (i == length(x)), ...)
    }
  }
  invisible(x)
}

solve.pdMat <-
  function(a, b)
{
  if (!isInitialized(a)) {
    stop("Cannot get the inverse of an uninitialized object")
  }
  matrix(a) <- solve(as.matrix(a))
  a
}

summary.pdMat <-
  function(object, structName = class(object)[1], noCorrelation = FALSE)
{
  if (isInitialized(object)) {
    value <- corMatrix(object)
    attr(value, "structName") <- structName
    attr(value, "noCorrelation") <- noCorrelation
    attr(value, "formula") <- formula(object)
    class(value) <- "summary.pdMat"
    value
  } else {
    object
  }
}

"[.pdMat" <- 
  function(x, i, j, drop = TRUE)
{
  xx <- x
  x <- as.matrix(x)
  if (missing(i)) li <- 0
  else li <- length(i)
  if (missing(j)) lj <- 0
  else lj <- length(j)
  
  if ((li + lj == 0) ||
      (li == lj) && ((mode(i) == mode(j)) && all(i == j))) {
    drop <- F				# even for a 1 by 1 submatrix,
					# you want it to be a matrix
    pdConstruct(xx, NextMethod())
  } else {
    NextMethod()
  }
}

"[<-.pdMat" <- 
  function(x, i, j, value)
{
  xx <- x
  x <- as.matrix(x)
  pdConstruct(xx, NextMethod())
}

##*## Classes that substitute for (i.e. inherit from) pdMat

###*# pdSymm - a class of general pd matrices

####* Constructor

pdSymm <-
  ## Constructor for the pdSymm class
  function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent()))
#	   pdClass = c("pdMatrixLog", "pdChol", "pdLogChol", "pdSpher",
#	       "pdGivens"))
{
#  pdClass <- match.arg(pdClass)
  object <- numeric(0)
#  class(object) <- c(pdClass, "pdSymm", "pdMat")
  class(object) <- c("pdSymm", "pdMat")
  pdConstruct(object, value, form, nam, data)
}

####* Methods for local generics

pdConstruct.pdSymm <-
  function(object, value = numeric(0), form = formula(object), 
	   nam = Names(object), data = sys.frame(sys.parent()))
{
  val <- NextMethod()
  if (length(val) == 0) {               # uninitialized object
    class(val) <- c("pdSymm", "pdMat")
    return(val)
  }

  if (is.matrix(val)) {			
    vald <- svd(val, nu = 0)
    object <- vald$v %*% (log(vald$d) * t(vald$v))
    value <- object[row(object) <= col(object)]
    attributes(value) <- attributes(val)[names(attributes(val)) !=  "dim"]
    class(value) <- c("pdSymm", "pdMat")
    return(value)
  }
  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
    stop(paste("An object of length", length(val),
	       "does not match the required parameter size"))
  }
  class(val) <- c("pdSymm", "pdMat")
  val
}

pdFactor.pdSymm <-
  function(object)
{
  Ncol <- round((-1 + sqrt(1 + 8 * length(object))) / 2)
  .C("matrixLog_pd", 
     Factor = double(Ncol * Ncol),
     as.integer(Ncol), 
     as.double(object),
     PACKAGE = "nlme")$Factor
}

pdMatrix.pdSymm <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot extract matrix from an uninitialized object")
  }
  if (factor) {
    Ncol <- Dim(object)[2]
    value <- array(pdFactor(object), c(Ncol, Ncol), attr(object, "Dimnames"))
    attr(value, "logDet") <- sum(log(abs(svd(value)$d)))
    value
  } else {
    NextMethod()
  }
}

####* Methods for standard generics

coef.pdSymm <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained || !isInitialized(object)) NextMethod()
  else {				# upper triangular elements
    val <- as.matrix(object)
    aN <- Names(object)
    aN1 <- paste("cov(", aN, sep ="")
    aN2 <- paste(aN, ")", sep ="")
    aNmat <- t(outer(aN1, aN2, paste, sep = ","))
    aNmat[row(aNmat) == col(aNmat)] <- paste("var(",aN,")",sep="")
    val <- val[row(val) <= col(val)]
    names(val) <- aNmat[row(aNmat) <= col(aNmat)]
    val
  }
}

Dim.pdSymm <-
  function(object)
{
  if (isInitialized(object)) {
    val <- round((sqrt(8*length(object) + 1) - 1)/2)
    c(val, val)
  } else {
    NextMethod()
  }
}

logDet.pdSymm <-
  function(object)
{
  if (!isInitialized(object)) {
    stop(paste("Cannot extract the log of the determinant",
	       "from an uninitialized object"))
  }
  attr(pdMatrix(object, factor = TRUE), "logDet")
}

solve.pdSymm <-
  function(a, b)
{
  if (!isInitialized(a)) {
    stop("Cannot extract the inverse from an uninitialized object")
  }
  coef(a) <- -coef(a, TRUE)
  a
}

summary.pdSymm <-
  function(object,
	   structName = "General positive-definite")
{
  summary.pdMat(object, structName)
}

### No need to implement other methods as the methods for pdMat
### are sufficient.

####*# pdChol - a general positive definite structure parameterized by
####   the non-zero elements of the Cholesky factor.

#####* Constructor

#pdChol <-
#  ## Constructor for the pdChol class
#  function(value = numeric(0), form = NULL, nam = NULL, data = sys.parent())
#{
#  object <- numeric(0)
#  class(object) <- c("pdChol", "pdMat")
#  pdConstruct(object, value, form, nam, data)
#}

#####* Methods for local generics

#pdConstruct.pdChol <-
#  function(object, value = numeric(0), form = formula(object), 
#	   nam = Names(object), data = sys.parent())
#{
#  val <- pdConstruct.pdMat(object, value, form, nam, data)
#  if (length(val) == 0) {               # uninitialized object
#    class(val) <- c("pdChol", "pdSymm", "pdMat")
#    return(val)
#  }
#  if (is.matrix(val)) {		
#    value <- val[row(val) <= col(val)]
#    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
#    class(value) <- c("pdChol", "pdSymm", "pdMat")
#    return(value)
#  }
#  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
#  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
#    stop(paste("An object of length", length(val),
#	       "does not match a Cholesky factor"))
#  }
#  class(val) <- c("pdChol", "pdSymm", "pdMat")
#  val
#}

#pdFactor.pdChol <-
#  function(object)
#{
#  round(Ncol <- (-1 + sqrt(1 + 8 * length(object))) / 2)
#  .C("Chol_pd", 
#     Factor = double(Ncol * Ncol),
#     as.integer(Ncol), 
#     as.double(object))$Factor
#}

#####* Methods for standard generics

#solve.pdChol <-
#  function(a, b)
#{
#  if (!isInitialized(a)) {
#    stop("Cannot get the inverse of an uninitialized object")
#  }
#  Ncol <- (-1 + sqrt(1 + 8 * length(a))) / 2
#  val <- array(.Fortran("dbksl",
#			as.double(pdFactor(a)),
#			as.integer(Ncol),
#			as.integer(Ncol),
#			val = as.double(diag(Ncol)),
#			as.integer(Ncol),
#			integer(1))[["val"]], c(Ncol, Ncol))
#  coef(a) <-  qr(t(val))$qr[c(row(val) <= col(val))]
#  a
#}

#summary.pdChol <-
#  function(object,
#           structName = "General positive-definite, Cholesky parametrization")
#{
#  summary.pdMat(object, structName)
#}

#### No need to implement other methods as the methods for pdMat
#### are sufficient.

####*# pdLogChol - a general positive definite structure parameterized
####   by the non-zero elements of the Cholesky factor with the diagonal
####   elements given in the logarithm scale.

#####* Constructor

#pdLogChol <-
#  ## Constructor for the pdLogChol class
#  function(value = numeric(0), form = NULL, nam = NULL, data = sys.parent())
#{
#  object <- numeric(0)
#  class(object) <- c("pdLogChol", "pdMat")
#  pdConstruct(object, value, form, nam, data)
#}

#####* Methods for local generics

#pdConstruct.pdLogChol <-
#  function(object, value = numeric(0), form = formula(object), 
#	   nam = Names(object), data = sys.parent())
#{
#  val <- pdConstruct.pdMat(object, value, form, nam, data)
#  if (length(val) == 0) {               # uninitialized object
#    class(val) <- c("pdLogChol", "pdSymm", "pdMat")
#    return(val)
#  }
#  if (is.matrix(val)) {			
#    value <- c(log(diag(val)), val[row(val) < col(val)])
#    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
#    class(value) <- c("pdLogChol", "pdSymm", "pdMat")
#    return(value)
#  }
#  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
#  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
#    stop(paste("An object of length", length(val),
#	       "does not match a Cholesky factor"))
#  }
#  class(val) <- c("pdLogChol", "pdSymm", "pdMat")
#  val
#}

#pdFactor.pdLogChol <-
#  function(object)
#{
#  round(Ncol <- (-1 + sqrt(1 + 8 * length(object))) / 2)
#  .C("logChol_pd", 
#     Factor = double(Ncol * Ncol),
#     as.integer(Ncol), 
#     as.double(object))$Factor
#}

#####* Methods for standard generics

#solve.pdLogChol <-
#  function(a, b)
#{
#  if (!isInitialized(a)) {
#    stop("Cannot get the inverse of an uninitialized object")
#  }
#  Ncol <- (-1 + sqrt(1 + 8 * length(a))) / 2
#  val <- array(.Fortran("dbksl",
#			as.double(pdFactor(a)),
#			as.integer(Ncol),
#			as.integer(Ncol),
#			val = as.double(diag(Ncol)),
#			as.integer(Ncol),
#			integer(1))[["val"]], c(Ncol, Ncol))
#  val <- qr(t(val))$qr
#  val <- sign(diag(val)) * val
#  coef(a) <- c(log(diag(val)), val[c(row(val) < col(val))])
#  a
#}

#summary.pdLogChol <-
#  function(object,
#           structName = "General positive-definite, Log-Cholesky parametrization")
#{
#  summary.pdMat(object, structName)
#}

#### No need to implement other methods as the methods for pdMat
#### are sufficient.

####*# pdSpher - a general positive definite structure parameterized
####   by the non-zero elements of the Cholesky factor with each column
####   represented in spherical coordinates

#####* Constructor

#pdSpher <-
#  ## Constructor for the pdSpher class
#  function(value = numeric(0), form = NULL, nam = NULL, data = sys.parent())
#{
#  object <- numeric(0)
#  class(object) <- c("pdSpher", "pdMat")
#  pdConstruct(object, value, form, nam, data)
#}

#####* Methods for local generics

#pdConstruct.pdSpher <-
#  function(object, value = numeric(0), form = formula(object), 
#	   nam = Names(object), data = sys.parent())
#{
#  val <- pdConstruct.pdMat(object, value, form, nam, data)
#  if (length(val) == 0) {			# uninitiliazed object
#    class(val) <- c("pdSpher", "pdSymm", "pdMat")
#    return(val)
#  }
#  if (is.matrix(val)) {			
#    Ncol <- dim(val)[2]
#    value <- log(apply(val, FUN = function(x){sqrt(sum(x^2))},2))
#    for(i in (1:Ncol)[-1]) {
#      aux <- acos(val[1:(i-1),i]/sqrt(cumsum(val[i:1,i]^2)[i:2]))
#      value <- c(value, log(aux/(pi - aux)))
#    }
#    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
#    class(value) <- c("pdSpher", "pdSymm", "pdMat")
#    return(value)
#  }
#  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
#  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
#    stop(paste("An object of length", length(val),
#	       "does not match a Cholesky factor"))
#  }
#  class(val) <- c("pdSpher", "pdSymm", "pdMat")
#  val
#}

#pdFactor.pdSpher <-
#  function(object)
#{
#  round(Ncol <- (-1 + sqrt(1 + 8 * length(object))) / 2)
#  .C("spher_pd", 
#     Factor = double(Ncol * Ncol),
#     as.integer(Ncol), 
#     as.double(object))$Factor
#}

#####* Methods for standar generics

#summary.pdSpher <-
#  function(object,
#           structName = "General positive-definite, Spherical parametrization")
#{
#  summary.pdMat(object, structName)
#}

####*# pdMatrixLog - a general positive definite structure parameterized
####   by the matrix logarithm.

#####* Constructor

#pdMatrixLog <- 
#  ## Constructor for the pdMatrixLog class
#  function(value = numeric(0), form = NULL, nam = NULL, data = sys.parent())
#{
#  object <- numeric(0)
#  class(object) <- c("pdMatrixLog", "pdMat")
#  pdConstruct(object, value, form, nam, data)
#}

#####* Methods for local generics

#pdConstruct.pdMatrixLog <-
#  function(object, value = numeric(0), form = formula(object), 
#	   nam = Names(object), data = sys.parent())
#{
#  val <- pdConstruct.pdMat(object, value, form, nam, data)
#  if (length(val) == 0) {               # uninitialized object
#    class(val) <- c("pdMatrixLog", "pdSymm", "pdMat")
#    return(val)
#  }

#  if (is.matrix(val)) {			
#    object <- eigen(crossprod(val), symmetric = TRUE)
#    object <- object$vectors %*% (log(object$values) * t(object$vectors))
#    value <- object[row(object) <= col(object)]
#    attributes(value) <- attributes(val)[names(attributes(val)) !=  "dim"]
#    class(value) <- c("pdMatrixLog", "pdSymm", "pdMat")
#    return(value)
#  }
#  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
#  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
#    stop(paste("An object of length", length(val),
#	       "does not match the required parameter size"))
#  }
#  class(val) <- c("pdMatrixLog", "pdSymm", "pdMat")
#  val
#}

#pdFactor.pdMatrixLog <-
#  function(object)
#{
#  round(Ncol <- (-1 + sqrt(1 + 8 * length(object))) / 2)
#  .C("matrixLog_pd", 
#     Factor = double(Ncol * Ncol),
#     as.integer(Ncol), 
#     as.double(object))$Factor
#}

#####* Methods for standard generics
  
#solve.pdMatrixLog <-
#  function(a, b)
#{
#  if (!isInitialized(a)) {
#    stop("Cannot extract the inverse from an uninitialized object")
#  }
#  coef(a) <- -coef(a, TRUE)
#  a
#}

#summary.pdMatrixLog <-
#  function(object,
#	   structName = "General positive-definite")
#{
#  summary.pdMat(object, structName)
#}

#### No need to implement other methods as the methods for pdMat
#### are sufficient.


####*# pdGivens - a general positive definite structure parameterized
####   by the eigenvalues and eigenvectors (as Givens rotations)

#####* Constructor

#pdGivens <- 
#  ## Constructor for the pdGivens class
#  function(value = numeric(0), form = NULL, nam = NULL, data = sys.parent())
#{
#  object <- numeric(0)
#  class(object) <- c("pdGivens", "pdMat")
#  pdConstruct(object, value, form, nam, data)
#}

#####* Methods for local generics

#pdConstruct.pdGivens <-
#  function(object, value = numeric(0), form = formula(object), 
#	   nam = Names(object), data = sys.parent())
#{
#  val <- pdConstruct.pdMat(object, value, form, nam, data)
#  if (length(val) == 0) {               # uninitiliazed object
#    class(val) <- c("pdGivens", "pdSymm", "pdMat")
#    return(val)
#  }
#  if (is.matrix(val)) {			
#    q <- dim(val)[1]
#    aux <-  eigen(crossprod(val), symmetric = TRUE)
#    Q <- aux$vectors
#    values <- aux$values
#    angles <- array(0,q*(q-1)/2)
#    k <- 0
#    for(i in 1:(q-1)) {
#      for(j in ((i+1):q)) {
#	k <- k + 1
#	p <- sqrt(Q[i,i]^2 + Q[j,i]^2)
#	if (p == 0) {
#	  angles[k] <- 0
#	} else {
#	  aux0 <- Q[i,i]/p
#	  aux1 <- Q[j,i]/p
#	  if (aux1 < 0) {
#	    aux0 <- -aux0
#	    aux1 <- -aux1
#	  }
#	  aux <- Q[i,]
#	  angles[k] <- log(acos(aux0)/(pi - acos(aux0)))
#	  Q[i,] <- Q[i,] * aux0 + Q[j,] * aux1
#	  Q[j,] <- Q[j,] * aux0 - aux * aux1
#	}
#      }
#    }
#    value <- c(log(c(values[q], diff(values[q:1]))), angles)
#    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
#    class(value) <- c("pdGivens", "pdSymm", "pdMat")
#    return(value)
#  }
#  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
#  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
#    stop(paste("An object of length", length(val),
#	       "does not match the required parameter size"))
#  }
#  class(val) <- c("pdGivens", "pdSymm", "pdMat")
#  val
#}

#pdFactor.pdGivens <-
#  function(object)
#{
#  round(Ncol <- (-1 + sqrt(1 + 8 * length(object))) / 2)
#  .C("Givens_pd", 
#     Factor = double(Ncol * Ncol),
#     as.integer(Ncol), 
#     as.double(object))$Factor
#}

#####* Methods for standard generics

#summary.pdGivens <-
#  function(object,
#	   structName = "General positive-definite, Givens parametrization")
#{
#  summary.pdMat(object, structName)
#}

#### No need to implement other methods as the methods for pdMat
#### are sufficient.

#pdConstruct.pdSymm <- pdConstruct.pdMatrixLog    #default parametrization

####*# pdNatural - a general positive definite structure parameterized
####   by the log of the square root of the diagonal elements and the
####   generalized logit of the correlations. This is NOT an unrestricted
####   parametrization 

####* Constructor

pdNatural <- 
  ## Constructor for the pdNatural class
  function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent()))
{
  object <- numeric(0)
  class(object) <- c("pdNatural", "pdMat")
  pdConstruct(object, value, form, nam, data)
}

####* Methods for local generics

pdConstruct.pdNatural <-
  function(object, value = numeric(0), form = formula(object), 
	   nam = Names(object), data = sys.frame(sys.parent()))
{
  val <- pdConstruct.pdMat(object, value, form, nam, data)
  if (length(val) == 0) {               # uninitiliazed object
    class(val) <- c("pdNatural", "pdMat")
    return(val)
  }
  if (is.matrix(val)) {			
    q <- ncol(val)
    if (q > 1) {
      aux <- crossprod(val)
      stdDev <- sqrt(diag(aux))
      aux <- t(aux/stdDev)/stdDev
      aux <- aux[row(aux) > col(aux)]
      value <- c(log(stdDev), log((aux + 1)/(1 - aux)))
    } else {
      value <- log(val)
    }
    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
    class(value) <- c("pdNatural", "pdMat")
    return(value)
  }
  Ncol <- round((sqrt(8*length(val) + 1) - 1)/2)
  if (length(val) != round((Ncol * (Ncol + 1))/2)) {
    stop(paste("An object of length", length(val),
	       "does not match the required parameter size"))
  }
  class(val) <- c("pdNatural", "pdMat")
  val
}

pdFactor.pdNatural <-
  function(object)
{
  Ncol <- round((-1 + sqrt(1 + 8 * length(object))) / 2)
  .C("natural_pd", 
     Factor = double(Ncol * Ncol),
     as.integer(Ncol), 
     as.double(object),
     PACKAGE = "nlme")$Factor
}

pdMatrix.pdNatural <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot extract matrix from an uninitialized object")
  }
  if (factor) {
    Ncol <- Dim(object)[2]
    value <- array(pdFactor(object), c(Ncol, Ncol), attr(object, "Dimnames"))
    attr(value, "logDet") <- sum(log(diag(value)))
    value
  } else {
    NextMethod()
  }
}

####* Methods for standard generics

coef.pdNatural <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained || !isInitialized(object)) NextMethod()
  else {				# standard deviations and correlations
    Ncol <- round((-1 + sqrt(1 + 8 * length(object))) / 2)
    val <- exp(as.vector(object))
    aux <- val[-(1:Ncol)]
    val[-(1:Ncol)] <- (aux - 1) / (aux + 1)
    aN <- Names(object)
    aNmat <- t(outer(aN, aN, paste, sep = ","))
    names(val) <- c(paste("sd(",aN,")", sep = ""), 
		    if (Ncol > 1) {
		      paste("cor(", aNmat[row(aNmat) > col(aNmat)],")",sep="")
		    })
    val
  }
}

Dim.pdNatural <-
  function(object)
{
  if (isInitialized(object)) {
    val <- round((sqrt(8*length(object) + 1) - 1)/2)
    c(val, val)
  } else {
    NextMethod()
  }
}

logDet.pdNatural <-
  function(object)
{
  if (!isInitialized(object)) {
    stop(paste("Cannot extract the log of the determinant",
	       "from an uninitialized object"))
  }
  attr(pdMatrix(object, factor = TRUE), "logDet")
}
 

solve.pdNatural <-
  function(a, b)
{
  if (!isInitialized(a)) {
    stop("Cannot get the inverse of an uninitialized object")
  }
  Ncol <- round((-1 + sqrt(1 + 8 * length(a))) / 2)
  if (Ncol > 1) {
    val <- array(.Fortran("dbksl",
			  as.double(pdFactor(a)),
			  as.integer(Ncol),
			  as.integer(Ncol),
			  val = as.double(diag(Ncol)),
			  as.integer(Ncol),
			  integer(1))[["val"]], c(Ncol, Ncol))
    val <- val %*% t(val)
    stdDev <- sqrt(diag(val))
    val <- t(val/stdDev)/stdDev
    val <- val[row(val) > col(val)]
    coef(a) <- c(log(stdDev), log((val + 1)/(1 - val)))
  } else {
    coef(a) <- -coef(a)
  }
  a
}

summary.pdNatural <-
  function(object,
	   structName = "General positive-definite, Natural parametrization")
{
  summary.pdMat(object, structName)
}

### No need to implement other methods as the methods for pdMat
### are sufficient.

###*# pdDiag - diagonal structure parameterized by the logarithm of
###   the square root of the diagonal terms.

####* Constructor

pdDiag <-
  ## Constructor for the pdDiag class
  function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent()))
{
  object <- numeric(0)
  class(object) <- c("pdDiag", "pdMat")
  pdConstruct(object, value, form, nam, data)
}

####* Methods for local generics

corMatrix.pdDiag <-
  function(object)
{
  val <- diag(length(as.vector(object)))
  attr(val, "stdDev") <- exp(as.vector(object))
  len <- length(as.vector(object))
  if (length(nm <- Names(object)) == 0) {
    nm <- paste("V", 1:len, sep = "")
    dimnames(val) <- list(nm, nm)
  }
  names(attr(val, "stdDev")) <- nm
  val
}
  
pdConstruct.pdDiag <-
  function(object, value = numeric(0), form = formula(object), 
	   nam = Names(object), data = sys.frame(sys.parent()))
{
  val <- NextMethod()
  if (length(val) == 0) {               # uninitiliazed object
    return(val)
  }
  if (is.matrix(val)) {			# initialize from a positive definite
#    if (any(value[row(val) != col(val)])) {
#      warning("Initializing matrix is not diagonal")
#    }
    value <- log(diag(crossprod(val)))/2
    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
    class(value) <- c("pdDiag", "pdMat")
    return(value)
  }
  if ((aux <- length(Names(val))) > 0) {
    if (aux && (aux != length(val))) {
      stop(paste("An object of length", length(val),
		 "does not match the required parameter size"))
    }
  }
  val
}

pdFactor.pdDiag <-
  function(object)
{
  diag(exp(as.vector(object)), length(object))
}

pdMatrix.pdDiag <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot extract the matrix from an uninitialized object")
  }
  len <- length(as.vector(object))
  if (factor) {
    value <- diag(exp(as.vector(object)), len)
    attr(value, "logDet") <- sum(as.vector(object))
  } else {
    value <- diag(exp(2 * as.vector(object)), len)
  }
  dimnames(value) <- attr(object, "Dimnames")
  value
}

####* Methods for standard generics

coef.pdDiag <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained) NextMethod()
  else {
    val <- exp(as.vector(object))
    names(val) <- paste("sd(",Names(object),")", sep ="")
    val
  }
}

Dim.pdDiag <-
  function(object)
{
  if (isInitialized(object)) {
    val <- length(object)
    c(val, val)
  } else {
    NextMethod()
  }
}

logDet.pdDiag <-
  function(object)
{
  if (!isInitialized(object)) {
    stop(paste("Cannot extract the log of the determinant",
	       "from an uninitialized object"))
  }
  sum(as.vector(object))
}

solve.pdDiag <-
  function(a, b)
{
  if (!isInitialized(a)) {
    stop("Cannot extract the inverse from an uninitialized object")
  }
  coef(a) <- -coef(a, TRUE)
  a
}

summary.pdDiag <-
  function(object, structName = "Diagonal")
{
  summary.pdMat(object, structName, noCorrelation = TRUE)
}

### No need to implement other methods as the "pdMat" methods suffice.

###*# pdIdent: multiple of the identity matrix - the parameter is
###   the log of the multiple. 

####* Constructor

pdIdent <-
  ## Constructor for the pdIdent class
  function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent()))
{
  object <- numeric(0)
  class(object) <- c("pdIdent", "pdMat")
  pdConstruct(object, value, form, nam, data)
}

####* Methods for local generics

corMatrix.pdIdent <-
  function(object)
{
  if (!isInitialized(object)) {
    stop("Cannot extract the matrix from an uninitialized pdMat object")
  }
  if (is.null(Ncol <- attr(object, "ncol"))) {
    stop(paste("Cannot extract the matrix with uninitialized dimensions"))
  }
  val <- diag(Ncol)
  attr(val, "stdDev") <- rep(exp(as.vector(object)), Ncol)
  if (length(nm <- Names(object)) == 0) {
    nm <- paste("V", 1:len, sep = "")
    dimnames(val) <- list(nm, nm)
  }
  names(attr(val, "stdDev")) <- nm
  val
}

pdConstruct.pdIdent <-
  function(object, value = numeric(0), form = formula(object), 
	   nam = Names(object), data = sys.frame(sys.parent()))
{
  val <- NextMethod()
  if (length(val) == 0) {			# uninitialized object
    if ((ncol <- length(Names(val))) > 0) {
      attr(val, "ncol") <- ncol
    }
    return(val)
  }
  if (is.matrix(val)) {
#    if (any(val[row(val) != col(val)])) {
#      warning("Initializing pdIdent object from non-diagonal matrix")
#    }
#    if (any(diag(val) != val[1,1])) {
#      warning("Diagonal of initializing matrix is not constant")
#    }
    value <- log(mean(diag(crossprod(val))))/2
    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
    attr(value, "ncol") <- dim(val)[2]
    class(value) <- c("pdIdent", "pdMat")
    return(value)
  }
  if (length(val) > 1) {
    stop(paste("An object of length", length(val),
	       "does not match the required parameter size"))
  }
  if (((aux <- length(Names(val))) == 0) && is.null(formula(val))) {
    stop(paste("Must give names when initializing pdIdent from parameter.",
	       "without a formula"))
  } else {
    attr(val, "ncol") <- aux
  }
  val
}

pdFactor.pdIdent <-
  function(object)
{
  exp(as.vector(object)) * diag(attr(object, "ncol"))
}


pdMatrix.pdIdent <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot extract the matrix from an uninitialized pdMat object")
  }
  if (is.null(Ncol <- attr(object, "ncol"))) {
    stop(paste("Cannot extract the matrix with uninitialized dimensions"))
  }
  value <- diag(Ncol)
  if (factor) {
    value <- exp(as.vector(object)) * value
    attr(value, "logDet") <- Ncol * as.vector(object)
  } else {
    value <- exp(2 * as.vector(object)) * value
  }
  dimnames(value) <- attr(object, "Dimnames")
  value
}

####* Methods for standard generics

coef.pdIdent <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained) NextMethod()
  else structure(exp(as.vector(object)),
           names = c(paste("sd(", deparse(formula(object)[[2]]),")",sep = "")))
}

Dim.pdIdent <- 
  function(object)
{
  if (!is.null(val <- attr(object, "ncol"))) {
    c(val, val)
  } else {
    stop("Cannot extract the dimensions")
  }
}

logDet.pdIdent <-
  function(object)
{
  attr(object, "ncol") * as.vector(object)
}

solve.pdIdent <-
  function(a, b)
{
  if (!isInitialized(a)) {
    stop("Cannot extract the inverse from an uninitialized object")
  }
  coef(a) <- -coef(a, TRUE)
  a
}

summary.pdIdent <-
  function(object, structName = "Multiple of an Identity")
{
  summary.pdMat(object, structName, noCorrelation = TRUE)
}

###*# pdCompSymm: Compound symmetry structure

####* Constructor

pdCompSymm <-
  ## Constructor for the pdCompSymm class
  function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent()))
{
  object <- numeric(0)
  class(object) <- c("pdCompSymm", "pdMat")
  pdConstruct(object, value, form, nam, data)
}

####* Methods for local generics

corMatrix.pdCompSymm <-
  function(object)
{
  if (!isInitialized(object)) {
    stop("Cannot extract the matrix from an uninitialized pdMat object")
  }
  if (is.null(Ncol <- attr(object, "ncol"))) {
    stop(paste("Cannot extract the matrix with uninitialized dimensions"))
  }
  obj <- as.vector(object)
  aux <- exp(obj[2])
  aux <- c(exp(2 * obj[1]), (aux - 1/(Ncol - 1))/(aux + 1))
  value <- array(aux[2], c(Ncol, Ncol))
  value[row(value) == col(value)] <- 1
  attr(value, "stdDev") <- rep(exp(obj[1]), Ncol)
  if (length(nm <- Names(object)) == 0) {
    nm <- paste("V", 1:Ncol, sep = "")
    dimnames(value) <- list(nm, nm)
  }
  names(attr(value, "stdDev")) <- nm
  value
}

pdConstruct.pdCompSymm <-
  function(object, value = numeric(0), form = formula(object), 
	   nam = Names(object), data = sys.frame(sys.parent()))
{
  val <- NextMethod()
  if (length(val) == 0) {                # uninitialized object
    if ((nc <- length(Names(val))) > 0) {
      attr(val, "ncol") <- nc
    }
    return(val)
  }
  if (is.matrix(val)) {
    value <- crossprod(val)
#    if (length(unique(value[row(value) != col(value)])) > 1) {
#      warning("Initializing pdCompSymm object from non-compound symmetry matrix")
#    }
#    if (any(diag(value) != value[1,1])) {
#      warning("Diagonal of initializing matrix is not constant")
#    }
    nc <- dim(value)[2]
    aux <- 1/sqrt(diag(value))
    aux <- aux * t(value * aux)
    if ((aux <- mean(aux[row(aux) != col(aux)])) <= -1/(nc - 1)) {
      aux <- -1/nc
      warning("Initializing pdCompSymm object is not positive definite")
    }
    value <- c(log(mean(diag(value)))/2, log((aux + 1/(nc - 1))/(1 - aux)))
    attributes(value) <- attributes(val)[names(attributes(val)) != "dim"]
    attr(value, "ncol") <- nc
    class(value) <- c("pdCompSymm", "pdMat")
    return(value)
  }
  if (length(val) != 2) {
    stop(paste("An object of length", length(val),
	       "does not match the required parameter size"))
  }
  if (((aux <- length(Names(val))) == 0) && is.null(formula(val))) {
    stop(paste("Must give names when initializing pdCompSymm from parameter.",
	       "without a formula"))
  } else {
    attr(val, "ncol") <- aux
  }
  val
}

pdFactor.pdCompSymm <-
  function(object)
{
  Ncol <- attr(object, "ncol")
  .C("compSymm_pd", 
     Factor = double(Ncol * Ncol),
     as.integer(Ncol),
     as.double(object),
     PACKAGE = "nlme")$Factor
}

pdMatrix.pdCompSymm <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot extract the matrix from an uninitialized pdMat object")
  }
  if (is.null(Ncol <- attr(object, "ncol"))) {
    stop(paste("Cannot extract the matrix with uninitialized dimensions"))
  }

  obj <- as.vector(object)
  aux <- exp(obj[2])
  aux <- c(exp(2 * obj[1]), (aux - 1/(Ncol - 1))/(aux + 1))
  if (factor) {
    value <- array(pdFactor(object), c(Ncol, Ncol))
    attr(value, "logDet") <-  Ncol * obj[1] + 
      ((Ncol - 1) * log(1 - aux[2]) + log(1 + (Ncol - 1) * aux[2]))/2
  } else {
    value <- array(aux[2], c(Ncol, Ncol))
    value[row(value) == col(value)] <- 1
    value <- aux[1] * value
  }
  dimnames(value) <- attr(object, "Dimnames")
  value
}

####* Methods for standard generics

coef.pdCompSymm <-
  function(object, unconstrained = TRUE)
{
  if (unconstrained || !isInitialized(object)) NextMethod()
  else {
    if (is.null(Ncol <- attr(object, "ncol"))) {
      stop(paste("Cannot obtain constrained coefficients with",
		 "uninitialized dimensions"))
    }
    val <- as.vector(object)
    aux <- exp(val[2])
    val <- c(exp(val[1]), (aux - 1 / (Ncol - 1)) / (aux + 1))
    names(val) <- c("std. dev", "corr.")
    val
  }
}

Dim.pdCompSymm <- 
  function(object)
{
  if (!is.null(val <- attr(object, "ncol"))) {
    c(val, val)
  } else {
    stop("Cannot extract the dimensions")
  }
}

logDet.pdCompSymm <-
  function(object)
{
  attr(pdMatrix(object, factor = TRUE), "logDet")
}

summary.pdCompSymm <-
  function(object, structName = "Compound Symmetry")
{
  summary.pdMat(object, structName)
}

####*# pdBlocked: A blocked variance structure

#####* Constructor

pdBlocked <-
  ## Constructor for the pdBlocked class
  function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent()),
	   pdClass = "pdSymm")
{
  object <- numeric(0)
  class(object) <- c("pdBlocked", "pdMat")
  pdConstruct(object, value, form, nam, data, pdClass)
}

####* Methods for local generics

corMatrix.pdBlocked <-
  function(object)
{
  if (!isInitialized(object)) {
    stop("Cannot access the matrix of uninitialized objects")
  }
  if (length(Names(object)) == 0) {
    stop("Cannot access the matrix of object without names")
  }
  namesList <- Names(object, TRUE)
  Ncol <- Dim(object)[2]
  value <- array(0, c(Ncol, Ncol), attr(object, "Dimnames"))
  stdDev <- double(Ncol)
  names(stdDev) <- colnames(value)
  for (i in seq(along = object)) {
    aux <- corMatrix(object[[i]])
    value[namesList[[i]], namesList[[i]]] <- as.vector(aux)
    stdDev[namesList[[i]]] <- attr(aux, "stdDev")
  }
  attr(value, "stdDev") <- stdDev
  value
}
  

pdConstruct.pdBlocked <-
  function(object, value = numeric(0), form = formula(object, TRUE), 
	   nam = Names(object, TRUE), data = sys.frame(sys.parent()), 
	   pdClass = "pdSymm")
{
  if (inherits(value, "pdMat")) {	# constructing from another pdMat
    if (inherits(value, "pdBlocked")) {
      if (length(form) == 0) form <- formula(value, TRUE)
      if (length(nam) == 0) nam <- Names(value, TRUE)
      if (missing(pdClass)) pdClass <- unlist(lapply(value, data.class))
    }
    if (isInitialized(value)) {
      return(pdConstruct(object, as.matrix(value), form, nam, data, pdClass))
    } else {
      return(pdConstruct(object, form = form, nam = nam, data = data,
                         pdClass = pdClass))
    }
  }
  ## checking validity and consistency of form, nam, and pdClass
  if (!is.null(form)) {
    if (data.class(form) != "list") {
      stop("\"form\" must be a list")
    }
    nF <- length(form)
  } else {
    nF <- 0
  }

  if (!is.null(nam)) {
    if (data.class(nam) != "list") {
      stop("\"nam\" must be a list")
    }
    nN <- length(nam)
    if ((nF > 0) && (nN != nF)) {
      stop("\"form\" and \"nam\" have incompatible lengths")
    }
  } else {
    nN <- 0
  }

  if (!missing(pdClass)) {
    if (!is.character(pdClass)) {
      stop("\"pdClass\" must be a character vector")
    }
    nP <- length(pdClass)
    if ((nP > 1)) {
      if ((nF > 0) && (nF != nP)) {
	stop("\"form\" and \"pdClass\" have incompatible lengths")
      }
      if ((nN > 0) && (nN != nP)) {
	stop("\"nam\" and \"pdClass\" have incompatible lengths")
      }
    }
  } else {
    nP <- 1
  }
  
  nB <- max(c(nF, nN, nP))

  oVal <- value
  if (length(value) == 0 || is.matrix(value) || is.numeric(value)) {
    if (nB == 1) {
      stop("None of the arguments specify more than one block")
    }
    ## will first do a null initialization when value is a matrix or numeric
    value <- lapply(vector("list", nB), function(el) numeric(0))
  } else {
    if (data.class(value) != "list") {
      stop(paste("\"object\" must be a list, when not missing,",
		 "not a matrix, and not numeric"))
    }
    nO <- length(value)
    if ((nB > 1) && (nB != nO)) {
      stop("Arguments imply different number of blocks")
    }
    nB <- nO
  }
  if (nP == 1) {
    pdClass <- rep(pdClass, nB)
  }

  object <- vector("list", nB)
  namInterc <- rep(FALSE, nB)
  namCoef <- vector("list", nB)
  for(i in 1:nB) {
    if (is.null(nm <- nam[[i]])) {
      if (is.null(frm <- form[[i]])) {
        if (inherits(value[[i]], "formula")) {
          nm <- Names(getCovariateFormula(value[[i]]))
          if ((length(nm) == 1) && (nm == "(Intercept)") &&
              length(value[[i]]) == 3) {
            ## nlme case with single intercept terms
            nm <-  sapply(splitFormula(getResponseFormula(value[[i]])[[2]],
                                       sep = "+"),
                          function(el) deparse(el[[2]]))
          }
          if (length(value[[i]]) == 3) { # nlme case
            namCoef[[i]] <-
              sapply(splitFormula(getResponseFormula(value[[i]])[[2]],
                                  sep = "+"),
                     function(el) deparse(el[[2]]))
          }
        }
      } else {
        if (inherits(frm, "formula")) {
          nm <- Names(getCovariateFormula(frm))
          if ((length(nm) == 1) && (nm == "(Intercept)") &&
              length(frm) == 3) {
            ## nlme case with single intercept terms
            nm <-  sapply(splitFormula(getResponseFormula(frm)[[2]],
                                       sep = "+"),
                          function(el) deparse(el[[2]]))
          }
          if (length(value[[i]]) == 3) { # nlme case
            namCoef[[i]] <-
              sapply(splitFormula(getResponseFormula(value[[i]])[[2]],
                                  sep = "+"),
                     function(el) deparse(el[[2]]))
          }
        } else {                        # listForm
          nm <- unique(unlist(lapply(frm,
                                     function(el) {
                                       Names(getCovariateFormula(el))
                                     })))
          if ((length(nm) == 1) && (nm == "(Intercept)") &&
              length(frm[[1]]) == 3) {
            ## nlme case with single intercept terms
            nm <-  sapply(frm, function(el) {
              sapply(splitFormula(getResponseFormula(el)[[2]],
                                  sep = "+"), function(el1) deparse(el1[[2]]))
            })
          }
          namCoef[[i]] <- sapply(frm, function(el) {
            sapply(splitFormula(getResponseFormula(el)[[2]],
                                  sep = "+"), function(el1) deparse(el1[[2]]))
          })
        }
      }
    }
    if (!is.null(nm)) {
      namInterc[i] <- (length(nm) == 1) && (nm == "(Intercept)")
    }
    object[[i]] <- pdMat(value[[i]], form[[i]], nam[[i]], data, pdClass[i])
  }
  if (!all(unlist(lapply(object, inherits, "pdMat")))) {
    stop("all elements in the argument must generate pdMat objects")
  }
  namesList <- lapply(object, Names)
  lNam <- unlist(lapply(namesList, length))
#  namInterc <- unlist(lapply(namesList,
#                             function(el) {
#                               (length(el) == 1) && (el == "(Intercept)")
#                             }))
  if (!is.null(namCoef[[1]])) {         # nlme case
    namCoef <- unlist(namCoef)
    duplCoef <- unique(namCoef[duplicated(namCoef)])
    if (length(duplCoef) > 0) {
      for(i in 1:nB) {
        wchDupl <- !is.na(match(namesList[[i]], duplCoef))
        if (any(wchDupl)) {
          namesList[[i]][wchDupl] <-
            paste(namesList[[i]][wchDupl], "(Intercept)", sep = ".")
          Names(object[[i]]) <- namesList[[i]]
        }
      }
    }
  }
  if (sum(namInterc) > 1 && (length(unique(lNam[namInterc])) == 1)) {
    stop("Cannot have duplicated column names in a pdMat object")
  }
  if ((sum(namInterc) == length(lNam)) ||
      !any(lNam[!namInterc])) {			# no names
    class(object) <- c("pdBlocked", "pdMat")
    if (is.null(formula(object))) {
      stop("Must have formula, when no names are given")
    }
    if (length(oVal) && (is.matrix(oVal) || is.numeric(oVal))) {
      stop("Must give names when initializing from matrix or parameter")
    }
    return(object)
  } else {
    if (!all(lNam)) {
      stop("All elements must have names, when any has names.")
    }
    attr(object, "namesList") <- namesList
    allNames <- unlist(namesList)
    if (any(duplicated(allNames))) {
      stop("Cannot have duplicated column names in a pdMat object")
    }
    plen <- unlist(lapply(object, function(el)
			  {
			    if (isInitialized(el)) {
			      length(coef(el, TRUE))
			    } else {
			      matrix(el) <- diag(length(Names(el)))
			      length(coef(el, TRUE))
			    }
			  }))
    if (!all(plen)) {
      stop("All elements must have a non-zero size")
    }
    attr(object, "plen") <- plen
    attr(object, "Dimnames") <- list(allNames, allNames)
    class(object) <- c("pdBlocked", "pdMat")

    if (length(oVal) > 0) {
      if (is.matrix(oVal)) {		# initializing from matrix
	matrix(object) <- oVal
      } else if (is.numeric(oVal)){		# initializing from a vector
	coef(object) <- oVal
      }
    }
    return(object)
  }
}

pdMatrix.pdBlocked <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot access the matrix of uninitialized objects")
  }
  if (length(Names(object)) == 0) {
    stop("Cannot access the matrix of object without names")
  }
  namesList <- Names(object, TRUE)
  Ncol <- Dim(object)[2]
  value <- array(0, c(Ncol, Ncol), attr(object, "Dimnames"))
  if (factor) {
    lD <- 0
  }
  for (i in seq(along = object)) {
    aux <- pdMatrix(object[[i]], factor)
    value[namesList[[i]], namesList[[i]]] <- as.vector(aux)
    if (factor) lD <- lD + attr(aux, "logDet")
  }
  if (factor) attr(value, "logDet") <- lD
  value
}

####* Methods for standard generics

coef.pdBlocked <-
  function(object, unconstrained = TRUE)
{
  unlist(lapply(object, coef, unconstrained))
}

"coef<-.pdBlocked" <-
  function(object, value)
{
  if (is.null(plen <- attr(object, "plen"))) {
    stop(paste("Cannot change the parameter when",
	       "length of parameters is undefined"))
  }
  if (length(value) != sum(plen)) {
    stop("Cannot change parameter length of initialized pdMat object")
  }
  ends <- cumsum(plen)
  starts <- 1 + c(0, ends[-length(ends)])
  for (i in seq(along = object)) {
    coef(object[[i]]) <- value[(starts[i]):(ends[i])]
  }
  object
}

formula.pdBlocked <-
  function(object, asList = TRUE)
{
  val <- lapply(object, formula)
  isNULL <- unlist(lapply(val, is.null))
  if (all(isNULL)) return(NULL)
  if (any(isNULL)) {
    stop("All elements must have formulas, when any has a formula.")
  }
  if (asList) return(val)
  isTwoSided <- unlist(lapply(val,
                              function(el) {
                                inherits(el, "listForm")
                              }))
  if (all(isTwoSided)) {
    ## list of two-sided formulas
    val <- do.call("c", val)
#    for(i in seq(along = object)) {
#      val <- if (inherits(object[[i]], "formula")) list(object[[i]])
#               else object[[i]]
#    }
    class(val) <- "listForm"
    return(val)
  }
  if (any(isTwoSided)) {
    stop(paste("All elements of formula must be list of two-sided formulae",
               "or two-sided formulae"))
  }
  val <- lapply(val, terms)
  aux <- paste(unlist(lapply(val, function(el) attr(el, "term.labels"))),
	       collapse = "+")
  if (!any(unlist(lapply(val, function(el) attr(el, "intercept"))))) {
    ## no intercept
    aux <- paste(aux, " - 1")
  }
  eval(parse(text = paste("~", aux)))
}

isInitialized.pdBlocked <-
  function(object)
{
  all(unlist(lapply(object, isInitialized)))
}

logDet.pdBlocked <-
  function(object)
{
  sum(unlist(lapply(object, logDet)))
}

"matrix<-.pdBlocked" <-
  function(object, value)
{
  value <- as.matrix(value)
  namesList <- Names(object, TRUE)
  Ncol <- Dim(object)[2]
  dims <- dim(value)
  if (!((dims[1] == dims[2]) && (dims[1] == Ncol))) {
    stop("Cannot change the number of columns on an initialized object")
  }
  if (is.null(vNames <- rownames(value))) {
    vNames <- unlist(namesList)
    dimnames(value) <- list(vNames, vNames)
  } else {
    if (!(all(match(unlist(namesList), vNames, nomatch = 0)))) {
      stop("Names of object and value must match.")
    }
    attr(object, "Dimnames") <- list(vNames, vNames)
  }
  for (i in seq(along = object)) {
    matrix(object[[i]]) <- value[namesList[[i]], namesList[[i]]]
  }
  object
}

Names.pdBlocked <-
  function(object, asList = FALSE)
{
  if (asList) attr(object, "namesList")
  else attr(object, "Dimnames")[[2]]
}

"Names<-.pdBlocked" <-
  function(object, ..., value)
{
  if (!is.null(Names(object))) NextMethod()
  else {
    ## cannot do anything before initialization of names
    object
  }
}

pdFactor.pdBlocked <-
  function(object)
{
  pdMatrix(object, factor = TRUE)
}

solve.pdBlocked <-
  function(a, b)
{
  if (!isInitialized(a)) {
    stop("Cannot get the inverse of an uninitialized object")
  }
  coef(a) <- unlist(lapply(a, function(el) coef(solve(el), TRUE)))
  a
}

summary.pdBlocked <-
  function(object, structName = "Blocked")
{
  value <- lapply(object, summary)
  names(value) <- unlist(lapply(object, function(el) paste(Names(el),
							   collapse = ", ")))
  attr(value, "structName") <- structName
  attr(value, "elementName") <- "Block"
  class(value) <- "summary.pdMat"
  value
}

"[.pdBlocked" <- 
  function(x, i, j, drop = TRUE)
{
  xx <- x
  x <- as.matrix(x)
  mCall <- match.call()
  mCall[[1]] <- get("[")
  mCall[["x"]] <- x
  mCall[["drop"]] <- drop
  if (length(i) == length(j) && mode(i) == mode(j) && all(i == j)) {
    mCall[["drop"]] <- F		# even for a 1 by 1 submatrix,
					# you want it to be a matrix
    val <- eval(mCall)
    vNames <- colnames(val)
    auxNames <- lapply(Names(xx, TRUE), 
		       function(el, vN) {
			 aux <- match(vN, el)
			 if (any(aux1 <- !is.na(aux))) {
			   el[aux[aux1]]
			 }
		       }, vN = vNames)
    auxWhich <- !unlist(lapply(auxNames, is.null))
    if (sum(auxWhich) == 1) {
      return(pdConstruct(as.list(xx)[auxWhich][[1]], val))
    }
    auxNames <- auxNames[auxWhich]
    auxClass <- unlist(lapply(xx, function(el) class(el)[1]))[auxWhich]
    return(pdConstruct(xx, val, nam = auxNames, form = NULL, 
		       pdClass = auxClass))
  } else {
    eval(mCall)
  }
}

### Local variables:
### mode: S
### End:


### $Id: reStruct.q,v 1.2 1999/11/17 22:09:19 saikat Exp $
###
###      Methods for the class of random-effects structures.
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

##*## Generics that should be implemented for any reStruct class

###*# Constructor

reStruct <- 
  function(object, pdClass = "pdSymm", REML = FALSE, data = sys.frame(sys.parent()))
{
  ## object can be:
  ## 1) a named list of formulas or pdMats with grouping factors as names
  ##    (assume same order of nesting as order of names)
  ## 2) a formula of the form ~ x | g or ~ x | g1/g2/../gn
  ## 3) a list of formulas like ~x | g
  ## 4) a formula like ~x, a pdMat object, or a list of such
  ##    formulas or objects . In this case, the data used to
  ##    initialize the reStruct will be required to inherit from class
  ##    "groupedData" 
  ## 5) another reStruct object
  ## parametrization specifies the pdMat constructor to be used for all
  ## formulas used in object

  if (inherits(object, "reStruct")) {	# little to do, return object
    if (!missing(REML)) attr(object, "settings")[1] <- as.integer(REML)
    object[] <- lapply(object,
		       function(el, data) {
			 pdMat(el, data = data)
		       }, data = data)
    return(object)
  }
  plen <- NULL
  if (inherits(object, "formula")) {	# given as a formula
    if (is.null(grpForm <- getGroupsFormula(object, asList = TRUE))) {
      object <- list( object )
    } else {
      if (length(object) == 3) {        # nlme type of formula
        object <-
          eval(parse(text = paste(deparse(getResponseFormula(object)[[2]]),
                       deparse(getCovariateFormula(object)[[2]]), sep = "~")))
      } else {
        object <- getCovariateFormula(object)
      }
      object <- rep( list(object), length( grpForm ) )
      names( object ) <- names( grpForm )
    }
  } else if (inherits(object, "pdMat")) { # single group, as pdMat
    if (is.null(formula(object))) {
      stop("pdMat element must have a formula")
    }
    object <- list(object)
  } else {
    if (data.class(object) != "list") {
      stop("Object must be a list or a formula")
    }
    ## checking if nlme-type list - unnamed list of 2-sided formulas
    if (is.null(names(object)) &&
        all(unlist(lapply(object, function(el) {
          inherits(el, "formula") && length(el) == 3})))) {
      object <- list(object)
    } else {
      ## checking if elements are valid
      object <- lapply(object, 
                       function(el) {
                         if (inherits(el, "pdMat")) {
                           if (is.null(formula(el))) {
                             stop("pdMat elements must have a formula")
                           }
                           return(el) 
                         }
                         if (inherits(el, "formula")) {
                           grpForm <- getGroupsFormula(el)
                           if (!is.null(grpForm)) {
                             el <- getCovariateFormula(el)
                             attr(el, "grpName") <- deparse(grpForm[[2]])
                           } 
                           return(el)
                         } else {
                           if (data.class(el) == "list" &&
                               all(unlist(lapply(el, function(el1) {
                                 inherits(el1, "formula") && length(el1) == 3
                               })))) { return(el) }
                           else {
                 stop("Elements in object must be formulas or pdMat objects")
                           }
                         }
		     })
    }
    if (is.null(namObj <- names(object))) {
      namObj <- rep("", length(object))
    }
    aux <- unlist(lapply(object, 
			 function(el) {
			   if (inherits(el, "formula") && 
			       !is.null(attr(el, "grpName"))) {
			     attr(el, "grpName")
			   } else ""
			 }))
    auxNam <- namObj == ""
    if (any(auxNam)) {
      namObj[auxNam] <- aux[auxNam]
    }
    names(object) <- namObj
  }

  ## converting elements in object to pdMat objects
  object <- lapply(object,
		   function(el, pdClass, data) {
		     pdMat(el, pdClass = pdClass, data = data)
		   }, pdClass = pdClass, data = data)

  object <- rev(object)			# inner to outer groups
  if (all(unlist(lapply(object, isInitialized)))) {
    plen <- unlist(lapply(object, function(el) length(coef(el))))
  }
  pC <- unlist(lapply(object, data.class))
  pC <- match(pC, c("pdSymm", "pdDiag", "pdIdent", "pdCompSymm"), 0) - 1
#  if (any(pC == -1)) {                 # multiple nesting 
#    pC <- -1
#  } 
  ## at this point, always require asDelta = TRUE and gradHess = 0
  attr(object, "settings") <- c(as.integer(REML), 1, 0, pC)
  attr(object, "plen") <- plen
  class(object) <- "reStruct"
  object
}

###*# Methods for pdMat generics

corMatrix.reStruct <-
  function(object)
{
  if (!isInitialized(object)) {
    stop("Cannot access the matrix of uninitialized objects")
  }
  as.list(rev(lapply(object, corMatrix)))
}
  
pdFactor.reStruct <-
  function(object)
{
  unlist(lapply(object, pdFactor))
}

pdMatrix.reStruct <-
  function(object, factor = FALSE)
{
  if (!isInitialized(object)) {
    stop("Cannot access the matrix of uninitialized objects")
  }
  as.list(rev(lapply(object, pdMatrix, factor)))
}

###*# Methods for standard generics

as.matrix.reStruct <-
  function(object) pdMatrix(object)

coef.reStruct <-
  function(object, unconstrained = TRUE)
{
  unlist(lapply(object, coef, unconstrained))
}

"coef<-.reStruct" <-
  function(object, value)
{
  if (is.null(plen <- attr(object, "plen"))) {
    stop(paste("Cannot change the parameter when",
	       "length of parameters is undefined"))
  }
  if (length(value) != sum(plen)) {
    stop("Cannot change parameter length of initialized objects")
  }
  ends <- cumsum(plen)
  starts <- 1 + c(0, ends[-length(ends)])
  for (i in seq(along = object)) {
    coef(object[[i]]) <- value[(starts[i]):(ends[i])]
  }
  object
}

formula.reStruct <-
  function(object, asList = FALSE)
{
  as.list(lapply(object, formula, asList))
}

getGroupsFormula.reStruct <-
  function(object, asList = FALSE, sep)
{
  if (is.null(val <- rev(formula(object)))) {
    stop("Can not extract groups formula without a formula")
  }
  if (is.null(nVal <- names(val))) return(NULL)
  if (asList) {
    for(i in nVal) {
      val[[i]] <- eval(parse(text = paste("~",i)))
    }
  } else {
    val <- eval(parse(text = paste("~",paste(nVal, collapse = "/"))))
  }
  val
}

isInitialized.reStruct <-
  function(object) all(unlist(lapply(object, isInitialized)))

initialize.reStruct <-
  function(object, data, conLin, control = list(niterEM = 20))
{
  ## initialize reStruct object, possibly getting initial estimates
  seqO <- seq(along = object)
  ## check if names are defined
  lNams <- unlist(lapply(object, function(el) length(Names(el)))) == 0
  if (any(lNams)) {			# need to resolve formula names
    aux <- seqO[lNams]
    object[aux] <- lapply(object[aux], 
			  function(el, data) {
			    pdConstruct(el, el, data = data)
			  }, data = data)
  }
  ## obtaining the parameters mapping 
  plen <- unlist(lapply(object, function(el)
			{
			  if (isInitialized(el)) {
			    length(coef(el))
			  } else {
			    matrix(el) <- diag(length(Names(el)))
			    length(coef(el))
			  }
			}))
  if (!all(plen > 0)) {
    stop("All elements of a reStruct object must have a non-zero size")
  }
  attr(object, "plen") <- plen

  ## checking initialization
  isIni <- unlist(lapply(object, isInitialized))
  if (!all(isIni)) {			# needs initialization
    dims <- conLin$dims
    Q <- dims$Q
    qvec <- dims$qvec[1:Q]
    auxInit <- 
      lapply(split(0.375^2 * apply((conLin$Xy[, 1:sum(qvec), drop = FALSE])^2, 
	     2, sum)/ rep(dims$ngrps[1:Q], qvec), rep(1:Q, qvec)),
	     function(x) diag(x, length(x)))
  }
  for(i in seqO) {
    if (isIni[i]) {
      object[[i]] <- solve(object[[i]])	#working with precisions
    } else {
      matrix(object[[i]]) <- auxInit[[i]]
    }
    NULL
  }
  MEEM(object, conLin, control$niterEM) # refine initial estimates with EM
}

logDet.reStruct <-
  function(object) 
{
  unlist(lapply(object, logDet))
}

logLik.reStruct <-
  function(object, conLin)
{
  .C("mixed_loglik",
     as.double(conLin$Xy),
     as.integer(unlist(conLin$dims)),
     as.double(pdFactor(object)),
     as.integer(attr(object, "settings")),
     loglik = double(1),
     double(1),
     PACKAGE = "nlme")$loglik
}

"matrix<-.reStruct" <-
  function(object, value)
{
  if (data.class(value) != "list") value <- list(value)
  if (length(value) != length(object)) {
    stop("Cannot change the length of object")
  }
  value <- rev(value)                   # same order as object
  for(i in seq(along = object)) {
    matrix(object[[i]]) <- value[[i]]
  }
  object
}

model.matrix.reStruct <-
  function(object, data, contrast = NULL)
{
  if (is.null(form <- formula(object, asList = TRUE))) {
    stop("Cannot extract model matrix without formula")
  }
  form1 <- asOneFormula(form)
  if (length(form1) > 0) {
    data <- model.frame(form1, data = data)
  } else {
    data <- data.frame("(Intercept)" = rep(1, nrow(data)))
  }
  any2list <- function( object, data, contrast ) {
    form2list <- function(form, data, contrast) {
      if (length(asOneFormula( form )) == 0) {# the ~ 1 case
        return(list("(Intercept)" = rep(1, dim(data)[1])))
      }
      as.data.frame(unclass(model.matrix(form,
                                         model.frame(form, data),
                                         contrast)))
    }
    if (inherits( object, "formula" )) {
      return( form2list( object, data, contrast ) )
    }
    if (is.list( object ) ) {
      return( unlist(lapply(object, form2list, data = data, contrast = contrast),
                     recursive = FALSE ) )
    }
    return( NULL)
  }
  value <- as.list(lapply(form, any2list,
                          data = data, contrast = contrast))
  ## save the contrasts currently in effect for later predictions
  contr <- as.list(lapply( as.data.frame(data), function(x)
                  if( inherits( x, "factor" ) &&
                     length(levels(x)) > 1) contrasts(x) else NULL ))
  contr[names(contrast)] <- contrast
  
  ncols <- as.vector(unlist(lapply(value, length)))
  nams <- if (length(value) == 1) {
    names(value[[1]])
  } else {
    paste(rep(names(value), ncols), unlist(lapply(value, names)), sep = ".")
  }
  val <- matrix(unlist(value), nrow = nrow(data),
                dimnames = list(row.names(data), nams))
  attr(val, "ncols") <- ncols
  attr(val, "nams") <- as.list(lapply(value, names))
  attr(val, "contr") <- contr
  val
}

Names.reStruct <-
  function(object)
{
  as.list(lapply(object, Names))
}

"Names<-.reStruct" <-
  function(object, ..., value) 
{
  if (length(object) != length(value)) {
    stop("Incompatible lengths for object names")
  }
  for(i in seq(along = object)) {
    Names(object[[i]]) <- value[[i]]
  }
  object
}

needUpdate.reStruct <-
  function(object) F

print.reStruct <-
  function(x, sigma = 1, reEstimates, verbose = FALSE, ...)
{
  if (isInitialized(x)) {
    nobj <- length(x)
    if (is.null(namx <- names(x))) names(x) <- nobj:1
    aux <- t(array(rep(names(x), nobj), c(nobj, nobj)))
    aux[lower.tri(aux)] <- ""
    x[] <- rev(x)
    names(x) <- 
      rev(apply(aux, 1, function(x) paste(x[x != ""], collapse = " %in% ")))
    cat("Random effects:\n")
    for(i in seq(along = x)) {
      print(summary(x[[i]]), sigma, Level = names(x)[i],
            resid = (i == length(x)), ...)
      if (verbose) {
	cat("Random effects estimates:\n")
	print(reEstimates[[i]])
      }
      cat("\n")
    }
  } else {
    cat("Uninitialized random effects structure\n")
  }
}

recalc.reStruct <-
  function(object, conLin)
{
  conLin[["logLik"]] <- conLin[["logLik"]] + logLik(object, conLin)
  conLin
}

solve.reStruct <-
  function(a, b)
{
  a[] <- lapply(a, solve)
  a
}

summary.reStruct <- function(object) object

update.reStruct <-
  function(object, data)
{
  object
}

"[.reStruct" <-
  function(x, ...)
{
  val <- NextMethod()
  if (length(val)) class(val) <- "reStruct"
  val
}

### Local variables:
### mode: S
### End:


### $Id: simulate.q,v 1.3 1999/11/17 22:09:19 saikat Exp $
###
###            Fit a general linear mixed effects model
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

"createConLin"<-
  function(fixed, data = sys.frame(sys.parent()),
	   random = pdSymm(eval(as.call(fixed[-2]))), ...)
{
  Call <- match.call()
  if(!inherits(fixed, "formula") || length(fixed) != 3) {
    stop("\nFixed-effects model must be a formula of the form \"resp ~ pred\"")
  }
  REML <- FALSE
  reSt <- reStruct(random, REML = REML, data = NULL)
  groups <- getGroupsFormula(reSt)
  if(is.null(groups)) {
    if(inherits(data, "groupedData")) {
      groups <- getGroupsFormula(data)
      groupsL <- rev(getGroupsFormula(data, 
				      asList = TRUE))
      Q <- length(groupsL)
      if(length(reSt) != Q) {		# may need to repeat reSt
	if(length(reSt) != 1) {
	  stop("Incompatible lengths for \"random\" and grouping factors")
	}
	auxForm <-
	  eval(parse(text = paste("~", deparse(formula(random)[[2]]), "|",
		       deparse(groups[[2]]))))
	reSt <- reStruct(auxForm, REML = REML, data = NULL)
      }
      else {
	names(reSt) <- names(groupsL)
      }
    }
    else {
      stop(paste("Data must inherit from \"groupedData\" class ",
		 "if random does not define groups"))
    }
  }
  ## create an lme structure containing the random effects model
  lmeSt <- lmeStruct(reStruct = reSt)	
  ## extract a data frame with enough information to evaluate
  ## fixed, groups, reStruct, corStruct, and varStruct
  dataMix <-
    model.frame(formula = asOneFormula(formula(lmeSt), fixed, groups), data = data)
  origOrder <- row.names(dataMix)	# preserve the original order
  ## sort the model.frame by groups and get the matrices and parameters
  ## used in the estimation procedures
  grps <- getGroups(dataMix, eval(parse(text = paste("~1",
					  deparse(groups[[2]]), sep = "|"))))	
  ## ordering data by groups
  if(inherits(grps, "factor")) {	# single level
    ##"order" treats a single named argument peculiarly so must split this off
    ord <- order(grps)			
    grps <- data.frame(grps)
    row.names(grps) <- origOrder
    names(grps) <- as.character(deparse((groups[[2]])))
  }
  else {
    ord <- do.call("order", grps)	
    ## making group levels unique
    for(i in 2:ncol(grps)) {
      grps[, i] <-
        as.factor(paste(as.character(grps[, i - 1]), as.character(grps[, i]), 
                        sep = "/"))
      NULL
    }
  }
  grps <- grps[ord,  , drop = FALSE]
  dataMix <- dataMix[ord,  , drop = FALSE]
  revOrder <- match(origOrder, row.names(dataMix)) # putting in orig. order
  ## obtaining basic model matrices
  N <- nrow(grps)
  Z <- model.matrix(reSt, dataMix)
  ncols <- attr(Z, "ncols")
  Names(lmeSt$reStruct) <- attr(Z, "nams")	
  ## keeping the contrasts for later use in predict
  contr <- attr(Z, "contr")
  X <- model.frame(fixed, dataMix)
  auxContr <- lapply(X, function(el)
		     if(inherits(el, "factor")) contrasts(el))
  contr <- c(contr, auxContr[is.na(match(names(auxContr), names(contr)))])
  contr <- contr[!unlist(lapply(contr, is.null))]
  X <- model.matrix(fixed, X)
  y <- eval(fixed[[2]], dataMix)
  ncols <- c(ncols, dim(X)[2], 1)
  Q <- ncol(grps)	## creating the condensed linear model
  list(Xy = array(c(Z, X, y), c(N, sum(ncols)),
	 list(row.names(dataMix),
	      c(colnames(Z), colnames(X), deparse(fixed[[2]])))),
       dims = MEdims(grps, ncols), logLik = 0)
}

simulate.lme <-
  function(m1, m2, Random.seed, method = c("REML", "ML"), nsim = 1000,
           niterEM = c(40, 200), useGen = FALSE)
{
## m1 is a list of arguments to lme, or an lme object from which the
##   call i sextracted, to define the null model
## m2 is an option list of arguments to lme to define the feared model
  getResults1 <-
    function(conLin, nIter, pdClass, REML, ssq, p, pp1)
  {
    unlist(.C("mixed_combined",
              as.double(conLin$Xy),
              as.integer(unlist(conLin$dims)),
              double(ssq),
              as.integer(nIter),
              as.integer(pdClass),
              as.integer(REML),
              logLik = double(1),
              R0 = double(pp1),
              lRSS = double(1),
              info = integer(1),
              PACKAGE = "nlme")[c("info", "logLik")])
  }
  getResults2 <-
    function(conLin, reSt, REML, control)
  {
    lmeSt <- lmeStruct(reStruct = reStruct(reSt, REML = REML))
    attr(lmeSt, "conLin") <- conLin
    lmeSt <- initialize(lmeSt, data = NULL, groups = NULL, control = control)
    attr(lmeSt, "conLin") <- MEdecomp(attr(lmeSt, "conLin"))
    aMs <- ms( ~ -logLik(lmeSt, lmePars),
              start = list(lmePars = c(coef(lmeSt))),
              control= list(rel.tolerance = control$msTol, 
                maxiter = control$msMaxIter,
                scale = control$msScale))
    c(info = aMs$flags[1], logLik = -aMs$value)
  }

  if (missing(Random.seed)) {
    aux <- rnorm(1)			# DMB using "aux" to confuse everyone :-)
    Random.seed <- .Random.seed
  }
  assign(".Random.seed", Random.seed, envir = globalenv())

  if (inherits(m1, "lme")) {            # given as an lme object
    fit1 <- m1
    m1 <- as.list(m1$call[-1])
  } else {
    m1 <- as.list(match.call(lme, substitute(m1))[ -1 ])
    fit1 <- do.call("lme", m1)
  }
  if (length(fit1$modelStruct) > 1) {
    stop("Models with corStruct and/or varFunc objects not allowed.")
  }
  reSt1 <- fit1$modelStruct$reStruct
  condL1 <- do.call("createConLin", m1)
  pdClass1 <- unlist(lapply(reSt1, data.class))
  pdClass1 <- match(pdClass1, c("pdSymm", "pdDiag", "pdIdent",
                                "pdCompSymm"), 0) - 1
  control1 <- lmeControl()
  if (!is.null(m1$control)) {
    control1[names(m1$control)] <- m1$control
  }
  control1$niterEM <- niterEM[1]
  sig <- fit1$sigma
  DeltaInv <- pdMatrix(reSt1, factor = TRUE)
  for(i in names(DeltaInv)) {
    DeltaInv[[i]] <- sig * DeltaInv[[i]]
  }
  if (missing(useGen)) {
    useGen <- any(pdClass1 == -1)
  }
  nullD <- condL1$dims
  N <- nullD$N
  Q <- nullD$Q
  p1 <- nullD$ncol[Q + 1]
  pp11 <- p1 * (p1 + 1)
  ycol1 <- sum(nullD$ncol)
  qvec <- nullD$qvec[1:Q]
  ssq1 <- sum(qvec^2)
  csq1 <- cumsum(c(1, qvec[ - Q]))
  csq2 <- cumsum(qvec)
  ngrp <- nullD$ngrps
  ind <- vector("list", Q)
  ## base for creating response
  base <-
    condL1$Xy[, ycol1 - (nullD$ncol[Q + 1]:1), drop = FALSE] %*% fixef(fit1)
  for(i in 1:Q) {
    ind[[i]] <- rep(1:ngrp[i], nullD$ZXlen[[i]])
  }
  value <- list(null = list())
  if (ML <- !is.na(match("ML", method))) {
    value$null$ML <-
      array(0, c(nsim, 2), list(1:nsim, c("info", "logLik")))
  }
  if (REML <- !is.na(match("REML", method))) {
    value$null$REML <-
      array(0, c(nsim, 2), list(1:nsim, c("info", "logLik")))
  }
  attr(value, "call") <- match.call()
  attr(value, "Random.seed") <- Random.seed
  ALT <- FALSE
  if (!missing(m2)) {
    ALT <- TRUE
    if (inherits(m2, "lme")) {            # given as an lme object
      fit2 <- m2
      m2 <- as.list(m2$call[-1])
    } else {
      m2 <- as.list(match.call(lme, substitute(m2))[ -1 ])
      if (is.null(m2$random)) {
        m2$random <- asOneSidedFormula(m1$fixed[-2])
      }
      aux <- m1
      aux[names(m2)] <- m2
      m2 <- aux
      fit2 <- do.call("lme", m2)
    }    
    if (length(fit2$modelStruct) > 1) {
      stop("Models with corStruct and/or varFunc objects not allowed.")
    }
    condL2 <- do.call("createConLin", m2)
    reSt2 <- fit2$modelStruct$reStruct
    control2 <- lmeControl()
    if (!is.null(m2$control)) {
      control2[names(m2$control)] <- m2$control
    }
    control2$niterEM <- niterEM[2]
    pdClass2 <- unlist(lapply(fit2$modelStruct$reStruct, data.class))
    pdClass2 <- match(pdClass2, c("pdSymm", "pdDiag", "pdIdent",
                                  "pdCompSymm"), 0) - 1
    if (missing(useGen)) {
      useGen <- useGen || any(pdClass2 == -1)
    }
    altD <- condL2$dims
    ssq2 <- sum((altD$qvec[1:altD$Q])^2)
    p2 <- altD$ncol[altD$Q + 1]
    pp12 <- p2 * (p2 + 1)
    ycol2 <- sum(altD$ncol)
    if (ML) {
      value$alt$ML <- value$null$ML
    }
    if (REML) {
      value$alt$REML <- value$null$REML
    }
  }
  for(i in 1:nsim) {
    base2 <- base + rnorm(N, sd = sig)
    for(j in 1:Q) {
      base2 <- base2 +
        ((array(rnorm(ngrp[j] * qvec[j]), c(ngrp[j], qvec[j]),
                list(1:ngrp[j], NULL)) %*%
          DeltaInv[[j]])[ind[[j]], , drop = FALSE] * condL1$Xy[,csq1[j]:csq2[j],
                                     drop = FALSE]) %*% rep(1, qvec[j])
    }
    condL1$Xy[, ycol1] <- base2
    if (REML) {
      if (useGen) {
        value$null$REML[i,] <-
          getResults2(condL1, reSt1, TRUE, control1)
      } else {
        value$null$REML[i,] <-
          getResults1(condL1, niterEM[1], pdClass1, TRUE, ssq1, p1, pp11)
      }
    }
    if (ML) {
      if (useGen) {
        value$null$ML[i,] <-
          getResults2(condL1, reSt1, FALSE, control1)
      } else {
        value$null$ML[i,] <-
          getResults1(condL1, niterEM[1], pdClass1, FALSE, ssq1, p1, pp11)
      }
    }
    if (ALT) {
      condL2$Xy[, ycol2] <- base2
      if (REML) {
        if (useGen) {
          value$alt$REML[i,] <-
            getResults2(condL2, reSt2, TRUE, control2)
        } else {
          value$alt$REML[i,] <-
            getResults1(condL2, niterEM[2], pdClass2, TRUE, ssq2, p2, pp12)
        }
      }
      if (ML) {
        if (useGen) {
          value$alt$ML[i,] <-
            getResults2(condL2, reSt2, FALSE, control2)
        } else {
          value$alt$ML[i,] <-
            getResults1(condL2, niterEM[2], pdClass2, FALSE, ssq2, p2, pp12)
        }
      }
    }
  }
  if (ML) {
    value$null$ML[, "logLik"] <-
      N * (log(N) - (1 + log(2*pi)))/2 + value$null$ML[, "logLik"]
    if (ALT) {
      value$alt$ML[, "logLik"] <-
        N * (log(N) - (1 + log(2*pi)))/2 + value$alt$ML[, "logLik"]
    }
  }
  if (REML) {
    value$null$REML[, "logLik"] <-
      (N - p1) * (log(N - p1) - (1 + log(2*pi)))/2 + value$null$REML[, "logLik"]
    if (ALT) {
      value$alt$REML[, "logLik"] <-
        (N - p2) * (log(N - p2) - (1 + log(2*pi)))/2 + value$alt$REML[, "logLik"]
    }
  }
  attr(value, "df") <- p1 + length(coef(reSt1)) + 1
  if (ALT) {
    attr(value, "df") <-
      abs(attr(value, "df") - (p2 + length(coef(reSt2)) + 1))
  }
  attr(value, "useGen") <- useGen
  class(value) <- "simulate.lme"
  value
}

print.simulate.lme <-
  function(x, ...)
{
  if (is.null(attr(x, "useGen"))) {     # from simulate.lme
    attr(x$null, "dims") <- NULL
    if (!is.null(x$alt)) {
      attr(x$alt, "dims") <- NULL
    }
  } else {
    attr(x, "useGen") <- attr(x, "df") <- NULL
  }
  attr(x, "Random.seed") <- attr(x, "call") <- NULL
  NextMethod()
}


plot.simulate.lme <-
  function(x, form = y ~ x | df * method, df = attr(x, "df"), weights, 
           xlab = "Empirical p-value",
           ylab = "Nominal p-value", xlim = c(0.037, 0.963),
           ylim = c(0.037, 0.963), aspect = 1,
           strip = function(...) strip.default(..., style = 1), ...)
{
  if (!is.null(x$null$ML)) {
    ML <- TRUE
    if (is.null(x$alt$ML)) {
      stop("Plot method only implemented for comparing models")
    }
    okML <- x$null$ML[, "info"] < 8 & x$alt$ML[, "info"] < 8
  } else {
    ML <- FALSE
  }
  if (!is.null(x$null$REML)) {
    REML <- TRUE
    if (is.null(x$alt$REML)) {
      stop("Plot method only implemented for comparing models")
    }
    okREML <- x$null$REML[, "info"] < 8 & x$alt$REML[, "info"] < 8
  } else {
    REML <- FALSE
  }

  if (is.null(df)) {
    stop("No degrees of freedom specified")
  }
  if ((ldf <- length(df)) > 1){
    df <- sort(unique(df))
    if (missing(weights)) {
      weights <- rep(1/ldf, ldf)
    } else {
      if (!(length(weights) == 1 && weights == FALSE) &&
          length(weights) != ldf) {
        stop("Degrees of freedom and weights must have the same length")
      }
    }
  } else {
    weights <- FALSE
  }

  if (length(weights) == 1) {           # no weights
    useWgts <- FALSE
  } else {
    useWgts <- TRUE
  }

  if (any(df < 0)) {
    stop("Negative degrees of freedom not allowed")
  } else {
    if ((ldf == 1) && (df == 0)) {
      stop("More than one degree of freedom is needed when one them is zero.")
    }
  }
  if (ML) {
    MLstat <-
      rev(sort(2 * pmax(0, x$alt$ML[okML, "logLik"] - x$null$ML[okML,"logLik"])))
    MLy <- lapply(df,
                  function(df, x) {
                    if (df > 0) {
                      1 - pchisq(x, df)
                    } else {
                      val <- rep(0, length(x))
                      val[x == 0] <- 1
                      val
                    }
                  }, x = MLstat)
    dfC <- paste("df",df,sep="=")
    if (useWgts) {                      # has weights
      if (ldf == 2) {                   # will interpolate
        MLy <-
          c(MLy[[1]], weights[1] * MLy[[1]] + weights[2] * MLy[[2]], MLy[[2]])
        MLdf <- rep(c(dfC[1], paste("Mix(",df[1],",",df[2],")",sep=""),
                      dfC[2]), rep(length(MLstat), ldf + 1))
      } else {
        aux <- weights[1] * MLy[[1]]
        auxNam <- paste("Mix(",df[1],sep="")
        for(i in 2:ldf) {
          aux <- aux + weights[i] * MLy[[i]]
          auxNam <- paste(auxNam, ",", df[i],sep="")
        }
        auxNam <- paste(auxNam, ")",sep="")
        MLy <- c(unlist(MLy), aux)
        MLdf <- rep(c(dfC, auxNam), rep(length(MLstat), ldf + 1))
      }
      MLx <- rep((1:length(MLstat) - 0.5)/length(MLstat), ldf + 1)
    } else {
      MLy <- unlist(MLy)
      MLdf <- rep(dfC, rep(length(MLstat), ldf))
      MLx <- rep((1:length(MLstat) - 0.5)/length(MLstat), ldf)
    }
    auxInd <- MLdf != "df=0"
    meth <- rep("ML", length(MLy))
    Mdf <- MLdf
  } else {
    MLy <- MLdf <- MLx <- auxInd <- meth <- Mdf <- NULL
  }
  if (REML) {
    REMLstat <- rev(sort(2 * pmax(0, x$alt$REML[okREML, "logLik"] -
                              x$null$REML[okREML, "logLik"])))
    REMLy <- lapply(df,
                    function(df, x) {
                      if (df > 0) {
                        1 - pchisq(x, df)
                      } else {
                        val <- rep(0, length(x))
                        val[x == 0] <- 1
                        val
                      }
                    }, x = REMLstat)
    dfC <- paste("df",df,sep="=")
    if (useWgts) {                      # has weights
      if (ldf == 2) {                   # will interpolate
        REMLy <-
          c(REMLy[[1]], weights[1] * REMLy[[1]] + weights[2] * REMLy[[2]], REMLy[[2]])
        REMLdf <- rep(c(dfC[1], paste("Mix(",df[1],",",df[2],")",sep=""),
                      dfC[2]), rep(length(REMLstat), ldf + 1))
      } else {
        aux <- weights[1] * REMLy[[1]]
        auxNam <- paste("Mix(",df[1],sep="")
        for(i in 2:ldf) {
          aux <- aux + weights[i] * REMLy[[i]]
          auxNam <- paste(auxNam, ",", df[i],sep="")
        }
        auxNam <- paste(auxNam, ")",sep="")
        REMLy <- c(unlist(REMLy), aux)
        REMLdf <- rep(c(dfC, auxNam), rep(length(REMLstat), ldf + 1))
      }
      REMLx <- rep((1:length(REMLstat) - 0.5)/length(REMLstat), ldf + 1)
    } else {
      REMLy <- unlist(REMLy)
      REMLdf <- rep(dfC, rep(length(REMLstat), ldf))
      REMLx <- rep((1:length(REMLstat) - 0.5)/length(REMLstat), ldf)
    }
    auxInd <- c(auxInd, REMLdf != "df=0")
    meth <- c(meth, rep("REML", length(REMLy)))
    Mdf <- c(Mdf, REMLdf)
  } else {
    REMLy <- REMLdf <- REMLx <- NULL
  }

  meth <- meth[auxInd]
  Mdf <- Mdf[auxInd]
  Mdf <- ordered(Mdf, levels = unique(Mdf))
  frm <- data.frame(x = c(MLx, REMLx)[auxInd], y = c(MLy, REMLy)[auxInd],
		    df = Mdf,  method = meth)
  names(frm$x) <- rep(1, nrow(frm))
  if (df[1] == 0) {
    names(frm$x)[substring(frm$df,1,3) == "Mix"] <- 1 - weights[1]
    if (missing(ylim)) {
      ylim <- c(0.0384, 1)
    }
  }
  xyplot(form, data = frm,
	 panel = function(x, y) {
           panel.grid();
           panel.xyplot(x, y, type = "l")
           if ((dfType <- as.double(names(x)[1])) == 1) {
             panel.abline( 0, as.double(names(x)[1]), lty = 2 )
           } else {
             panel.xyplot(c(0,dfType,dfType,1), c(0,dfType,1,1),
                          type="l", lty = 2, col = 1)
           }
         },
	 strip = strip, xlab = xlab, ylab = ylab, aspect = aspect,
         xlim = xlim, ylim = ylim, ...)
}

## Local Variables:
## mode:S
## End:

### $Id: system.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###                 System-dependent routines
###
### Copyright 1997-1999  Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

### Force loading of the lme dynamic library in R
.First.lib <- function(lib, pkg) library.dynam( "lme", pkg, lib )

### Local variables:
### mode: S
### End:
### $Id: varFunc.q,v 1.2 1999/11/04 16:46:39 saikat Exp $
###
###              Classes of variance functions
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

##*## Generics that should be implemented for any varFunc class

varWeights <-
  ## Calculates the weights of the variance function
  function(object) UseMethod("varWeights")

##*## varFunc - a virtual class of variance functions

###*# Constructor

varFunc <-
  ## Can take as argument either a varFunc object, in which case it does 
  ## nothing, a formula or a character string , in which case it 
  ## calls varFixed 
  function(object)
{
  if(is.null(object)) return(object)	# NULL object - no varFunc structure
  if (inherits(object, "varFunc")) {
    ## constructing from another varFunc object
    return(object)
  }
  if (inherits(object, "formula") || is.character(object)) {
    ## constructing from a formula of the form ~ x
    return(varFixed(asOneSidedFormula(object)))
  }

  stop(paste("Can only construct varFunc object from another varFunc",
	     "object, a formula, or a character string"))
}


###*# Methods for local generics

varWeights.varFunc <-
  function(object) attr(object, "weights")

###*# Methods for standard generics

coef.varFunc <-
  function(object, unconstrained = TRUE, allCoef = FALSE) 
{
  ### checking if initialized
  wPar <- attr(object, "whichFix")
  if (is.null(wPar) ||
      (length(object) != (length(wPar) - sum(wPar)))) {
    stop("Cannot extract parameters of uninitialized object")
  }
  if (unconstrained) {
    if (allCoef) {
      val <- double(length(wPar))
      if (any(wPar)) {
        val[wPar] <- attr(object, "fixed")
      }
      if (any(!wPar)) {
        val[!wPar] <- as.vector(object)
      }
    } else {
      val <- as.vector(object)
    }
    val
  } else {
    stop(paste("Don't know how to get coefficients for",
	       class(object)[1],"object"))
  }
}

"covariate<-.varFunc" <-
  function(object, value)
{
  value <- as.numeric(value)
  if (!is.null(aux <- getCovariate(object))) {
    if (length(aux) != length(value)) {
      stop("Cannot change the length of covariate in varFunc object")
    }
  }
  attr(object, "covariate") <- value
  object
}

formula.varFunc <-
  function(object) eval(attr(object, "formula"))

getCovariate.varFunc <-
  function(object, form, data) attr(object, "covariate")

getGroups.varFunc <-
  function(object, form, level, data, sep) attr(object, "groups")

initialize.varFunc <-
  function(object, data, ...)
{
  if (is.null(varWeights(object))) {
    attr(object, "weights") <- rep(1, dim(data)[1])
  }
  if (is.null(logLik(object))) {
    attr(object, "logLik") <- 0
  }
  object
}

logLik.varFunc <-
  function(object, data) attr(object, "logLik")

print.summary.varFunc <-
  function(x, header = TRUE, ...)
{
  class(x) <- attr(x, "oClass")
  if (length(aux <- coef(x, uncons = FALSE, allCoef = TRUE)) > 0) {
    if (header) cat("Variance function:\n")
    cat(paste(" Structure: ", attr(x, "structName"), "\n", sep = ""))
    cat(paste(" Formula:", deparse(as.vector(formula(x))),"\n"))
    cat(" Parameter estimates:\n")
    print(aux)
  } else {
    if (inherits(x, "varIdent")) {
      ## varIdent with no parameters - nothing to print
      return()
    }
    cat("Variance function structure of class", class(x)[1],
	"with no parameters, or uninitialized\n")
  }
}

print.varFunc <-
  function(x, ...)
{
  if (length(aux <- coef(x, uncons = FALSE, allCoef = TRUE)) > 0) {
    cat("Variance function structure of class", class(x)[1], 
	"representing\n")
    print(invisible(aux), ...)
  } else {
    cat("Variance function structure of class", class(x)[1],
	"with no parameters, or uninitialized\n")
  }
}

recalc.varFunc <-
  function(object, conLin)
{
  conLin$Xy[] <- conLin$Xy * varWeights(object)
  conLin$logLik <- conLin$logLik + logLik(object)
  conLin
}

summary.varFunc <-
  function(object, structName = class(object)[1])
{
  attr(object, "structName") <- structName
  attr(object, "oClass") <- class(object)
  class(object) <- "summary.varFunc"
  object
}

update.varFunc <-
  function(object, data)
{
  if (needUpdate(object)) {
    covariate(object) <- 
      eval(getCovariateFormula(object)[[2]], data)
  }
  object
}

##*## Classes that substitute for (i.e. inherit from) varFunc

###*# varFixed - fixed weights

####* Constructor

varFixed <-
  function(value = ~ 1)
{
  if (!inherits(value, "formula")) {
    stop("Value must be a one sided formula")
  }
  form <- asOneSidedFormula(value)
  if (length(all.vars(getCovariateFormula(form))) == 0) {
    stop("\"form\" must have a covariate")
  }
  if (!is.null(getGroupsFormula(form))) {
    form <- getCovariateFormula(form)
    warning("Ignoring \"groups\" in \"varFixed\" formula")
  }
  value <- numeric(0)
  attr(value, "formula") <- form
  class(value) <- c("varFixed", "varFunc")
  value
}

###*# Methods for standard generics

coef.varFixed <-
  function(object, unconstrained, allCoef) numeric(0)

"coef<-.varFixed" <-
  function(object, value) object

initialize.varFixed <-
  function(object, data, ...)
{
  form <- formula(object)
  if (any(is.na(match(all.vars(form), names(data))))) {
    ## cannot evaluate covariate on data
    stop("All variables used in \"formula\" must be in \"data\"")
  }
  attr(object, "needUpdate") <- FALSE
  attr(object, "covariate") <- getCovariate(data, form)
  attr(object, "logLik") <-
    sum(log(attr(object, "weights") <- 1/sqrt(abs(attr(object,"covariate")))))
  object
}

print.summary.varFixed <-
  function(x, header = TRUE, ...)
{
  cat("Variance function:\n")
  cat(" Structure: fixed weights\n")
  cat(paste(" Formula:", deparse(as.vector(formula(x))),"\n"))
}

summary.varFixed <-
  function(object, structName)
{
  class(object) <- "summary.varFixed"
  object
}

###*# varFIdent - equal variances per stratum structure

####* Constructor

varIdent <-
  function(value = numeric(0), form = ~ 1, fixed = NULL)
{
  if (is.null(getGroupsFormula(form))) { # constant value
    value <- numeric(0)
    attr(value, "fixed") <- NULL	# nothing to estimate
  } else {
    if ((lv <- length(value)) > 0) {		# initialized
      if (is.null(grpNames <- names(value)) && (lv > 1)) {
	stop("Initial values must have group names in varIdent")
      }
      value <- unlist(value)		# may be a list with names
      if (any(value <= 0)) {
	stop("Initial values for \"varIdent\" must be > 0.")
      }
      value <- log(value)               # unconstrained form
    } else grpNames <- NULL
    attr(value, "groupNames") <- grpNames
    if (!is.null(attr(value, "fixed"))) {
       fix <- attr(value, "fixed") <- log(unlist(fixed))
      if (is.null(fixNames <- names(fix))) {
	stop("Fixed parameters must have names in varIdent")
      }
      if (!is.null(attr(value, "groupNames"))) {
	attr(value, "groupNames") <- c(attr(value, "groupNames"), fixNames)
      }
    }
  }
  attr(value, "formula") <- asOneSidedFormula(form)
  class(value) <- c("varIdent", "varFunc")
  value
}

###*# Methods for standard generics

coef.varIdent <-
  function(object, unconstrained = TRUE, allCoef = FALSE) 
{
  if (!is.null(getGroupsFormula(object)) &&
      !is.null( wPar <- attr(object, "whichFix"))) {
    ## different groups variances
    if (unconstrained && !allCoef) {
      return(as.vector(object))
    }
    val <- double(length(wPar))
    if (any(wPar)) {
      val[wPar] <- attr(object, "fixed")
    }
    if (any(!wPar)) {
      val[!wPar] <- as.vector(object)
    }
    if (!unconstrained) {
      val <- c(1, exp(val))
      names(val) <- attr(object, "groupNames")
      if (!allCoef) {
	val <- val[c(FALSE, !attr(object, "whichFix"))]
      }
    }
    val
  } else {
    numeric(0)
  }
}

"coef<-.varIdent" <- 
  function(object, value) 
{
  if (!(is.null(grps <- getGroups(object)) || 
       all(attr(object, "whichFix")))) { 
    ## different group variances & varying parameters
    value <- as.numeric(value)
    nGroups <- length(attr(object, "groupNames"))
#    if (nGroups == 0) {
#      stop("Cannot assign parameters of uninitialized varIdent object")
#    }
    if (length(value) != nGroups - 1) {
      stop(paste("Cannot change the length of the varIdent", 
		 "parameter after initialization"))
    }
    object[] <- value
    natPar <- coef(object, FALSE, allCoef = TRUE)
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- 1/natPar[grps]))
  }
  object
}

initialize.varIdent <-
  function(object, data, ...)
{
  if (!is.null(form <- formula(object)) &&
      !is.null(grpForm <- getGroupsFormula(form))) {
    if (length(coef(object)) > 0) { # initialized - nothing to do
      return(object)
    }
    strat <- attr(object, "groups") <- 
      as.character(getGroups(data, form,
                             level = length(splitFormula(grpForm, sep = "*")),
                             sep = "*"))
    if (length((uStrat <- unique(strat))) == 1) {
      ## equal variances structure
      return(initialize(varIdent(), data))
    }
    if (!is.null(fix <- attr(object, "fixed"))) {
      fixNames <- names(fix)
      if (any(is.na(match(fixNames, uStrat)))) {
	stop(paste("Fixed parameters names in varIdent",
		   "must be a subset of groups names"))
      }
      uStratVar <- uStrat[is.na(match(uStrat, fixNames))] # varying strata
      uStrat <- c(uStratVar, fixNames)
    } else {				# nothing fixed
      uStratVar <- uStrat
    }
    if ((nStratVar <- length(uStratVar)) == 0) {
      stop("Cannot fix variances in all groups")
    }
    if (nStratVar > 1) {
      if (length(object) <= 1) {
	## repeat for all groups
	oldAttr <- attributes(object)
	if (length(object) > 0) {		# initialized
	  object <- rep(as.vector(object), nStratVar - 1)
	} else {			# uninitialized
	  object <- rep(0, nStratVar - 1)
	}
	attributes(object) <- oldAttr
	attr(object, "groupNames") <- uStrat
      } else {
	if (length(as.vector(object)) != (len <- (nStratVar - 1))) {
	  stop(paste("Initial value for \"varIdent\" should be of length",
		     len))
	}
	if (!is.null(stN <- attr(object, "groupNames"))) {
	  missStrat <- uStrat[is.na(match(uStrat, stN))]
	  if (length(missStrat) != 1) {
	    stop(paste("Names of starting value for \"varIdent\" object",
		       "must contain all but one of the stratum levels"))
	  }
	  stN <-  c(missStrat, stN)
	  if ((length(stN) != length(uStrat)) ||
	      any(sort(stN) != sort(uStrat))) {
	    stop("Nonexistent groups names for initial values in varIdent")
	  }
	  attr(object, "groupNames") <- stN
	} else {
	  attr(object, "groupNames") <- uStrat
	}
      }
    } else {				# fixed for all but one strata
      oldAttr <- attributes(object)
      object <- numeric(0)
      attributes(object) <- oldAttr
      attr(object, "groupNames") <- uStrat
    }
    attr(object, "whichFix") <- 
      !is.na(match(attr(object, "groupNames")[-1], names(fix)))
    if (all(attr(object, "whichFix"))) {
      if (all(attr(object, "fixed") == 0)) {
	## equal variances structure
	return(initialize(varIdent(), data))
      } else {
	oldAttr <- attributes(object)
	object <- numeric(0)
	attributes(object) <- oldAttr
      }
    }
    ## initializing weights and logDet
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- 1/coef(object,F,allCoef = TRUE)[strat]))
    object
  } else {				# no strata
    attr(object, "whichFix") <- T
    NextMethod()
  }
}

needUpdate.varIdent <-
  function(object) FALSE

recalc.varIdent <-
  function(object, conLin)
{
  if (is.null(formula(object))) conLin else NextMethod()
}

summary.varIdent <-
  function(object, 
	   structName = if (is.null(formula(object))) "Constant variance"
	                else "Different standard deviations per stratum")
  { summary.varFunc(object, structName) }


###*# varPower - power of variance covariate variance structure

####* Constructor

varPower <-
  function(value = numeric(0), form = ~ fitted(.), fixed = NULL)
{
  value <- unlist(value)		# may be given as a list
  fixed <- attr(value, "fixed") <- unlist(fixed)
  attr(value, "formula") <- form <- asOneSidedFormula(form)
  if (length(all.vars(getCovariateFormula(form))) == 0) {
    stop("\"form\" must have a covariate")
  }
  if (!is.null(getGroupsFormula(form))) {
    if (is.null(grpNames <- names(value)) && (length(value) > 1)) {
      stop("Initial values must have group names in varPower")
    }
    if (!is.null(fixed)) {
      if (is.null(names(fixed))) {
	stop("Fixed parameters must have group names in varPower")
      }
    }
    attr(value, "groupNames") <- c(grpNames, names(fixed))
  } else {                              # single parameter
    attr(value, "whichFix") <- !is.null(fixed)
  }
  class(value) <- c("varPower", "varFunc")
  value
}

###*# Methods for standard generics

coef.varPower <-
  function(object, unconstrained = TRUE, allCoef = FALSE) 
{
  if (((length(object) == 0) &&
       (!allCoef || is.null(attr(object, "fixed")))) ||
      is.null(wPar <- attr(object, "whichFix"))) {
    ## uninitialized
    return(numeric(0))
  }
  val <- double(length(wPar))
  if (any(wPar)) {
    val[wPar] <- attr(object, "fixed")
  }
  if (any(!wPar)) {
    val[!wPar] <- as.vector(object)
  }
  if (!is.null(getGroupsFormula(object))) {
    ##different values per group
    names(val) <- attr(object, "groupNames")
  } else {
    names(val) <- "power"
  }
  if (!allCoef) {
    val <- val[!wPar]
  }
  val
}

"coef<-.varPower" <-
  function(object, value)
{
  if ((len <- length(object)) > 0) {		# varying parameters
    value <- as.numeric(value)
    if (length(value) != len) {
      stop(paste("Cannot change the length of the varStruct", 
		 "parameter after initialization"))
    }
    object[] <- value
    aux <- coef(object, FALSE, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(object))) {
      aux <- aux[grps]
    }
    covariateObj <- getCovariate(object)
    if(is.null(covariateObj)) covariateObj <- NA
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- abs(covariateObj)^(-aux)))
  } else {
    stop(paste("Cannot change coefficients before initialization or",
               "when all parameters are fixed"))
  }
  object
}
  
initialize.varPower <-
  function(object, data, ...)
{
  form <- formula(object)
  if (all(!is.na(match(all.vars(getCovariateFormula(form)), names(data))))) {
    ## can evaluate covariate on data
    attr(object, "needUpdate") <- FALSE
    attr(object, "covariate") <- getCovariate(data, form)
  } else {
    attr(object, "needUpdate") <- TRUE
  }
  if (!is.null(grpForm <- getGroupsFormula(form))) { 
    strat <- as.character(getGroups(data, form,
                            level = length(splitFormula(grpForm, sep = "*")),
                            sep = "*"))
    uStrat <- unique(strat)
    if (length(uStrat) > 1) {		# multi-groups
      attr(object, "groups") <- strat
      if (!is.null(attr(object, "fixed"))) {
	fixNames <- names(attr(object, "fixed"))
	if (is.null(fixNames)) {
	  stop("Fixed parameters must have group names")
	}
	if (any(is.na(match(fixNames, uStrat)))) {
	  stop("Mismatch between group names and fixed values names")
	}
      } else {
	fixNames <- NULL
      }
      uStratVar <- uStrat[is.na(match(uStrat, fixNames))]
      nStratVar <- length(uStratVar)
      attr(object, "whichFix") <- !is.na(match(uStrat, fixNames))
      if (nStratVar > 0) {
	if (length(object) <= 1) {
	  ## repeat for all groups
	  names(object) <- NULL
	  oldAttr <- attributes(object)
	  if (length(object) > 0) {
	    object <- rep(as.vector(object), nStratVar)
	  } else {
	    object <- rep(0, nStratVar)
	  }
	  attributes(object) <- oldAttr
	  attr(object, "groupNames") <- uStrat
	  names(object) <- uStratVar
	} else {
	  if (length(as.vector(object)) != nStratVar) {
	    stop(paste("Initial value for \"varPower\" should be of length", 
		       nStratVar))
	  }
	  stN <- attr(object, "groupNames") # must have names
	  if (length(stN) != length(uStrat) ||
	      any(sort(stN) != sort(uStrat))) {
	    stop("Nonexistent groups names for initial values in varPower")
	  }	
	}
      } else {				# all parameters are fixed
	if (all(attr(object, "fixed") == 0)) {
	  ## equal variances structure
	  return(initialize(varIdent(), data))
	} else {
	  oldAttr <- attributes(object)
	  object <- numeric(0)
	  attributes(object) <- oldAttr
	  attr(object, "groupNames") <- uStrat
	}
      }
    } else {                            # single stratum
      attr(object, "formula") <- getCovariateFormula(formula(object))
      attr(object, "whichFix") <- !is.null(attr(object, "fixed"))
    }
  }
  if (is.null(getGroupsFormula(object))) {
    ## single stratum
    if (attr(object, "whichFix")) {
      if (attr(object, "fixed") == 0) {
        ## equal variances structure
        return(initialize(varIdent(), data))
      } else {				# fixed power
        oldAttr <- attributes(object)
        object <- numeric(0)
        attributes(object) <- oldAttr
      }
    } else {
      len <- length(as.vector(object))
      if (len == 0) {			# uninitialized
        oldAttr <- attributes(object)
        object <- 0
        attributes(object) <- oldAttr
      } else if (len > 1) {
        stop("Initial value for \"varPower\" should be of length 1.")
      }
    }
  }
  if (!is.null(covar <- getCovariate(object))) {
    natPar <- coef(object, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(object))) {
      natPar <- natPar[grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- abs(covar^(-natPar))))
    object
  } else {
    NextMethod()
  }
}

summary.varPower <-
  function(object, structName = "Power of variance covariate")
{ 
  if (!is.null(getGroupsFormula(object))) {
    structName <- paste(structName, " different strata", sep = ",")
  }
  summary.varFunc(object, structName) 
}

update.varPower <-
  function(object, data)
{
  val <- NextMethod()
  if (length(val) == 0) {		# chance to update weights
    aux <- coef(val, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(val))) {
      aux <- aux[grps]
    }
    attr(val, "logLik") <-
      sum(log(attr(val, "weights") <- abs(getCovariate(val))^(-aux)))
  }
  val
}

###*# varExp - exponential of variance covariate variance structure

####* Constructor

varExp <-
  function(value = numeric(0), form = ~ fitted(.), fixed = NULL)
{
  value <- unlist(value)		# may be given as a list
  fixed <- attr(value, "fixed") <- unlist(fixed)
  attr(value, "formula") <- form <- asOneSidedFormula(form)
  if (length(all.vars(getCovariateFormula(form))) == 0) {
    stop("\"form\" must have a covariate")
  }
  if (!is.null(getGroupsFormula(form))) {
    if (is.null(grpNames <- names(value)) && (length(value) > 1)) {
      stop("Initial values must have groups names in varPower")
    }
    if (!is.null(fixed)) {
      if (is.null(names(fixed))) {
	stop("Fixed parameters must have groups names in varPower")
      }
    }
    attr(value, "groupNames") <- c(grpNames, names(fixed))
  } else {
    attr(value, "whichFix") <- !is.null(fixed)
  }
  class(value) <- c("varExp", "varFunc")
  value
}

###*# Methods for standard generics

coef.varExp <-
  function(object, unconstrained = TRUE, allCoef = FALSE) 
{
  if (((length(object) == 0) &&
       (!allCoef || is.null(attr(object, "fixed")))) ||
      is.null( wPar <- attr(object, "whichFix"))) {
    return(numeric(0))
  }
  val <- double(length(wPar))
  if (any(wPar)) {
    val[wPar] <- attr(object, "fixed")
  }
  if (any(!wPar)) {
    val[!wPar] <- as.vector(object)
  }
  if (!is.null(getGroupsFormula(object))) {
    ##different values per group
    names(val) <- attr(object, "groupNames")
  } else {
    names(val) <- "expon"
  }
  if (!allCoef) {
    val <- val[!wPar]
  }
  val
}

"coef<-.varExp" <-
  function(object, value)
{
  if ((len <- length(object)) > 0) {		# varying parameters
    value <- as.numeric(value)
    if (length(value) != length(object)) {
      stop(paste("Cannot change the length of the varStruct", 
		 "parameter after initialization"))
    }
    object[] <- value
    aux <- coef(object, FALSE, allCoef = TRUE)
    if (!is.null(grps <- getGroups(object))) {
      aux <- aux[grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- exp(-aux * getCovariate(object))))
  } else {
    stop(paste("Cannot change coefficients before initialization or",
               "when all parameters are fixed"))
  }
  object
}

initialize.varExp <-
  function(object, data, ...)
{
  form <- formula(object)
  if (all(!is.na(match(all.vars(getCovariateFormula(form)), names(data))))) {
    ## can evaluate covariate on data
    attr(object, "needUpdate") <- F
    attr(object, "covariate") <- getCovariate(data, form)
  } else {
    attr(object, "needUpdate") <- T
  }
  if (!is.null(grpForm <- getGroupsFormula(form))) { 
    strat <- as.character(getGroups(data, form,
                            level = length(splitFormula(grpForm, sep = "*")),
                            sep = "*"))
    uStrat <- unique(strat)
    if (length(uStrat) > 1) {		# multi-groups
      attr(object, "groups") <- strat
      if (!is.null(attr(object, "fixed"))) {
	fixNames <- names(attr(object, "fixed"))
	if (is.null(fixNames)) {
	  stop("Fixed parameters must have group names")
	}
	if (any(is.na(match(fixNames, uStrat)))) {
	  stop("Mismatch between group names and fixed values names")
	}
      } else {
	fixNames <- NULL
      }
      uStratVar <- uStrat[is.na(match(uStrat, fixNames))]
      nStratVar <- length(uStratVar)
      attr(object, "whichFix") <- !is.na(match(uStrat, fixNames))
      if (nStratVar > 0) {
	if (length(object) <= 1) {
	  ## repeat for all groups
	  names(object) <- NULL
	  oldAttr <- attributes(object)
	  if (length(object) > 0) {
	    object <- rep(as.vector(object), nStratVar)
	  } else {
	    object <- rep(0, nStratVar)
	  }
	  attributes(object) <- oldAttr
	  attr(object, "groupNames") <- uStrat
	  names(object) <- uStratVar
	} else {
	  if (length(as.vector(object)) != nStratVar) {
	    stop(paste("Initial value for \"varExp\" should be of length", 
		       nStratVar))
	  }
	  stN <- attr(object, "groupNames") #must have names
	  if ((length(stN) != length(uStrat)) ||
	      any(sort(stN) != sort(uStrat))) {
	    stop("Nonexistent groups names for initial values in varExp")
	  }	
	}
      } else {
	if (all(attr(object, "fixed") == 0)) {
	  ## equal variances structure
	  return(initialize(varIdent(), data))
	} else {
	  oldAttr <- attributes(object)
	  object <- numeric(0)
	  attributes(object) <- oldAttr
	  attr(object, "groupNames") <- uStrat
	}
      }	  
    } else {                            # single stratum
      attr(object, "formula") <- getCovariateFormula(formula(object))
      attr(object, "whichFix") <- !is.null(attr(object, "fixed"))
    }
  }
  if (is.null(getGroupsFormula(object))) {
    ## single stratum
    if (attr(object, "whichFix")) {
      if (!attr(object, "fixed")) {
        ## equal variances structure
        return(initialize(varIdent(), data))
      } else {
        oldAttr <- attributes(object)
        object <- numeric(0)
        attributes(object) <- oldAttr
      }
    } else {
      len <- length(as.vector(object))
      if (len == 0) {			# uninitialized
        oldAttr <- attributes(object)
        object <- 0
        attributes(object) <- oldAttr
      } else if (len > 1) {
        stop("Initial value for \"varExp\" should be of length 1.")
      }
    }
  }
  if (!is.null(covar <- getCovariate(object))) {
    natPar <- coef(object, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(object))) {
      natPar <- natPar[grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- exp(-natPar * covar)))
    object
  } else {
    NextMethod()
  }
}
  

summary.varExp <-
  function(object, structName = "Exponential of variance covariate")
{
  if (!is.null(getGroupsFormula(object))) {
    structName <- paste(structName, " different strata", sep = ",")
  }
  summary.varFunc(object, structName) 
}

update.varExp <-
  function(object, data)
{
  val <- NextMethod()
  if (length(val) == 0) {		# chance to update weights
    aux <- coef(val, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(val))) {
      aux <- aux[grps]
    }
    attr(val, "logLik") <-
      sum(log(attr(val, "weights") <- exp(-aux * getCovariate(val))))
  }
  val
}

###*# varConstPower - Constant plus power of covariance function
###*#               variance structure

####* Constructor

varConstPower <-
  ## Constructor for the varConstPower class
  function(const = numeric(0), power = numeric(0),
	   form = ~ fitted(.), fixed = NULL)
{
  CPconstr <- function(val, form, nam) {
    if ((lv <- length(val)) == 0) return(val)
    if (lv > 2) {
      stop(paste(nam,"can have at most two components"))
    }
    if (is.null(nv <- names(val))) {
      names(val) <- c("const", "power")[1:lv]
    } else {
      if (any(is.na(match(nv, c("const", "power"))))) {
	stop(paste(nam,"can only have names \"const\" and \"power\""))
      }
    }
    nv <- names(val)
    if (data.class(val) == "list") {
      val <- lapply(val, unlist)
      grpNames <- unique(unlist(lapply(val, names)))
    } else {				# must be a vector or a scalar
      if (!is.numeric(val)) {
	stop(paste(nam,"can only be a list, or numeric"))
      }
      val <- as.list(val)
      names(val) <- nv
      grpNames <- NULL
    }    
    if (!is.null(getGroupsFormula(form))) {
      if (any(unlist(lapply(val, function(el) {
	(length(el) > 1) && is.null(names(el))
      })))) {
	stop(paste(nam,"must have group names in varConstPower"))
      }
      attr(val, "groupNames") <- grpNames
    }
    if (length(val$const) > 0) {
      if (any(val$const <= 0)) {
	stop("Constant in varConstPower structure must be > 0")
      }
      val$const <- log(val$const)
    }
    list(const = val$const, power = val$power)
  }
  value <- list(const = const, power = power)
  form <- asOneSidedFormula(form)
  if (length(all.vars(getCovariateFormula(form))) == 0) {
    stop("\"form\" must have a covariate")
  }
  ## initial value may be given as a vector or list. If groups are
  ## present and different initial values are given for each group, then 
  ## it must be a list with components "const" and/or "power"
  value <- CPconstr(value, form, "Value")
  fixed <- CPconstr(fixed, form, "Fixed")
  attr(value, "formula") <- form
  attr(value, "groupNames") <- 
    unique(c(attr(value, "groupNames"), 
	   attr(attr(value[["const"]], "fixed"), "groupNames"),
	   attr(attr(value[["power"]], "fixed"), "groupNames")))
  for (i in names(fixed)) {
    attr(value[[i]], "fixed") <- c(fixed[[i]])
  }
  if (is.null(getGroupsFormula(form))) {   # no groups
    whichFix <- array(F, c(2,1), list(c("const", "power"), NULL))
    whichFix[,1] <- unlist(lapply(value, 
                                  function(el) !is.null(attr(el, "fixed"))))
    attr(value, "whichFix") <- whichFix
  }
  class(value) <- c("varConstPower", "varFunc")
  value
}

###*# Methods for standard generics

coef.varConstPower <-
  function(object, unconstrained = TRUE, allCoef = FALSE)
{
  wPar <- attr(object, "whichFix")
  nonInit <- !unlist(lapply(object, length))
  nonInit <- is.null(wPar) || (any(nonInit) && !all(c(wPar[nonInit,])))
  
  if (nonInit || (!allCoef && (length(unlist(object)) == 0))) {
    return(numeric(0))
  }
  val <- array(0, dim(wPar), dimnames(wPar))
  for (i in names(object)) {
    if (any(wPar[i,])) {
      val[i, wPar[i,]] <- attr(object[[i]], "fixed")
    }
    if (any(!wPar[i,])) {
      val[i, !wPar[i,]] <- c(object[[i]])
    }
  }
  if (!unconstrained) {
    val[1,] <- exp(val[1,])
  }
  if (!allCoef) {
    val <- list(const = if (!all(wPar[1,])) val[1,!wPar[1,]] else NULL,
		power = if (!all(wPar[2,])) val[2,!wPar[2,]] else NULL)
    ## getting rid of name repetition 
    val <- lapply(val, function(el)
                  ifelse(length(el) == 1, as.vector(el), el))
    val <- unlist(val[!unlist(lapply(val, is.null))])
  } else {
    val <- val[, 1:ncol(val)]
  }
  val
}

"coef<-.varConstPower" <-
  function(object, value)
{
  if ((len <- length(unlist(object))) > 0) {	# varying parameters
    value <- as.numeric(value)
    if (length(value) != length(unlist(object))) {
      stop(paste("Cannot change the length of the", 
		 "parameter after initialization"))
    }
    start <- 0
    for(i in names(object)) {
      if (aux <- length(object[[i]])) {
	object[[i]][] <- value[start + (1:aux)]
	start <- start + aux
      }
    }
    natPar <- as.matrix(coef(object, FALSE, allCoef = TRUE))
    if (!is.null(grps <- getGroups(object))) {
      natPar <- natPar[, grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <-
	      1/(natPar[1,] + abs(getCovariate(object))^natPar[2,])))
  } else {
    stop(paste("Cannot change coefficients before initialization or",
               "when all parameters are fixed"))
  }    
  object
}

initialize.varConstPower <-
  function(object, data, ...)
{
  form <- formula(object)
  if (all(!is.na(match(all.vars(getCovariateFormula(form)), names(data))))) {
    ## can evaluate covariate on data
    attr(object, "needUpdate") <- FALSE
    attr(object, "covariate") <- getCovariate(data, form)
  } else {
    attr(object, "needUpdate") <- TRUE
  }
  dfltCoef <- c(const = log(0.1), power = 0)
  if (!is.null(grpForm <- getGroupsFormula(form))) { 
    strat <- as.character(getGroups(data, form,
                            level = length(splitFormula(grpForm, sep = "*")),
                            sep = "*"))
    uStrat <- unique(strat)
    whichFix <- array(FALSE, c(2, length(uStrat)), 
		      list(c("const", "power"), uStrat))
    if (length(uStrat) > 1) {		# multi-groups
      attr(object, "groups") <- strat
      for(i in names(object)) {
	if (!is.null(attr(object[[i]], "fixed"))) {
	  fixNames <- names(attr(object[[i]], "fixed"))
	  if (is.null(fixNames)) {
	    stop("Fixed parameters must have group names")
	  }
	  if (any(is.na(match(fixNames, uStrat)))) {
	    stop("Mismatch between group names and fixed values names")
	  }
	} else {
	  fixNames <- NULL
	}
	uStratVar <- uStrat[is.na(match(uStrat, fixNames))]
	nStratVar <- length(uStratVar)
	whichFix[i,] <- !is.na(match(uStrat, fixNames))
	if (nStratVar > 0) {
	  if (length(object[[i]]) <= 1) {
	    ## repeat for all groups
	    names(object[[i]]) <- NULL
	    oldAttr <- attributes(object[[i]])
	    if (length(object[[i]]) > 0) {
	      object[[i]] <- rep(as.vector(object[[i]]), nStratVar)
	    } else {
	      object[[i]] <- rep(dfltCoef[i], nStratVar)
	    }
	    attributes(object[[i]]) <- oldAttr
	    names(object[[i]]) <- uStratVar
	  } else {
	    if (length(as.vector(object[[i]])) != nStratVar) {
	      stop(paste("Initial value should be of length", nStratVar))
	    }
	    stN <- names(object[[i]]) # must have names
	    if ((length(stN) != length(uStratVar)) ||
		any(sort(stN) != sort(uStratVar))) {
	      stop("Nonexistent groups names for initial values")
	    }
	  }
	}
      }
      if (all(whichFix) &&
	  all(attr(object[["const"]], "fixed") == 0) &&
	  all(attr(object[["power"]], "fixed") == 0)) {
	## equal variances structure
	return(initialize(varIdent(), data))
      }
      for(i in names(object)) {
	if (all(whichFix[i,])) {
	  oldAttr <- attributes(object[[i]])
	  object[[i]] <- numeric(0)
	  attributes(object[[i]]) <- oldAttr
	}
      }
      attr(object, "whichFix") <- whichFix
      attr(object, "groupNames") <- uStrat
      return(NextMethod())
    }
  }
  ## single stratum
  whichFix <- attr(object, "whichFix")
  if (all(whichFix) && 
      !any(unlist(lapply(object, function(el) attr(el, "fixed"))))) { 
    ## equal variances structure
    return(initialize(varIdent(), data))
  }
  for(i in names(object)) {
    if (all(whichFix[i,])) {
      oldAttr <- attributes(object[[i]])
      object[[i]] <- numeric(0)
      attributes(object[[i]]) <- oldAttr
    } else {
      if (length(object[[i]]) == 0) {
	object[[i]] <- dfltCoef[i]
      }
    }
  }
  aux <- 2 - sum(whichFix[,1])
  if (length(as.vector(unlist(object))) != aux) {
    stop(paste("Initial value should be of length", aux))
  }
  NextMethod()
}

summary.varConstPower <-
  function(object, structName = "Constant plus power of variance covariate")
{
  if (!is.null(getGroupsFormula(object))) {
    structName <- paste(structName, " different strata", sep = ",")
  }
  summary.varFunc(object, structName) 
}

update.varConstPower <-
  function(object, data)
{
  val <- NextMethod()
  if (length(unlist(val)) == 0) {	# chance to update weights
    aux <- as.matrix(coef(val, FALSE, allCoef = TRUE))
    if (!is.null(grps <- getGroups(val))) {
      aux <- aux[, grps]
    }
    attr(val, "logLik") <-
      sum(log(attr(val, "weights") <-
	      1/(aux[1,] + abs(getCovariate(val))^aux[2,])))
  }
  val
}

###*# varFComb - combination of variance function structures

####* Constructor

varComb <- 
  ## constructor for the varComb class
  function(...)
{
  val <- list(...)
  if (!all(unlist(lapply(val, inherits, "varFunc")))) {
    stop("All arguments to \"varComb\" must be of class \"varFunc\".")
  }
  if (is.null(names(val))) {
    names(val) <- LETTERS[1:length(val)]
  }
  class(val) <- c("varComb", "varFunc")
  val
}

####* Methods for local generics


varWeights.varComb <-
  function(object)
{
  apply(as.data.frame(lapply(object, varWeights)), 1, prod)
}

###*# Methods for standard generics

coef.varComb <-
  function(object, unconstrained = TRUE, allCoef = FALSE) 
{
  unlist(lapply(object, coef, unconstrained, allCoef))
}

"coef<-.varComb" <-
  function(object, value)
{
  plen <- attr(object, "plen")
  if ((len <- sum(plen)) > 0) {		# varying parameters
    if (length(value) != len) {
      stop("Cannot change parameter length of initialized varComb object.")
    }
    start <- 0
    for (i in seq(along = object)) {
      if (plen[i] > 0) {
	coef(object[[i]]) <- value[start + (1:plen[i])]
	start <- start + plen[i]
      }
    }
  }
  object
}

formula.varComb <-
  function(object) lapply(object, formula)

initialize.varComb <-
  function(object, data, ...)
{
  val <- lapply(object, initialize, data)
  attr(val, "plen") <- unlist(lapply(val, function(el) length(coef(el))))
  class(val) <- c("varComb", "varFunc")
  val
}

logLik.varComb <-
  function(object) sum(unlist(lapply(object, logLik)))

needUpdate.varComb <-
  function(object) any(unlist(lapply(object, needUpdate)))

print.varComb <-
  function(x)
{
  cat("Combination of:\n")
  lapply(x, print)
  invisible()
}

print.summary.varComb <-
  function(x, ...)
{
  cat(attr(x, "structName"),"\n")
  lapply(x, print, FALSE)
}

summary.varComb <-
  function(object, structName = "Combination of variance functions:")
{
  object[] <- lapply(object, summary)
  attr(object, "structName") <- structName
  class(object) <- c("summary.varComb", class(object))
  object
}

update.varComb <-
  function(object, data)
{
  object[] <- lapply(object, update, data)
  object
}


##*## Beginning of epilogue
### This file is automatically placed in Outline minor mode.
### The file is structured as follows:
### Chapters:     ^L # 
### Sections:    ##*##
### Subsections: ###*###
### Components:  non-comment lines flushed left
###              Random code beginning with a ####* comment

### Local variables:
### mode: S
### mode: outline-minor
### outline-regexp: "\^L\\|\\`#\\|##\\*\\|###\\*\\|[a-zA-Z]\\|\\\"[a-zA-Z]\\|####\\*"
### End:



### $Id: zzMethods.q,v 1.1 1999/10/13 00:50:10 saikat Exp $
###
###   Miscellaneous methods that must be defined last in the library
###
### Copyright 1997, 1999 Jose C. Pinheiro <jcp$research.bell-labs.com>,
###                      Douglas M. Bates <bates$stat.wisc.edu>
###
### This file is part of the nlme library for S and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

AIC.lme <- AIC.lmList <- AIC.gls <- AIC.lm
BIC.lme <- BIC.lmList <- BIC.gls <- BIC.lm

comparePred.lme <- comparePred.lmList <- comparePred.gls

getData.nlme <- getData.gnls

getData.lme <- getData.gls <- getData.nls

qqnorm.gls <- qqnorm.lm <- qqnorm.nls 

plot.lme <- plot.nls

### $Id: zzz.R,v 1.1 1999/11/04 16:42:28 saikat Exp $
###
### nlme for R
###
### Copyright 1999-1999 Douglas M. Bates <bates@stat.wisc.edu>,
###                     Saikat DebRoy <saikat@stat.wisc.edu>
###
### This file is part of the nlme library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### 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., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

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