mkdata.Gamma <- ## Make pseudo data for gamma regression
function(y,eta,wt,offset) {
  if (is.null(wt)) wt <- rep(1,length(y))
  if (is.null(offset)) offset <- rep(0,length(y))
  if (min(y)<=0)
    stop("gss error: gamma responses should be positive")
  mu <- exp(eta)
  u <- 1-y/mu
  w <- y/mu
  ywk <- eta-u/w-offset
  wt <- w*wt
  list(ywk=ywk,wt=wt)
}

dev.resid.Gamma <- ## Calculate the deviance residuals of gamma fit
function(y,eta,wt) {
  if (is.null(wt)) wt <- rep(1,length(y))
  mu <- exp(eta)
  as.vector(2*wt*(-log(y/mu)+(y-mu)/mu))
}

dev.null.Gamma <-
function(y,wt,offset) {
  if (is.null(wt)) wt <- rep(1,length(y))
  mu <- sum(wt*y)/sum(wt)
  if (!is.null(offset)) {
    eta <- log(mu)-mean(offset)
    repeat {
      mu <- exp(eta+offset)
      u <- 1-y/mu
      w <- y/mu
      eta.new <- eta-sum(wt*u)/sum(wt*w)
      if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break
      eta <- eta.new    
    }
  }
  sum(2*wt*(-log(y/mu)+(y-mu)/mu))
}
mkdata.binomial <- ## Make pseudo data for logistic regression
function(y,eta,wt,offset) {
  if (is.vector(y)) y <- as.matrix(y)
  if (is.null(wt)) wt <- rep(1,dim(y)[1])
  if (is.null(offset)) offset <- rep(0,dim(y)[1])
  if (dim(y)[2]==1) {
    if ((max(y)>1)|(min(y)<0))
      stop("gss error: binomial responses should be between 0 and 1")
  }
  else {
    if (min(y)<0)
      stop("gss error: paired binomial response should be nonnegative")
    wt <- wt * (y[,1]+y[,2])
    y <- y[,1]/(y[,1]+y[,2])
  }
  p <- 1-1/(1+exp(eta))
  u <- p - y
  w <- p*(1-p)
  ywk <- eta-u/w-offset
  wt <- w*wt
  list(ywk=ywk,wt=wt)
}

dev.resid.binomial <- ## Calculate the deviance residuals of logistic fit
function(y,eta,wt) {
  if (is.vector(y)) y <- as.matrix(y)
  if (is.null(wt)) wt <- rep(1,dim(y)[1])
  if (dim(y)[2]>1) {
    wt <- wt * (y[,1]+y[,2])
    y <- y[,1]/(y[,1]+y[,2])
  }
  p <- 1-1/(1+exp(eta))
  as.vector(2*wt*(y*log(ifelse(y==0,1,y/p))
                  +(1-y)*log(ifelse(y==1,1,(1-y)/(1-p)))))
}

dev.null.binomial <-
function(y,wt,offset) {
  if (is.vector(y)) y <- as.matrix(y)
  if (is.null(wt)) wt <- rep(1,dim(y)[1])
  if (dim(y)[2]>1) {
    wt <- wt * (y[,1]+y[,2])
    y <- y[,1]/(y[,1]+y[,2])
  }
  p <- sum(wt*y)/sum(wt)
  if (!is.null(offset)) {
    eta <- log(p/(1-p)) - mean(offset)
    repeat {
      p <- 1-1/(1+exp(eta+offset))
      u <- p - y
      w <- p*(1-p)
      eta.new <- eta-sum(wt*u)/sum(wt*w)
      if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break
      eta <- eta.new    
    }
  }
  sum(2*wt*(y*log(ifelse(y==0,1,y/p))
            +(1-y)*log(ifelse(y==1,1,(1-y)/(1-p)))))
}
fitted.ssanova <-
function(obj) {
  y <- model.response(obj$mf,"numeric")
  w <- model.weights(obj$mf)
  res <- 10^obj$nlambda*obj$c
  if (!is.null(w)) res <- res/sqrt(w)
  as.numeric(y-res)
}

fitted.gssanova <-
function(obj) obj$eta
getcrdr <- ## Obtain c & d for new y's
function(obj,r) {
  ## Check inputs
  if (is.vector(r)) r <- as.matrix(r)
  if (!(any(class(obj)=="ssanova")&is.matrix(r))) {
    stop("gss error in getcrdr: inputs are of wrong types")
  }
  nobs <- length(obj$c)
  nnull <- length(obj$d)
  nr <- dim(r)[2]
  if (!((dim(r)[1]==nobs)&(nr>0))) {
    stop("gss error in getcrdr: inputs have wrong dimensions")
  }
  ## Call RKPACK ulitity DCRDR
  z <- .Fortran("dcrdr",
                as.double(obj$swk), as.integer(nobs),
                as.integer(nobs), as.integer(nnull),
                as.double(obj$qraux), as.integer(obj$jpvt),
                as.double(obj$qwk), as.integer(nobs),
                as.double(obj$nlambda),
                as.double(r), as.integer(nobs), as.integer(nr),
                cr=double(nobs*nr), as.integer(nobs),
                dr=double(nnull*nr), as.integer(nnull),
                double(2*nobs), integer(1))[c("cr","dr")]
  ## Return cr and dr
  z$cr <- matrix(z$cr,nobs,nr)
  z$dr <- matrix(z$dr,nnull,nr)
  z
}
getsms <- ## Obtain var-cov matrix for fixed effects
function(obj) {
  ## Check input
  if (!any(class(obj)=="ssanova")) {
    stop("gss error in getsms: inputs are of wrong types")
  }
  nobs <- length(obj$c)
  nnull <- length(obj$d)
  ## Call RKPACK ulitity DSMS
  z <- .Fortran("dsms",
                as.double(obj$swk), as.integer(nobs),
                as.integer(nobs), as.integer(nnull),
                as.integer(obj$jpvt),
                as.double(obj$qwk), as.integer(nobs),
                as.double(obj$nlambda),
                sms=double(nnull*nnull), as.integer(nnull),
                double(2*nobs), integer(1))["sms"]
  ## Return the nnull-by-nnull matrix
  matrix(z$sms,nnull,nnull)
}
gssanova <- ## Fit gssanova model
function(formula,family,type="cubic",data=list(),
         weights,subset,offset,na.action=na.omit,
         partial=NULL,method=NULL,varht=1,
         prec=1e-7,maxiter=30,ext=.05,order=2) {
  ## Obtain model frame and model terms
  mf <- match.call()
  mf$family <- mf$type <- mf$method <- mf$varht <- mf$partial <- NULL
  mf$prec <- mf$maxiter <- mf$ext <- mf$order <- NULL
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf,sys.frame(sys.parent()))
  if (type=="cubic") term <- mkterm.cubic(mf,ext)
  if (type=="linear") term <- mkterm.linear(mf,ext)
  if (type=="tp") term <- mkterm.tp(mf,order,mf,1)
  ## Specify default method
  if (is.null(method)) {
    method <- switch(family,
                     binomial="u",
                     nbinomial="u",
                     poisson="u",
                     inverse.gaussian="v",
                     Gamma="v")
  }
  ## Generate s, q, and y
  nobs <- dim(mf)[1]
  s <- q <- NULL
  nq <- 0
  for (label in term$labels) {
    if (label=="1") {
      s <- cbind(s,rep(1,len=nobs))
      next
    }
    x <- mf[,term[[label]]$vlist]
    nphi <- term[[label]]$nphi
    nrk <- term[[label]]$nrk
    if (nphi) {
      phi <- term[[label]]$phi
      for (i in 1:nphi)
        s <- cbind(s,phi$fun(x,nu=i,env=phi$env))
    }
    if (nrk) {
      rk <- term[[label]]$rk
      for (i in 1:nrk) {
        nq <- nq+1
        q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq))
      }
    }
  }
  ## Add the partial term
  if (!is.null(partial)) {
    if (is.vector(partial)) partial <- as.matrix(partial)
    if (dim(partial)[1]!=dim(mf)[1])
      stop("gss error: partial data are of wrong size")
    term$labels <- c(term$labels,"partial")
    term$partial <- list(nphi=dim(partial)[2],nrk=0,
                         iphi=ifelse(is.null(s),0,dim(s)[2])+1)
    s <- cbind(s,partial)
    mf$partial <- partial
  }
  if (qr(s)$rank<dim(s)[2])
    stop("gss error: fixed effects are linearly dependent")
  y <- model.response(mf,"numeric")
  wt <- model.weights(mf)
  offset <- model.offset(mf)
  if (!is.null(offset)) {
    term$labels <- c(term$labels,"offset")
    term$offset <- list(nphi=0,nrk=0)
  }
  if (!nq) stop("use glm for models with only fixed effects")
  ## Fit the model
  if (nq==1) {
    q <- q[,,1]
    z <- sspregpoi(family,s,q,y,wt,offset,method,varht,prec,maxiter)
  }
  else z <- mspregpoi(family,s,q,y,wt,offset,method,varht,prec,maxiter)
  ## Brief description of model terms
  desc <- NULL
  for (label in term$labels)
    desc <- rbind(desc,as.numeric(c(term[[label]][c("nphi","nrk")])))
  desc <- rbind(desc,apply(desc,2,sum))
  rownames(desc) <- c(term$labels,"total")
  colnames(desc) <- c("Fixed","Random")
  ## Return the results
  obj <- c(list(call=match.call(),family=family,mf=mf,terms=term,desc=desc),z)
  class(obj) <- c("gssanova","ssanova")
  obj
}
mkdata.inverse.gaussian <- ## Make pseudo data for IG regression
function(y,eta,wt,offset) {
  if (is.null(wt)) wt <- rep(1,length(y))
  if (is.null(offset)) offset <- rep(0,length(y))
  if (min(y)<=0)
    stop("gss error: inverse gaussian responses should be positive")
  mu <- exp(eta)
  u <- (1-y/mu)/mu
  w <- 1/mu
  ywk <- eta-u/w-offset
  wt <- w*wt
  list(ywk=ywk,wt=wt)
}

dev.resid.inverse.gaussian <- ## Calculate the deviance residuals of IG fit
function(y,eta,wt) {
  if (is.null(wt)) wt <- rep(1,length(y))
  mu <- exp(eta)
  as.vector(wt*((y-mu)^2/(y*mu^2)))
}

dev.null.inverse.gaussian <-
function(y,wt,offset) {
  if (is.null(wt)) wt <- rep(1,length(y))
  mu <- sum(wt*y)/sum(wt)
  if (!is.null(offset)) {
    eta <- log(mu)-mean(offset)
    repeat {
      mu <- exp(eta+offset)
      u <- (1-y/mu)/mu
      w <- 1/mu
      eta.new <- eta-sum(wt*u)/sum(wt*w)
      if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break
      eta <- eta.new    
    }
  }
  sum(wt*((y-mu)^2/(y*mu^2)))
}
mkphi.cubic <- ## Make phi function for cubic splines
function() {
  ## Create the phi function
  fun <- function(x,nu,env=NULL) {
    ## Check inputs
    if (!is.vector(x)) {
      stop("gss error in phi: inputs are of wrong types")
    }
    if ((min(x)<0)|(max(x)>1)) {
      stop("gss error in phi: inputs are out of range")
    }
    ## Return the results
    phi1 <- function(x) rep(1,len=length(x))
    phi2 <- function(x) x-.5
    switch(nu, phi1(x), phi2(x))
  }
  ## Return the function and the (null) environment
  list(fun=fun,env=NULL)
}
mkphi.tp <-  ## Make phi function for thin-plate splines
function(dm,order,mesh,weight) {
  ## Check inputs
  if (!((2*order>dm)&(dm>=1))) {
    stop("gss error: thin-plate spline undefined for the parameters")
  }
  if (xor(is.vector(mesh),dm==1)
      |xor(is.matrix(mesh),dm>=2)) {
    stop("gss error in mkphi: mismatched inputs")
  }
  if ((min(weight)<0)|(max(weight)<=0)) {
    stop("gss error in mkphi: negative weights")
  }
  ## Set weights
  if (is.vector(mesh)) N <- length(mesh)
  else N <- dim(mesh)[1]
  weight <- rep(weight,len=N)
  weight <- sqrt(weight/sum(weight))
  ## Create the environment
  phi.p <- mkphi.tp.p(dm,order)
  nnull <- choose(dm+order-1,dm)
  s <- NULL
  for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env))
  s <- qr(weight*s)
  if (s$rank<nnull) {
    stop("gss error in mkphi: insufficient normalizing mesh for thin-plate spline")
  }
  r <- qr.R(s)
  env <- list(dim=dm,order=order,phi.p=phi.p,r=r)
  ## Create the phi function
  fun <- function(x,nu,env) {
    nnull <- choose(env$dim+env$order-1,env$dim)
    phix <- NULL
    for(i in 1:nnull)
      phix <- rbind(phix,env$phi.p$fun(x,i,env$phi.p$env))
    t(backsolve(env$r,phix,tr=TRUE))[,nu]
  }
  ## Return the function and the environment
  list(fun=fun,env=env)
}
mkphi.tp.p <-  ## Make pseudo phi function for thin-plate splines
function(dm,order) {
  ## Check inputs
  if (!((2*order>dm)&(dm>=1))) {
    stop("gss error: thin-plate spline undefined for the parameters")
  }
  ## Create the environment
  pol.code <- NULL
  for (i in 0:(order^dm-1)) {
    ind <- i; code <- NULL
    for (j in 1:dm) {
      code <- c(code,ind%%order)
      ind <- ind%/%order
    }
    if (sum(code)<order) pol.code <- cbind(pol.code,code)
  }
  env <- list(dim=dm,pol.code=pol.code)
  ## Create the phi function  
  fun <- function(x,nu,env) {
    if (env$dim==1) x <- as.matrix(x)
    if (env$dim!=dim(x)[2]) {
      stop("gss error in phi: inputs are of wrong dimensions")
    }
    apply(t(x)^env$pol.code[,nu],2,prod)
  }
  ## Return the function and the environment
  list(fun=fun,env=env)
}
mkrk.cubic <- ## Make RK for cubic splines
function() {
  ## Create the rk function
  fun <- function(x,y,env=NULL,outer.prod=FALSE) {
    ## Check inputs
    if (!(is.vector(x)&is.vector(y))) {
      stop("gss error in rk: inputs are of wrong types")
    }
    if ((min(x,y)<0)|(max(x,y)>1)) {
      stop("gss error in rk: inputs are out of range")
    }
    ## Return the results
    rk <- function(x,y) {
      k2 <- function(x) ((x-.5)^2-1/12)/2
      k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24
      k2(x)*k2(y)-k4(abs(x-y))
    }
    if (outer.prod) outer(x,y,rk)
    else rk(x,y)
  }
  ## Return the function and the (null) environment
  list(fun=fun,env=NULL)
}
mkrk.linear <- ## Make RK for linear splines
function() {
  ## Create the rk function
  fun <- function(x,y,env=NULL,outer.prod=FALSE) {
    ## Check inputs
    if (!(is.vector(x)&is.vector(y))) {
      stop("gss error in rk: inputs are of wrong types")
    }
    if ((min(x,y)<0)|(max(x,y)>1)) {
      stop("gss error in rk: inputs are out of range")
    }
    ## Return the results
    rk <- function(x,y) {
      k1 <- function(x) (x-.5)
      k2 <- function(x) ((x-.5)^2-1/12)/2
      k1(x)*k1(y)+k2(abs(x-y))
    }
    if (outer.prod) outer(x,y,rk)
    else rk(x,y)
  }
  ## Return the function and the (null) environment
  list(fun=fun,env=NULL)
}
mkrk.tp <- ## Make RK for thin-plate splines
function(dm,order,mesh,weight=1) {
  ## Check inputs
  if (!((2*order>dm)&(dm>=1))) {
    stop("gss error: thin-plate spline undefined for the parameters")
  }
  if (xor(is.vector(mesh),dm==1)
      |xor(is.matrix(mesh),dm>=2)) {
    stop("gss error in mkrk: mismatched inputs")
  }
  if ((min(weight)<0)|(max(weight)<=0)) {
    stop("gss error in mkrk: negative weights")
  }
  ## Set weights
  if (is.vector(mesh)) N <- length(mesh)
  else N <- dim(mesh)[1]
  weight <- rep(weight,len=N)
  weight <- sqrt(weight/sum(weight))
  ## Obtain orthonormal basis
  phi.p <- mkphi.tp.p(dm,order)
  nnull <- choose(dm+order-1,dm)
  s <- NULL
  for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env))
  s <- qr(weight*s)
  if (s$rank<nnull) {
    stop("gss error in mkrk: insufficient normalizing mesh for thin-plate spline")
  }
  q <- qr.Q(s)
  r <- qr.R(s)
  ## Set Q^{T}E(|u_{i}-u_{j}|)Q
  rk.p <- mkrk.tp.p(dm,order)
  pep <- weight*t(weight*rk.p$fun(mesh,mesh,rk.p$env,out=TRUE))
  pep <- t(q)%*%pep%*%q
  ## Create the environment
  env <- list(dim=dm,order=order,weight=weight,
              phi.p=phi.p,rk.p=rk.p,q=q,r=r,mesh=mesh,pep=pep)
  ## Create the rk function
  fun <- function(x,y,env,outer.prod=FALSE) {
    ## Check inputs
    if (env$dim==1) {
      if (!(is.vector(x)&is.vector(y))) {
        stop("gss error in rk: inputs are of wrong types")
      }
      nx <- length(x)
      ny <- length(y)
    }
    else {
      if (is.vector(x)) x <- t(as.matrix(x))
      if (env$dim!=dim(x)[2]) {
        stop("gss error in rk: inputs are of wrong dimensions")
      }
      nx <- dim(x)[1]
      if (is.vector(y)) y <- t(as.matrix(y))
      if (env$dim!=dim(y)[2]) {
        stop("gss error in rk: inputs are of wrong dimensions")
      }
      ny <- dim(y)[1]
    }
    ## Return the results
    nnull <- choose(env$dim+env$order-1,env$dim)
    if (outer.prod) {
      phix <- phiy <- NULL
      for (nu in 1:nnull) {
        phix <- rbind(phix,env$phi.p$fun(x,nu,env$phi.p$env))
        phiy <- rbind(phiy,env$phi.p$fun(y,nu,env$phi.p$env))
      }
      phix <- backsolve(env$r,phix,tr=TRUE)
      phiy <- backsolve(env$r,phiy,tr=TRUE)
      ex <- env$rk.p$fun(env$mesh,x,env$rk.p$env,out=TRUE)
      ex <- env$weight*ex
      ex <- t(env$q)%*%ex
      ey <- env$rk.p$fun(env$mesh,y,env$rk.p$env,out=TRUE)
      ey <- env$weight*ey
      ey <- t(env$q)%*%ey
      env$rk.p$fun(x,y,env$rk.p$env,out=TRUE)-t(phix)%*%ey-
        t(ex)%*%phiy+t(phix)%*%env$pep%*%phiy
    }
    else {
      N <- max(nx,ny)
      phix <- phiy <- NULL
      for (nu in 1:nnull) {
        phix <- rbind(phix,env$phi.p$fun(x,nu,env$phi.p$env))
        phiy <- rbind(phiy,env$phi.p$fun(y,nu,env$phi.p$env))
      }
      phix <- backsolve(env$r,phix,tr=TRUE)
      phix <- matrix(phix,nnull,N)
      phiy <- backsolve(env$r,phiy,tr=TRUE)
      phiy <- matrix(phiy,nnull,N)
      ex <- env$rk.p$fun(env$mesh,x,env$rk.p$env,out=TRUE)
      ex <- env$weight*ex
      ex <- t(env$q)%*%ex
      ex <- matrix(ex,nnull,N)
      ey <- env$rk.p$fun(env$mesh,y,env$rk.p$env,out=TRUE)
      ey <- env$weight*ey
      ey <- t(env$q)%*%ey
      ey <- matrix(ey,nnull,N)
      fn1 <- function(x,n) x[1:n]%*%x[n+(1:n)]
      fn2 <- function(x,pep,n) t(x[1:n])%*%pep%*%x[n+(1:n)]
      env$rk.p$fun(x,y,env$rk.p$env)-apply(rbind(phix,ey),2,fn1,nnull)-
        apply(rbind(phiy,ex),2,fn1,nnull)+
          apply(rbind(phix,phiy),2,fn2,env$pep,nnull)
    }
  }
  ## Return the function and the environment
  list(fun=fun,env=env)
}
mkrk.tp.p <- ## Make pseudo RK for thin-plate splines
function(dm,order) {
  ## Check inputs
  if (!((2*order>dm)&(dm>=1))) {
    stop("gss error: thin-plate spline undefined for the parameters")
  }
  ## Create the environment
  if (dm%%2) {                    
    theta <- gamma(dm/2-order)/2^(2*order)/pi^(dm/2)/gamma(order)
  }
  else {
    theta <- (-1)^(dm/2+order+1)/2^(2*order-1)/pi^(dm/2)/
      gamma(order)/gamma(order-dm/2+1)
  }
  env <- list(dim=dm,order=order,theta=theta)
  ## Create the rk.p function
  fun <- function(x,y,env,outer.prod=FALSE) {
    ## Check inputs
    if (env$dim==1) {
      if (!(is.vector(x)&is.vector(y))) {
        stop("gss error in rk: inputs are of wrong types")
      }
    }
    else {
      if (is.vector(x)) x <- t(as.matrix(x))
      if (env$dim!=dim(x)[2]) {
        stop("gss error in rk: inputs are of wrong dimensions")
      }
      if (is.vector(y)) y <- t(as.matrix(y))
      if (env$dim!=dim(y)[2]) {
        stop("gss error in rk: inputs are of wrong dimensions")
      }
    }
    ## Return the results
    if (outer.prod) {               
      if (env$dim==1) {
        fn1 <- function(x,y) abs(x-y)
        d <- outer(x,y,fn1)
      }
      else {
        fn2 <- function(x,y) sqrt(sum((x-y)^2))
        d <- NULL
        for (i in 1:dim(y)[1]) d <- cbind(d,apply(x,1,fn2,y[i,]))
      }
    }
    else {
      if (env$dim==1) d <- abs(x-y)
      else {
        N <- max(dim(x)[1],dim(y)[1])
        x <- t(matrix(t(x),env$dim,N))
        y <- t(matrix(t(y),env$dim,N))
        fn <- function(x) sqrt(sum(x^2))
        d <- apply(x-y,1,fn)
      }
    }
    power <- 2*env$order-env$dim
    switch(1+env$dim%%2,
           env$theta*d^power*log(ifelse(d>0,d,1)),
           env$theta*d^power)
  }
  ## Return the function and the environment
  list(fun=fun,env=env)
}
mkterm.cubic <- ## Make phi and rk for cubic spline model terms
function(mf,ext) {
  ## Obtain model terms
  mt <- attr(mf,"terms")
  xvars <- as.character(attr(mt,"variables"))[-1]
  xfacs <- attr(mt,"factors")
  term.labels <- labels(mt)
  if (attr(attr(mf,"terms"),"intercept"))
    term.labels <- c("1",term.labels)
  ## Create the phi and rk functions
  term <- list(labels=term.labels)
  iphi.wk <- 1
  irk.wk <- 1
  for (label in term.labels) {
    if (label=="1") {                   # the constant term
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + 1
      term[[label]] <- list(iphi=iphi,nphi=1,nrk=0)
      next
    }
    vlist <- xvars[as.logical(xfacs[,label])]
    x <- mf[,vlist]
    dm <- length(vlist)
    if (dm==1) {
      mx <- max(x)
      mn <- min(x)
      range <- mx - mn
      ## phi
      phi.env <- list(phi=mkphi.cubic()$fun,
                      mn=mn-ext*range,mx=mx+ext*range)
      phi.fun <- function(x,nu=1,env) {
        env$phi((x-env$mn)/(env$mx-env$mn),2)
      }
      nphi <- 1
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + nphi
      phi <- list(fun=phi.fun,env=phi.env)
      ## rk
      rk.env <- list(rk=mkrk.cubic()$fun,
                     mn=mn-ext*range,mx=mx+ext*range)
      rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
        x <- (x-env$mn)/(env$mx-env$mn)
        y <- (y-env$mn)/(env$mx-env$mn)
        env$rk(x,y,out=outer.prod)
      }
      nrk <- 1
      irk <- irk.wk
      irk.wk <- irk.wk + nrk
      rk <- list(fun=rk.fun,env=rk.env)
    }
    else {
      mx <- apply(x,2,max)
      mn <- apply(x,2,min)
      range <- mx - mn
      ## phi
      phi.env <- list(phi=mkphi.cubic()$fun,
                      dim=dm,mn=mn-ext*range,mx=mx+ext*range)
      phi.fun <- function(x,nu=1,env) {
        if (is.vector(x)) x <- t(as.matrix(x))
        if (env$dim!=dim(x)[2]) {
          stop("gss error in phi: inputs are of wrong dimensions")
        }
        x <- t((t(x)-env$mn)/(env$mx-env$mn))
        z <- env$phi(x[,1],2)
        for (i in 2:env$dim) z <- z * env$phi(x[,i],2)
        z
      }
      nphi <- 1
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + nphi
      phi <- list(fun=phi.fun,env=phi.env)
      ## rk
      rk.env <- list(rk=mkrk.cubic()$fun,phi=mkphi.cubic()$fun,
                     dim=dm,mn=mn-ext*range,mx=mx+ext*range)
      rk.fun <- function(x,y,nu,env,outer.prod=FALSE) {
        if (is.vector(x)) x <- t(as.matrix(x))
        if (env$dim!=dim(x)[2]) {
          stop("gss error in rk: inputs are of wrong dimensions")
        }
        x <- t((t(x)-env$mn)/(env$mx-env$mn))
        if (is.vector(y)) y <- t(as.matrix(y))
        if (env$dim!=dim(y)[2]) {
          stop("gss error in rk: inputs are of wrong dimensions")
        }
        y <- t((t(y)-env$mn)/(env$mx-env$mn))
        z <- 1
        ind <- nu
        for (i in 1:env$dim) {
          code <- ind%%2
          ind <- ind%/%2
          if (code) z <- z * env$rk(x[,i],y[,i],out=outer.prod)
          else {
            phix <- env$phi(x[,i],2)
            phiy <- env$phi(y[,i],2)
            if (outer.prod) z <- z * outer(phix,phiy)
            else z <- z * phix * phiy
          }
        }
        z
      }
      nrk <- 2^dm-1
      irk <- irk.wk
      irk.wk <- irk.wk + nrk
      rk <- list(fun=rk.fun,env=rk.env)
    }
    term[[label]] <- list(vlist=vlist,
                          iphi=iphi,nphi=nphi,phi=phi,
                          irk=irk,nrk=nrk,rk=rk)
  }
  term
}
mkterm.linear <- ## Make phi and rk for cubic spline model terms
function(mf,ext) {
  ## Obtain model terms
  mt <- attr(mf,"terms")
  xvars <- as.character(attr(mt,"variables"))[-1]
  xfacs <- attr(mt,"factors")
  term.labels <- labels(mt)
  if (attr(attr(mf,"terms"),"intercept"))
    term.labels <- c("1",term.labels)
  ## Create the phi and rk functions
  term <- list(labels=term.labels)
  iphi.wk <- 1
  irk.wk <- 1
  for (label in term.labels) {
    if (label=="1") {                   # the constant term
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + 1
      term[[label]] <- list(iphi=iphi,nphi=1,nrk=0)
      next
    }
    vlist <- xvars[as.logical(xfacs[,label])]
    x <- mf[,vlist]
    dm <- length(vlist)
    if (dm==1) {
      mx <- max(x)
      mn <- min(x)
      range <- mx - mn
      ## phi
      nphi <- 0
      ## rk
      rk.env <- list(rk=mkrk.linear()$fun,
                     mn=mn-ext*range,mx=mx+ext*range)
      rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
        x <- (x-env$mn)/(env$mx-env$mn)
        y <- (y-env$mn)/(env$mx-env$mn)
        env$rk(x,y,out=outer.prod)
      }
      nrk <- 1
      irk <- irk.wk
      irk.wk <- irk.wk + nrk
      rk <- list(fun=rk.fun,env=rk.env)
    }
    else {
      mx <- apply(x,2,max)
      mn <- apply(x,2,min)
      range <- mx - mn
      ## phi
      nphi <- 0
      ## rk
      rk.env <- list(rk=mkrk.linear()$fun,
                     dim=dm,mn=mn-ext*range,mx=mx+ext*range)
      rk.fun <- function(x,y,nu,env,outer.prod=FALSE) {
        if (is.vector(x)) x <- t(as.matrix(x))
        if (env$dim!=dim(x)[2]) {
          stop("gss error in rk: inputs are of wrong dimensions")
        }
        x <- t((t(x)-env$mn)/(env$mx-env$mn))
        if (is.vector(y)) y <- t(as.matrix(y))
        if (env$dim!=dim(y)[2]) {
          stop("gss error in rk: inputs are of wrong dimensions")
        }
        y <- t((t(y)-env$mn)/(env$mx-env$mn))
        z <- 1
        ind <- nu
        for (i in 1:env$dim)
          z <- z * env$rk(x[,i],y[,i],out=outer.prod)
        z
      }
      nrk <- 1
      irk <- irk.wk
      irk.wk <- irk.wk + nrk
      rk <- list(fun=rk.fun,env=rk.env)
    }
    term[[label]] <- list(vlist=vlist,nphi=nphi,
                          irk=irk,nrk=nrk,rk=rk)
  }
  term
}
mkterm.tp <- ## Make phi and rk for thin-plate spline model terms
function(mf,order,mesh,weight) {
  ## Obtain model terms
  mt <- attr(mf,"terms")
  xvars <- as.character(attr(mt,"variables"))[-1]
  xfacs <- attr(mt,"factors")
  term.labels <- labels(mt)
  if (attr(attr(mf,"terms"),"intercept"))
    term.labels <- c("1",term.labels)
  ## Create the phi and rk functions
  term <- list(labels=term.labels)
  iphi.wk <- 1
  irk.wk <- 1
  for (label in term.labels) {
    if (label=="1") {                   # the constant term
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + 1
      term[[label]] <- list(iphi=iphi,nphi=1,nrk=0)
      next
    }
    vlist <- xvars[as.logical(xfacs[,label])]
    x <- mf[,vlist]
    xmesh <- mesh[,vlist]
    dm <- length(vlist)
    if (dm==1) {
      if (is.vector(x)) xdim <- 1
      else xdim <- dim(x)[2]
      ## phi
      phi.env <- list(phi=mkphi.tp(xdim,order,xmesh,weight))
      phi.fun <- function(x,nu,env) {
        env$phi$fun(x,nu+1,env=env$phi$env)
      }
      nphi <- choose(xdim+order-1,xdim)-1
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + nphi
      phi <- list(fun=phi.fun,env=phi.env)
      ## rk
      rk.env <- list(rk=mkrk.tp(xdim,order,xmesh,weight))
      rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
        env$rk$fun(x,y,env=env$rk$env,out=outer.prod)
      }
      nrk <- 1
      irk <- irk.wk
      irk.wk <- irk.wk + nrk
      rk <- list(fun=rk.fun,env=rk.env)
    }
    else {
      xdim <- phi.list <- rk.list <- NULL
      for (i in 1:dm) {
        if (is.vector(x[[i]])) xdim <- c(xdim,1)
        else xdim <- c(xdim,dim(x[[i]])[2])
        phi <- mkphi.tp(xdim[i],order,xmesh[[i]],weight)
        phi.list <- c(phi.list,list(phi))
        rk <- mkrk.tp(xdim[i],order,xmesh[[i]],weight)
        rk.list <- c(rk.list,list(rk))
      }
      ## phi
      nnphi <- choose(xdim+order-1,xdim)-1
      phi.env <- list(dim=dm,phi=phi.list,nnphi=nnphi)
      phi.fun <- function(x,nu,env) {
        nu.wk <- nu - 1
        code <- NULL
        for (i in 1:env$dim) {
          code <- c(code,nu.wk%%env$nnphi[i]+1)
          nu.wk <- nu.wk%/%env$nnphi[i]
        }
        z <- 1
        for (i in 1:env$dim) {
          z <- z * env$phi[[i]]$fun(x[[i]],code[i]+1,env=env$phi[[i]]$env)
        }
        z
      }
      nphi <- prod(nnphi)
      iphi <- iphi.wk
      iphi.wk <- iphi.wk + nphi
      phi <- list(fun=phi.fun,env=phi.env)
      ## rk
      rk.env <- list(dim=dm,phi=phi.list,rk=rk.list,nnphi=nnphi)
      rk.fun <- function(x,y,nu,env,outer.prod=FALSE) {
        nnrk <- ifelse(env$nnphi,2,1)
        ind <- nu - 1 + ifelse(all(nnrk==2),1,0)
        z <- 1
        for (i in 1:env$dim) {
          code <- ind%%nnrk[i] + 1
          ind <- ind%/%nnrk[i]
          if (code==nnrk[i]) {
            z <- z * env$rk[[i]]$fun(x[[i]],y[[i]],env=env$rk[[i]]$env,out=outer.prod)
          }
          else {
            z.wk <- 0
            for (j in 1:env$nnphi[i]) {
              phix <- env$phi[[i]]$fun(x[[i]],j+1,env=env$phi[[i]]$env)
              phiy <- env$phi[[i]]$fun(y[[i]],j+1,env=env$phi[[i]]$env)
              if (outer.prod) z.wk <- z.wk + outer(phix,phiy)
              else z.wk <- z.wk + phix * phiy
            }
            z <- z * z.wk
          }
        }
        z
      }
      nnrk <- ifelse(nnphi,2,1)
      nrk <- prod(nnrk) - ifelse(all(nnrk==2),1,0)
      irk <- irk.wk
      irk.wk <- irk.wk + nrk
      rk <- list(fun=rk.fun,env=rk.env)
    }
    term[[label]] <- list(vlist=vlist,
                          iphi=iphi,nphi=nphi,phi=phi,
                          irk=irk,nrk=nrk,rk=rk)
  }
  term
}
mspreg <- ## Fit Multiple Smoothing Parameter REGression
function(s,q,y,method="v",varht=1,prec=1e-7,maxiter=30) {
  ## Check inputs
  if (is.vector(s)) s <- as.matrix(s)
  if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3)
        &is.vector(y)&is.character(method))) {
    stop("gss error in mspreg: inputs are of wrong types")
  }
  nobs <- length(y)
  nnull <- dim(s)[2]
  nq <- dim(q)[3]
  if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs)
        &(nobs>=nnull)&(nnull>0)&(nq>1))) {
    stop("gss error in mspreg: inputs have wrong dimensions")
  }
  ## Set method for smoothing parameter selection
  code <- (1:3)[c("v","m","u")==method]
  if (!length(code)) {
    stop("gss error: unsupported method for smoothing parameter selection")
  }
  ## Call RKPACK driver DMUDR
  z <- .Fortran("dmudr0",
                as.integer(code),
                as.double(s),           # s
                as.integer(nobs), as.integer(nobs), as.integer(nnull),
                as.double(q),           # q
                as.integer(nobs), as.integer(nobs), as.integer(nq),
                as.double(y),           # y
                as.double(0), as.integer(0),
                as.double(prec), as.integer(maxiter),
                theta=double(nq), nlambda=double(1),
                score=double(1), varht=as.double(varht),
                c=double(nobs), d=double(nnull),
                double(nobs*nobs*(nq+2)),
                info=integer(1))[c("theta","info")]
  ## Check info for error
  if (info<-z$info) {               
    if (info>0)
      stop("gss error in mspreg: matrix s is rank deficient")
    if (info==-2)
      stop("gss error in mspreg: matrix q is indefinite")
    if (info==-1)
      stop("gss error in mspreg: input data have wrong dimensions")
    if (info==-3)
      stop("gss error in mspreg: unknown method for smoothing parameter selection.")
    if (info==-4)
      stop("gss error in mspreg: iteration fails to converge, try to increase maxiter")
    if (info==-5)
      stop("gss error in mspreg: iteration fails to find a reasonable descent direction")
  }
  qwk <- 10^z$theta[1]*q[,,1]
  for (i in 2:nq) qwk <- qwk + 10^z$theta[i]*q[,,i]
  ## Call RKPACK driver DSIDR
  zz <- .Fortran("dsidr0",
                 as.integer(code),
                 swk=as.double(s), as.integer(nobs),
                 as.integer(nobs), as.integer(nnull),
                 as.double(y),
                 qwk=as.double(qwk), as.integer(nobs),
                 as.double(0), as.integer(0), double(2),
                 nlambda=double(1), score=double(1), varht=as.double(varht),
                 c=double(nobs), d=double(nnull),
                 qraux=double(nnull), jpvt=integer(nnull),
                 double(3*nobs),
                 info=integer(1))
  ## Return the fit
  c(list(method=method,theta=z$theta),
    zz[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")])
}
mspregpoi <- ## Fit Multiple Smoothing Parameter REGression
             ## by Performance-Oriented Iteration
function(family,s,q,y,wt,offset,method="u",varht=1,prec=1e-7,maxiter=30) {
  ## Check inputs
  if (is.vector(s)) s <- as.matrix(s)
  if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3)
        &is.character(method))) {
    stop("gss error in mspregpoi: inputs are of wrong types")
  }
  nobs <- dim(s)[1]
  nnull <- dim(s)[2]
  nq <- dim(q)[3]
  if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs)
        &(nobs>=nnull)&(nnull>0))) {
    stop("gss error in sspregpoi: inputs have wrong dimensions")
  }
  ## Set method for smoothing parameter selection
  code <- (1:3)[c("v","m","u")==method]
  if (!length(code)) {
    stop("gss error: unsupported method for smoothing parameter selection")
  }
  eta <- rep(0,nobs)
  init <- 0
  theta <- rep(0,nq)
  iter <- 0
  alpha <- NULL
  qwk <- array(0,c(nobs,nobs,nq))
  repeat {
    iter <- iter+1
    dat <- switch(family,
                  binomial=mkdata.binomial(y,eta,wt,offset),
                  nbinomial=mkdata.nbinomial(y,eta,wt,offset,alpha),
                  poisson=mkdata.poisson(y,eta,wt,offset),
                  inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset),
                  Gamma=mkdata.Gamma(y,eta,wt,offset))
    alpha <- dat$alpha
    w <- as.vector(sqrt(dat$wt))
    ywk <- w*dat$ywk
    swk <- w*s
    for (i in 1:nq) qwk[,,i] <- w*t(w*q[,,i])
    ## Call RKPACK driver DMUDR
    z <- .Fortran("dmudr0",
                  as.integer(code),
                  as.double(swk),         # s
                  as.integer(nobs), as.integer(nobs), as.integer(nnull),
                  as.double(qwk),         # q
                  as.integer(nobs), as.integer(nobs), as.integer(nq),
                  as.double(ywk),         # y
                  as.double(0), as.integer(init),
                  as.double(prec), as.integer(maxiter),
                  theta=as.double(theta), nlambda=double(1),
                  score=double(1), varht=as.double(varht),
                  c=double(nobs), d=double(nnull),
                  double(nobs*nobs*(nq+2)),
                  info=integer(1))[c("theta","nlambda","c","info")]
    ## Check info for error
    if (info<-z$info) {               
      if (info>0)
        stop("gss error in mspreg: matrix s is rank deficient")
      if (info==-2)
        stop("gss error in mspreg: matrix q is indefinite")
      if (info==-1)
        stop("gss error in mspreg: input data have wrong dimensions")
      if (info==-3)
        stop("gss error in mspreg: unknown method for smoothing parameter selection.")
      if (info==-4)
        stop("gss error in mspreg: iteration fails to converge, try to increase maxiter")
      if (info==-5)
        stop("gss error in mspreg: iteration fails to find a reasonable descent direction")
    }
    eta.new <- (ywk-10^z$nlambda*z$c)/w
    if (!is.null(offset)) eta.new <- eta.new + offset
    disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt)
    if (disc<prec) break
    if (iter>=maxiter) {
      warning("gss warning: performance-oriented iteration fails to converge")
      break
    }
    init <- 1
    theta <- z$theta
    eta <- eta.new
  }
  qqwk <- 10^z$theta[1]*qwk[,,1]
  for (i in 2:nq) qqwk <- qqwk + 10^z$theta[i]*qwk[,,i]
  ## Call RKPACK driver DSIDR
  z <- .Fortran("dsidr0",
                as.integer(code),
                swk=as.double(swk), as.integer(nobs),
                as.integer(nobs), as.integer(nnull),
                as.double(ywk),
                qwk=as.double(qqwk), as.integer(nobs),
                as.double(0), as.integer(0), double(2),
                nlambda=double(1), score=double(1), varht=as.double(varht),
                c=double(nobs), d=double(nnull),
                qraux=double(nnull), jpvt=integer(nnull),
                double(3*nobs),
                info=integer(1))
  ## Check info for error
  if (info<-z$info) {               
    if (info>0)
      stop("gss error in sspregpoi: matrix s is rank deficient")
    if (info==-2)
      stop("gss error in sspregpoi: matrix q is indefinite")
    if (info==-1)
      stop("gss error in sspregpoi: input data have wrong dimensions")
    if (info==-3)
      stop("gss error in sspregpoi: unknown method for smoothing parameter selection.")
  }
  ## Return the fit
  c(list(method=method,theta=theta,w=as.vector(dat$wt),
         eta=as.vector(eta),iter=iter,alpha=alpha),
    z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")])
}
mkdata.nbinomial <- ## Make pseudo data for negative binomial regression
function(y,eta,wt,offset,alpha) {
  if (is.vector(y)) y <- as.matrix(y)
  if (is.null(wt)) wt <- rep(1,dim(y)[1])
  if (is.null(offset)) offset <- rep(0,dim(y)[1])
  if (dim(y)[2]==2) {
    if (min(y[,1])<0)
      stop("gss error: negative binomial response should be nonnegative")
    if (min(y[,2])<=0)
      stop("gss error: negative binomial size should be positive")
    p <- 1-1/(1+exp(eta))
    u <- (y[,1]+y[,2])*p-y[,2]
    w <- (y[,1]+y[,2])*p*(1-p)
    ywk <- eta-u/w-offset
    wt <- w*wt
    list(ywk=ywk,wt=wt)
  }
  else {
    if (min(y)<0)
      stop("gss error: negative binomial response should be nonnegative")
    p <- 1-1/(1+exp(eta))
    if (is.null(alpha)) log.alpha <- log(mean(y*exp(eta)))
    else log.alpha <- log(alpha)
    repeat {
      alpha <- exp(log.alpha)
      ua <- sum(digamma(y+alpha)-digamma(alpha)+log(p))*alpha
      wa <- sum(trigamma(y+alpha)-trigamma(alpha))*alpha*alpha+ua
      log.alpha.new <- log.alpha - ua/wa
      if (abs(log.alpha-log.alpha.new)/(1+abs(log.alpha))<1e-7) break
      log.alpha <- log.alpha.new
    }
    u <- (y+alpha)*p-alpha
    w <- (y+alpha)*p*(1-p)
    ywk <- eta-u/w-offset
    wt <- w*wt
    list(ywk=ywk,wt=wt,alpha=alpha)
  }
}

dev.resid.nbinomial <-
function(y,eta,wt) {
  if (is.null(wt)) wt <- rep(1,dim(y)[1])
  p <- 1-1/(1+exp(eta))
  as.vector(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/(1-p)))
                  +y[,2]*log(y[,2]/(y[,1]+y[,2])/p)))
}

dev.null.nbinomial <-
function(y,wt,offset) {
  if (is.null(wt)) wt <- rep(1,dim(y)[1])
  p <- sum(y[,2])/sum(y)
  if (!is.null(offset)) {
    eta <- log(p/(1-p)) - mean(offset)
    repeat {
      p <- 1-1/(1+exp(eta+offset))
      u <- (y[,1]+y[,2])*p-y[,2]
      w <- (y[,1]+y[,2])*p*(1-p)
      eta.new <- eta-sum(wt*u)/sum(wt*w)
      if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break
      eta <- eta.new    
    }
  }
  sum(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/(1-p)))
            +y[,2]*log(y[,2]/(y[,1]+y[,2])/p)))
}
mkdata.poisson <- ## Make pseudo data for Poisson regression
function(y,eta,wt,offset) {
  if (is.null(wt)) wt <- rep(1,length(y))
  if (is.null(offset)) offset <- rep(0,length(y))
  if (min(y)<0)
    stop("gss error: paired binomial response should be nonnegative")
  lambda <- exp(eta)
  u <- lambda - y
  w <- lambda
  ywk <- eta-u/w-offset
  wt <- w*wt
  list(ywk=ywk,wt=wt)
}

dev.resid.poisson <- ## Calculate deviance residuals for Poisson regression
function(y,eta,wt) {
  if (is.null(wt)) wt <- rep(1,length(y))
  lambda <- exp(eta)
  as.vector(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda)))
}

dev.null.poisson <-
function(y,wt,offset) {
  if (is.null(wt)) wt <- rep(1,length(y))
  lambda <- mean(y)
  if (!is.null(offset)) {
    eta <- log(lambda) - mean(offset)
    repeat {
      lambda <- exp(eta+offset)
      u <- lambda - y
      w <- lambda
      eta.new <- eta-sum(wt*u)/sum(wt*w)
      if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break
      eta <- eta.new    
    }
  }
  sum(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda)))
}
predict.ssanova <- ## Calculate prediction and Bayesian SE from ssanova objects
function(obj,newdata,se.fit=FALSE,include=obj$terms$labels) {
  nnew <- dim(newdata)[1]
  nobs <- length(obj$c)
  ## Extract included terms
  term <- obj$terms
  philist <- rklist <- NULL
  s <- q <- NULL
  nq <- 0
  for (label in include) {
    if (label=="1") {
      philist <- c(philist,term[[label]]$iphi)
      s <- cbind(s,rep(1,len=nnew))
      next
    }
    if (label=="partial") next
    if (label=="offset") next
    xnew <- newdata[,term[[label]]$vlist]
    x <- obj$mf[,term[[label]]$vlist]
    nphi <- term[[label]]$nphi
    nrk <- term[[label]]$nrk
    if (nphi) {
      iphi <- term[[label]]$iphi
      phi <- term[[label]]$phi
      for (i in 1:nphi) {
        philist <- c(philist,iphi+(i-1))
        s <- cbind(s,phi$fun(xnew,nu=i,env=phi$env))
      }
    }
    if (nrk) {
      irk <- term[[label]]$irk
      rk <- term[[label]]$rk
      for (i in 1:nrk) {
        rklist <- c(rklist,irk+(i-1))
        nq <- nq+1
        q <- array(c(q,rk$fun(xnew,x,nu=i,env=rk$env,out=TRUE)),c(nnew,nobs,nq))
      }
    }
  }
  if (any(include=="partial")) {
    nphi <- term$partial$nphi
    iphi <- term$partial$iphi
    for (i in 1:nphi) philist <- c(philist,iphi+(i-1))
    s <- cbind(s,newdata$partial)
  }
  qq <- matrix(0,nnew,nobs)
  nq <- 0
  for (i in rklist) {
    nq <- nq + 1
    qq <- qq + 10^obj$theta[i]*q[,,nq]
  }
  if (!is.null(obj$w)) w <- obj$w
  else w <- model.weights(obj$mf)
  if (!is.null(w)) qq <- t(sqrt(w)*t(qq))
  ## Compute posterior mean
  nphi <- length(philist)
  pmean <- as.vector(qq%*%obj$c)
  if (nphi) pmean <- pmean + as.vector(s%*%obj$d[philist])
  if (any(include=="offset")) {
    if (is.null(model.offset(obj$mf)))
      stop("gss error: no offset in the fit")
    offset <- newdata$offset
    if (is.null(offset)) offset <- newdata$"(offset)"
    if (is.null(offset)) stop("gss error: missing offset")
    pmean <- pmean + offset
  }
  if (se.fit) {
    b <- obj$varht/10^obj$nlambda
    ## Get cr, dr, and sms
    crdr <- getcrdr(obj,t(qq))
    cr <- crdr$cr
    dr <- crdr$dr[philist,,drop=FALSE]
    sms <- getsms(obj)[philist,philist]
    ## Compute posterior variance
    r <- 0
    for (label in include) {
      if (label=="1") next
      xnew <- newdata[,term[[label]]$vlist]
      nrk <- term[[label]]$nrk
      if (nrk) {
        irk <- term[[label]]$irk
        rk <- term[[label]]$rk
        for (i in 1:nrk) {
          ind <- irk+(i-1)
          r <- r + 10^obj$theta[ind]*rk$fun(xnew,xnew,nu=i,env=rk$env)
        }
      }
    }
    fn2 <- function(x,n) x[1:n]%*%x[n+(1:n)]
    pvar <- r - apply(rbind(t(qq),cr),2,fn2,nobs)
    if (nphi) {
      fn1 <- function(x,sms) t(x)%*%sms%*%x
      pvar <- pvar + apply(s,1,fn1,sms)
      pvar <- pvar - 2*apply(rbind(t(s),dr),2,fn2,nphi)
    }
    pse <- as.numeric(sqrt(b*pvar))
    list(fit=pmean,se.fit=pse)
  }
  else pmean
}
print.ssanova <-
function(obj) {
  ## call
  cat("\nCall:\n",deparse(obj$call),"\n\n",sep="")
  ## terms
  cat("Terms:\n")
  print.default(obj$terms$labels)
  cat("\n")
  ## terms overview
  cat("Number of fixed and random effects:\n\n")
  print.default(obj$desc)
  cat("\n")
  if (obj$method=="v") Method <- "GCV.\n"
  if (obj$method=="m") Method <- "Type-II ML.\n"
  if (obj$method=="u") Method <- "Mallows CL.\n"
  cat("Smoothing parameters are selected by",Method)
  cat("\n")
  ## the rest are suppressed
  invisible()
}

print.summary.ssanova <-
function (x,digits=6) {
  ## call
  cat("\nCall:\n",deparse(x$call),"\n",sep="")
  cat("\nEstimate of error standard deviation:",x$sigma,"\n")
  ## residuals
  res <- x$res
  cat("\nResiduals:\n")
  nam <- c("Min", "1Q", "Median", "3Q", "Max")
  rq <- structure(quantile(res), names = nam)
  print(rq,digits=digits)
  cat("Residual sum of squares:",x$rss)
  cat("\nR square:",x$r.squared)
  ## selected summaries
  cat("\n\nPenalty associated with the fit:",x$pen)
#  cat("\n\nNumber of Observations:",length(x$res))
  cat("\n\n")
  invisible()
}

print.summary.gssanova <-
function (x,digits=6) {
  ## call
  cat("\nCall:\n",deparse(x$call),"\n",sep="")
  if (x$method=="u")
    cat("\n(Dispersion parameter for ",x$family,
        " family taken to be ",format(x$dispersion),")\n\n",sep="")
  if (x$method=="v")
    cat("\n(Dispersion parameter for ",x$family,
        " family estimated to be ",format(x$dispersion),")\n\n",sep="")
  ## residuals
  res <- x$res
  cat("Working residuals:\n")
  nam <- c("Min", "1Q", "Median", "3Q", "Max")
  rq <- structure(quantile(res), names = nam)
  print(rq,digits=digits)
  cat("Residual sum of squares:",x$rss,"\n")
  ## deviance residuals
  res <- x$dev.res
  cat("\nDeviance residuals:\n")
  nam <- c("Min", "1Q", "Median", "3Q", "Max")
  rq <- structure(quantile(res), names = nam)
  print(rq,digits=digits)
  cat("Deviance:",x$deviance)
  cat("\nNull deviance:",x$dev.null)
  ## selected summaries
  cat("\n\nPenalty associated with the fit:",x$pen)
  cat("\n\nNumber of performance-oriented iterations:",x$iter)
  cat("\n\n")
  invisible()
}
residuals.ssanova <-
function(obj) {
  w <- model.weights(obj$mf)
  res <- 10^obj$nlambda*obj$c
  if (!is.null(w)) res <- res/sqrt(w)
  res
}

residuals.gssanova <-
function(obj,type="working") {
  res <- 10^obj$nlambda*obj$c
  if (!is.na(charmatch(type,"deviance"))) {
    y <- model.response(obj$mf,"numeric")
    wt <- model.weights(obj$mf)
    dev.resid <- switch(obj$family,
                        binomial=dev.resid.binomial(y,obj$eta,wt),
                        poisson=dev.resid.poisson(y,obj$eta,wt))
    res <- sqrt(dev.resid)*sign(res)
  }
  res
}
ssanova <- ## Fit ssanova model
function(formula,type="cubic",data=list(),weights,subset,offset,na.action=na.omit,
         partial=NULL,method="v",varht=1,prec=1e-7,maxiter=30,ext=.05,order=2) {
  ## Obtain model frame and model terms
  mf <- match.call()
  mf$type <- mf$method <- mf$varht <- mf$partial <- NULL
  mf$prec <- mf$maxiter <- mf$ext <- mf$order <- NULL
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf,sys.frame(sys.parent()))
  if (type=="cubic") term <- mkterm.cubic(mf,ext)
  if (type=="linear") term <- mkterm.linear(mf,ext)
  if (type=="tp") term <- mkterm.tp(mf,order,mf,1)
  ## Generate s, q, and y
  nobs <- dim(mf)[1]
  s <- q <- NULL
  nq <- 0
  for (label in term$labels) {
    if (label=="1") {
      s <- cbind(s,rep(1,len=nobs))
      next
    }
    x <- mf[,term[[label]]$vlist]
    nphi <- term[[label]]$nphi
    nrk <- term[[label]]$nrk
    if (nphi) {
      phi <- term[[label]]$phi
      for (i in 1:nphi)
        s <- cbind(s,phi$fun(x,nu=i,env=phi$env))
    }
    if (nrk) {
      rk <- term[[label]]$rk
      for (i in 1:nrk) {
        nq <- nq+1
        q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq))
      }
    }
  }
  ## Add the partial term
  if (!is.null(partial)) {
    if (is.vector(partial)) partial <- as.matrix(partial)
    if (dim(partial)[1]!=dim(mf)[1])
      stop("gss error: partial data are of wrong size")
    term$labels <- c(term$labels,"partial")
    term$partial <- list(nphi=dim(partial)[2],nrk=0,
                         iphi=ifelse(is.null(s),0,dim(s)[2])+1)
    s <- cbind(s,partial)
    mf$partial <- partial
  }
  ## Prepare the data
  y <- model.response(mf,"numeric")
  w <- model.weights(mf)
  offset <- model.offset(mf)
  if (!is.null(offset)) {
    term$labels <- c(term$labels,"offset")
    term$offset <- list(nphi=0,nrk=0)
    y <- y - offset
  }
  if (!is.null(w)) {
    w <- sqrt(w)
    y <- w*y
    s <- w*s
    for (i in 1:nq) q[,,i] <- w*t(w*q[,,i])
  }
  if (qr(s)$rank<dim(s)[2])
    stop("gss error: fixed effects are linearly dependent")
  if (!nq) stop("use lm for models with only fixed effects")
  ## Fit the model
  if (nq==1) {
    q <- q[,,1]
    z <- sspreg(s,q,y,method,varht)
  }
  else z <- mspreg(s,q,y,method,varht,prec,maxiter)
  ## Brief description of model terms
  desc <- NULL
  for (label in term$labels)
    desc <- rbind(desc,as.numeric(c(term[[label]][c("nphi","nrk")])))
  desc <- rbind(desc,apply(desc,2,sum))
  rownames(desc) <- c(term$labels,"total")
  colnames(desc) <- c("Fixed","Random")
  ## Return the results
  obj <- c(list(call=match.call(),mf=mf,terms=term,desc=desc),z)
  class(obj) <- c("ssanova")
  obj
}
sspreg <- ## Fit Single Smoothing Parameter REGression
function(s,q,y,method="v",varht=1) {
  ## Check inputs
  if (is.vector(s)) s <- as.matrix(s)
  if (!(is.matrix(s)&is.matrix(q)&is.vector(y)&is.character(method))) {
    stop("gss error in sspreg: inputs are of wrong types")
  }
  nobs <- length(y)
  nnull <- dim(s)[2]
  if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs)
        &(nobs>=nnull)&(nnull>0))) {
    stop("gss error in sspreg: inputs have wrong dimensions")
  }
  ## Set method for smoothing parameter selection
  code <- (1:3)[c("v","m","u")==method]
  if (!length(code)) {
    stop("gss error: unsupported method for smoothing parameter selection")
  }
  ## Call RKPACK driver DSIDR
  z <- .Fortran("dsidr0",
                as.integer(code),
                swk=as.double(s), as.integer(nobs),
                as.integer(nobs), as.integer(nnull),
                as.double(y),
                qwk=as.double(q), as.integer(nobs),
                as.double(0), as.integer(0), double(2),
                nlambda=double(1), score=double(1), varht=as.double(varht),
                c=double(nobs), d=double(nnull),
                qraux=double(nnull), jpvt=integer(nnull),
                double(3*nobs),
                info=integer(1))
  ## Check info for error
  if (info<-z$info) {               
    if (info>0)
      stop("gss error in sspreg: matrix s is rank deficient")
    if (info==-2)
      stop("gss error in sspreg: matrix q is indefinite")
    if (info==-1)
      stop("gss error in sspreg: input data have wrong dimensions")
    if (info==-3)
      stop("gss error in sspreg: unknown method for smoothing parameter selection.")
  }
  ## Return the fit
  c(list(method=method,theta=0),
    z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")])
}
sspregpoi <- ## Fit Single Smoothing Parameter REGression
             ## by Performance-Oriented Iteration
function(family,s,q,y,wt,offset,method="u",varht=1,prec=1e-7,maxiter=30) {
  ## Check inputs
  if (is.vector(s)) s <- as.matrix(s)
  if (!(is.matrix(s)&is.matrix(q)&is.character(method))) {
    stop("gss error in sspregpoi: inputs are of wrong types")
  }
  nobs <- dim(s)[1]
  nnull <- dim(s)[2]
  if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs)
        &(nobs>=nnull)&(nnull>0))) {
    stop("gss error in sspregpoi: inputs have wrong dimensions")
  }
  ## Set method for smoothing parameter selection
  code <- (1:3)[c("v","m","u")==method]
  if (!length(code)) {
    stop("gss error: unsupported method for smoothing parameter selection")
  }
  eta <- rep(0,nobs)
  nla0 <- log10(mean(abs(diag(q))))
  limnla <- nla0+c(-.5,.5)
  iter <- 0
  alpha <- NULL
  repeat {
    iter <- iter+1
    dat <- switch(family,
                  binomial=mkdata.binomial(y,eta,wt,offset),
                  nbinomial=mkdata.nbinomial(y,eta,wt,offset,alpha),
                  poisson=mkdata.poisson(y,eta,wt,offset),
                  inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset),
                  Gamma=mkdata.Gamma(y,eta,wt,offset))
    alpha <- dat$alpha
    w <- as.vector(sqrt(dat$wt))
    ywk <- w*dat$ywk
    swk <- w*s
    qwk <- w*t(w*q)
    ## Call RKPACK driver DSIDR
    z <- .Fortran("dsidr0",
                  as.integer(code),
                  swk=as.double(swk), as.integer(nobs),
                  as.integer(nobs), as.integer(nnull),
                  as.double(ywk),
                  qwk=as.double(qwk), as.integer(nobs),
                  as.double(0), as.integer(-1), as.double(limnla),
                  nlambda=double(1), score=double(1), varht=as.double(varht),
                  c=double(nobs), d=double(nnull),
                  qraux=double(nnull), jpvt=integer(nnull),
                  double(3*nobs),
                  info=integer(1))
    ## Check info for error
    if (info<-z$info) {               
      if (info>0)
        stop("gss error in sspregpoi: matrix s is rank deficient")
      if (info==-2)
        stop("gss error in sspregpoi: matrix q is indefinite")
      if (info==-1)
        stop("gss error in sspregpoi: input data have wrong dimensions")
      if (info==-3)
        stop("gss error in sspregpoi: unknown method for smoothing parameter selection.")
    }
    eta.new <- (ywk-10^z$nlambda*z$c)/w
    if (!is.null(offset)) eta.new <- eta.new + offset
    disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt)
    limnla <- pmax(z$nlambda+c(-.5,.5),nla0-5)
    if (disc<prec) break
    if (iter>=maxiter) {
      warning("gss warning: performance-oriented iteration fails to converge")
      break
    }
    eta <- eta.new
  }
  ## Return the fit
  c(list(method=method,theta=0,w=as.vector(dat$wt),
         eta=as.vector(eta),iter=iter,alpha=alpha),
    z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")])
}
summary.gssanova <- ## Summarize gssanova objects
function(obj,diagnostics=FALSE) {
  y <- model.response(obj$mf,"numeric")
  wt <- model.weights(obj$mf)
  offset <- model.offset(obj$mf)
  if (!is.null(obj$alpha)) y <- cbind(y,obj$alpha)
  dev.resid <- switch(obj$family,
                      binomial=dev.resid.binomial(y,obj$eta,wt),
                      nbinomial=dev.resid.nbinomial(y,obj$eta,wt),
                      poisson=dev.resid.poisson(y,obj$eta,wt),
                      inverse.gaussian=dev.resid.inverse.gaussian(y,obj$eta,wt),
                      Gamma=dev.resid.Gamma(y,obj$eta,wt))
  dev.null <- switch(obj$family,
                     binomial=dev.null.binomial(y,wt,offset),
                     nbinomial=dev.null.nbinomial(y,wt,offset),
                     poisson=dev.null.poisson(y,wt,offset),
                     inverse.gaussian=dev.null.inverse.gaussian(y,wt,offset),
                     Gamma=dev.null.Gamma(y,wt,offset))
  w <- obj$w
  if (is.null(offset)) offset <- rep(0,length(obj$eta))
  ## Calculate the summaries
  res <- 10^obj$nlambda*obj$c           # Residuals
  fitted <- obj$eta                     # Fitted values
  fitted.off <- fitted-offset
  sigma2 <- obj$varht                   # dispersion
  rss <- sum(res^2)                     # Residual sum of squares
  dev <- sum(dev.resid)
  penalty <- sum(obj$c*fitted.off*sqrt(w))
  penalty <-                            # Penalty associated with the fit
    as.vector(10^obj$nlambda*penalty)
  ## Calculate the diagnostics
  if (diagnostics) {
    comp <- NULL
    for (label in obj$terms$labels) {
      if (label=="1") next
      if (label=="offset") next
      comp <- cbind(comp,predict(obj,obj$mf,inc=label))
    }
    comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res/sqrt(w),e=res/sqrt(w))
    term.label <- obj$terms$labels[obj$terms$labels!="1"]
    term.label <- term.label[term.label!="offset"]
    colnames(comp) <- c(term.label,"yhat","y","e")
    comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w)
    corr <- t(comp)%*%comp
    corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr))
    norm <- apply(comp,2,function(x){sqrt(sum(x^2))})
    cosines <- rbind(corr[c("y","e"),],norm)
    rownames(cosines) <- c("cos.y","cos.e","norm")
    corr <- corr[term.label,term.label,drop=FALSE]
    if (qr(corr)$rank<dim(corr)[2]) kappa <- rep(Inf,len=dim(corr)[2])
    else kappa <- as.numeric(diag(solve(corr)))
    rough <- as.vector(10^obj$nlambda*t(comp[,term.label])%*%obj$c/penalty)
    names(kappa) <- names(rough) <- term.label
  }
  else kappa <- cosines <- rough <- NULL
  ## Return the summaries
  z <- list(call=obj$call,family=obj$family,method=obj$method,iter=obj$iter,
            fitted=fitted,dispersion=sigma2,residuals=res,rss=rss,
            deviance=dev,dev.resid=sqrt(dev.resid)*sign(res),
            dev.null=dev.null,penalty=penalty,
            kappa=kappa,cosines=cosines,roughness=rough)
  class(z) <- "summary.gssanova"
  z
}
summary.ssanova <- ## Summarize ssanova objects
function(obj,diagnostics=FALSE) {
  y <- model.response(obj$mf,"numeric")
  w <- model.weights(obj$mf)
  offset <- model.offset(obj$mf)
  if (is.null(offset)) offset <- rep(0,length(obj$c))
  ## Calculate the summaries
  res <- 10^obj$nlambda*obj$c           # Residuals
  if (!is.null(w)) res <- res/sqrt(w)
  fitted <- as.numeric(y-res)           # Fitted values
  fitted.off <- fitted-offset
  sigma <- sqrt(obj$varht)              # (estimated) sigma
  if (!is.null(w)) {                    # R^2
    r.squared <- sum(w*(fitted-sum(w*fitted)/sum(w))^2)
    r.squared <- r.squared/sum(w*(y-sum(w*y)/sum(w))^2)
  }
  else r.squared <- var(fitted)/var(y)       
  if (is.null(w)) rss <- sum(res^2)     # Residual sum of squares
  else rss <- sum(w*res^2)
  if (is.null(w))                       # Penalty associated with the fit
    penalty <- sum(obj$c*fitted.off)
  else penalty <- sum(obj$c*fitted.off*sqrt(w))
  penalty <- as.vector(10^obj$nlambda*penalty)
  ## Calculate the diagnostics
  if (diagnostics) {
    comp <- NULL
    for (label in obj$terms$labels) {
      if (label=="1") next
      if (label=="offset") next
      comp <- cbind(comp,predict(obj,obj$mf,inc=label))
    }
    comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res)
    term.label <- obj$terms$labels[obj$terms$labels!="1"]
    term.label <- term.label[term.label!="offset"]
    colnames(comp) <- c(term.label,"yhat","y","e")
    if (!is.null(w))
      comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w)
    else comp <- sweep(comp,2,apply(comp,2,mean))
    corr <- t(comp)%*%comp
    corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr))
    norm <- apply(comp,2,function(x){sqrt(sum(x^2))})
    cosines <- rbind(corr[c("y","e"),],norm)
    rownames(cosines) <- c("cos.y","cos.e","norm")
    corr <- corr[term.label,term.label,drop=FALSE]
    if (qr(corr)$rank<dim(corr)[2]) kappa <- rep(Inf,len=dim(corr)[2])
    else kappa <- as.numeric(diag(solve(corr)))
    rough <- as.vector(10^obj$nlambda*t(comp[,term.label])%*%obj$c/penalty)
    names(kappa) <- names(rough) <- term.label
  }
  else kappa <- cosines <- rough <- NULL
  ## Return the summaries
  z <- list(call=obj$call,method=obj$method,fitted=fitted,residuals=res,
            sigma=sigma,r.squared=r.squared,rss=rss,penalty=penalty,
            kappa=kappa,cosines=cosines,roughness=rough)
  class(z) <- "summary.ssanova"
  z
}
.First.lib <-
function(lib, pkg)
  library.dynam("gss", pkg, lib)
