##%%%%%%%%%%  Binomial Family %%%%%%%%%%

## Make pseudo data for logistic regression
mkdata.binomial <- 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)
}

## Calculate deviance residuals for logistic regression
dev.resid.binomial <- 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)))))
}

## Calculate null deviance for logistic regression
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)))))
}


##%%%%%%%%%%  Poisson Family %%%%%%%%%%

## Make pseudo data for Poisson regression
mkdata.poisson <- 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)
}

## Calculate deviance residuals for Poisson regression
dev.resid.poisson <- 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)))
}

## Calculate null deviance for Poisson regression
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)))
}


##%%%%%%%%%%  Gamma Family %%%%%%%%%%

## Make pseudo data for Gamma regression
mkdata.Gamma <- 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)
}

## Calculate deviance residuals for Gamma regression
dev.resid.Gamma <- 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))
}

## Calculate null deviance for Gamma regression
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))
}


##%%%%%%%%%%  Inverse Gaussian Family %%%%%%%%%%

## Make pseudo data for IG regression
mkdata.inverse.gaussian <- 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)
}

## Calculate deviance residuals for IG regression
dev.resid.inverse.gaussian <- 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)))
}

## Calculate null deviance for IG regression
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)))
}


##%%%%%%%%%%  Negative Binomial Family %%%%%%%%%%

## Make pseudo data for NB regression
mkdata.nbinomial <- 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)
    }
}

## Calculate deviance residuals for NB regression
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)))
}

## Calculate null deviance for NB regression
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)))
}
## Obtain fitted values from ssanova objects
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)
}

## Obtain fitted values in working scale from gssanova objects
fitted.gssanova <- function(obj) obj$eta

## Obtain residuals from ssanova objects
residuals.ssanova <- function(obj)
{
    w <- model.weights(obj$mf)
    res <- 10^obj$nlambda*obj$c
    if (!is.null(w)) res <- res/sqrt(w)
    res
}

## Obtain residuals from gssanova objects
residuals.gssanova <- function(obj,type="working")
{
    res <- 10^obj$nlambda*obj$c/sqrt(obj$w)
    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),
                            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))
        res <- sqrt(dev.resid)*sign(res)
    }
    res
}
## Fit Single Smoothing Parameter REGression by Performance-Oriented Iteration
sspregpoi <- 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")])
}

## Fit Multiple Smoothing Parameter REGression by Performance-Oriented Iteration
mspregpoi <- 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")])
}
## Fit gssanova model
gssanova <- 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
}
## Make RK for linear splines
mkrk.linear <- function(range)
{
    ## Create the environment
    env <- list(min=min(range), max=max(range))
    ## Create the rk function
    fun <- function(x,y,env,outer.prod=FALSE) {
        ##% Check the inputs
        if (!(is.vector(x)&is.vector(y))) {
            stop("gss error in rk: inputs are of wrong types")
        }
        if ((min(x,y)<env$min)|(max(x,y)>env$max)) {
            stop("gss error in rk: inputs are out of range")
        }
        ##% Scale the inputs
        x <- (x-env$min)/(env$max-env$min)
        y <- (y-env$min)/(env$max-env$min)
        ##% Return the result
        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 environment
    list(fun=fun,env=env)
}

## Make RK for cubic splines
mkrk.cubic <- function(range)
{
    ## Create the environment
    env <- list(min=min(range), max=max(range))
    ## Create the rk function
    fun <- function(x,y,env,outer.prod=FALSE) {
        ##% Check the inputs
        if (!(is.vector(x)&is.vector(y))) {
            stop("gss error in rk: inputs are of wrong types")
        }
        if ((min(x,y)<env$min)|(max(x,y)>env$max)) {
            stop("gss error in rk: inputs are out of range")
        }
        ##% Scale the inputs
        x <- (x-env$min)/(env$max-env$min)
        y <- (y-env$min)/(env$max-env$min)
        ##% Return the result
        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 environment
    list(fun=fun,env=env)
}

## Make phi function for cubic splines
mkphi.cubic <- function(range)
{
    ## Create the environment
    env <- list(min=min(range), max=max(range))
    ## Create the phi function
    fun <- function(x,env) {
        ##% Check the input
        if (!is.vector(x)) {
            stop("gss error in phi: inputs are of wrong types")
        }
        if ((min(x)<env$min)|(max(x)>env$max)) {
            stop("gss error in phi: inputs are out of range")
        }
        ##% Return the result
        (x-env$min)/(env$max-env$min)-.5
    }
    ## Return the function and the environment
    list(fun=fun,env=env)
}
## Make RK for thin-plate splines
mkrk.tp <- 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.tp: mismatched inputs")
    }
    if ((min(weight)<0)|(max(weight)<=0)) {
        stop("gss error in mkrk.tp: 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.tp: 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)
}

## Make phi function for thin-plate splines
mkphi.tp <-  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.tp: mismatched inputs")
    }
    if ((min(weight)<0)|(max(weight)<=0)) {
        stop("gss error in mkphi.tp: 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)
}

## Make pseudo RK for thin-plate splines
mkrk.tp.p <- 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)
}

## Make pseudo phi function for thin-plate splines
mkphi.tp.p <- 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)
}
## Make RK for nominal shrinkage
mkrk.nominal <- function(levels)
{
    k <- length(levels)
    if (k<2) stop("gss error: factor should have at least two levels")
    code <- 1:k
    names(code) <- as.character(levels)
    ## Create the environment
    env <- list(code=code,table=diag(k)-1/k)
    ## Create the rk function
    fun <- function(x, y, env, outer.prod = FALSE) {
        if (!(is.factor(x)&is.factor(y))) {
            stop("gss error in rk: inputs are of wrong types")
        }
        x <- as.numeric(env$code[as.character(x)])
        y <- as.numeric(env$code[as.character(y)])
        if (any(is.na(c(x,y)))) {
            stop("gss error in rk: unknown factor levels")
        }
        if (outer.prod) env$table[x, y]
        else env$table[cbind(x,y)]
    }
    ## Return the function and the environment
    list(fun=fun,env=env)
}

## Make RK for ordinal shrinkage
mkrk.ordinal <- function(levels)
{
    k <- length(levels)
    if (k<2) stop("gss error: factor should have at least two levels")
    code <- 1:k
    names(code) <- as.character(levels)
    ## penalty matrix
    if (k==2) {
        B <- diag(.25,2)
        B[1,2] <- B[2,1] <- -.25
    }
    else {
        B <- diag(2,k)
        B[1,1] <- B[k,k] <- 1
        diag(B[-1,-k]) <- diag(B[-k,-1]) <- -1
        ## Moore-Penrose inverse
        B <- eigen(B)
        B <- B$vec[,-k] %*% diag(1/B$val[-k]) %*% t(B$vec[,-k])
        tol <- sqrt(.Machine$double.eps)
        B <- ifelse(abs(B)<tol,0,B)
    }
    ## Create the environment
    env <- list(code=code,table=B)
    ## Create the rk function
    fun <- function(x, y, env, outer.prod = FALSE) {
        if (!(is.factor(x)&is.factor(y))) {
            stop("gss error in rk: inputs are of wrong types")
        }
        x <- as.numeric(env$code[as.character(x)])
        y <- as.numeric(env$code[as.character(y)])
        if (any(is.na(c(x,y)))) {
            stop("gss error in rk: unknown factor levels")
        }
        if (outer.prod) env$table[x, y]
        else env$table[cbind(x,y)]
    }
    ## Return the function and the environment
    list(fun=fun,env=env)
}
## Make phi and rk for cubic spline model terms
mkterm.cubic <- 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) {
        iphi <- irk <- phi <- rk <- NULL
        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) {
            if (!is.factor(x)) {
                ## numeric variable
                mx <- max(x)
                mn <- min(x)
                range <- mx - mn
                ## phi
                phi.env <- mkphi.cubic(c(mn,mx)+c(-1,1)*ext*range)
                phi.fun <- function(x,nu=1,env) env$fun(x,env$env)
                nphi <- 1
                iphi <- iphi.wk
                iphi.wk <- iphi.wk + nphi
                phi <- list(fun=phi.fun,env=phi.env)
                ## rk
                rk.env <- mkrk.cubic(c(mn,mx)+c(-1,1)*ext*range)
                rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
                    env$fun(x,y,env$env,outer.prod)
                }
                nrk <- 1
                irk <- irk.wk
                irk.wk <- irk.wk + nrk
                rk <- list(fun=rk.fun,env=rk.env)
            }
            else {
                ## factor variable
                if (!is.ordered(x)) fun.env <- mkrk.nominal(levels(x))
                else fun.env <- mkrk.ordinal(levels(x))
                if (nlevels(x)>2) {
                    ## phi
                    nphi <- 0
                    ## rk
                    rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
                        env$fun(x,y,env$env,outer.prod)
                    }
                    nrk <- 1
                    irk <- irk.wk
                    irk.wk <- irk.wk + nrk
                    rk <- list(fun=rk.fun,env=fun.env)
                }
                else {
                    ## phi
                    phi.fun <- function(x,nu=1,env) {
                        wk <- as.factor(names(env$env$code)[1])
                        env$fun(x,wk,env$env)
                    }
                    nphi <- 1
                    iphi <- iphi.wk
                    iphi.wk <- iphi.wk + nphi
                    phi <- list(fun=phi.fun,env=fun.env)
                    ## rk
                    nrk <- 0
                }
            }
        }    
        else {
            bin.fac <- n.phi <- phi.list <- rk.list <- NULL
            for (i in 1:dm) {
                if (!is.factor(x[[i]])) {
                    ## numeric variable
                    mx <- max(x[[i]])
                    mn <- min(x[[i]])
                    range <- mx - mn
                    phi.wk <- mkphi.cubic(c(mn,mx)+c(-1,1)*ext*range)
                    rk.wk <- mkrk.cubic(c(mn,mx)+c(-1,1)*ext*range)
                    n.phi <- c(n.phi,1)
                    bin.fac <- c(bin.fac,0)
                }
                else {
                    ## factor variable
                    if (!is.ordered(x[[i]]))
                        rk.wk <- mkrk.nominal(levels(x[[i]]))
                    else rk.wk <- mkrk.ordinal(levels(x[[i]]))
                    phi.wk <- rk.wk
                    n.phi <- c(n.phi,0)
                    bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2))
                }
                phi.list <- c(phi.list,list(phi.wk))
                rk.list <- c(rk.list,list(rk.wk))
            }
            ## phi
            if (sum(n.phi+bin.fac)<dm) nphi <- 0
            else {
                phi.env <- list(dim=dm,n.phi=n.phi,phi=phi.list)
                phi.fun <- function(x,nu=1,env) {
                    z <- 1
                    for (i in 1:env$dim) {
                        if (env$n.phi[i])
                            z <- z * env$phi[[i]]$fun(x[[i]],env$phi[[i]]$env)
                        else {
                            wk <- as.factor(names(env$phi[[i]]$env$code)[1])
                            z <- z * env$phi[[i]]$fun(x[[i]],wk,env$phi[[i]]$env)
                        }
                    }
                    z
                }
                nphi <- 1
                iphi <- iphi.wk
                iphi.wk <- iphi.wk + nphi
                phi <- list(fun=phi.fun,env=phi.env)
            }
            ## rk
            rk.env <- list(dim=dm,n.phi=n.phi,nphi=nphi,phi=phi.list,rk=rk.list)
            rk.fun <- function(x,y,nu,env,outer.prod=FALSE) {
                div <- env$n.phi + 1
                ind <- nu - 1 + env$nphi
                z <- 1
                for (i in 1:env$dim) {
                    code <- ind%%div[i] + 1
                    ind <- ind%/%div[i]
                    if (code==div[i])
                        z <- z * env$rk[[i]]$fun(x[[i]],y[[i]],
                                                 env$rk[[i]]$env,outer.prod)
                    else {
                        phix <- env$phi[[i]]$fun(x[[i]],env$phi[[i]]$env)
                        phiy <- env$phi[[i]]$fun(y[[i]],env$phi[[i]]$env)
                        if (outer.prod) z <- z * outer(phix,phiy)
                        else z <- z * phix * phiy
                    }
                }
                z
            }
            nrk <- prod(n.phi+1) - nphi
            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
}
## Make phi and rk for linear spline model terms
mkterm.linear <- 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 <- irk.wk <- 1
    for (label in term.labels) {
        iphi <- irk <- phi <- rk <- NULL
        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) {
            if (!is.factor(x)) {
                ## numeric variable
                mx <- max(x)
                mn <- min(x)
                range <- mx - mn
                ## phi
                nphi <- 0
                ## rk
                rk.env <- mkrk.linear(c(mn,mx)+c(-1,1)*ext*range)
                rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
                    env$fun(x,y,env$env,outer.prod)
                }
                nrk <- 1
                irk <- irk.wk
                irk.wk <- irk.wk + nrk
                rk <- list(fun=rk.fun,env=rk.env)
            }
            else {
                ## factor variable
                if (!is.ordered(x)) fun.env <- mkrk.nominal(levels(x))
                else fun.env <- mkrk.ordinal(levels(x))
                if (nlevels(x)>2) {
                    ## phi
                    nphi <- 0
                    ## rk
                    rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
                        env$fun(x,y,env$env,outer.prod)
                    }
                    nrk <- 1
                    irk <- irk.wk
                    irk.wk <- irk.wk + nrk
                    rk <- list(fun=rk.fun,env=fun.env)
                }
                else {
                    ## phi
                    phi.fun <- function(x,nu=1,env) {
                        wk <- as.factor(names(env$env$code)[1])
                        env$fun(x,wk,env$env)
                    }
                    nphi <- 1
                    iphi <- iphi.wk
                    iphi.wk <- iphi.wk + nphi
                    phi <- list(fun=phi.fun,env=fun.env)
                    ## rk
                    nrk <- 0
                }
            }
        }
        else {
            bin.fac <- rk.list <- NULL
            for (i in 1:dm) {
                if (!is.factor(x[[i]])) {
                    ## numeric variable
                    mx <- max(x[[i]])
                    mn <- min(x[[i]])
                    range <- mx - mn
                    rk.wk <- mkrk.linear(c(mn,mx)+c(-1,1)*ext*range)
                    bin.fac <- c(bin.fac,0)
                }
                else {
                    ## factor variable
                    if (!is.ordered(x[[i]]))
                        rk.wk <- mkrk.nominal(levels(x[[i]]))
                    else rk.wk <- mkrk.ordinal(levels(x[[i]]))
                    bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2))
                }
                rk.list <- c(rk.list,list(rk.wk))
            }
            rk.env <- list(dim=dm,rk=rk.list)
            if (sum(bin.fac)==dm) {
                ## phi
                phi.fun <- function(x,nu=1,env) {
                    z <- 1
                    for (i in 1:env$dim) {
                        wk <- as.factor(names(env$rk[[i]]$env$code)[1])
                        z <- z * env$rk[[i]]$fun(x[[i]],wk,env$rk[[i]]$env)
                    }
                    z
                }
                nphi <- 1
                iphi <- iphi.wk
                iphi.wk <- iphi.wk + nphi
                phi <- list(fun=phi.fun,env=rk.env)
                ## rk
                nrk <- 0
            }
            else {             
                ## phi
                nphi <- 0
                ## rk
                rk.fun <- function(x,y,nu,env,outer.prod=FALSE) {
                    z <- 1
                    for (i in 1:env$dim)
                        z <- z * env$rk[[i]]$fun(x[[i]],y[[i]],
                                                 env$rk[[i]]$env,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,
                              iphi=iphi,nphi=nphi,phi=phi,
                              irk=irk,nrk=nrk,rk=rk)
    }
    term
}
## Make phi and rk for thin-plate spline model terms
mkterm.tp <- function(mf,order,mesh,weight)
{
    order <- max(order,1)
    ## 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) {
        iphi <- irk <- phi <- rk <- NULL
        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.factor(x)) {
                ## numeric variable
                if (is.vector(x)) xdim <- 1
                else xdim <- dim(x)[2]
                ## phi
                phi.env <- mkphi.tp(xdim,order,xmesh,weight)
                phi.fun <- function(x,nu,env) {
                    env$fun(x,nu+1,env$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 <- mkrk.tp(xdim,order,xmesh,weight)
                rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
                    env$fun(x,y,env$env,outer.prod)
                }
                nrk <- 1
                irk <- irk.wk
                irk.wk <- irk.wk + nrk
                rk <- list(fun=rk.fun,env=rk.env)
            }
            else {
                ## factor variable
                if (!is.ordered(x)) fun.env <- mkrk.nominal(levels(x))
                else fun.env <- mkrk.ordinal(levels(x))
                if (nlevels(x)>2) {
                    ## phi
                    nphi <- 0
                    ## rk
                    rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) {
                        env$fun(x,y,env$env,outer.prod)
                    }
                    nrk <- 1
                    irk <- irk.wk
                    irk.wk <- irk.wk + nrk
                    rk <- list(fun=rk.fun,env=fun.env)
                }
                else {
                    ## phi
                    phi.fun <- function(x,nu=1,env) {
                        wk <- as.factor(names(env$env$code)[1])
                        env$fun(x,wk,env$env)
                    }
                    nphi <- 1
                    iphi <- iphi.wk
                    iphi.wk <- iphi.wk + nphi
                    phi <- list(fun=phi.fun,env=fun.env)
                    ## rk
                    nrk <- 0
                }
            }
        }
        else {
            bin.fac <- xdim <- phi.list <- rk.list <- NULL
            for (i in 1:dm) {
                if (!is.factor(x[[i]])) {
                    ## numeric variable
                    if (is.vector(x[[i]])) xdim <- c(xdim,1)
                    else xdim <- c(xdim,dim(x[[i]])[2])
                    phi.wk <- mkphi.tp(xdim[i],order,xmesh[[i]],weight)
                    rk.wk <- mkrk.tp(xdim[i],order,xmesh[[i]],weight)
                    bin.fac <- c(bin.fac,0)
                }
                else {
                    ## factor variable
                    xdim <- c(xdim,0)
                    if (!is.ordered(x[[i]]))
                        rk.wk <- mkrk.nominal(levels(x[[i]]))
                    else rk.wk <- mkrk.ordinal(levels(x[[i]]))
                    phi.wk <- rk.wk
                    bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2))
                }
                phi.list <- c(phi.list,list(phi.wk))
                rk.list <- c(rk.list,list(rk.wk))
            }
            n.phi <- choose(xdim+order-1,xdim)-1
            ## phi
            if (!all(n.phi+bin.fac)) nphi <- 0
            else {
                phi.env <- list(dim=dm,phi=phi.list,n.phi=n.phi,bin.fac=bin.fac)
                phi.fun <- function(x,nu,env) {
                    ind <- nu - 1
                    z <- 1
                    for (i in 1:env$dim) {
                        if (env$bin.fac[i]) {
                            wk <- as.factor(names(env$phi[[i]]$env$code)[1])
                            z <- z * env$phi[[i]]$fun(x[[i]],wk,env$phi[[i]]$env)
                        }
                        else {
                            code <- ind%%env$n.phi[i] + 1
                            ind <- ind%/%env$n.phi[i]
                            z <- z * env$phi[[i]]$fun(x[[i]],code+1,env$phi[[i]]$env)
                        }
                    }
                    z
                }
                nphi <- prod(n.phi+bin.fac)
                iphi <- iphi.wk
                iphi.wk <- iphi.wk + nphi
                phi <- list(fun=phi.fun,env=phi.env)
            }
            ## rk
            rk.env <- list(dim=dm,n.phi=n.phi,nphi=nphi,
                           phi=phi.list,rk=rk.list)
            rk.fun <- function(x,y,nu,env,outer.prod=FALSE) {
                n.rk <- ifelse(env$n.phi,2,1)
                ind <- nu - !env$nphi
                z <- 1
                for (i in 1:env$dim) {
                    code <- ind%%n.rk[i] + 1
                    ind <- ind%/%n.rk[i]
                    if (code==n.rk[i]) {
                        z <- z * env$rk[[i]]$fun(x[[i]],y[[i]],
                                                 env$rk[[i]]$env,outer.prod)
                    }
                    else {
                        z.wk <- 0
                        for (j in 1:env$n.phi[i]) {
                            phix <- env$phi[[i]]$fun(x[[i]],j+1,env$phi[[i]]$env)
                            phiy <- env$phi[[i]]$fun(y[[i]],j+1,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
            }
            n.rk <- ifelse(n.phi,2,1)
            nrk <- prod(n.rk) - as.logical(nphi)
            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
}
## Calculate prediction and Bayesian SE from ssanova objects
predict.ssanova <- 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 function for ssanova objects
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 <- "GML.\n"
    if (obj$method=="u") Method <- "Mallows CL.\n"
    cat("Smoothing parameters are selected by",Method)
    cat("\n")
    ## the rest are suppressed
    invisible()
}

## Print function for summary.ssanova objects
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\n")
    invisible()
}

## Print function for summary.gssanova objects
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()
}
## Fit Single Smoothing Parameter REGression
sspreg <- 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")])
}

## Fit Multiple Smoothing Parameter REGression
mspreg <- 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")])
}

## Obtain c & d for new y's
getcrdr <- 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
}

## Obtain var-cov matrix for fixed effects
getsms <- 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)
}
## Fit ssanova model
ssanova <- 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
}
## Summarize gssanova objects
summary.gssanova <- 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))
    ## Residuals
    res <- 10^obj$nlambda*obj$c 
    ## Fitted values
    fitted <- obj$eta
    fitted.off <- fitted-offset
    ## dispersion
    sigma2 <- obj$varht
    ## RSS, deviance
    rss <- sum(res^2)
    dev <- sum(dev.resid)
    ## Penalty associated with the fit
    penalty <- sum(obj$c*fitted.off*sqrt(w))
    penalty <- as.vector(10^obj$nlambda*penalty)
    ## Calculate the diagnostics
    if (diagnostics) {
        ## Obtain retrospective linear model
        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")
        ## Sweep out constant
        comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w)
        ## Obtain pi
        comp1 <- comp[,c(term.label,"yhat")]
        decom <- t(comp1) %*% comp1[,"yhat"]
        names(decom) <- c(term.label,"yhat")
        decom <- decom[term.label]/decom["yhat"]
        ## Obtain kappa, norm, and cosines        
        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(sqrt(diag(solve(corr))))
        ## Obtain decomposition of penalty
        rough <- as.vector(10^obj$nlambda*t(comp[,term.label])%*%obj$c/penalty)
        names(kappa) <- names(rough) <- term.label
    }
    else decom <- 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/sqrt(w),rss=rss,
              deviance=dev,dev.resid=sqrt(dev.resid)*sign(res),
              dev.null=dev.null,penalty=penalty,
              pi=decom,kappa=kappa,cosines=cosines,roughness=rough)
    class(z) <- "summary.gssanova"
    z
}
## Summarize ssanova objects
summary.ssanova <- 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))
    ## Residuals
    res <- 10^obj$nlambda*obj$c         
    if (!is.null(w)) res <- res/sqrt(w)
    ## Fitted values
    fitted <- as.numeric(y-res)
    fitted.off <- fitted-offset
    ## (estimated) sigma
    sigma <- sqrt(obj$varht)
    ## R^2
    if (!is.null(w)) {
        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)       
    ## Residual sum of squares
    if (is.null(w)) rss <- sum(res^2)
    else rss <- sum(w*res^2)
    ## Penalty associated with the fit
    if (is.null(w)) 
        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) {
        ## Obtain retrospective linear model
        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"]
        if (any(outer(term.label,c("yhat","y","e"),"==")))
            warning("gss warning: avoid using yhat, y, or e as variable names")
        colnames(comp) <- c(term.label,"yhat","y","e")
        ## Sweep out constant
        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))
        ## Obtain pi
        comp1 <- comp[,c(term.label,"yhat")]
        decom <- t(comp1) %*% comp1[,"yhat"]
        names(decom) <- c(term.label,"yhat")
        decom <- decom[term.label]/decom["yhat"]
        ## Obtain kappa, norm, and cosines
        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(sqrt(diag(solve(corr))))
        ## Obtain decomposition of penalty
        rough <- as.vector(10^obj$nlambda*t(comp[,term.label])%*%obj$c/penalty)
        names(kappa) <- names(rough) <- term.label
    }
    else decom <- 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,
              pi=decom,kappa=kappa,cosines=cosines,roughness=rough)
    class(z) <- "summary.ssanova"
    z
}
.First.lib <- function(lib, pkg)
{
    library.dynam("gss", pkg, lib)
}
