### $Id: corStruct.q,v 1.10 1998/06/13 13:18:37 pinheiro Exp $
##*## End of prologue
 # Major classes, their constructors, and methods for standard generics

##*## corStruct - a virtual class of correlation structures

##*## 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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}
  
corMatrix.corStruct <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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))[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

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

coef.corStruct <-
  ## Accessor for constrained or unconstrained parameters of corStruct objects
  function(object, unconstrained = T) 
{
  if (unconstrained) {
    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) 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 (length(all.vars(covForm)) > 0) { # primary covariate present
      covar <- getCovariate(data, covForm)
    } else {
      covar <- NULL
    }
      
    if (!is.null(getGroupsFormula(form))) { # by groups
      grps <- getGroups(object, data = data)
      if (is.null(covar)) {
	covar <- unlist(tapply(grps, grps, function(x) 1:length(x)))
      }
      split(covar, grps)
    } else {				# no groups
      if (is.null(covar)) {
	covar <- 1:nrow(data)
      }
      covar
    }
  } else {				# just extract attribute
    covar
  }
}

getGroups.corStruct <-
  function(object, form = formula(object), data, level)
{
  if (is.null(aux <- attr(object, "groups"))) { # need to calculate
    if (length(val <- getGroups(data, form)) > 0) {
      factor(val, levels = as.character(unique(val)))
    } else {
      rep(1, dim(data)[1])
    }
  } else {
    aux
  }
}

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 = F)
  }
  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) F

print.corStruct <-
  function(x, ...)
{
  if (length(aux <- coef(x, F)) > 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, ...)
{
  cat(paste("Correlation Structure: ", attr(x, "structName"), "\n", sep = ""))
  cat(" Parameter estimate(s):\n")
  print(coef(x, F))
}

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))))[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + logLik(object)
  conLin
}
	 
summary.corStruct <-
  function(object, structName = class(object)[1])
{
  attr(object, "structName") <- structName
  class(object) <- c("summary.corStruct", class(object))
  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)
{
  attr(value, "formula") <- form
  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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corSymm <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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"]]))[["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))[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.corSymm <-
  function(object, unconstrained = T)
{
  if (unconstrained) return(as.vector(object))
  mC <- attr(object, "maxCov")
  .C("symm_fullCorr", as.double(aux), 
     as.integer(mC), corr = double(round(mC * (mC - 1) / 2)))[["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))[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corSymm <-
  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 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
  aux <- as.vector(object)
  if (length(aux) > 0) {
    ## parameters assumed in unconstrained form
    if (length(aux) != round(maxCov * (maxCov - 1) / 2))
      stop("Initial value for corSymm parameters of wrong dimension")
  } 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, F)
    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")
}

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))[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

summary.corSymm <- 
  function(object, structName = "Unstructured")
{
  summary.corStruct(object, structName)
}
###*# corIdent - independent structure

####* Constructor

corIdent <-
  ## Constructor for the corIdent class
  function(form = NULL)
{
  value <- numeric(0)
  attr(value, "formula") <- form
  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
    lapply(covariate, function(el, object) corMatrix(object, el))
  } else {
    diag(length(covariate))
  }
}

###*# Methods for standard generics

coef.corIdent <-
  function(object, unconstrained = T) as.numeric(object)

"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)
{
  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
  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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corAR1 <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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"]]))[["mat"]]
    lD <- NULL
  } else {
    val <- .C("AR1_factList",
              as.double(as.vector(object)),
              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.corAR1 <- 
  function(object, unconstrained = T) 
{
  if (unconstrained) {
    return(as.numeric(object))
  }
  aux <- exp(as.numeric(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))[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))[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)
{
  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
  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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corCAR1 <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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"]]))[["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))[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.corCAR1 <- 
  function(object, unconstrained = T) 
{
  if (unconstrained) {
    return(c(as.numeric(object)))
  }
  aux <- c(exp(as.numeric(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))[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))[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)
{
  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))$pars
  attributes(value) <- list(formula = form, p = p, q = q)
  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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

    
corMatrix.corARMA <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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"]]))[["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))[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.corARMA <- 
  function(object, unconstrained = T) 
{
  aux <-  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=""))
    }
    aux <- c(.C("ARMA_constCoef", as.integer(attr(object,"p")), 
		as.integer(attr(object,"q")),
		pars = as.double(aux))$pars)
    names(aux) <- nams
  }
  aux
}

"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))[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))[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)
{
  if (abs(value) >= 1) {
    stop(paste("Parameter in \"corCompSymm\" structure",
	       "must be < 1 in absolute value"))
  }
  attr(value, "formula") <- form
  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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corCompSymm <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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"]]))[["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))[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 local generics

coef.corCompSymm <- 
  function(object, unconstrained = T) 
{
  if (unconstrained) {
    return(as.numeric(object))
  }
  aux <- exp(as.numeric(object))
  aux <- c((aux + attr(object, "inf"))/(aux + 1))
  names(aux) <- "Rho"
  aux
}

"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))[c("factor", "logDet")]
  attr(object, "factor") <- aux[["factor"]]
  attr(object, "logDet") <- -aux[["logDet"]]
  object
}

initialize.corCompSymm <-
  ## Initializes corCompSymm objects
  function(object, data, ...)
{
  object <- NextMethod()
  corD <- Dim(object)
  attr(object, "inf") <- aux <- -1/(corD[["maxLen"]] - 1)
  natPar <- as.vector(object)
  if (natPar <= aux) {
    stop(paste("Initial value in corCompSymm must be > than", aux))
  }
  object[] <- log((natPar - aux)/(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))[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 = T)
{
  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 = T)
{
  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, ...)
{
  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)
  aux <- as.vector(object)
  if (length(aux) > 0) {
    if (length(aux) != maxCov)
      stop("Initial value for Huyn-Feldt parameters of wrong dimension")
    ## verifying if initial values satisfy constraints
    if (any(aux <= attr(object, "inf"))) {
      stop(paste("Initial values for \"corHF\" parameters",
		 "must be > than", attr(object, "inf")))
    }
    object[] <- log(aux - attr(object, "inf"))
  } else {				# initializing the parameters
    oldAttr <- attributes(object)
    object <- log(rep(-attr(object, "inf"), 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 = F,
	   type = c("spherical", "exponential", "gaussian", "linear"),
	   metric = c("euclidean", "maximum", "manhattan"))
{
  type <- match.arg(type)
  spClass <- switch(type,
		    spherical = "corSpher",
		    exponential = "corExp",
		    gaussian = "corGaus",
		    linear = "corLin")
  attr(value, "formula") <- form
  attr(value, "nugget") <- nugget
  attr(value, "metric") <- match.arg(metric)
  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))[c("factor", "logDet")]
  lD <- val[["logDet"]]
  val <- val[["factor"]]
  attr(val, "logDet") <- lD
  val
}

corMatrix.corSpatial <-
  function(object, covariate = getCovariate(object), corr = T)
{
  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"]]))[["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))[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.corSpatial <-
  function(object, unconstrained = T)
{
  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 ratio")
  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))[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 <- NextMethod()
  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"), 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 <- tapply(grps, grps, function(x) as.vector(dist(1:length(x))))
      } else {
	covar <- lapply(split(covar, grps), 
			function(el, metric) {
			  as.vector(dist(as.matrix(el), metric))
			}, metric = attr(object, "metric"))
      }
    } else {				# no groups
      if (is.null(covar)) {
	covar <- as.vector(dist(1:nrow(data)))
      } else {
	covar <- as.vector(dist(covar, metric = attr(object, "metric")))
      }
    }
    if (any(unlist(covar) == 0)) {
      stop("Cannot have zero distances in \"corSpatial\"")
    }
  }
  covar
}

initialize.corSpatial <-
  function(object, data, ...)
{
  object <- NextMethod()
  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 ratio not given
	val <- c(val, 0.9)		# setting it to 0.9
      } 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 in (0,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.9)
  }
  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))[c("Xy", "logLik")]
  conLin[["Xy"]][] <- val[["Xy"]]
  conLin[["logLik"]] <- conLin[["logLik"]] + val[["logLik"]]
  conLin
}

###*# corSpher - spherical spatial correlation structure

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

###*# Methods for standard generics

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

initialize.corSpher <-
  function(object, data, ...)
{
  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 ratio not given
	val <- c(val, 0.9)		# setting it to 0.9
      } 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 corSpher parameters of wrong dimension")
      }
    }
  } else {
    val <- minD * 1.1
    if (nug) val <- c(val, 0.9)
  }
  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)
}

###*# corExp - exponential spatial correlation structure

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

###*# Methods for standard generics

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

###*# corGaus - Gaussian spatial correlation structure

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

###*# Methods for standard generics

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

###*# corLin - Linear spatial correlation structure

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

###*# Methods for standard generics

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

initialize.corLin <-
  function(object, data, ...)
{
  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 ratio not given
	val <- c(val, 0.9)		# setting it to 0.9
      } 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 corSpher parameters of wrong dimension")
      }
    }
  } else {
    val <- minD * 1.1
    if (nug) val <- c(val, 0.9)
  }
  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)
}


##*## 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.1.1 1996/11/13 15:38:45 bates Exp $
 # Support functions
##*## deriv - symbolic differentiation for expressions

deriv <-
  ## Symbolic differentiation of expressions
  function(expr, ...) UseMethod("deriv")

deriv.default <-
  function(expr, namevec, function.arg = NULL, tag = ".expr")
{
  max.express <- unlist(options("expressions"))
  if(max.express < 1000) {
    options(expressions = 1000)		# this function is highly recursive
    on.exit(options(expressions = max.express))
  }
  assign("tag", tag, frame = 1)
  assign(".elist", NULL, frame = 1)
  npar <- length(namevec)
  fval <- exprgen(expr)
  ders <- 1:npar
  for(i in 1:npar) {
    di <- D(expr, namevec[i])
    if(!(ders[i] <- exprgen(di)))
      ders[i] <- addlist(di)
  }
  nexpr <- length(.elist)
  .elist <- c(.elist, paste(tag, c(fval, 0, ders), sep = ""))
  nextended <- length(.elist)
  expressions <- parse(text = .elist)
  graddef <- nexpr + 2	
  ## fold expressions.  Do not fold those used more than once
  nofold <- c(logical(nexpr), rep(T, npar + 2))
  nofold <- nofold | apply(outer(all.names(expressions),
				 paste(tag, 1:nextended, sep = ""), "=="),
			   2, sum) > 1
  parentemplate <- expression((a))[[1]]
  for(i in (1:nexpr)[!nofold]) {
    thisname <- paste(tag, i, sep = "")
    subst <- parentemplate
    subst[[2]] <- expressions[i][[1]]
    for(j in (i + 1):nextended) {
      if(match(thisname, all.names(expressions[j]), 0)) {
	thisexpr <- expressions[j][[1]]
	if(is.name(thisexpr))
	  thisexpr <- subst[[2]]
	else for(k in 1:length(thisexpr))
	  if(is.name(thisexpr[[k]]) && thisexpr[[k]] == 
	     thisname) thisexpr[[k]] <- subst
	expressions[j][[1]] <- thisexpr
	break
      }
    }
  }
  nams <- c(paste(tag, 1:nexpr, sep = ""), ".value", ".grad",
	    paste(".grad[ ,\"", namevec, "\"]", sep = ""))
  out <- parse(text = c("{", paste(nams, "<-", 0, sep = ""), "}"))
  body <- out[[1]]
  for(i in (1:nextended)[nofold])
    body[[i]][[2]] <- expressions[i][[1]]
  body[[graddef]][[2]] <- parse(text = c("array(0,c(length(.value),",
				    npar, "),list(NULL,",
				    deparse(namevec), "))"))[[1]]
  body <- body[nofold]
  added <- parse(text = c("attr(.value,\"gradient\") <- .grad", ".value"))
  body <- c(body, added)
  mode(body) <- "{"
  if(length(function.arg)) {
    if(is.function(function.arg))
      value <- function.arg
    else if(is.recursive(function.arg)) {
      value <- vector("expression", length(function.arg) + 1)
      value[ - length(value)] <- function.arg
    }
    else {
      value <- vector("expression", length(function.arg) + 1)
      names(value) <- c(as.character(function.arg), "")
    }
    mode(value) <- "function"
    value[[length(value)]] <- body
    ## manipulate the body so it puts the correct names on the gradient columns
    if (any(missng <- is.na(match(namevec, names(value))))) {
      warning(paste("The name(s)", paste(namevec[missng]),
		    "are not arguments to the function"))
      return(value)
    }
    replacement <-
      parse(text = paste(".actualArgs <- match.call()[",
		deparse(namevec), "];",
		"if (all(unlist(lapply(as.list(.actualArgs), is.name)))) {}")
	    )
    mode(replacement) <- "{"
    first.grad <- match(as.name(".grad"), unlist(lapply(body[-length(body)],
							"[[", 1)))
    gradCalc <-
      c(body[first.grad:(length(body) - 2)],
	parse(text = "dimnames(.grad) <- list(NULL, .actualArgs)"),
	body[length(body) - 1])
    mode(gradCalc) <- "{"
    replacement[[2]][[2]] <- gradCalc
    body <- c(body[1:(first.grad - 1)], replacement, body[length(body)])
    value[[length(value)]] <- body
    value
  }
  else {
    out[[1]] <- body
    out
  }
}

deriv.formula <-
  function(expr, namevec, function.arg = NULL, tag = ".expr")
{
  expr <- expr[[length(expr)]]
  NextMethod("deriv")
}

### 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]\\|####\\*"
### End:
### $Id: gls.q,v 1.12 1998/06/13 13:18:38 pinheiro Exp $
###
###  Fit a linear model with serial correlation or heteroscedasticity
###
### Copyright 1997, 1998 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.parent(),
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   REML = TRUE,
	   na.action = na.fail, 
	   control = list(),
	   verbose = F)
{
  Call <- match.call()

  ## control parameters
  controlvals <- glsControl()
  controlvals[names(control)] <- control

  ##
  ## checking arguments
  ##
  if (!inherits(model, "formula") || length(model) != 3) {
    stop("\nModel must be a formula of the form \"resp ~ pred\"")
  }
  ## check if correlation is present and has groups
  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
	}
	groups <- groups[[1]]
	attr(correlation, "formula") <- 
	  eval(parse(text = paste("~", 
		      deparse(getCovariateFormula(formula(correlation))[[2]]),
			 "|", deparse(groups[[2]]))))
      }
    }
  } 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
    grps <- getGroups(dataMod, 
	      eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|"))))

    ## ordering data by groups
    ord <- order(grps)	
    grps <- grps[ord]
    dataMod <- dataMod[ord, ,drop = F]
    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
    
  ## creating the condensed linear model
  attr(glsSt, "conLin") <-
    list(Xy = array(c(X, y), c(N, ncol(X) + 1), list(row.names(dataMod), 
	     c(dimnames(X)[[2]], 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
  attach(controlvals)
  repeat {
    oldPars <- c(attr(glsSt, "glsFit")[["beta"]], coef(glsSt))
    if (length(coef(glsSt))) {		# needs ms()
      if( exists( "is.R" ) && is.function( is.R ) && is.R() ) {
	aNlm <- nlm(f = function(glsPars) -logLik(glsSt, glsPars),
		    p = c(coef(glsSt)),
		    hessian = TRUE,
		    print = ifelse(msVerbose, 0, 2))
	numIter0 <- NULL
	coef(glsSt) <- aNlm$estimate
      } else {
	aMs <- ms(~-logLik(glsSt, glsPars),
		  start = list(glsPars = c(coef(glsSt))),
		  control = list(rel.tolerance = msTol, maxiter = msMaxIter,
		    scale = msScale), trace = msVerbose)
	coef(glsSt) <- aMs$parameters
	numIter0 <- aMs$numIter <- aMs$flags[31]
      }
    }
    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)
      if( exists( "is.R" ) && is.function( is.R ) && is.R() ) {
        cat("\nObjective:", format(aNlm$minimum), "\n")
      } else {
        cat("\nObjective:",format(aMs$value),", ms iterations:",
            aMs$numIter, "\n")
      }
      print(glsSt)
      cat("\nConvergence:\n")
      print(aConv)
    }
    if (max(aConv) <= tolerance) {
      break
    }
    if (numIter > maxIter) {
      stop("Maximum number of iterations reached without convergence.")
    }
  }
  detach()
  ## wrapping up
  glsFit <- attr(glsSt, "glsFit")
  namBeta <- names(glsFit$beta)
  p <- length(namBeta)
  varBeta <- crossprod(glsFit$sigma * glsFit$varBeta)*(N - REML * p)/(N - p)
  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"]])
  } 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(glsStruct = 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,
		 estMethod = c("ML", "REML")[REML + 1],
		 fitted = Fitted,
		 residuals = Resid)
  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") <- dimnames(X)[[2]]
  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))
{
  ## 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))[c("logLik", "lRSS")]
      aux <- 2 * (val[["lRSS"]] - lsigma)
      conLin[["logLik"]] + val[["logLik"]] + (N * aux - exp(aux))/2
    }
  if (length(glsCoef <- coef(glsSt)) > 0) {
    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)[["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
      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 = F, 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)))[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 <- dimnames(oXy)[[2]][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 = F] %*% beta
  list(logLik = N * (log(N) - (1 + log(2 * pi)))/2 + ll, beta = beta,
       sigma = val[["sigma"]], varBeta = varBeta, 
       fitted = fitVal, resid = oXy[, p + 1] - fitVal)
}

### Methods for standard generics

anova.gls <- 
  function(object, ..., test = TRUE, verbose = F)
{
  ## 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\" ")
    }
    dims <- object$dims
    N <- dims$N
    p <- dims$p
    REML <- dims$REML
    ##
    ## if just one object returns the t.table for the coefficients
    ##
    stdBeta <- sqrt(diag(object$varBeta))
    ##
    ## coefficients, std. deviations, t-ratios, and p-values
    ##
    beta <- coef(object)
    tratio <- beta/stdBeta
    aod <- data.frame(beta, stdBeta, tratio, 2 * pt(-abs(tratio), 
						    dims$N - dims$p))
    dimnames(aod) <- 
      list(names(beta),c("Value","Std.Error","t-value", "p-value"))
    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 <- T
    groups <- rep("1", length(primary))
    value <- data.frame(newprimary, rep("1", length(newprimary)))
  } else {
    noGrp <- F
    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 = F]
  }
  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"))
  class(value) <- c("augPred", class(value))
  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)))
  }
  value
}

coef.gls <-
  function(object, allCoef = F)
{
  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),
	   level = NULL, length.out = 51, ...) 
{
  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) object$groups

getGroupsFormula.gls <-
  function(object, asList = FALSE)
{
  if (!is.null(cSt <- object$glsStruct$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
    mult <- -qt((1-level)/2, dims$N - dims$p)
    est <- coef(object)
    std <- sqrt(diag(object$varBeta))
    val[["coef"]] <- 
      array(c(est - mult * std, est, est + mult * std),
	    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
      Nr <- dims$N - dims$REML * dims*p
      est <- object$sigma * sqrt(Nr)
      val[["sigma"]] <- 
	array(c(est/qchisq((1+level)/2, Nr), object$sigma, 
		est/qchisq((1-level)/2, Nr)), c(1, 3),
	      list("sigma", 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))
      }
      mult <- -qnorm((1-level)/2)
      est <- attr(aV, "Pars")
      nP <- length(est)
      std <- sqrt(diag(aV))
      glsSt <- object[["glsStruct"]]
      namG <- names(glsSt)
      auxVal <- vector("list", length(namG) + 1)
      names(auxVal) <- c(namG, "sigma")
      aux <-
	array(c(est - mult * std, est, est + mult * std),
	      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 = F]
      dimnames(aux)[[1]] <- namP <- names(coef(glsSt, F))
      for(i in 1:3) {
	coef(glsSt) <- aux[,i]
	aux[,i] <- coef(glsSt, unconstrained = F)
      }
      for(i in namG) {
	auxVal[[i]] <- aux[regexpr(i, namP)!=-1, , drop = F]
	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$estMethod
  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, "nobs") <- N - REML * p
  attr(val, "df") <- p + length(coef(object[["glsStruct"]])) + 1
  class(val) <- "logLik"
  val
}

plot.gls <- 
  function(object, form = resid(., type = "pearson") ~ fitted(.), abline, 
	   id = NULL, idLabels = NULL,  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))
      }
      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)
  } else {
    X <- array(1, c(N, 1), list(row.names(dataMod), "(Intercept)"))
  }
  cf <- coef(object)
  c(X[, names(cf), drop = F] %*% cf)
}

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(" ",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
  cat("Call:\n")
  cat(deparse(x$call),"\n")
  cat("\nCoefficients:\n")
  print(coef(x))
  cat("\n")
  print(summary(x$glsStruct))
  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 = F, digits = .Options$digits, ...)
{
  dd <- x$dims
  verbose <- verbose || attr(x, "verbose")
  cat("Call:\n")
  cat(deparse(x$call),"\n")
  cat("Standardized Residuals:\n")
  print(x$residuals)

  estMethod <- x$estMethod
  cat("\nEstimation Method:", estMethod,"\n")
  if (verbose) {
    cat("Convergence at iteration:",x$numIter,"\n")
    if (estMethod == "REML") {
      cat("Restricted ")
    }
    cat("Loglikelihood:",format(x$logLik),"\n")
    if (estMethod == "REML") {
      cat("Restricted ")
    }
    cat("AIC:",format(x$AIC),"\n")
    if (estMethod == "REML") {
      cat("Restricted ")
    }
    cat("BIC:",format(x$BIC))
   cat("\n")
  }
  cat("\nCoefficients:\n")
  print(x$tTable)
  if (nrow(x$tTable) > 1) {
    corr <- x$corBeta
    class(corr) <- "correlation"
    print(corr,
	  title = "\n Correlation of Coefficients",
	  ...)
  }
  cat("\n")
  print(summary(x$glsStruct))
  cat("Degrees of freedom:", dd[["N"]],"total;",dd[["N"]] - dd[["p"]],
      "residual\n")
  cat("Residual standard Error:", format(x$sigma),"\n")
}

residuals.gls <- 
  function(object, type = c("response", "pearson"))
{
  type <- match.arg(type)
  val <- object$residuals
  if (type == "pearson") {
    val <- val/attr(val, "std")
    attr(val, "label") <- "Standardized residuals"
  } else {
    lab <- "Residuals"
    if (!is.null(aux <- attr(object, "units")$y)) {
      lab <- paste(lab, " (", aux, ")", sep = "")
    }
    attr(val, "label") <- lab
  }
  val
}

summary.gls <- function(object, verbose = F) {
  ##
  ## 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)
  class(object) <- c("summary.gls", class(object))
  attr(object, "verbose") <- verbose
  object
}

update.gls <-
  function(object, 
	   model,
	   data,
	   correlation,
	   weights,
	   subset,
	   REML,
	   na.action, 
	   control,
	   verbose)
{
  thisCall <- as.list(match.call())[-(1:2)]
  nextCall <- as.list(object$call)[-1]
  nextCall[names(thisCall)] <- thisCall
  do.call("gls", nextCall)
}

###*### 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 = F,
                           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(F, 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))
  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 = F, singular.ok = F, 
	   qrTol = .Machine$single.eps, returnObject = F,
	   apVar = TRUE, .relStep = (.Machine$double.eps)^(1/3))
{
  list(maxIter = maxIter, msMaxIter = msMaxIter, tolerance = tolerance,
       msTol = msTol, msScale = msScale, msVerbose = msVerbose, 
       singular.ok = singular.ok, qrTol = qrTol, 
       returnObject = returnObject, apVar = apVar, 
       .relStep = .relStep)
}

### local generics for objects inheriting from class lme




## Local Variables:
## mode:S
## End:
### $Id: groupedData.q,v 1.19 1998/06/02 18:26:13 bates Exp $
###
###           groupedData - data frame with a grouping structure
###
### Copyright 1997, 1998 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, T)
  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 = F)
{
  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"]] <- 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]
      }
    }
  }
  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
    for(i in 2:Q) groups[, i] <-
      paste(as.character(groups[, i - 1]),
            as.character(groups[, 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[sort.list(rnams)]
    attr(value, "innerGroups") <- ~.collapseGroups
  }
  value
}

formula.groupedData <-
  function(object) 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) {
             panel.grid()
             panel.xyplot(x, y)
             y.avg <- tapply(y, x, mean) # lines through average y
             xvals <- as.numeric(names(y.avg))
             ord <- order(xvals)
             panel.xyplot(xvals[ord], y.avg[ord], type = "l")
           }, key = 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, frame = 1)
        assign("trll.col", trll.col, frame = 1)
        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, frame = 1)
      assign("trll.col", trll.col, frame = 1)
      args[["panel"]] <- function(x, y, subscripts, groups)
	{
	  panel.grid()
	  panel.xyplot(x, y)
	  aux <- groups[subscripts]
	  aux <- match(unique(aux), aux)
          panel.superpose(x, y, subscripts, groups, type = "l",
			  col = trll.col[subscripts][aux],
			  lty = trll.lty[subscripts][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
  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 = groupExpr,
           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, ...)
{
  groupExpr <- deparse(getGroupsFormula(x)[[2]])
  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, ...)
{
  args <- list(outer = outer, inner = inner, ...)
  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"))
  NextMethod("print", 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")))]
  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, ..., drop = FALSE)
{
  oAttr <- attributes(x)
  if( exists( "is.R" ) && is.function( is.R ) && is.R() ) { #temporary kluge
    mycall <- match.call()
    mycall[[1]] <- as.name("[.data.frame")
    data <- eval(mycall, envir = sys.frame(sys.parent(1)))
  } else {
    x <- as.data.frame(x)
    data <- NextMethod()
  }
  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
    return( data )
  }
  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)
}

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


## $Id: lmList.q,v 1.24 1998/06/13 13:18:39 pinheiro Exp $
###
###                  Create a list of lm objects
###
### Copyright 1997, 1998 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"]] <- c(eval(parse(text = paste(deparse(form[[2]]), "~",
                                   deparse(form[[3]][[2]])))))
  args[["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)
  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 <- c(getGroupsFormula(data))
    } 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))
  }

  val <- lapply(split(data, groups),
		function(dat, formula, first = TRUE, na.action)
		{
		  restart(first)
		  if(first) {
		    first <- F
		    lm(formula = formula, data = dat, na.action = na.action)
		  } else {
		    NULL
		  }
		},
		formula = 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, "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"))
  class(value) <- c("augPred", class(value))
  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)))
  value
}

coef.lmList <-
  ## Extract the coefficients and form a  data.frame if possible
  function(object, augFrame = FALSE, level = 1, data = NULL,
           which = 1:ncol(data), 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)) {
          mCall <- attr(object, "call")
          data <- mCall[["data"]]
          if (mode(data) == "name") {
            data <- eval(data)
          }
        }
	data <- as.data.frame(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") <- 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", "random.effects.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")
      }
    }
    oatt <- attributes(object)[c("call", "class")]
    object <- object[subset]
    attributes(object)[c("call", "class")] <- oatt
  }
  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
}

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

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

getGroups.lmList <-  function(object) attr(object, "groups")

getGroupsFormula.lmList <-
  function(object, asList = FALSE)
{
  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 , ]
  dimnames(out)[[2]] <- c("lower", "est.", "upper")
  mult <- sqrt(qf(level, 1, smry$df.residual))
  out[ , "est.", ] <- coeff[ , "Value",  ]
  out[ , "lower", ] <- coeff[ , "Value", ] - mult * coeff[ , "Std. Error", ]
  out[ , "upper", ] <- coeff[ , "Value", ] + mult * coeff[ , "Std. Error", ]
  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[4]
    attr(val, "nobs") <- aux[1]
    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) {
    mCall <- attr(object, "call")
    mData <- mCall[["data"]]
    if (is.null(mData)) {		# 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 (is.name(mData)) {
	data <- eval(mData)
      } else {
	data <- mData
      }
      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]
  if (ncol(.x) == 1) {
    stop("Cannot do pairs of just one variable")
  }
  if (!missing(label)) {
    names(.x) <- labels
  }
  if (ncol(.x) == 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)) {
      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]]))))
  }
  
  ## 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(random.effects(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(as.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"]]
    }
  }

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

  ## 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 (!is.null(aux <- id[subscripts])) {
		      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 (!is.null(aux <- id[subscripts])) {
		      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 <- ""
  }

  dotplot(group ~ intervals | what,
	  data = tt,
	  scales = list(x=list(relation="free")),
	  strip = strip,
	  xlab = xlab,
	  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.random.effects.lmList <-
  function(object, outer = NULL, ...)
{
  eNames <- attr(object, "effectNames")
  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 (!is.null(outer)) {
    if (!inherits(outer, "formula") || (length(outer) != 2)) {
      stop("\"Outer\" must be a one-sided formula")
    }
    outer <- asOneSidedFormula(outer)
    onames <- all.vars(outer)
    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(outer)) {
      args$ylab <- attr(object, "grpNames")
    } else {
      args$ylab <- deparse(outer[[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", args)
}

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) {
    mCall <- attr(object, "call")
    mData <- mCall[["data"]]
    if (is.null(mData)) {		# 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 (is.name(mData)) {
	data <- eval(mData)
      } else {
	data <- mData
      }
      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 <- 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 , frame = 1)
  assign("idLabels", idLabels, frame = 1)
  assign("abl", abline, frame = 1)

  ## 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 (!is.null(aux <- id[subscripts])) {
			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 <- F
  }
  assign("grid", grid, frame = 1)

  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 <- attr(object, "call")[["data"]]
    if (is.name(myData)) myData <- eval(myData)
    grps <- getGroups(object)
    myData <- split(myData, grps)
    newdata <- NULL
    sameData <- F
  } else {
    newdata <- as.data.frame(newdata)
    sameData <- T
    ## 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 <- F
    }
  }				       
  if(!is.null(subset)) {
    if(any(is.na(match(subset, names(object))))) {
      stop("Non-existent group requested in \"subset\".")
    }
    oatt <- attributes(object)[c("call", "class")]
    object <- object[subset]
    attributes(object)[c("call", "class")] <- oatt
    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)
    }
  }
  val
}

print.intervals.lmList <-
  function(x, ...)
{			# Will need to be changed for S4!
  print(unclass(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) {
    mCall <- object$call
    mData <- mCall[["data"]]
    if (is.null(mData)) {		# 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 (is.name(mData)) {
	data <- eval(mData)
      } else {
	data <- mData
      }
      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 <- 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) || (regexpr("[Rr]esiduals", labs) == -1 &&
                        regexpr("[Rr]andom effects", labs) == -1)) {
    stop("Only residuals and random effects allowed")
  }
  if (regexpr("[Rr]esiduals", labs) == -1) {
    type <- "reff"
  } else {
    type <- "res"
  }
  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 = F)
    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 = F)
    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
    } 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 <- 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(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"]]
      }
      data <- cbind(fData, auxData)
    } else {
      data <- fData
    }
  }
  assign("id", if (is.null(id)) NULL else as.logical(as.character(id)),
         frame = 1)
  assign("idLabels", as.character(idLabels), frame = 1)
  assign("grid", grid, frame = 1)
  assign("abl", abline, frame = 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),
                 panel = function(x, y, subscripts, ...){
                   dots <- list(...)
                   if (grid) panel.grid()
                   panel.xyplot(x, y, ...)
                   if (!is.null(aux <- id[subscripts])) {
                     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)
}
  
random.effects.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, level = 1, data = NULL,
           which = 1:ncol(data), FUN = mean, standard = FALSE,
           omitGroupingFactor = TRUE)
{
  val <- coef(object, augFrame, level, 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) {
    effs <- 
      as.data.frame(as.matrix(effs) %*% diag(1/sqrt(diag(var(na.omit(effs))))))
    attr(val, "label") <- "Standardized random effects"
  } else {
    attr(val, "label") <- "Random effects"
  }
  val[, effNames] <- effs
  attr(val, "standardized") <- standard
  class(val) <- unique(c("random.effects.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")
      }
    }
    oatt <- attributes(object)[c("call", "class")]
    object <- object[subset]
    attributes(object)[c("call", "class")] <- oatt
  }
  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(T, 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
  do.call("lmList", nextCall)
}

### Local variables:
### mode: S
### End:
### $Id: lme.q,v 1.52 1998/07/02 21:25:19 bates Exp $
###
###            Fit a general linear mixed effects model
###
### Copyright 1997, 1998 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.parent(),
	   random,
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   REML = FALSE, 
	   na.action = na.fail, 
	   control = list())
  UseMethod("lme")

lme.groupedData <- 
  function(fixed,
	   data = sys.parent(),
	   random,
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   REML = FALSE, 
	   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.parent(),
	   random,
	   correlation = NULL,
	   weights = NULL,
	   subset,
	   REML = FALSE, 
	   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
  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 (is.name(mData)) {
      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(aux1 <- coef(fixed)), 0))) {
    if (isInitialized(reSt)) {
      warning("Initial value for reStruct overwritten in lme.lmList")
    }
    matrix(reSt[[1]]) <- var(na.omit(aux1)[, rNames])/(pooledSD(fixed)^2)
  }
  this.call[["random"]] <- reSt
  do.call("lme", this.call)
}

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

  ## control parameters
  controlvals <- lmeControl()
  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\"")
  }
  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"))
    }
  }
  ## check if corStruct is present and assign groups to its formula
  if (!is.null(correlation)) {
    ## will assign innermost group
    aux <- getGroupsFormula(eval(parse(text = paste("~1", 
			   deparse(groups[[2]]), sep ="|"))), asList = TRUE)
    aux <- aux[[length(aux)]]
    attr(correlation, "formula") <- 
      eval(parse(text = paste("~", 
		     deparse(getCovariateFormula(formula(correlation))[[2]]),
		     "|", deparse(aux[[2]]))))
  }
  ## 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, 
	     eval(parse(text = paste("~1", deparse(groups[[2]]), sep = "|"))))

  ## 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] <- 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
  attr(lmeSt, "conLin") <-
    list(Xy = array(c(Z, X, y), c(N, sum(ncols)), 
	     list(row.names(dataMix), c(dimnames(Z)[[2]], dimnames(X)[[2]],
					deparse(fixed[[2]])))),
	 dims = MEdims(grps, ncols), logLik = 0)
  ## initialization
  lmeSt <- initialize(lmeSt, dataMix, grps, control = controlvals)
  parMap <- attr(lmeSt, "pmap")
  ## Checking possibility of single decomposition
  if (length(coef(lmeSt)) == length(coef(lmeSt$reStruct)) &&
      is.null(weights))  {	# can do one decomposition
    ## need to save conLin for calculating fitted values and residuals
    oldConLin <- attr(lmeSt, "conLin")
    decomp <- T
    attr(lmeSt, "conLin") <- MEdecomp(attr(lmeSt, "conLin"))
  } else decomp <- F

  if (needUpdate(lmeSt)) {              # initializing varying weights
    attr(lmeSt, "lmeFit") <- MEestimate(lmeSt, grps)
    lmeSt <- update(lmeSt, dataMix)
  }
  ##
  ## getting the linear mixed effects fit object,
  ## possibly iterating for variance functions
  ##
  numIter <- 0
  attach(controlvals)
  repeat {
    oldPars <- coef(lmeSt)
    if( exists( "is.R" ) && is.function( is.R ) && is.R() ) {
      aNlm <- nlm(f = function(lmePars) -logLik(lmeSt, lmePars),
                  p = c(coef(lmeSt)),
                  hessian = TRUE,
                  print = ifelse(msVerbose, 2, 0))
      numIter0 <- NULL
      coef(lmeSt) <- aNlm$estimate
    } else {
      aMs <- ms(~-logLik(lmeSt, lmePars),
                start = list(lmePars = c(coef(lmeSt))),
                control = list(rel.tolerance = msTol, maxiter = msMaxIter,
		  scale = msScale), trace = msVerbose)
      coef(lmeSt) <- aMs$parameters
      numIter0 <- aMs$numIter <- aMs$flags[31]
    }
    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) <= tolerance) {
      break
    }
    if (numIter > maxIter) {
      stop("Maximum number of iterations reached without convergence.")
    }
  }
  detach()

  ## wrapping up
  lmeFit <- attr(lmeSt, "lmeFit")
  names(lmeFit$beta) <- namBeta <- dimnames(X)[[2]]
  varFix <- crossprod(lmeFit$sigma * lmeFit$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"]],
		      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,
		 estMethod = c("ML", "REML")[REML + 1],
		 fitted = Fitted,
		 residuals = Resid)
  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

lmeApVar <-
  function(lmeSt, sigma, conLin = attr(lmeSt, "conLin"), natural = TRUE,
           .relStep = (.Machine$double.eps)^(1/3))
{
  ## 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))[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 = T and no grad/Hess
  conLin[["logLik"]] <- 0               # making sure
  sig2 <- sigma * sigma
  reSt <- lmeSt[["reStruct"]]
  for(i in seq(along = reSt)) {
    matrix(reSt[[i]]) <- sig2 * pdMatrix(reSt[[i]])
    if (inherits(reSt[[i]], "pdSymm") && natural) {
      reSt[[i]] <- pdNatural(reSt[[i]])
    }
  }
  lmeSt[["reStruct"]] <- reSt
  Pars <- c(coef(lmeSt), lSigma = log(sigma))
  val <- fdHess(Pars, fullLmeLogLik, lmeSt, conLin, dims, N, sett,
		.relStep = .relStep)[["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)))[[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))[["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(F))[["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 <- as.list(apply(isLast, 2, function(x) seq(along = x)[x]))
  isLast <- t(isLast)
  strSizes <- cumsum(ncols * isLast) * isLast # required storage sizes
  lastStr <- as.list(apply(t(strSizes), 2, function(x) x[x != 0]))
  strRows <- max(lastStr[[length(lastStr)]])
  lastBlock <- vector("list", Q)
  names(lastBlock) <- dimnames(strSizes)[[1]][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

anova.lme <- 
  function(object, ..., test = TRUE, verbose = FALSE)

{
  ## returns the likelihood ratio statistics, the AIC, and the BIC
  dots <- list(...)
  if ((rt <- length(dots) + 1) == 1) {
    if (!inherits(object,"lme")) {
      stop("Object must inherit from class \"lme\" ")
    }
    ##
    ## if just one object returns the t.table for the fixed effects
    ##
    stdFix <- sqrt(diag(object$varFix))
    ##
    ## fixed effects coefficients, std. deviations, z-ratios, and p-values
    ##
    beta <- fixed.effects(object)
    zratio <- beta/stdFix
    aod <- data.frame(beta, stdFix, zratio, 2 * pnorm(-abs(zratio)))
    dimnames(aod) <- 
      list(names(beta),c("Value","Std.Error","z-value", "p-value"))
    attr(aod,"rt") <- rt
  }
  ##
  ## Otherwise construct the likelihood ratio and information table
  ## objects in ... may inherit from lm, lmList, and lme (for now)
  ##
  else {
    ancall <- sys.call()
    ancall$verbose <- ancall$test <- NULL
    object <- list(object, ...)
    termsClass <- unlist(lapply(object, data.class))
    if(!all(match(termsClass, c("gls", "lm", "lmList", "lme"), 0))) {
      stop(paste("Objects must inherit from classes \"gls\", \"lm\",",
		 "\"lmList\", or \"lme\""))
    }
    resp <- unlist(lapply(object, 
		  function(el) deparse(getResponseFormula(el)[[2]])))
    ## checking if responses are the same
    subs <- as.logical(match(resp, resp[1], F))
    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[["estMethod"]]
			       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"
    if(uEst == "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 = "&")
	     }
	   }))
      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, uEst == "REML")
    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, 
			  "Lik.Ratio" = c(NA, lratio),  
			  "p-value" = c(NA, pval),
			  check.names = FALSE)
      }
    }
    row.names(aod) <- unlist(lapply(as.list(ancall[-1]), as.character))
    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"))
  class(value) <- c("augPred", class(value))
  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)))
  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 <- fixed.effects(object)
  p <- length(fixed)
  value <- random.effects(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] <- effs[, nami] + value[[i]][as.character(grps[, i]), ]
  }

  if (augFrame) {			# can only do that for last level
    if (missing(data)) {
      mCall <- object[["call"]]
      data <- mCall[["data"]]
      if (mode(data) == "name") {
	data <- eval(data)
      }
    } 
    data <- as.data.frame(data)
    data <- data[, which, drop = FALSE]
    value <- random.effects(object, T, 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", "random.effects.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 <- 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)

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

getGroups.lme <-
  function(object, form, level = Q)
{
  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)
{
  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)
  mult <- -qnorm((1-level)/2)
  val <- list()
  if (which != "var-cov") {		# fixed effects included
    est <- fixed.effects(object)
    std <- sqrt(diag(object$varFix))
    val <- list(fixed = array(c(est - mult * std, est, est + mult * std),
                  c(length(est), 3), list(names(est), c("lower", "est.", "upper"))))
    attr(val[["fixed"]], "label") <- "Fixed effects:"
  }

  if (which != "fixed") {		# variance-covariance included
    if (is.character(aV <- object$apVar)) {
      stop(paste("Cannot get confidence intervals on var-cov components:",
		 aV))
    }
    nat <- attr(aV, "natural")
    est <- attr(aV, "Pars")
    nP <- length(est)
    std <- sqrt(diag(aV))
    lmeSt <- object[["modelStruct"]]
    namL <- names(lmeSt)
    auxVal <- vector("list", length(namL) + 1)
    names(auxVal) <- c(namL, "sigma")
    aux <-
      array(c(est - mult * std, est, est + mult * std),
	    c(nP, 3), list(NULL, c("lower", "est.", "upper")))
    if (nat) {
      for(i in seq(along = lmeSt$reStruct)) {
	if (inherits(lmeSt$reStruct[[i]], "pdSymm")) {
	  lmeSt$reStruct[[i]] <- pdNatural(lmeSt$reStruct[[i]])
	}
      }
    }
    auxVal[["sigma"]] <- exp(aux[nP,])
    attr(auxVal[["sigma"]], "label") <- "Within-group standard error:"
    aux <- aux[-nP,, drop = FALSE]
    dimnames(aux)[[1]] <- namP <- names(coef(lmeSt, F))
    for(i in 1:3) {
      coef(lmeSt) <- aux[,i]
      aux[,i] <- coef(lmeSt, unconstrained = FALSE)
    }
    for(i in namL) {
      if (exists("is.R") && is.function(is.R) && is.R()) {
        ## this is the way the code was originally written but it doesn't
        ## work under S-PLUS for Windows because the Windows version of
        ## grep is broken.  "regexpr" is used in S-PLUS instead but is not
        ## defined in R
        auxVal[[i]] <- aux[grep(i, namP), , drop = FALSE]
      } else {
        auxVal[[i]] <- aux[regexpr(i, namP) != -1, , drop = FALSE]
      }
      dimnames(auxVal[[i]])[[1]] <- 
	substring(dimnames(auxVal[[i]])[[1]], nchar(i) + 2)
      if (i == "reStruct") {
	namR <- names(lmeSt$reStruct)
	auxRe <- vector("list", length(namR))
	names(auxRe) <- namR
	namVR <- dimnames(auxVal[[i]])[[1]]
	for(j in namR) {
          if (exists("is.R") && is.function(is.R) && is.R()) {
            auxRe[[j]] <- auxVal[[i]][grep(j, namVR), , drop = FALSE]
          } else {
            auxRe[[j]] <- auxVal[[i]][regexpr(j, namVR)!=-1, , drop = FALSE]
          }
	  dimnames(auxRe[[j]])[[1]] <-
	    substring(dimnames(auxRe[[j]])[[1]], nchar(j) + 2)
	}
	auxVal[[i]] <- rev(auxRe)
      }
      attr(auxVal[[i]], "label") <-
	switch(i,
	       reStruct = "Random Effects:",
	       corStruct = "Correlation structure:",
	       varStruct = "Variance function:",
	       paste(i,":",sep=""))
    }
    val <- c(val, auxVal)
  }
  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$estMethod
  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, "nobs") <- object$dims$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 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) {
    mCall <- object$call
    mData <- mCall[["data"]]
    if (is.null(mData)) {		# 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 (is.name(mData)) {
	data <- eval(mData)
      } else {
	data <- mData
      }
      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]
  if (ncol(.x) == 1) {
    stop("Cannot do pairs of just one variable")
  }
  if (!missing(label)) {
    names(.x) <- labels
  }
  if (ncol(.x) == 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)) {
      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]]))))
  }
  
  ## 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(random.effects(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[[".g"]])) {
      argData[[".g"]] <- auxData[[".g"]]
    }

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

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

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

  ## 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 (!is.null(aux <- id[subscripts])) {
		      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 (!is.null(aux <- id[subscripts])) {
		      text(x[aux], y[aux], idLabels[subscripts][aux],
                           cex = dots$cex, adj = dots$adj)
                    }
		  }))
  }
  do.call(plotFun, args)
}


plot.lme <- 
  function(object, form = resid(., type = "pearson") ~ 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) {
    mCall <- object$call
    mData <- mCall[["data"]]
    if (is.null(mData)) {		# 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 (is.name(mData)) {
	data <- eval(mData)
      } else {
	data <- mData
      }
      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 <- 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)) {
      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="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")
      }
    }
  }

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

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

  ## 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 (!is.null(aux <- id[subscripts])) {
			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 <- F
  }
  assign("grid", grid, frame = 1)
  do.call(plotFun, args)
}

plot.random.effects.lme <-
  function(object, outer = NULL, omitFixed = TRUE, level = Q, ...)
{
  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")
  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 (!is.null(outer)) {
    if (!inherits(outer, "formula") || (length(outer) != 2)) {
      stop("\"Outer\" must be a one-sided formula")
    }
    outer <- asOneSidedFormula(outer)
    onames <- all.vars(outer)
    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(outer)) {
      args$ylab <- attr(object, "grpNames")
    } else {
      args$ylab <- deparse(outer[[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", args)
}

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] <- paste(as.character(grps[, i-1]), as.character(grps[,i]),
			   sep = "/")
	NULL
      }
    }
    naGrps <- cbind(F, 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)
          }
        }
      }
    }
    revOrder <- match(origOrder, row.names(dataMix)) # putting in orig. order
    Z <- model.matrix(reSt, dataMix, contr)
    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), object$contrasts) 
  } else {
    X <- array(1, c(N, 1), list(row.names(dataMix), "(Intercept)"))
  }
  if (maxQ == 0) {
    ## only population predictions
    return(c(X %*% fixed.effects(object)))
  }
  
  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(dimnames(Z)[[2]], dimnames(X)[[2]],
					"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 = fixed.effects(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] <- paste(as.character(oGrps[,i-1]), as.character(oGrps[,i]),
                          sep = "/")
    }
  }
  if (length(level) == 1) {
    if (level > 1) {
      grps <- do.call("paste", 
		      c(lapply(oGrps[, 1:level, drop = FALSE], 
			       as.character),  sep = "/"))
    } else {
      grps <- as.character(oGrps[,1])
    }
    if (asList) {
      val <- split(val, ordered(grps, levels = unique(grps)))
    } else {
      names(val) <- grps
    }
  } 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) {
    print(zapsmall(as.matrix(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 ((0 == length(levels(xx))) && is.numeric(xx)) {
	xna <- is.na(xx)
	xx <- format(zapsmall(xx, 5))
	xx[xna] <- ""
	x[[i]] <- xx
      }
    }
    invisible(print(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.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$estMethod == "REML", "REML\n", "maximum likelihood\n") )
    cat("  Model:", deparse(as.vector(x$call$object)),"\n")
  } else {				# lme objects
    cat( "Linear mixed-effects model fit by " )
    cat( ifelse( x$estMethod == "REML", "REML\n", "maximum likelihood\n") )
  }    
  cat("  Data:", as.character( x$call$data ), "\n")
  cat("  Log-", ifelse(x$estMethod == "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(fixed.effects(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.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$estMethod == "REML", "REML\n", "maximum likelihood\n") )
    cat("  Model:", deparse(as.vector(x$call$object)),"\n")
  } else {				# lme objects
    cat( "Linear mixed-effects model fit by " )
    cat( ifelse( x$estMethod == "REML", "REML\n", "maximum likelihood\n") )
  }    
  estMethod <- x$estMethod
  cat(" Data:", as.character( x$call$data ), "\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")
  }
  print(zapsmall(x$zTable))
  if (nrow(x$zTable) > 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) {
    mCall <- object$call
    mData <- mCall[["data"]]
    if (is.null(mData)) {		# 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 (is.name(mData)) {
	data <- eval(mData)
      } else {
	data <- mData
      }
      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 <- 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) || (regexpr("[Rr]esiduals", labs) == -1 &&
                        regexpr("[Rr]andom effects", labs) == -1)) {
    stop("Only residuals and random effects allowed")
  }
  if (regexpr("[Rr]esiduals", labs) == -1) {
    type <- "reff"
  } else {
    type <- "res"
  }
  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 = F)
    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="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 = F)
    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
    } 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 <- 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(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"]]
      }
      data <- cbind(fData, auxData)
    } else {
      data <- fData
    }
  }
  assign("id", if (is.null(id)) NULL else as.logical(as.character(id)),
         frame = 1)
  assign("idLabels", as.character(idLabels), frame = 1)
  assign("grid", grid, frame = 1)
  assign("abl", abline, frame = 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),
                 panel = function(x, y, subscripts, ...){
                   dots <- list(...)
                   if (grid) panel.grid()
                   panel.xyplot(x, y, ...)
                   if (!is.null(aux <- id[subscripts])) {
                     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)
}

random.effects.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)) {
      mCall <- object[["call"]]
      data <- mCall[["data"]]
      if (mode(data) == "name") {
	data <- eval(data)
      }
    } 
    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("random.effects.lme", class(effects))
  effects
}

residuals.lme <- 
  function(object, level = Q, type = c("response", "pearson"), 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 == "pearson") {		# standardize
    ## have to standardize properly for when corStruct neq corIdent
    val <- val[, level]/attr(val, "std")
  } else {
    val <- val[, level]
  }
  if (length(level) == 1) {
    grps <- as.character(object[["groups"]][, max(c(1, level - 1))])
    if (asList) {
      val <- split(val, ordered(grps, levels = unique(grps)))
    } else {
      names(val) <- grps
    }
    if (type == "pearson") {
      attr(val, "label") <- "Standardized residuals"
    } else {
      lab <- "Residuals"
      if (!is.null(aux <- attr(object, "units")$y)) {
	lab <- paste(lab, aux)
      }
      attr(val, "label") <- lab
    }
  }
  val
}

summary.lme <- function(object, verbose = FALSE)
{
  ##  variance-covariance estimates for fixed effects
  fixed <- fixed.effects(object)
  stdFixed <- sqrt(diag(as.matrix(object$varFix)))
  object$corFixed <- array(t(object$varFix/stdFixed)/stdFixed,
                           dim(object$varFix), list(names(fixed),names(fixed)))
  ## fixed effects coefficients, std. deviations and z-ratios
  ##
  zTable <- data.frame(fixed, stdFixed, fixed/stdFixed, fixed)
  dimnames(zTable)<-
    list(names(fixed),c("Value","Std.Error","z-value","p-value"))
  zTable[, "p-value"] <- 2 * pnorm(-abs(zTable[,"z-value"]))
  object$zTable <- as.matrix(zTable)
  ##
  ## 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)
  if (!inherits(object, "nlme")) {
    class(object) <- c("summary.lme", class(object))
  } else {
    class(object) <- c("summary.nlme", "summary.lme", class(object))
  }
  attr(object, "verbose") <- verbose
  object
}

update.lme <-
  function(object, 
	   fixed,
	   data,
	   random,
	   correlation,
	   weights,
	   subset,
	   REML,
	   na.action, 
	   control)
{
  thisCall <- as.list(match.call())[-(1:2)]
  nextCall <- as.list(object$call)[-1]
  if( exists("is.R") && is.function(is.R) && is.R() ) {
    argNams <- unique( c(names(nextCall), names(thisCall)) )
    args <- vector("list", length(argNams))
    names(args) <- argNams
    args[ names(nextCall) ] <- nextCall
    nextCall <- args
  }
  nextCall[names(thisCall)] <- thisCall
  do.call("lme", nextCall)
}

###*### 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, lmeFit = attr(object, "lmeFit"),
	   conLin = attr(object, "conLin"))
{
  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(F, c(1, length(len)))
  }
  dimnames(pmap) <- list(NULL, names(object))
  attr(object, "pmap") <- pmap
  if (length(coef(object)) == length(coef(object$reStruct)) && # only reStruct
      !needUpdate(object) &&		# and fixed varFunc 
      (attr(object, "settings")[4] >= 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))[["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, lmeFit = attr(object, "lmeFit"),
	   conLin = attr(object, "conLin"))
{
  Q <- conLin$dims$Q
  conLin$Xy[, conLin$dims$ZXcols] - fitted(object, level, lmeFit, conLin)
}

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), 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, natural = natural)
}

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

### $Id: modelStruct.q,v 1.5 1998/05/07 19:20:49 bates Exp $
##*## End of prologue
 # Major classes, their constructors, and methods for standard generics

##*## modelStruct - a virtual class of model structures

###*# 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 = T)
{
  unlist(lapply(object, coef, unconstrained))
}

"coef<-.modelStruct" <-
  function(object, value)
{
  value <- as.numeric(value)
  parMap <- attr(object, "pmap")
  for(i in names(object)) {
    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
}

##*## 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: newFunc.q,v 1.12 1998/06/13 13:18:41 pinheiro Exp $
###*### functions used in several parts of the code that do not belong to 
###*### any specific part

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(sys.call()[-1])
  dimnames(which) <- list(NULL, cnames[cnames != substitute(extract)])
  theta <- unlist(theta)
  attr(theta, "map") <- which
  theta
}

allVarsRec <-
  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"))
#{
#  func <- function(x) {			# should make all.vars generic
#    if (is.list(x)) {
##      return(unlist(lapply(x, all.vars)))
#      return(unlist(lapply(x, func, func = func)))
#    } 
#    all.vars(x)
#  }
#  names <- unique(unlist(lapply(list(...), func)))
#  names <- names[is.na(match(names, omit))]
#  if (length(names)) {
#    eval(parse(text = paste("~", paste(names, collapse = "+")))[[1]])
#  } else NULL
#}

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
}


asOneSidedFormula <-
  ## Converts an expression or a name or a character string
  ## to a one-sided formula
  function(object)
{
  if ((mode(object) == "call") && (object[[1]] == "~")) {
    object <- eval(object)
  }
  if (inherits(object, "formula")) {
    if (length(object) != 2) {
      stop(paste("Formula", deparse(as.vector(object)),
		 "must be of the form \"~expr.\""))
    }
    return(object)
  }
  do.call("~",
	  list(switch(mode(object),
		      name = ,
		      call = object,
		      character = as.name(object),
		      expression = object[[1]],
		      stop(paste(substitute(object), "cannot be of mode",
				 mode(object))))))
}

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) <- c("compareFits", class(out))
  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 = F]
  }
  contr
}

fdHess <- function(pars, fun, ..., .relStep = (.Machine$double.eps)^(1/3))
  ## Use a Koschal design to establish a second order model for the response
{
  pars <- as.numeric(pars)
  npar <- length(pars)
  incr <- ifelse( pars == 0, .relStep, 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 ) ] )
  Hess[ row( Hess ) > col ( Hess ) ] <- coefs[ -(1:(1 + 2 * npar)) ]
  list( mean = coefs[ 1 ], gradient = coefs[ 1 + seq( along = pars ) ],
       Hessian = ( Hess + t(Hess) )/2 )
}

gapply <-
  ## Apply a function to the subframes of a data.frame 
  ## If "apply" were generic, this would be the method for groupedData
  function(object, 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")
    }
  }
  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 = mean, 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) <- 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] <- 
	  tapply(c(object[[nm]]), groups, FUN[["numeric"]], ...)
      } else {
	value[,nm] <- 
	  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))
}


##*## 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: newGenerics.q,v 1.21 1998/06/06 20:15:23 bates Exp $
###
###    New generics used in the plug-ins, groupedData, and reStruct
###
### Copyright 1997, 1998 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 <-
  ## Return the object's value of the Aikaike Information Criterion
  function(object, ...) UseMethod("AIC")

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") 
BIC <-
  ## Return the object's value of the Bayesian Information Criterion
  function(object, ...) UseMethod("BIC")

"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("fixed.effects")

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

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

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)
    UseMethod("getGroupsFormula")

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

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

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")

logLik <- 
  function(object, ...) UseMethod("logLik")

"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("random.effects")

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

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

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

### $Id: newMethods.q,v 1.24 1998/07/02 21:41:59 bates Exp $
###
###      Methods for generics from newGenerics.q for some standard classes
###
### Copyright 1997, 1998 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 logLiks 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)

formula.nls <- function(object) object$call$formula

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])
  }
}

getGroups.data.frame <-
  ## Return the groups associated with object according to form for level
  function(object, form = formula(object), level, data)
{
  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)
    if (is.null(grpForm)) {
      ## will use right hand side of form as the group formula
      grpForm <- splitFormula(asOneSidedFormula(form[[length(form)]]))
      names(grpForm) <-
        unlist( lapply( grpForm, function(el) deparse( el[[ length(el) ]] ) ) )
    }
    if (any(unlist(lapply(grpForm,
                          function(el) length(el[[length(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) 
		  pruneLevels(as.factor(eval(x[[length(x)]], dat))),
		  dat = 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 = "/")))
  if (inherits(value[, 1], "ordered")) {
    value <- value[do.call("order", value),]
    aux <- unique(do.call("paste", c(lapply(as.list(value), 
					    as.character), sep = "/")))
    return(ordered(val, aux))
  } else {
    return(ordered(val, unique(as.character(val))))
  }
}

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)
{
  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]]))
  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) val
  else eval(parse(text = paste("~",  paste(names(val), collapse = "/"))))
}

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)
}


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$R)[1:p])))
  attr(val, "df") <- p + 1
  attr(val, "nobs") <- N
  class(val) <- "logLik"
  val
}

logLik.nls <- 
  function(object)
{
  res <- resid(object)
  n <- length(res)
  if(is.null(w <- object$weights)) {	
    w <- rep(1, n)
  }
  val <-  -n * (log(2 * pi) + 1 - log(n) - sum(log(w)) + log(sum(w*res^2)))/2
  attr(val, "df") <- length(object[["parameters"]]) + 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.augPred <-
  function(x, key = TRUE, ...)
{
  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, ...) {
                     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, ...) {
                     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 <- regexpr("predict.", levs) != -1
      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
  }
  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])), where = 1)
  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)
}

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(dimnames(x)[[2]])) {
      dimnames(x)[[2]] <- abbreviate(dimnames(x)[[2]], minlength = rdig + 3)
    }
   print(x[-1,  - p, drop = FALSE], ..., quote = FALSE)
  }
  invisible(x)
}

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

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)))])
}  






### $Id: nlme.q,v 1.7 1998/06/13 13:18:43 pinheiro Exp $
###
###            Fit a general nonlinear mixed effects model
###
### Copyright 1997, 1998 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(object,
	   fixed, 
	   data = sys.parent(),
	   random = fixed,
	   groups, 
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   REML = FALSE,
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  UseMethod("nlme")
}

nlme.nlsList <- 
  function(object,
	   fixed, 
	   data = sys.parent(),
	   random = fixed,
	   groups, 
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   REML = FALSE,
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  this.call <- as.list(match.call())[-1]
  ## checking the use of arguments defined within the function
  if (any(!is.na(match(names(this.call),
		       c("fixed", "groups", "data", "start"))))) {
    warning(paste("nlme.nlsList will redefine \"fixed\", \"groups\",",
		  "\"data\", and \"start\""))
  }
  ## add object, data, and optionally groups from the call that created object
  last.call <- as.list(attr(object, "call"))[-1]
  last.call$control <- NULL
  last.call$pool <- NULL
  ## was
  ## last.call <- last.call[is.na(match(names(last.call), "control"))]
  this.call[names(last.call)] <- last.call
  ## Got to fix up inconsistency with name of "model" and "object"
  ## Better to do this in the original functions
  this.call[["object"]] <- last.call[["model"]]
  this.call[["model"]] <- NULL
  ## create "fixed" and "start" 
  start <- list(fixed = fixed.effects(object))
  pnames <- names(start$fixed)
  this.call[["fixed"]] <- lapply(as.list(pnames), function(el)
                                 eval(parse(text = paste(el, 1, sep = "~"))))
  if(missing(random)) {
    random <- this.call[["fixed"]]
  }
  reSt <- reStruct(random, data = NULL)
  ranForm <- formula(reSt)[[1]]
  if (!is.list(ranForm)) {
    ranForm <- list(ranForm)
  }
  mData <- this.call[["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 (is.name(mData)) {
      mData <- eval(mData)
    } 
  }
  reSt <- reStruct(random, REML = REML, data = mData)
  rnames <- unlist(lapply(ranForm, "[[", 2))
  ## if the random effects are a subset of the coefficients,
  ## construct "random" initial estimates 
  if(all(match(rnames, pnames, 0))) {
    re <- random.effects(object)
    re[is.na(re)] <- 0
    start[["random"]] <- re[, rnames, drop = F]
    sSquared <- pooledSD(object)^2
    if(isInitialized(reSt)) {
      warning("Initial value for reStruct overwritten in nlme.nlsList")
    }
    matrix(reSt) <- 
      var(na.omit(coef(object))[, rnames, drop = F])/sSquared
  }
  this.call[["start"]] <- start
  this.call[["random"]] <- reSt
  do.call("nlme.formula", this.call)
}


nlme.formula <- 
  function(object,
	   fixed, 
	   data = sys.parent(),
	   random = fixed,
	   groups, 
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   REML = FALSE,
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose= FALSE)
{
  ## This is the method that actually does the fitting
  assign("finiteDiffGrad",
	 function(model, data, pars)
	 {
	   dframe <- data.frame(data, pars)
	   base <- eval(model, dframe)
	   nm <- dimnames(pars)[[2]]
	   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
	 },
	 frame = 1)
  ## keeping the call
  Call <- match.call()
  ## assigning a new name to the "object" argument
  form <- object

  ## control parameters
  controlvals <- nlmeControl()
  if(!missing(control)) {
    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\"")

  if(missing(groups)) {
    if (inherits(data, "groupedData")) {
      Call[["groups"]] <- groups <- 
        getGroupsFormula(data)
    } else {
      stop (paste("Data must inherit from \"groupedData\" class ",
		  "if \"groups\" is missing"))
    }
  }

  ##
  ## checking if self-starting formula is given
  ##
  if(missing(start) && !is.null(attr(eval(form[[3]][[1]]), "initial"))) {
    nlmeCall <- Call
    nlsLCall <- nlmeCall[c("","object","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.parent()
    if(is.null(dim(data))) {
      stop("\"data\" must be given explicitly to use \"nlsList()\"")
    }
    nlsLObj <- eval(nlsLCall)
    nlmeCall[["object"]] <- as.name("nlsLObj")
    nlmeCall <- as.call(nlmeCall)
    return(eval(nlmeCall))
  }
  nlmeModel <- call("-", form[[2]], form[[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]]), fixed[[i]][[3]], sep = "~"),
                 collapse=","),")"))))
    }
  }
  fixed <- 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

  reSt <- reStruct(random, REML = REML, data = NULL)
  ranForm <- formula(reSt)[[1]]         # for now
  if (!is.list(ranForm)) {
    ranForm <- list(ranForm)
  }
  rnames <- character(length(ranForm))
  for (i in seq(along = ranForm)) {
    this <- eval(ranForm[[i]])
    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] <- as.character(this[[2]])
  }
  names(ranForm) <- rnames
  ## all parameter names
  pnames <- unique(c(fnames, 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]], frame = 1)
    }
    attr(data,"parameters") <- NULL
    class(data) <- "data.frame"
  }

  ## check if correlation is present and assign groups to its formula
  if (!is.null(correlation)) {
    ## will assign innermost group
    aux <- getGroupsFormula(eval(parse(text = paste("~1", 
			   deparse(groups[[2]]), sep ="|"))), asList = TRUE)
    aux <- aux[[length(aux)]]
    attr(correlation, "formula") <- 
      eval(parse(text = paste("~", 
		     deparse(getCovariateFormula(formula(correlation))[[2]]),
		     "|", deparse(aux[[2]]))))
  }
  ## 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), form, 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
  ord <- order(grps)	#"order" treats a single named argument peculiarly
  grps <- grps[ord]            # ordered group
  ugrp <- unique(grps)
  dataMix <- dataMix[ord,, drop = FALSE]       # ordered data frame
  grps <- data.frame(grps)
  row.names(grps) <- row.names(dataMix)
  names(nlmeSt$reStruct) <- names(grps) <- as.character(deparse((groups[[2]])))
  naPat <- naPat[ord]			# ordered naPat
  dataMixShrunk <- dataMix[naPat, , drop=FALSE]
  ordShrunk <- ord[naPat]
  grpShrunk <- grps[naPat,, drop = FALSE]
  revOrder <- match(origOrder, row.names(dataMix))
  revOrderShrunk <- match(origOrderShrunk, row.names(dataMixShrunk))
  yShrunk <- eval(form[[2]], dataMixShrunk)
  ##
  ## defining list with parameter information
  ##
  plist <- vector("list", length(pnames))
  names(plist) <- pnames
  for (nm in pnames) {
    this <- list(fixed = !is.null(fixed[[nm]]),
                 random = !is.null(ranForm[[nm]]))
    if (this[["fixed"]]) {
      if (as.name(fixed[[nm]][[3]]) != "1") {
	this[["fixed"]] <-
          model.matrix(asOneSidedFormula(fixed[[nm]][[3]]), dataMix)
      }
    }
    if (this[["random"]]) {
      wch <- (1:length(rnames))[regexpr(nm, rnames) != -1]
      if (length(wch) == 1) {           # only one formula for nm
        if (as.name(ranForm[[nm]][[3]]) != "1"){
          this[["random"]] <-
            model.matrix(asOneSidedFormula(ranForm[[nm]][[3]]), dataMix)
        }
      } else {
        this[["random"]] <-
          lapply(ranForm[wch], function(el, data) {
            if (as.name(el[[3]]) == "1") TRUE
            else model.matrix(asOneSidedFormula(el[[3]]), data)
          }, data = dataMix)
      }
    }
    plist[[nm]] <- this
  }
  if (is.null(sfix <- start$fixed))
    stop ("start must have a component called \"fixed\"")
  ##
  ## Fixed effects names
  ##
  fn <- character(0)
  for(nm in fnames) {
    if(is.logical(f <- plist[[nm]]$fixed)) {
      if(is.logical(plist[[nm]]$random)) {
        fn <- c(fn, nm) 
      } else {
        fn <- c(fn, paste(nm, "(Intercept)", sep="."))
      }
    } else {
      fn <- c(fn, paste(nm, dimnames(f)[[2]], sep = "."))
    }
  }
  flength <- length(fn)
  if (length(sfix) != flength) 
    stop ("starting values for the fixed component are not the correct length")
  names(sfix) <- fn
  ##
  ## Random effects names
  ##
  rn <- character(0)
  uRnames <- unique(rnames)
  wchRnames <- integer(length(uRnames))
  names(wchRnames) <- uRnames
  for(i in seq(along = rnames)) {
    nm <- rnames[i]
    wchRnames[nm] <- wchRnames[nm] + 1
    r <- plist[[nm]]$random
    if (data.class(r) == "list") r <- r[[wchRnames[nm]]]
    if(is.logical(r)) {
      if(r) { 
        if(is.logical(plist[[nm]]$fixed)) {
          rn <- c(rn, nm) 
        } else {
          rn <- c(rn, paste(nm,"(Intercept)",sep="."))
        }
      }
    } else {
      rn <- c(rn, paste(nm, dimnames(r)[[2]], sep = ".")) 
    }
  }
  rlength <- length(rn)
  if (is.null(start$random)) {
    sran <- array(0, c(rlength, length(ugrp)),
                  list(rn, as.character(ugrp)))
  } else {
    sran <- start$random
    if (!is.matrix(sran))
      stop ("starting values for the random component should be a matrix")
    dimsran <- dim(sran)
    if (dimsran[1] != length(ugrp))
      stop (paste("number of rows in starting values for random component",
                  "should be", length(ugrp)))
    if (dimsran[2] != rlength)
      stop (paste("number of columns in starting values for",
                  "random component should be", rlength))
    dnamesran <- dimnames(sran)[[2]]
    if ((!is.null(dnamesran)) && (!all(sort(dnamesran) == sort(rn)))) {
      stop ("names mismatch in random and starting values for random")
    }
    if(any(dnamesran != rn)) {
      sran <- sran[, rn, drop = F]
    }
    sran <- t(sran)
  }
  Names(nlmeSt$reStruct[[1]]) <- rn
  ##
  ##   defining values of constants used in calculations
  ##
  p <- flength; q <- rlength; M <- length(ugrp)
  NReal <- sum(naPat)
  Dims  <- c(p, q, NReal, M, REML, N)
  ##
  ## 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 <- list()
  n1 <- 1
  wchRnames[] <- 0
  for(nm in rnames) {
    wchRnames[nm] <- wchRnames[nm] + 1
    r <- plist[[nm]]$random
    if (data.class(r) == "list") {
      r <- r[[wchRnames[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[[nm]])) {
      rmap[[nm]] <- val
    } else {
      rmap[[nm]] <- c(rmap[[nm]], list(val))
    }
  }
  Q <- ncol(grps)

  ##
  ## defining the nlFrame
  ##
  nlFrame <- new.frame(list(model = nlmeModel,
			    data = dataMix,
			    groups = as.character(grps[, 1]),
			    plist = plist,
			    beta = sfix,
			    b = sran,
			    pars = array(0, c(N, length(pnames)),
			      list(NULL, pnames)),
			    X = array(0, c(N, flength),
			      list(NULL, fn)),
			    Z = array(0, c(N, rlength), list(NULL, rn)),
			    N = N,
			    fmap = fmap,
			    rmap = rmap,
                            level = Q,
			    .parameters = c("beta", "b")),
		       FALSE)
  ##
  ## defining the model expression
  ##
  modelExpression <- ~
  {
    pars <- getPars(plist, fmap, rmap, groups, beta, b, level)
    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
      }
      if (is.logical(r <- plist[[nm]]$random)) {
        if(r) {
          Z[, rmap[[nm]]] <- gradnm
        }
      } else {
        if (data.class(rmap[[nm]]) != "list") {
          Z[, rmap[[nm]]] <- gradnm * r
        } else {
          for(i in seq(along = rmap[[nm]])) {
            if (is.logical(rr <- r[[i]])) {
              Z[, rmap[[nm]][[i]]] <- gradnm
            } else {
              Z[, rmap[[nm]][[i]]] <- gradnm * rr
            }
          }
        }
      }
    }
    result <- c(res, Z, X)
    result[is.na(result)] <- 0
    result
  }

  ww <- eval(modelExpression[[2]], local = nlFrame)
  w <- ww[1:N][naPat]
  ZX <- array(ww[-(1:N)], c(N, p + q), list(row.names(dataMix),
                                            c(rn, fn)))[naPat,]
  w <- w + ZX[, q + (1:p), drop = F] %*% sfix
  if(!is.null(start$random)) {
    w <- w + (ZX[, 1:q, drop = F] * 
              t(sran)[as.character(grpShrunk[, 1]),,drop = F]) %*% rep(1,q)
  }
  ncols <- c(rlength, flength, 1)
  ## creating the condensed linear model
  attr(nlmeSt, "conLin") <-
    list(Xy = array(c(ZX, w), c(NReal, sum(ncols)), 
	     list(row.names(dataMixShrunk), c(dimnames(ZX)[[2]],
					deparse(form[[2]])))),
	 dims = MEdims(grpShrunk, ncols), logLik = 0)
  ## some groups dimensions
  aGlen <- list(glen = attr(nlmeSt, "conLin")$dims[["ZXlen"]][[1]],
                gstart = attr(nlmeSt, "conLin")$dims$ZXoff[[1]])
  aGlen$maxglen <- max(aGlen$glen)
                
  ## additional attributes of nlmeSt
  attr(nlmeSt, "resp") <- yShrunk
  attr(nlmeSt, "model") <- modelExpression
  attr(nlmeSt, "local") <- nlFrame
  attr(nlmeSt, "N") <- N
  attr(nlmeSt, "NReal") <- NReal
  attr(nlmeSt, "naPat") <- naPat
  ## 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 <- T
  } else decomp <- F

  numIter <- 0				# number of iterations
  attach(controlvals)
  pnlsSettings <- c(pnlsMaxIter, minScale, pnlsTol, 0, 0, 0)
  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)
    aMs <- ms(~-logLik(nlmeSt, nlmePars),
              start = list(nlmePars = c(coef(nlmeSt))),
              control = list(rel.tolerance = msTol, maxiter = msMaxIter,
                scale = msScale), trace = msVerbose)
    aConv <- coef(nlmeSt) <- aMs$parameters
    convIter <- aMs$numIter <- aMs$flags[31]
    aFit <- attr(nlmeSt, "lmeFit") <- MEestimate(nlmeSt, grpShrunk)
    if (verbose) {
      cat("\n**Iteration", numIter)
      cat("\n")
      cat("LME step: Loglik:", format(aFit$logLik),
          ", ms iterations:", aMs$numIter, "\n")
      print(nlmeSt)
    }

    ## PNLS step
    dims <- .C("setup_nonlin",
	       n = integer(3),
	       list(modelExpression),
	       as.integer(nlFrame),
	       NAOK = T)$n
    Factor <- pdMatrix(solve(nlmeSt$reStruct[[1]]), factor = TRUE)
    if (is.null(correlation)) {
      cF <- 1
    } else {
      cF <- corFactor(nlmeSt$corStruct)
    }
    if (is.null(weights)) {
      vW <- 1
    } else {
      vW <- varWeights(nlmeSt$varStruct)
    }
    work <- .C("do_nlme", 
	       thetaPNLS = c(sfix, sran), 
	       as.double(cF),
	       as.double(vW),
	       as.integer(Dims),
	       settings = as.double(pnlsSettings),
	       additional = double(NReal * ( 1 + p + q)),
	       as.double(Factor),
	       as.double(t(solve(Factor))),
	       as.integer(unlist(grps)),
	       as.integer(aGlen$glen),
	       as.integer(aGlen$gstart),
	       as.integer(aGlen$maxglen),
	       as.integer(!is.null(correlation)),
	       as.integer(!is.null(weights)),
	       as.integer(rep(naPat, p + q + 1)),
	       NAOK = T);
    if (verbose) {
      cat("\nPNLS step: RSS = ", format(work$set[6]), "\n fixed effects:")
      for (i in 1:p) cat(format(signif(work$thetaPNLS[i]))," ")
      cat("\n iterations:",work$set[5],"\n")
    }
    oldPars <- c(sfix, oldPars)
    convIter <- max(c(convIter, work$settings[5]))
    aConv <- c(work$thetaPNLS[1:p], aConv)
    sfix[] <- work$thetaPNLS[1:p]
    w <- work$additional[1:NReal]
    ZX[] <- work$additional[-(1:NReal)]
    sran[] <- work$thetaPNLS[-(1:p)]
    w <- w + as.vector((ZX[, 1:q, drop = F] * 
                        t(sran)[as.character(grpShrunk[, 1]),,drop=F]) %*%
                       rep(1,q) + ZX[,-(1:q), drop = F] %*% sfix)
    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(aConv == 0, 1, aConv))
    aConv <- c(max(conv[1:p]))
    names(aConv) <- "fixed"
    conv <- conv[-(1:p)]
    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) <= tolerance) || (convIter == 1)) {
      convResult <- 0
      break
    }
    if(numIter >= maxIter) {
      convResult <- 1
      if(returnObject) {
	warning("Maximum number of iterations reached without convergence")
	break
      } else {
	stop("Maximum number of iterations reached without convergence")
      }
    }
  }
  detach()

  ## wraping up
  if (decomp) {
    aFit <- MEestimate(nlmeSt, grpShrunk, oldConLin)
  } else {
    aFit <- MEestimate(nlmeSt, grpShrunk)
  }

  varFix <- crossprod(aFit$sigma * aFit$varFix)
  dimnames(varFix) <- list(fn, fn)
  ##
  ## fitted.values and residuals (in original order)
  ##
#  Resid <- vector("list", Q + 1)
#  names(Resid) <- c("fixed", names(grps))
#  Resid[[2]] <- resid(nlmeSt)
#  assign("level", 0, frame=nlFrame)
#  Resid[["fixed"]] <- resid(nlmeSt)
#  Resid <- as.data.frame(Resid)
#  row.names(Resid) <- row.names(dataMixShrunk)
#  Fitted <- yShrunk - Resid
  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") <- aFit$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, aFit$sigma, 
		      .relStep = controlvals[[".relStep"]],
		      natural = controlvals[["natural"]])
  } else {
    apVar <- "Approximate variance-covariance matrix not available"
  }
  ## putting sran in the right format (for now - later multiple levels)
  sran <- list(t(sran))
  names(sran) <- names(grps)
  ## getting rid of condensed linear model and fit
  attr(nlmeSt, "conLin") <- NULL
  attr(nlmeSt, "lmeFit") <- NULL
  ##
  ## creating the  nlme object
  ##
  estOut <- list(modelStruct = nlmeSt,
		 dims = dims,
		 coefficients = list(fixed = sfix, random = t(sran)),
		 varFix = varFix,
		 sigma = aFit$sigma,
		 apVar = apVar,
		 logLik = aFit$logLik,
		 numIter = numIter,
		 groups = grpShrunk,
		 call = Call,
		 estMethod = c("ML", "REML")[REML + 1],
		 fitted = Fitted,
		 residuals = Resid,
		 plist = plist,
                 map = list(fixed = fmap, random = rmap))
  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
###

getPars <- function(plist, fmap, rmap, groups, beta, b, level) {
  pars <- array(0, c(length(groups), 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) {
      if (is.logical(r <- plist[[nm]]$random)) {
        if(r) {
          pars[, nm] <- pars[, nm] + b[rmap[[nm]], groups]
        }
      } else {
        if (data.class(r) != "list") {
          pars[,nm] <- pars[,nm] + (r * t(b)[groups, rmap[[nm]], drop = F])%*% 
            rep(1, ncol(r))
        } else {
          for(i in seq(along = rmap[[nm]])) {
            if (is.logical(rr <- r[[i]])) {
              pars[, nm] <- pars[, nm] + b[rmap[[nm]][[i]], groups]
            } else {
              pars[,nm] <- pars[,nm] +
                (rr * t(b)[groups, rmap[[nm]][[i]], drop = F]) %*%
                  rep(1, ncol(rr))
            }
          }
        }
      }
    }
  }
  pars  
}

###
###  Methods for standard generics
###

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


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)
  newdata <- as.data.frame(newdata)
  mfArgs <- list(formula = asOneFormula(formula(object),
                   formula(object$call$fixed),
                   formula(object$modelStruct), naPattern, 
                   omit = c(names(object$plist),".", "pi",
                     deparse(getResponseFormula(object)[[2]]))),
                 data = newdata, na.action = na.action)
  dataMix <- do.call("model.frame", mfArgs)
  newdata <- newdata[row.names(dataMix), , drop = FALSE]
  if (maxQ > 0) {                       # predictions with random effects
    groups <- getGroupsFormula(object)
    if(!all(match(all.vars(groups), names(newdata), 0))) {
      ## groups cannot be evaluated in newdata
      stop("Cannot evaluate groups for desired levels on \"newdata\"")
    }
    grps <- eval(groups[[2]], newdata)
    naGrp <- is.na(match(grps, levels(object$groups[,1])))
    if(all(naGrp)) {
      stop("Cannot calculate group predictions if all groups are NA.")
    } else {
      if(any(naGrp)) {
        oldGrpsNA <- as.character(grps)[naGrp]
	grps[naGrp] <- grps[!naGrp][1]
      }
#      if(any(is.na(match(levels(grps),
#                         levels((object$groups)[,1]))))) {
#	stop("Groups not used in the fit included in \"newdata\".")
#      }	
    }
  } else {
    grps <- rep(1, dim(newdata)[1])
    ran <- NULL
  }
  N <- dim(newdata)[1]
  ##
  ## evaluating the naPattern expression, if any
  ##
  if(is.null(naPattern)) naPat <- rep(T, N)
  else naPat <- as.logical(eval(asOneSidedFormula(naPattern)[[2]], newdata))

  ##
  ## 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]]), fixed[[i]][[3]], sep = "~"),
                 collapse=","),")"))))
    }
  }
  fixed <- val
  fnames <- unlist(lapply(fixed, function(el) deparse(el[[2]])))
  names(fixed) <- fnames
  fix <- fixed.effects(object)
  fn <- names(fix)
  for(nm in fnames) {
    if (!is.logical(plist[[nm]]$fixed)) {
      plist[[nm]]$fixed <- model.matrix(asOneSidedFormula(fixed[[nm]][[3]]),
                                        dataMix)
    }
  }

  if (maxQ > 0) {
    ranForm <- formula(object$modelStruct$reStruct)[[1]]
    rnames <- unlist(lapply(ranForm, function(el) deparse(el[[2]])))
    ran <- random.effects(object)
    rn <- dimnames(ran)[[2]]
    ran <- t(ran)
    for(nm in names(plist)) {
      if (!is.logical(plist[[nm]]$random)) {
        wch <- (1:length(rnames))[regexpr(nm, rnames) != -1]
        if (length(wch) == 1) {         # only one formula for nm
          plist[[nm]]$random <-
            model.matrix(asOneSidedFormula(ranForm[[nm]][[3]]), dataMix)
        } else {                        # multiple formulae
          plist[[nm]]$random <- lapply(ranForm[wch],
                           function(el, data) {
                             model.matrix(asOneSidedFormula(el[[3]]), data)
                           }, data = dataMix)
        }
      }
    }
  }
  nlev <- length(level)
  val <- vector("list", nlev)
  namGrp <- names(object$modelStruct$reStruct)
  names(val) <- c("fixed", namGrp)[level + 1]
  grps <- as.character(grps)
  for(i in 1:nlev) {
    val[[i]] <- eval(formula(object)[[3]], data.frame(dataMix,
                  getPars(plist, object$map$fixed, object$map$random, grps,
                          fix, ran, level[i])))
  }

  if (maxQ > 0 && any(naGrp)) {
    val[[namGrp]][naGrp] <- NA
    grps[naGrp] <- oldGrpsNA
  }
  if (nlev == 1) {
    val <- unlist(val)
    if (maxQ > 0) {                     # only group predictions
      if (asList) {
        val <- split(val, ordered(grps, levels = unique(grps)))
      } else {
        names(val) <- grps
      }
    }
    return(val)
  }
  grps <- data.frame(grps)
  names(grps) <- namGrp
  data.frame(grps, predict = as.data.frame(val))
}

update.nlme <- 
  function(object,
	   fixed, 
	   random = fixed,
	   groups,
	   data = sys.parent(),
	   start, 
           correlation = NULL,
           weights = NULL,
	   subset,
	   REML = FALSE,
	   na.action = na.fail,
	   naPattern, 
	   control = list(),
	   verbose = FALSE)
{
  thisCall <- as.list(match.call())[-(1:2)]
  nextCall <- as.list(object$call)[-1]
  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", frame = loc)
  on.exit(assign("level", oLev, frame = 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], frame = loc, immediate = TRUE)
    val[, i] <- c(eval(attr(object, "model")[[2]],
      local=loc))[1:attr(object, "N")][attr(object, "naPat")]
  }
  val
}

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

### Local Variables:
### mode:S
### S-keep-dump-files: t
### End:
 
### $Id: nlsList.q,v 1.8 1998/06/13 13:18:44 pinheiro Exp $
###
###                  Create a list of nls objects
###
### Copyright 1997, 1998 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

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
  model <- c(substitute(model), names(model))
  model <- model[-length(model)]	# last name is always blank
  form <- formula(data)
  model[2] <- getCovariateFormula(data)[[2]]
  form[[3]] <- as.call(lapply(as.list(model), as.name))
  mCall$model <- as.vector(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)
  if (is.null(grpForm <- getGroupsFormula(model))) {
    if (inherits(data, "groupedData")) {
      if (missing(level)) level <- length(getGroupsFormula(data, asList = T))
      else if (length(level) > 1) {
	stop("Multiple levels not allowed")
      }
      groups <- pruneLevels(getGroups(data, level = level))
      grpForm <- c(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))
  }
  controlvals <- nls.control()
  if(!missing(control)) {
    controlvals[names(control)] <- control
  }
  val <- lapply(split(data, groups),
		function(dat, formula, start, control, first = T)
		{
		  restart(first)
		  if(first) {
		    first <- F
		    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.30 1998/06/29 18:27:50 bates Exp $
###
###              Classes of positive-definite matrices
###
### Copyright 1997, 1998 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.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) <- dimnames(Var)[[2]]
  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.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 (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]]), 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(w1 <- is.na(match(nam, namesForm))) |
            any(w2 <- is.na(match(namesForm, nam)))) {
          err <- FALSE
          ## checking nlme case
          if (any(w1)) {
            nam1 <- nam
            nm1 <- nam[w1]              # unmatched names
            wch1 <- regexpr("Intercept", nm1) != -1
            if (sum(wch1) != length(nm1)) {
              err <- TRUE
            } else {
              nm1 <- substring(nm1, 1, nchar(nm1) - 12)
              if (any(is.na(match(nm1, namesForm)))) err <- TRUE
            }
          }
          if (any(w2)) {
            nf1 <- namesForm
            nf1[w2] <- paste(nf1[w2], "(Intercept)", sep = ".")
            if (any(is.na(match(nf1, nam)))) srr <- TRUE
          }
          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 (any(w1 <- is.na(match(value, dn))) |
	any(w2 <- is.na(match(dn, value)))) {
      err <- FALSE
      ## checking nlme case
      if (any(w1)) {
        nam1 <- value
        nm1 <- nam1[w1]                 # non-matching names
        wch1 <- regexpr("Intercept", nm1) != -1
        if (sum(wch1) != length(nm1)) {
          err <- TRUE
        } else {
          nm1 <- substring(nm1, 1, nchar(nm1) - 12)
          if (any(is.na(match(nm1, dn)))) err <- TRUE
        }
      }
      if (any(w2)) {
        nf1 <- dn
        nf1[w2] <- paste(nf1[w2], "(Intercept)", sep = ".")
        if (any(is.na(match(nf1, value)))) srr <- TRUE
      }
      if (err) {
        stop(paste("Names being assigned do not correspond to a permutation",
                   "of previous names", sep = "\n"))
      }
    }
    if (all(value == dn)) {
      return(object)
    }
    ## must be a permutation of names
    attr(object, "Dimnames") <- list(value, value)
    if (isInitialized(object)) {	       
      return(pdConstruct(object, as.matrix(object)))
    }
    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, frame = 1)
  assign(".angles", seq(-pi, pi, length = nseg + 1), frame = 1)
  assign(".cosines", cos(.angles), frame = 1)
  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 <- formula(x)))) {
      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(dimnames(x)[[2]])) {
          xx[1, -1] <- abbreviate(dimnames(x)[[2]][ -p ], minlength = rdig + 3)
        }
        if (resid) {
          x <- array("", dim(xx) + c(1, 0),
                     list(c(dimnames(xx)[[1]], "Residual"), dimnames(xx)[[2]]))
          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, drop = FALSE, 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.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.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 %*% (2*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))$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.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.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))$Factor
}

####* 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.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.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) <- class(object)
    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.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.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) <- class(object)
    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 c("std. dev" = exp(as.vector(object)))
}

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.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.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
### Attribute "A" is no longer used?
#    aux <- model.matrix(~C(as.factor(1:nc), helmert), list(nc = nc))
#    attr(value, "A") <- 1/sqrt(apply(aux, 2, function(x) sum(x^2))) * t(aux)
    class(value) <- class(object)
    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
#    aux <- model.matrix(~C(as.factor(1:nc), helmert), list(nc = nc))
#    attr(val, "A") <- 1/sqrt(apply(aux, 2, function(x) sum(x^2))) * t(aux)
  }
  val
}

pdFactor.pdCompSymm <-
  function(object)
{
  Ncol <- attr(object, "ncol")
  .C("compSymm_pd", 
     Factor = double(Ncol * Ncol),
     as.integer(Ncol),
     as.double(object))$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",
		 "unitialized 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.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) <- dimnames(value)[[2]]
  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.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(form)
    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)
  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]]))
        }
      } else {
        if (inherits(frm, "formula")) {
          nm <- Names(getCovariateFormula(frm))
        } else {                        # listForm
          nm <- unique(unlist(lapply(frm,
                                     function(el) {
                                       Names(getCovariateFormula(el))
                                     })))
        }
      }
    }
    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 (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 <- dimnames(value)[[1]])) {
    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 <- dimnames(val)[[2]]
    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.27 1998/07/02 21:43:49 bates Exp $
###
###      Methods for the class of random-effects structures.
###
### Copyright 1997, 1998 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.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 {
      object <- rep( list(getCovariateFormula(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
    if (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 {
                 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[!is.na(match(pC, 
#      c("pdChol","pdLogChol","pdMatrixLog","pdSpher","pdGivens")))] <- "pdSymm"
  pC <- match(pC, c("pdSymm", "pdDiag", "pdIdent", "pdCompSymm")) - 1
  pC[is.na(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")
  }
  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")
  }
  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)
{
  lapply(object, formula, asList)
}

getGroupsFormula.reStruct <-
  function(object, asList = FALSE)
{
  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 * sqrt(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))$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, contrasts = 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)
  }
  any2list <- function( object, data, contrasts ) {
    form2list <- function(form, data, contrasts) {
      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),
                                         contrasts)))
    }
    if (inherits( object, "formula" )) {
      return( form2list( object, data, contrasts ) )
    }
    if (is.list( object ) ) {
      return( unlist(lapply(object, form2list, data = data, contrasts = contrasts),
                     recursive = FALSE ) )
    }
    return( NULL)
  }
  value <- lapply(form, any2list,
                  data = data, contrasts = contrasts)
  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 = ".")
  }
  structure(matrix(unlist(value), nrow = nrow(data),
                   dimnames = list(row.names(data), nams)),
            class = "matrix",
            ncols = ncols, nams = lapply(value, names),
            contr = contrasts)
}

Names.reStruct <-
  function(object)
{
  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)] <- ""
    names(x) <- 
      apply(aux, 1, function(x) paste(x[x != ""], collapse = " %in% "))
    x[] <- rev(x)
    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: selfStart.q,v 1.1.1.1 1996/11/13 15:38:45 bates Exp $
 # Major classes, their constructors, and methods for standard generics
##*## selfStart - self-starting nonlinear regression models

getInitial <- 
  ## Create initial values for object from data
  function(object, data, ...) UseMethod("getInitial")

getInitial.formula <-
  function(object, data, ...)
{
  if(!is.null(attr(data, "parameters"))) {
    return(attr(data, "parameters"))
  }
  obj <- object				# kluge to create a copy inside this
  obj[[1]] <- as.name("~")		# function.match.call() is misbehaving
  switch (length(obj),
	  stop("argument \"object\" has an impossible length"),
	  {				# one-sided formula
	    func <- get(obj[[2]][[1]])
	    getInitial(func, data,
		       mCall = match.call(func, call = obj[[2]]))
	  },
	  {				# two-sided formula
	    func <- get(obj[[3]][[1]])
	    getInitial(func, data,
		       mCall = match.call(func, call = obj[[3]]),
		       LHS = obj[[2]])
	  })
}

getInitial.selfStart <-
  function(object, data, mCall, LHS = NULL)
{
  (attr(object, "initial"))(mCall = mCall, data = data, LHS = LHS)
}

nls <-
  function(formula, data = sys.parent(),
	   start = getInitial(formula, data),
	   control, 
	   algorithm = "default",
	   trace = F)
{
  convert.twiddle <- function(formula)
    {
      if(length(formula) < 3)
	return(formula)
      form <- call("~", call("-", formula[[2]], formula[[3]]))
      attr(form, "class") <- "formula"
      form
    }
  if(is.numeric(data))
    data <- sys.frame(data)
  cl <- class(data)
  if(inherits(data, "pframe")) {
    class(data) <- NULL
    pp <- parameters(data)
    if(length(pp)) {
      np <- names(pp)
      if(any(match(np, names(data), 0)))
	stop(
	     "can't have variables, parameters with same name"
	     )
      data[np] <- pp
    }
  }
  else if(inherits(data, "data.frame"))
    cl <- c("pframe", cl)
  class(data) <- NULL	
  ## First, figure out the par. names, make start a list
  switch(mode(start),
	 numeric = {
	   .parameters <- names(start)
	   start <- as.list(start)
	   names(start) <- .parameters
	 }
	 ,
	 list = {
	   .parameters <- names(start)
	 }
	 ,
	 NULL = .parameters <- parameter.names(formula, data),
	 stop("\"start\" should be numeric or list"))
  if(!length(.parameters))
    stop("names for parameters needed, from formula or from start")
  pn <- .parameters
  .expr <- formula	
  ## select the algorithm and possibly massage the formula
  if(length(start)) data[.parameters] <- start	#used by setup_nonlin
  data$.parameters <- .parameters
  nl.frame <- new.frame(data, F)
  frame.attr("class", nl.frame) <- cl	# in case data is returned
  formula <- switch(algorithm,
		    plinear = {
		      if(length(formula) < 3)
			stop(
			     "formula for plinear algorithm be of the form resp ~ array"
			     )
		      response <- eval(formula[[2]], nl.frame)
		      design <- eval(formula[[3]], nl.frame)
		      nnobs <- length(response)
		      nlinear <- if(is.matrix(design)) dim(design)[2] else 
		      length(design)/nnobs
		      form <- call("~", formula[[3]])
		      attr(form, "class") <- "formula"
		      form
		    }
		    ,
		    default = convert.twiddle(formula))
  dims <- .C("setup_nonlin",
	     n = integer(3),
	     list(formula),
	     as.integer(nl.frame))$n
  npar <- dims[1]
  nderiv <- dims[2]
  nobs <- dims[3]
  resp <- eval(.expr[[2]], nl.frame)
  if(length(.expr) == 2) resp[] <- 0	
  ## setup_nonlin will have set .parameters if missing
  if(is.null(start)) {
    start <- list()
    if(is.null(names(start)) && length(start) == length(pn))
      names(start) <- pn
    for(i in .parameters)
      start[[i]] <- get(i, frame = nl.frame)
  }
  asgn <- start
  si <- 1
  for(i in 1:length(asgn)) {
    ni <- length(asgn[[i]])
    asgn[[i]] <- seq(from = si, length = ni)
    si <- si + ni
  }
  start <- unlist(start)
  controlvals <- nls.control()
  if(!missing(control))
    controlvals[names(control)] <- control
  ret.data <- is.logical(ret.data <- controlvals$data) && ret.data
  max.iterations <- if(is.null(controlvals$maxiter)) 50 * npar else 
  controlvals$maxiter
  settings <- c(0, max.iterations, controlvals$minscale, controlvals$
		tolerance, 0)
  if(algorithm == "plinear") {
    settings[1] <- 1
    dims <- c(dims, nlinear)
    start <- c(start, numeric(nlinear))
    pn <- c(pn, paste(".lin", 1:nlinear, sep = ""))
    dims[3] <- nnobs
    outmat <- array(c(response, numeric(nnobs * (npar + nlinear))), 
		    c(nnobs, npar + nlinear + 1))
  }
  else outmat <- array(0, c(nobs, npar + 1))
  storage.mode(outmat) <- "double"
  storage.mode(start) <- "double"
  nls.trace <- if(missing(trace)) controlvals$trace else trace
  std.trace <- FALSE
  if(is.logical(nls.trace)) {
    if(std.trace <- nls.trace)
      nls.trace <- "trace.nls"
    else nls.trace <- NULL
  }
  else std.trace <- is.character(nls.trace) && nls.trace == "trace.nls"
  if(std.trace) {
    assign("trace.mat",
	   array(0, c(max.iterations, npar + 2),
		 list(NULL, c("obj.", "conv.", paste("par", 1:npar)))),
	   frame = 1)
    assign("trace.expr", expression(trace.mat[last.iteration,  ] <- it.row),
	   frame = 1)
  }
  z <- .C("do_nls",
	  parameters = start,
	  dims = as.integer(dims),
	  control = as.double(settings),
	  outmat = outmat,
	  trace = list(nls.trace))
  if(sum(abs(z$outmat[, 1])) == 0) {
					# converged to zero residuals
    z$control[5] <- F
  }
  if(z$control[5])
    stop(switch(as.integer(z$control[5]),
		"step factor reduced below minimum",
		"maximum number of iterations exceeded",
		"singular gradient matrix",
		"singular design matrix",
		"singular gradient matrix"))
  nls.out <- list(parameters = z$parameters, formula = .expr, call = 
		  match.call(), residuals = z$outmat[, 1])
  if(algorithm == "plinear") {
    class(nls.out) <- c("nls.pl", "nls")
    R <- qr(z$outmat[, -1])$qr[1:(npar + nlinear),  , drop = F]
  }
  else {
    class(nls.out) <- "nls"
    R <- qr(z$outmat[, -1])$qr[1:npar,  , drop = F]
  }
  R[lower.tri(R)] <- 0
  nls.out$R <- R
  nls.out$fitted.values <- resp - nls.out$residuals
  nls.out$assign <- asgn
  if(ret.data) {
    data <- sys.frame(nl.frame)
    data$.parameters <- NULL	
    ## dbdetach does the right thing--only matters that nl.frame>1
    if(inherits(data, "pframe"))
      data <- dbdetach(data, nl.frame)
    nls.out$data <- data
  }
  if(std.trace && exists("last.iteration", frame = 1))
    nls.out$trace <- get("trace.mat", frame = 1)[1:get(
					  "last.iteration", frame = 1),  ]
  nls.out
}

selfStart <- 
  ## Constructor for the selfStart class of objects
  function(model, initial, parameters, template) UseMethod("selfStart")

selfStart.default <-
  function(model, initial, parameters, template)
{
  structure(as.function(model), initial = as.function(initial),
	    class = "selfStart")
}

selfStart.formula <-
  function(model, initial, parameters, template = NULL)
{
  if (is.null(template)) {		# create a template if not given
    nm <- all.vars(model)
    if (any(msng <- is.na(match(parameters, nm)))) {
      stop(paste("Parameter(s)", parameters[msng],
		 "do not occur in the model formula"))
    }
    template <-
      as.function(c(structure(lapply(vector("list", length(nm)),
				     function(el) vector("missing")),
			      names = c(nm[is.na(match(nm, parameters))],
				  parameters)), list(vector("{"))))
  }
  structure(deriv(model, parameters, template),
	    initial = initial,
	    class = "selfStart")
}

sortedXyData <-
  ## Constructor of the sortedXyData class
  function(x, y, data) UseMethod("sortedXyData")

sortedXyData.default <-
  function(x, y, data)
{
  ## works for x and y either numeric or language elements
  ## that can be evaluated in data
  if (is.language(x)) {
    x <- eval(asOneSidedFormula(x)[[2]], data)
  }
  x <- as.numeric(x)
  if (is.language(y)) {
    y <- eval(asOneSidedFormula(y)[[2]], data)
  }
  y <- as.numeric(y)
  y.avg <- tapply(y, x, mean) 
  xvals <- as.numeric(names(y.avg))
  ord <- order(xvals)
  structure(na.omit(data.frame(x = xvals[ord], y = as.vector(y.avg[ord]))),
	    class = c("sortedXyData", "data.frame"))
}

NLSstClosestX <-
  ## find the x value in the xy frame whose y value is closest to yval
  function(xy, yval) UseMethod("NLSstClosestX")

NLSstClosestX.sortedXyData <-
  ## find the x value in the xy frame whose y value is closest to yval
  function(xy, yval)
{
  deviations <- abs(xy$y - yval)
  xy$x[match(min(deviations), deviations)]
}

NLSstRtAsymptote <-
  ## Find a reasonable value for the right asymptote.
  function(xy) UseMethod("NLSstRtAsymptote")

NLSstRtAsymptote.sortedXyData <-
  function(xy)
{
  ## Is the last response value closest to the minimum or to
  ## the maximum?
  in.range <- range(xy$y)
  last.dif <- abs(in.range - xy$y[nrow(xy)])
  ## Estimate the asymptote as the largest (smallest) response
  ## value plus (minus) 1/8 of the range. 
  if(match(min(last.dif), last.dif) == 2) {
    return(in.range[2] + diff(in.range)/8)
  }
  in.range[1] - diff(in.range)/8
}

NLSstLfAsymptote <-
  ## Find a reasonable value for the left asymptote.
  function(xy) UseMethod("NLSstLfAsymptote")

NLSstLfAsymptote.sortedXyData <-
  function(xy)
{
  ## Is the first response value closest to the minimum or to
  ## the maximum?
  in.range <- range(xy$y)
  first.dif <- abs(in.range - xy$y[1])
  ## Estimate the asymptote as the largest (smallest) response
  ## value plus (minus) 1/8 of the range. 
  if(match(min(first.dif), first.dif) == 2) {
    return(in.range[2] + diff(in.range)/8)
  }
  in.range[1] - diff(in.range)/8
}

NLSstAsymptotic <-
  ## fit the asymptotic regression model in the form
  ## b0 + b1*exp(-exp(lrc) * x)
  function(xy) UseMethod("NLSstAsymptotic")

NLSstAsymptotic.sortedXyData <-
  function(xy)
{
  xy$rt <- NLSstRtAsymptote(xy)
  ## Initial estimate of log(rate constant) from a linear regression
  structure(coef(nls(y ~ cbind(1, 1 - exp(-exp(lrc) * x)),
		     data = xy,
		     start = list(lrc =
			 as.vector(log(-coef(lm(log(abs(y - rt)) ~ x,
						data = xy))[2]))),
		     algorithm = "plinear"))[c(2, 3, 1)],
	    names = c("b0", "b1", "lrc"))
}
			     
### 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]\\|####\\*"
### End:
### $Id: simulate.q,v 1.2 1998/06/30 22:04:57 bates Exp $
###
###            Fit a general linear mixed effects model
###
### Copyright 1997, 1998 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.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] <- 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(dimnames(Z)[[2]], dimnames(X)[[2]], deparse(fixed[[2]])))),
       dims = MEdims(grps, ncols), logLik = 0)
}

"simulate.lme"<-
  function(m1, m2, Random.seed, nsim = 1000, sigma, niterEM = c(40, 200))
  ## m1 is a list of arguments to lme to define the null model
  ## m2 is an option list of arguments to lme to define the feared model
{
  if (missing(Random.seed)) {
    aux <- rnorm(1)			# DMB using "aux" to confuse everyone :-)
    Random.seed <- .Random.seed
  }
  assign(".Random.seed", Random.seed, where = 1)
  m1 <- as.list(match.call(lme, substitute(m1))[ -1 ])
  fits <- list(null = do.call("lme", m1))
  condL <- list(null = do.call("createConLin", m1))
  ycol <- list(null = ncol(condL$null$Xy))
  storage.mode(condL$null$Xy) <- "double" # just in case
  pdims <- list(null = as.integer(unlist(condL$null$dims)))
  DeltaInv <- lapply(fits$null$modelStruct$reStruct, pdMatrix, factor = TRUE )
  Delta <- list(null = lapply(DeltaInv, solve))
  delt <- list(null = as.double(unlist(Delta$null)))
  ldelt <- list(null = length(delt$null))
  value <- list(null = list(ML = array(double(nsim * (ldelt$null + 4)),
			      c(nsim, ldelt$null + 4),
			      list(NULL,
				   c("cvrg", "info", "logLik", "lRlen",
				     paste("delta", 1:(ldelt$null), sep = ""))))))
  value$null$REML <- value$null$ML
  attr(value, "call") <- match.call()
  attr(value, "Random.seed") <- Random.seed
  ALT <- FALSE
  if (!missing(m2)) {
    m2 <- as.list(match.call(lme, substitute(m2))[-1])
    ALT <- TRUE
    aux <- m1
    aux[names(m2)] <- m2
    fits[["alt"]] <- do.call("lme", aux)
    condL[["alt"]] <- do.call("createConLin", aux)
    storage.mode(condL$alt$Xy) <- "double"
    pdims$alt <- as.integer(unlist(condL$alt$dims))
    DeltaInv <- lapply(fits$alt$modelStruct$reStruct, pdMatrix, factor = TRUE )
    Delta$alt <- lapply(DeltaInv, solve)
    delt$alt <- as.double(unlist(Delta$alt))
    ldelt$alt <- length(delt$alt)
    ycol$alt <- ncol(condL$alt$Xy)
    value$alt <- list(ML = array(double(nsim * (ldelt$alt + 4)),
			c(nsim, ldelt$alt + 4),
			list(NULL,
			     c("cvrg", "info", "logLik", "lRlen",
			       paste("delta", 1:(ldelt$alt), sep = "")))))
    value$alt$REML <- value$alt$ML
  }
  nullD <- condL$null$dims
  base <-				# form the base response from fixed effects
   matrix(condL$null$Xy[nullD$ZXoff$X +
			1:(nullD$ZXlen$X * nullD$ncol[nullD$Q + 1])],
	  nrow = nullD$N) %*% fits$null$coefficients$fixed
  N <- nullD$N
  if (any(nullD$qvec > 1)) {
    stop("only handling the case of variance components now")
  }
  if (nullD$Q > 1) {
    stop("only handling one level of random effects now")
  }
  ngrp <- nullD$ngrps[1]
  if (missing(sigma)) sigma <- fits$null$sigma
  sdgrp <- sigma/delt$null
  ind <- rep(1:ngrp, nullD$ZXlen[[1]])
  for (i in 1:nsim) {
    if (ALT) {
      condL$alt$Xy[, ycol$alt] <- condL$null$Xy[, ycol$null] <-
	base + rnorm(N, sd = sigma) +
	  rnorm(ngrp, sd = sdgrp)[ind] * condL$null$Xy[, 1]
    } else {
      condL$null$Xy[, ycol$null] <-
	base + rnorm(N, sd = sigma) +
	  rnorm(ngrp, sd = sdgrp)[ind] * condL$null$Xy[, 1]
    }
    value$null$ML[i, ] <-
      unlist(.C("mixed_combined",
		ZXy = condL$null$Xy,
		pdims = pdims$null,
		DmHalf = double(sum(condL$null$dims$q^2)),
		nIter = as.integer( niterEM[1] ),
		pdClass = as.integer( 0 ),
		RML = as.integer( FALSE ),
		logLik = double(1),
		Ra = double(length(delt$null)),
		lRlen = double(1),
                cvrg = double(1),
                info = integer(1))[c("cvrg", "info", "logLik", "lRlen", "DmHalf")])
    value$null$REML[i, ] <-
      unlist(.C("mixed_combined",
		ZXy = condL$null$Xy,
		pdims = pdims$null,
		DmHalf = double(sum(condL$null$dims$q^2)),
		nIter = as.integer( niterEM[1] ),
		pdClass = as.integer( 0 ),
		RML = as.integer( TRUE ),
		logLik = double(1),
		Ra = double(length(delt$null)),
		lRlen = double(1),
                cvrg = double(1),
                info = integer(1))[c("cvrg", "info", "logLik", "lRlen", "DmHalf")])
    if (ALT) {
      value$alt$ML[i, ] <-
	unlist(.C("mixed_combined",
		  ZXy = condL$alt$Xy,
		  pdims = pdims$alt,
		  DmHalf = double(sum(condL$alt$dims$q^2)),
		  nIter = as.integer( niterEM[2] ),
		  pdClass = as.integer( 0 ),
		  RML = as.integer( FALSE ),
		  logLik = double(1),
		  Ra = double(length(delt$alt)),
		  lRlen = double(1),
                  cvrg = double(1),
                  info = integer(1))[
                    c("cvrg", "info", "logLik", "lRlen", "DmHalf")])
      value$alt$REML[i, ] <-
	unlist(.C("mixed_combined",
		  ZXy = condL$alt$Xy,
		  pdims = pdims$alt,
		  DmHalf = double(sum(condL$alt$dims$q^2)),
		  nIter = as.integer( niterEM[2] ),
		  pdClass = as.integer( 0 ),
		  RML = as.integer( TRUE ),
		  logLik = double(1),
		  Ra = double(length(delt$alt)),
		  lRlen = double(1),
                  cvrg = double(1),
                  info = integer(1))[
                    c("cvrg", "info", "logLik", "lRlen", "DmHalf")])
    }
  }
  attr(value$null, "dims") <- condL$null$dims
  if (ALT) {
    attr(value$alt, "dims") <- condL$alt$dims
  }
  class(value) <- "simulate.lme"
  value
}

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

plot.simulate.lme <-
  function(x, ...)
{
  dots <- list(...)
  df <- as.list(dots$df)
  okML <- x$null$ML[, "info"] < 8 & x$alt$ML[, "info"]
  MLstat <- sort(2 * (x$alt$ML[okML, "logLik"] - x$null$ML[okML, "logLik"]))
  MLy <- unlist(lapply(df, function(df, x) pchisq(x, df), x = MLstat))
  MLdf <- rep(unlist(df), rep(length(MLstat), length(df)))
  MLx <- rep((1:length(MLstat) - 0.5)/length(MLstat), length(df))
  okREML <- x$null$REML[, "info"] < 8 & x$alt$REML[, "info"]
  REMLstat <- sort(2*(x$alt$REML[okREML, "logLik"] - x$null$REML[okREML, "logLik"]))
  REMLy <- unlist(lapply(df, function(df, x) pchisq(x, df), x = REMLstat))
  REMLdf <- rep(unlist(df), rep(length(REMLstat), length(df)))
  REMLx <- rep((1:length(REMLstat) - 0.5)/length(REMLstat), length(df))
  frm <- data.frame(x = c(MLx, REMLx), y = c(MLy, REMLy),
		    df = as.factor(c(MLdf, REMLdf)),
		    method = as.factor(rep(c("ML","REML"),
		      c(length(MLy), length(REMLy)))))
  xyplot(y ~ x | df * method, data = frm,
	 panel = function(x, y) { panel.grid();
				  panel.xyplot(x, y, type = "l")
				  panel.abline(0,1) },
	 strip = function(...) strip.default(..., style = 1),
	 xlab = "Theoretical quantiles", ylab = "Observed quantiles")
}
  
## Local Variables:
## mode:S
## End:
### $Id: varFunc.q,v 1.12 1998/06/29 18:34:46 bates Exp $
##*## End of prologue
 # Major classes, their constructors, and methods for standard generics

##*## 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 unitialized object")
  }
  if (unconstrained) {
    if (allCoef) {
      val <- double(length(wPar))
      val[wPar] <- attr(object, "fixed")
      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) attr(object, "formula")

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

getGroups.varFunc <-
  function(object) 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, ...)
{
  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 {
    cat("Variance function structure of class", class(x)[1],
	"with no parameters, or unitilialized\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 unitilialized\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
  class(object) <- c("summary.varFunc", class(object))
  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") <- F
  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.name(formula(x))),"\n"))
}

summary.varFixed <-
  function(object, structName)
{
  class(object) <- c("summary.varFixed", class(object))
  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.")
      }
    } else grpNames <- NULL
    attr(value, "groupNames") <- grpNames
    attr(value, "formula") <- asOneSidedFormula(form)
    if (!is.null(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)
      }
    }
  }
  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))
    }
    aux <- double(length(wPar))
    aux[wPar] <- attr(object, "fixed")
    aux[!wPar] <- as.vector(object)
    if (!unconstrained) {
      aux <- c(1, exp(aux))
      names(aux) <- attr(object, "groupNames")
      if (!allCoef) {
	aux <- aux[c(FALSE, !attr(object, "whichFix"))]
      }
    }
    aux
  } 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 unitialized varIdent object")
#    }
    if (length(value) != nGroups - 1) {
      stop(paste("Cannot change the length of the varIdent", 
		 "parameter after initialization"))
    }
    object[] <- value
    natPar <- coef(object, F, 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(getGroupsFormula(form))) {
    strat <- attr(object, "groups") <- 
      as.character(getGroups(data, form))
    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(1, 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
	}
      }
      object[] <- log(object[])		# unconstrained parametrization
    } 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) F

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(fix))) {
	stop("Fixed parameters must have group names in varPower")
      }
    }
    attr(value, "groupNames") <- c(grpNames, names(fix))
  } 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) ||
      is.null(wPar <- attr(object, "whichFix"))) {
    ## uninitialized
    return(numeric(0))
  }
  aux <- double(length(wPar))
  if (any(wPar)) { aux[wPar] <- attr(object, "fixed") }
  if (any(!wPar)) { aux[!wPar] <- as.vector(object) }
  if (!is.null(getGroupsFormula(object))) {
    ##different values per group
    names(aux) <- attr(object, "groupNames")
  } else {
    names(aux) <- "power"
  }
  if (!allCoef) {
    aux <- aux[!wPar]
  }
  aux
}

"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, F, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(object))) {
      aux <- aux[grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- abs(getCovariate(object))^(-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") <- F
    attr(object, "covariate") <- getCovariate(data, form)
  } else {
    attr(object, "needUpdate") <- T
  }
  if (!is.null(getGroupsFormula(form))) { 
    strat <- as.character(getGroups(data, form))
    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
	}
      }
      return(NextMethod())
    }
  }
  ## 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.")
    }
  }
  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, F, 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(fix))) {
	stop("Fixed parameters must have groups names in varPower")
      }
    }
    attr(value, "groupNames") <- c(grpNames, names(fix))
  } 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) ||
      is.null( wPar <- attr(object, "whichFix"))) {
    return(numeric(0))
  }
  aux <- double(length(wPar))
  aux[wPar] <- attr(object, "fixed")
  aux[!wPar] <- as.vector(object)
  if (!is.null(getGroupsFormula(object))) {
    ##different values per group
    names(aux) <- attr(object, "groupNames")
  } else {
    names(aux) <- "expon"
  }
  if (!allCoef) {
    aux <- aux[!wPar]
  }
  aux
}

"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, F, allCoef = TRUE)
    if (!is.null(grps <- getGroups(object))) {
      aux <- aux[grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <- exp(-aux*abs(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(getGroupsFormula(form))) { 
    strat <- as.character(getGroups(data, form))
    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
	}
      }	  
      return(NextMethod())
    }
  }
  ## 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.")
    }
  }
  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, F, allCoef = TRUE) 
    if (!is.null(grps <- getGroups(val))) {
      aux <- aux[grps]
    }
    attr(val, "logLik") <-
      sum(log(attr(val, "weights") <- exp(-aux*abs(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")
  cwPar <- c(wPar)
  if (is.null(wPar) ||
      (length(unlist(object)) != (length(cwPar) - sum(cwPar)))) {
    ## unitialized
    return(numeric(0))
  }
  aux <- array(0, dim(wPar), dimnames(wPar))
  for (i in names(object)) {
    aux[i, wPar[i,]] <- attr(object[[i]], "fixed")
    aux[i, !wPar[i,]] <- c(object[[i]])
  }
  if (!unconstrained) {
    aux[1,] <- exp(aux[1,])
  }
  if (!allCoef) {
    aux <- list(const = if (!all(wPar[1,])) aux[1,!wPar[1,]] else NULL,
		power = if (!all(wPar[2,])) aux[2,!wPar[2,]] else NULL)
    aux <- unlist(aux[!unlist(lapply(aux, is.null))])
  } else {
    aux <- aux[, 1:ncol(aux)]
  }
  aux
}

"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, F, allCoef = TRUE))
    if (!is.null(grps <- getGroups(object))) {
      natPar <- natPar[, grps]
    }
    attr(object, "logLik") <-
      sum(log(attr(object, "weights") <-
	      1/sqrt(natPar[1,] + abs(getCovariate(object))^(2*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") <- F
    attr(object, "covariate") <- getCovariate(data, form)
  } else {
    attr(object, "needUpdate") <- T
  }
  dfltCoef <- c(const = log(0.1), power = 0)
  if (!is.null(getGroupsFormula(form))) {
    strat <- as.character(getGroups(data, form))
    uStrat <- unique(strat)
    whichFix <- array(F, 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, F, allCoef = TRUE))
    if (!is.null(grps <- getGroups(val))) {
      aux <- aux[, grps]
    }
    attr(val, "logLik") <-
      sum(log(attr(val, "weights") <-
	      1/sqrt(aux[1,] + abs(getCovariate(val))^(2*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) 
{
  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, F)
}

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.4 1998/06/13 13:18:48 pinheiro Exp $
###
###   Miscellaneous methods that must be defined last in the library
###
### Copyright 1997, 1998 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
qqnorm.nls <- qqnorm.gls <- qqnorm.lme

plot.nls <- plot.lme
### Force loading of the lme dynamic library in R
### and patch up a few little problems

is.R <- function() { ## returns  'TRUE'  iff we are using 'R'
  exists("version") && !is.null(vl <- version$language) && vl == "R"
}

is.S <- function() !is.R()

coef <- function(x, ...) UseMethod("coef")
fitted <- function(x, ...) UseMethod("fitted")

solve <- function(a, b, ...) UseMethod("solve")
solve.default <- function (a, b, tol = 1e-07) 
{
  if (!is.qr(a)) 
    a <- qr(a, tol = tol)
  nc <- ncol(a$qr)
  if (a$rank != nc) 
    stop("singular matrix 'a' in solve")
  if (missing(b)) {
    if (nc != nrow(a$qr)) 
      stop("only square matrices can be inverted")
    b <- diag(1, nc)
  }
  b <- as.matrix(b)
  return(qr.coef(a, b))
}

formula.default <- function (x) 
{
  if (!is.null(x$formula)) 
    return(eval(x$formula))
  if (!is.null(x$call$formula)) 
    return(eval(x$call$formula))
  if (!is.null(x$terms)) 
    return(x$terms)
  if (!is.null(attr(x, "formula")))
    return(attr(x, "formula"))
  switch(mode(x), NULL = structure(NULL, class = "formula"), 
         character = formula(eval(parse(text = x)[[1]])), 
         call = eval(x), stop("invalid formula"))
}

zapsmall <-
  ## forces small values to 0, for the sake of printing
  function(x, digits = .Options$digits)
{
	x.ok <- x[!is.na(x)]
	if(length(x.ok) == 0)
		return(x)
	m <- max(abs(x.ok))
	if(m > 0)
		digits <- max(digits - log10(m), 0)
	round(x, digits)
}

library.dynam("lme")
provide("lme")
