.packageName <- "car"
# Type II and III tests for linear and generalized linear models (J. Fox)

# last modified 31 Jan 04

relatives<-function(term, names, factors){
    is.relative<-function(term1, term2) {
        all(!(factors[,term1]&(!factors[,term2])))
        }
    if(length(names)==1) return(NULL)
    which.term<-which(term==names)
    (1:length(names))[-which.term][sapply(names[-which.term], function(term2) is.relative(term, term2))]
    }
    

Anova<-function(mod, ...){
    UseMethod("Anova", mod)
    }

 # linear models
 
Anova.lm<-function(mod, error, type=c("II","III"), ...){
    type<-match.arg(type)
    switch(type,
        II=Anova.II.lm(mod, error, ...),
        III=Anova.III.lm(mod, error, ...))
    }

Anova.aov <- function(mod, ...){
    # last modified 8 Mar 2002 by J. Fox
    class(mod) <- "lm"
    Anova.lm(mod, ...)
    }

        # type II
        
Anova.II.lm<-function(mod, error, ...){
    # last modified by J.Fox 11 Dec 2000
    if (!missing(error)){
        sumry<-summary(error, corr=FALSE)
        s2<-sumry$sigma^2
        error.df<-error$df.residual
        error.SS<-s2*error.df
        }
    SS.term<-function(term){
        which.term<-which(term==names)
        subs.term<-which(assign==which.term)
        relatives<-relatives(term, names, fac)
        subs.relatives<-NULL
        for (relative in relatives) subs.relatives<-c(subs.relatives, which(assign==relative))
        hyp.matrix.1<-I.p[subs.relatives,]
        hyp.matrix.2<-I.p[c(subs.relatives,subs.term),]
        SS1<-if (length(subs.relatives)==0) 0 
            else linear.hypothesis(mod, hyp.matrix.1, summary.model=sumry, ...)$SSH
        SS2<-linear.hypothesis(mod, hyp.matrix.2, summary.model=sumry, ...)$SSH
        SS2-SS1
        }
    fac<-attr(mod$terms, "factors")
    intercept<-has.intercept(mod)
    p<-length(coefficients(mod))
    I.p<-diag(p)
    assign<-mod$assign
    names<-term.names(mod)
    if (intercept) names<-names[-1]
    n.terms<-length(names)
    SS<-rep(0, n.terms+1)
    df<-rep(0, n.terms+1)
    f<-rep(0, n.terms+1)
    p<-rep(0, n.terms+1)
    sumry<-summary(mod, corr = FALSE)
    SS[n.terms+1]<-if (missing(error)) sumry$sigma^2*mod$df.residual else error.SS   
    df[n.terms+1]<-if (missing(error)) mod$df.residual else error.df
    f[n.terms+1]<-NA
    p[n.terms+1]<-NA
    for (i in 1:n.terms){
        SS[i]<-SS.term(names[i])
        df[i]<-df.terms(mod, names[i])
        f[i]<-df[n.terms+1]*SS[i]/(df[i]*SS[n.terms+1])
        p[i]<-1-pf(f[i],df[i],df[n.terms+1])
        }    
    result<-data.frame(SS, df, f, p)
    row.names(result)<-c(names,"Residuals")
    names(result)<-c("Sum Sq", "Df", "F value", "Pr(>F)")
    class(result)<-c("anova","data.frame")
    attr(result,"heading")<-c("Anova Table (Type II tests)\n", paste("Response:", responseName(mod)))
    result
    }

        # type III
        
Anova.III.lm<-function(mod, error, ...){
    # last modified by J.Fox 11 Dec 2000
    if (!missing(error)){
        sumry<-summary(error, corr=FALSE)
        s2<-sumry$sigma^2
        error.df<-error$df.residual
        error.SS<-s2*error.df
        }
    intercept<-has.intercept(mod)
    p<-length(coefficients(mod))
    I.p<-diag(p)
    Source<-term.names(mod)
    n.terms<-length(Source)
    SS<-rep(0, n.terms+1)
    df<-rep(0, n.terms+1)
    f<-rep(0, n.terms+1)
    p<-rep(0, n.terms+1)
    assign<-mod$assign
    sumry<-summary(mod, corr = FALSE)
    for (term in 1:n.terms){
        subs<-which(assign==term-intercept)
        hyp.matrix<-I.p[subs,]
        test<-if (missing(error)) linear.hypothesis(mod, hyp.matrix, summary.model=sumry, ...)
            else linear.hypothesis(mod, hyp.matrix, error.SS=error.SS, error.df=error.df, 
                summary.model=sumry, ...)
        SS[term]<-test$SSH
        df[term]<-test$Df[1]
        f[term]<-test$f
        p[term]<-test$p
        }
     Source[n.terms+1]<-"Residuals"
     df.res<-if (missing(error)) mod$df.residual
        else error.df     
     s2<-sumry$sigma^2
     SS[n.terms+1]<-if (missing(error)) s2*df.res
        else error.SS
     df[n.terms+1]<-df.res
     f[n.terms+1]<-NA
     p[n.terms+1]<-NA
     result<-data.frame(SS, df, f, p)
     row.names(result)<-Source
     names(result)<-c("Sum Sq", "Df", "F value", "Pr(>F)")
     class(result)<-c("anova","data.frame")
     attr(result,"heading")<-c("Anova Table (Type III tests)\n", paste("Response:", responseName(mod)))
     result
     }

    # generalized linear models
    
Anova.glm<-function(mod, type=c("II","III"), test.statistic=c("LR", "Wald", "F"), 
    error, error.estimate=c("pearson", "dispersion", "deviance"), ...){
    #last modified by J. Fox 15 Feb 2001
    type<-match.arg(type)
    test.statistic<-match.arg(test.statistic)
    error.estimate<-match.arg(error.estimate)
    switch(type,
        II=switch(test.statistic,
            LR=Anova.II.LR.glm(mod),
            Wald=Anova.II.Wald.glm(mod),
            F=Anova.II.F.glm(mod, error, error.estimate)),
        III=switch(test.statistic,
            LR=Anova.III.LR.glm(mod),
            Wald=Anova.III.Wald.glm(mod),
            F=Anova.III.F.glm(mod, error, error.estimate)))
    }

    
        # type III
        
            # Wald test
        
Anova.III.Wald.glm<-function(mod, ...){
    # last modified by J.Fox 11 Dec 2000
    intercept<-has.intercept(mod)
    p<-length(coefficients(mod))
    I.p<-diag(p)
    Source<-term.names(mod)
    n.terms<-length(Source)
    Wald<-rep(0, n.terms)
    df<-rep(0, n.terms)
    p<-rep(0, n.terms)
    assign<-attr(model.matrix(mod),"assign")
    sumry<-summary(mod, corr=FALSE)
    for (term in 1:n.terms){
        subs<-which(assign==term-intercept)
        hyp.matrix<-I.p[subs,]
        test<-linear.hypothesis(mod, hyp.matrix, summary.model=sumry)
        Wald[term]<-test$ChiSquare
        df[term]<-test$Df
        p[term]<-test$p
        }
     result<-data.frame(Wald, df, p)
     row.names(result)<-Source
     names(result)<-c("Wald Chisq","Df","Pr(>Chisq)")
     class(result)<-c("anova","data.frame")
     attr(result,"heading")<-c("Anova Table (Type III tests)\n", paste("Response:", responseName(mod)))
     result
     }
     
            # LR test

Anova.III.LR.glm<-function(mod, ...){
    Source<-if (has.intercept(mod)) term.names(mod)[-1]
        else term.names(mod)
    n.terms<-length(Source)
    LR<-rep(0, n.terms)
    df<-rep(0, n.terms)
    p<-rep(0, n.terms)
    dispersion<-summary(mod, corr = FALSE)$dispersion
    deviance<-deviance(mod)/dispersion
    for (term in 1:n.terms){
        mod.1<-drop1(mod, scope=
            eval(parse(text=paste("~",Source[term]))))
        LR[term]<-(mod.1$Deviance[2]/dispersion)-deviance
        df[term]<-mod.1$Df[2]
        p[term]<-1-pchisq(LR[term], df[term])
        }
     result<-data.frame(LR, df, p)
     row.names(result)<-Source
     names(result)<-c("LR Chisq","Df","Pr(>Chisq)")
     class(result)<-c("anova","data.frame")
     attr(result,"heading")<-c("Anova Table (Type III tests)\n", paste("Response:", responseName(mod)))
     result
     }

            # F test

Anova.III.F.glm<-function(mod, error, error.estimate, ...){
    # last modified by J. Fox 25 Apr 2003
    fam <- family(mod)$family
    if (fam == "binomial" || fam == "poisson") 
        warning("dispersion parameter estimated from the Pearson residuals, not taken as 1")
    if (missing(error)) error<-mod
    df.res <- df.residual(error)
    error.SS<-switch(error.estimate,
        pearson=sum(residuals(error, "pearson")^2),
        dispersion=df.res*summary(error, corr = FALSE)$dispersion,
        deviance=deviance(error))
    Source<-if (has.intercept(mod)) term.names(mod)[-1]
        else term.names(mod)
    n.terms<-length(Source)
    p <- df <- f <- SS <-rep(0, n.terms+1)
    f[n.terms+1] <- p[n.terms+1] <- NA
    df[n.terms+1]<-df.res
    SS[n.terms+1]<-error.SS
    dispersion<-error.SS/df.res
    deviance<-deviance(mod)
    for (term in 1:n.terms){
        mod.1<-drop1(mod, scope=
            eval(parse(text=paste("~",Source[term]))))
        df[term]<-mod.1$Df[2]
        SS[term]<-mod.1$Deviance[2] - deviance
        f[term]<-(SS[term]/df[term])/dispersion
        p[term]<-1-pf(f[term], df[term], df.res)
        }
     result<-data.frame(SS, df, f, p)
     row.names(result)<-c(Source, "Residuals")
     names(result)<-c("SS", "Df", "F", "Pr(>F)")
     class(result)<-c("anova","data.frame")
     attr(result,"heading")<-c("Anova Table (Type III tests)\n", paste("Response:", responseName(mod)))
     result
     }
     
        # type II
        
            # Wald test
        
Anova.II.Wald.glm<-function(mod, ...){
    # last modified by J.Fox 11 Dec 2000
    chisq.term<-function(term){
        which.term<-which(term==names)
        subs.term<-which(assign==which.term)
        relatives<-relatives(term, names, fac)
        subs.relatives<-NULL
        for (relative in relatives) subs.relatives<-c(subs.relatives, which(assign==relative))
        hyp.matrix.1<-I.p[subs.relatives,]
        hyp.matrix.2<-I.p[c(subs.relatives,subs.term),]
        sumry<-summary(mod, corr=FALSE)
        chisq.1<-if (length(subs.relatives)==0) 0 
            else linear.hypothesis(mod, hyp.matrix.1, summary.model=sumry)$ChiSquare
        chisq.2<-linear.hypothesis(mod, hyp.matrix.2, summary.model=sumry)$ChiSquare
        chisq.2-chisq.1
        }
    fac<-attr(mod$terms, "factors")
    intercept<-has.intercept(mod)
    p<-length(coefficients(mod))
    I.p<-diag(p)
    names<-term.names(mod)
    if (intercept) names<-names[-1]
    assign<-rep(1:length(names), df.terms(mod))
    assign<-if (intercept) c(0,assign) else assign
    n.terms<-length(names)
    Wald<-rep(0, n.terms)
    df<-rep(0, n.terms)
    p<-rep(0, n.terms)
    for (i in 1:n.terms){
        Wald[i]<-chisq.term(names[i])
        df[i]<-df.terms(mod, names[i])
        p[i]<-1-pchisq(Wald[i],df[i])
        }    
    result<-data.frame(Wald, df, p)
    row.names(result)<-names
    names(result)<-c("Wald Chisq","Df","Pr(>Chisq)")
    class(result)<-c("anova","data.frame")
    attr(result,"heading")<-c("Anova Table (Type II tests)\n", paste("Response:", responseName(mod)))
    result
    }

            # LR test
            
Anova.II.LR.glm <- function(mod, ...){
    # last modified 5 Nov 2002 by J. Fox
    # (some code adapted from drop1.glm)
    which.nms <- function(name) which(asgn == which(names == name))
    fac <- attr(mod$terms, "factors")
    names <- if (has.intercept(mod)) term.names(mod)[-1]
        else term.names(mod)
    n.terms <- length(names)
    X <- model.matrix(mod)
    y <- mod$y
    if (is.null(y)) y <- model.response(model.frame(mod), "numeric")
    wt <- mod$prior.weights
    if (is.null(wt)) wt <- rep(1, length(y))
    asgn <- attr(X, 'assign')
    LR <- rep(0, n.terms)
    df <- df.terms(mod)
    p <- rep(0, n.terms)
    dispersion <- summary(mod, corr = FALSE)$dispersion
    for (term in 1:n.terms){
        rels <- names[relatives(names[term], names, fac)]
        exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms)))
        mod.1 <- glm.fit(X[, -exclude.1, drop = FALSE], y, wt, offset = mod$offset, 
            family = mod$family, control = mod$control)
        dev.1 <- deviance(mod.1)
        mod.2 <- if (length(rels) == 0) mod
            else {
                exclude.2 <- as.vector(unlist(sapply(rels, which.nms)))
                glm.fit(X[, -exclude.2, drop = FALSE], y, wt, offset = mod$offset, 
                    family = mod$family, control = mod$control)
                }
        dev.2 <- deviance(mod.2)
        LR[term] <- (dev.1 - dev.2)/dispersion
        p[term] <- 1 - pchisq(LR[term], df[term])
        }
     result <- data.frame(LR, df, p)
     row.names(result) <- names
     names(result) <- c("LR Chisq", "Df", "Pr(>Chisq)")
     class(result) <- c("anova", "data.frame")
     attr(result,"heading") <- 
        c("Anova Table (Type II tests)\n", paste("Response:", responseName(mod)))
     result
     }


            # F test
            
Anova.II.F.glm <- function(mod, error, error.estimate, ...){
    # last modified 25 Apr 2003 by J. Fox
    # (some code adapted from drop1.glm)
    fam <- family(mod)$family
    if (fam == "binomial" || fam == "poisson") 
        warning("dispersion parameter estimated from the Pearson residuals, not taken as 1")
    which.nms <- function(name) which(asgn == which(names == name))
    if (missing(error)) error <- mod
    df.res <- df.residual(error)
    error.SS <- switch(error.estimate,
        pearson = sum(residuals(error, "pearson")^2),
        dispersion = df.res*summary(error, corr = FALSE)$dispersion,
        deviance = deviance(error))
    fac <- attr(mod$terms, "factors")
    names<-if (has.intercept(mod)) term.names(mod)[-1]
        else term.names(mod)
    n.terms <- length(names)
    X <- model.matrix(mod)
    y <- mod$y
    if (is.null(y)) y <- model.response(model.frame(mod), "numeric")
    wt <- mod$prior.weights
    if (is.null(wt)) wt <- rep(1, length(y))
    asgn <- attr(X, 'assign')
    p <- df <- f <- SS <- rep(0, n.terms+1)
    f[n.terms+1] <- p[n.terms+1] <- NA
    df[n.terms+1] <- df.res
    SS[n.terms+1] <- error.SS
    dispersion <- error.SS/df.res
    df <- c(df.terms(mod), df.res)
    for (term in 1:n.terms){
        rels <- names[relatives(names[term], names, fac)]
        exclude.1 <- as.vector(unlist(sapply(c(names[term], rels), which.nms)))
        mod.1 <- glm.fit(X[, -exclude.1, drop = FALSE], y, wt, offset = mod$offset, 
            family = mod$family, control = mod$control)
        dev.1 <- deviance(mod.1)
        mod.2 <- if (length(rels) == 0) mod
            else {
                exclude.2 <- as.vector(unlist(sapply(rels, which.nms)))
                glm.fit(X[, -exclude.2, drop = FALSE], y, wt, offset = mod$offset, 
                    family = mod$family, control = mod$control)
                }
        dev.2 <- deviance(mod.2)
        SS[term] <- dev.1 - dev.2
        f[term] <- SS[term]/(dispersion*df[term])
        p[term] <- 1 - pf(f[term], df[term], df.res)
        }
     result <- data.frame(SS, df, f, p)
     row.names(result) <- c(names, "Residuals")
     names(result) <- c("SS","Df","F","Pr(>F)")
     class(result) <- c("anova","data.frame")
     attr(result,"heading") <- c("Anova Table (Type II tests)\n", 
        paste("Response:", responseName(mod)))
     result
     }
# change an argument to a function interactively (J. Fox)

Ask<-function(arg, fun, ...){ 
    fun<-fun
    repeat{   
        value<-readline(paste("Enter",deparse(substitute(arg)),": "))
        if (value == "") break()
        eval(parse(text=paste("fun(",deparse(substitute(arg)),"=",value,",...)")))
        }
    }
 
# Axes for transformations (J. Fox)

# last modified 2 April 02 by J. Fox

# function to find "nice" numbers

nice<-function(x, direction=c("round", "down", "up")){
    direction<-match.arg(direction)
    if (length(x)>1) return(sapply(x, nice, direction=direction))
    if (x==0) return(0)
    power.10<-floor(log(abs(x),10))
    lead.digit<-switch(direction,
        round=round(abs(x)/10^power.10),
        down=floor(abs(x)/10^power.10),
        up=ceiling(abs(x)/10^power.10))
    sign(x)*lead.digit*10^power.10
    }


# functions to add untransformed axis to right or top of a plot
#  for power or Box-Cox power transformations

power.axis<-function(power, base=exp(1), side=c("right", "above", "left", "below"), 
    at, grid=FALSE, grid.col=gray(.50), grid.lty=3,
    axis.title = "Untransformed Data", cex = 1, las=par("las")) {
    # last modified 20 Feb 2002 by J. Fox
    side<-if(is.numeric(side)) side 
        else which(match.arg(side)==c("below", "left", "above", "right"))
    axp<-if (side %% 2 == 1) par("xaxp") else par("yaxp")
    ticks<-nice(seq(from=axp[1], to=axp[2], length=axp[3]+1))
    ticks.x<- if (power !=0) nice(ticks[ticks>0]^(1/power)) 
        else nice(log(base)*exp(ticks))
    ticks.x <- if (missing(at)) ticks.x
        else at
    ticks.text <- as.character(ticks.x)
    ticks.trans<-if (power !=0) ticks.x^power else log(ticks.x, base)
    axis(side, labels = ticks.text, at = ticks.trans, las=las)
    if (grid & (side %% 2 == 0)) abline(h=ticks.trans, lty=grid.lty, col=grid.col)
    if (grid & (side %% 2 == 1)) abline(v=ticks.trans, lty=grid.lty, col=grid.col)
    mtext(axis.title, side = side, line = 3, cex = cex)
    }

box.cox.axis<-function(power, side=c("right", "above", "left", "below"), 
    at, grid=FALSE, grid.col=gray(.50), grid.lty=3,
    axis.title = "Untransformed Data", cex = 1, las=par("las")) {
    # last modified 20 Feb 2002 by J. Fox
    inverse.power<-function(x,p){
        if (p==0) exp(x)
        else (1+p*x)^(1/p)
        }
    side<-if(is.numeric(side)) side 
        else which(match.arg(side)==c("below", "left", "above", "right"))
    axp<-if (side %% 2 == 1) par("xaxp") else par("yaxp")
    ticks<-nice(seq(from=axp[1], to=axp[2], length=axp[3]+1))
    ticks.x<- if (power !=0) nice(inverse.power(ticks[ticks>0], power))
        else nice(inverse.power(ticks, 0))
    ticks.x <- if (missing(at)) ticks.x
        else at
    ticks.text <- as.character(ticks.x)
    ticks.trans<-box.cox(ticks.x,power)
    axis(side, labels = ticks.text, at = ticks.trans, las=las)
    if (grid & (side %% 2 == 0)) abline(h=ticks.trans, lty=grid.lty, col=grid.col)
    if (grid & (side %% 2 == 1)) abline(v=ticks.trans, lty=grid.lty, col=grid.col)
    mtext(axis.title, side = side, line = 3, cex = cex)
    }


# function to add a right or top probability axis to a plot of logits

prob.axis<-function(at, side=c("right", "above", "left", "below"),
    grid=FALSE, grid.lty=3, grid.col=gray(.50),
    axis.title = "Probability", interval = 0.1, cex = 1, las=par("las"))
{
    # last modified 20 Feb 2002 by J. Fox
    side<-if(is.numeric(side)) side 
        else which(match.arg(side)==c("below", "left", "above", "right"))
    logit<-if (side %% 2 == 1) par("usr")[c(1,2)] else par("usr")[c(3,4)]
    fact <- 10^( - (floor(log(interval, 10))))
    p.min <- nice(1/(1 + exp( - logit[1])), direction="down")
    p.max <- nice(1/(1 + exp( - logit[2])), direction="up")
    tick.min <- max(interval, (floor(fact * p.min))/fact)
    tick.max <- min(1 - interval, (ceiling(fact * p.max))/fact)
    ticks.p <- seq(tick.min, tick.max, interval)
    if(p.min <= 0.05) ticks.p <- c(0.05, ticks.p)
    if(p.min <= 0.01) ticks.p <- c(0.01, ticks.p)
    if(p.max >= 0.95) ticks.p <- c(ticks.p, 0.95)
    if(p.max >= 0.99) ticks.p <- c(ticks.p, 0.99)
    ticks.p<-if (missing(at)) ticks.p else at
    ticks.text <- as.character(ticks.p)
    ticks.logit <- log(ticks.p/(1 - ticks.p))
    axis(side, labels = ticks.text, at = ticks.logit, las=las)
    if (grid & (side %% 2 == 0)) abline(h=ticks.logit, lty=grid.lty, col=grid.col)
    if (grid & (side %% 2 == 1)) abline(v=ticks.logit, lty=grid.lty, col=grid.col)
    mtext(axis.title, side = side, line = 3, cex = cex)
}
# last modified 2 Dec 2002 by J. Fox
# all of these functions are adapted from functions in the R base package

contr.Treatment <- function (n, base = 1, contrasts = TRUE) {
    if (is.numeric(n) && length(n) == 1) 
        levs <- 1:n
    else {
        levs <- n
        n <- length(n)
    }
    lev.opt <- getOption("decorate.contrasts")
    pre <- if (is.null(lev.opt)) "[" else lev.opt[1]
    suf <- if (is.null(lev.opt)) "]" else lev.opt[2]
    dec <- getOption("decorate.contr.Treatment")
    dec <- if (!contrasts) ""
           else if (is.null(dec)) "T." 
           else dec
    contr.names <- paste(pre, dec, levs, suf, sep="")
    contr <- array(0, c(n, n), list(levs, contr.names))
    diag(contr) <- 1
    if (contrasts) {
        if (n < 2) 
            stop(paste("Contrasts not defined for", n - 1, "degrees of freedom"))
        if (base < 1 | base > n) 
            stop("Baseline group number out of range")
        contr <- contr[, -base, drop = FALSE]
    }
    contr
}

contr.Sum <- function (n, contrasts = TRUE) 
{
    if (length(n) <= 1) {
        if (is.numeric(n) && length(n) == 1 && n > 1) 
            levels <- 1:n
        else stop("Not enough degrees of freedom to define contrasts")
    }
    else levels <- n
    lenglev <- length(levels)
    lev.opt <- getOption("decorate.contrasts")
    pre <- if (is.null(lev.opt)) "[" else lev.opt[1]
    suf <- if (is.null(lev.opt)) "]" else lev.opt[2]
    dec <- getOption("decorate.contr.Sum")
    dec <- if (!contrasts) ""
           else if (is.null(dec)) "S." 
           else dec
    show.lev <- getOption("contr.Sum.show.levels")
    contr.names <- if ((is.null(show.lev)) || show.lev) paste(pre, dec, levels, suf, sep="")
    if (contrasts) {
        cont <- array(0, c(lenglev, lenglev - 1), list(levels, 
            contr.names[-lenglev]))
        cont[col(cont) == row(cont)] <- 1
        cont[lenglev, ] <- -1
    }
    else {
        cont <- array(0, c(lenglev, lenglev), list(levels,
            contr.names))
        cont[col(cont) == row(cont)] <- 1
    }
    cont
}


contr.Helmert <- function (n, contrasts = TRUE) 
{
    if (length(n) <= 1) {
        if (is.numeric(n) && length(n) == 1 && n > 1) 
            levels <- 1:n
        else stop("contrasts are not defined for 0 degrees of freedom")
    }
    else levels <- n
    lenglev <- length(levels)
    lev.opt <- getOption("decorate.contrasts")
    pre <- if (is.null(lev.opt)) "[" else lev.opt[1]
    suf <- if (is.null(lev.opt)) "]" else lev.opt[2]
    dec <- getOption("decorate.contr.Helmert")
    dec <- if (!contrasts) ""
           else if (is.null(dec)) "H." 
           else dec
    nms <- if (contrasts) 1:lenglev else levels
    contr.names <- paste(pre, dec, nms, suf, sep="")
    if (contrasts) {
        cont <- array(-1, c(lenglev, lenglev - 1), list(levels, 
            contr.names[-lenglev]))
        cont[col(cont) <= row(cont) - 2] <- 0
        cont[col(cont) == row(cont) - 1] <- 1:(lenglev - 1)
    }
    else {
        cont <- array(0, c(lenglev, lenglev), list(levels, contr.names))
        cont[col(cont) == row(cont)] <- 1
    }
    cont
}
# Ellipses (J. Fox and G. Monette)

# last modified 19 Sept 02 by J. Fox

ellipse<-function(center, shape, radius, center.pch=19, center.cex=1.5, segments=51, add=TRUE, 
        xlab="", ylab="", las=par("las"), col=palette()[2], lwd=2, lty=1, ...) {
    # last modified 20 Feb 2002 by J. Fox
    if (! (is.vector(center) && 2==length(center))) stop("center must be a vector of length 2")
    if (! (is.matrix(shape) && all(2==dim(shape)))) stop("shape must be a 2 by 2 matrix")
    angles <- (0:segments)*2*pi/segments 
    unit.circle <- cbind(cos(angles),sin(angles)) 
    ellipse <- t( center + radius * t( unit.circle %*% chol( shape ) ) ) 
    if (add) lines(ellipse, col=col, lwd=lwd, lty=lty, ...) 
    else plot(ellipse, xlab = xlab, ylab = ylab, type ="l", col=col, 
        lwd=lwd, lty=lty, las=las, ... ) 
    if (center.pch) points(center[1],center[2],pch=center.pch,cex=center.cex,col=col)
}

data.ellipse<-function(x, y, levels=c(0.5, 0.9), center.pch=19, center.cex=1.5,
        plot.points=TRUE, add=!plot.points, segments=51, robust=FALSE,
        xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), 
        las=par("las"), col=palette()[2], pch=1, lwd=2, lty=1, ...) {
    # last modified 20 Feb 2002 by J. Fox
    if(missing(y)){
        if(is.matrix(x) && ncol(x)==2) {
            if (missing(xlab)) xlab<-colnames(x)[1]
            if (missing(ylab)) ylab<-colnames(x)[2]
            y<-x[,2]
            x<-x[,1]
            }
        else stop("x and y must be vectors, or x must be a 2 column matrix")
        }
    else if(! (is.vector(x) && is.vector(y) && length(x)==length(y)))
        stop("x and y must be vectors of the same length")
    if (plot.points & !add) plot(x, y, xlab=xlab, ylab=ylab, col=col, pch=pch, las=las, ...)
    if (plot.points & add) points(x, y, col=col, pch=pch, ...)
    dfn<-2
    dfd<-length(x)-1
    if (robust) {
        require(MASS)
        v<-cov.trob(cbind(x,y))
        shape<-v$cov
        center<-v$center
        }
    else {
        shape<-var(cbind(x,y))
        center<-c(mean(x), mean(y))
        }
    for (level in levels) {
        radius <- sqrt ( dfn * qf(level, dfn, dfd ))
        ellipse(center, shape, radius, 
            center.pch=center.pch, center.cex=center.cex, segments=segments, 
            col=col, lty=lty, lwd=lwd, ...)
        }
    }

confidence.ellipse<-function (model, ...) {
    UseMethod("confidence.ellipse")
    }
    
confidence.ellipse.lm<-function(model, which.coef, levels=0.95, Scheffe=FALSE, 
        center.pch=19, center.cex=1.5, segments=51, xlab, ylab, 
        las=par("las"), col=palette()[2], lwd=2, lty=1, ...){
    # last modified 20 Feb 2002 by J. Fox
    which.coef<-if(length(coefficients(model)) == 2) c(1,2)
                else{
                    if (missing(which.coef)){
                        if (has.intercept(model)) c(2,3) else c(1,2)
                        } else which.coef
                    }
    coef<-coefficients(model)[which.coef]
    xlab<-if (missing(xlab)) paste(names(coef)[1], "coefficient")
    ylab<-if (missing(ylab)) paste(names(coef)[2], "coefficient")
    dfn<-if (Scheffe) sum(df.terms(model)) else 2
    dfd<-df.residual(model)
    shape<-vcov(model)[which.coef, which.coef]
    for (level in rev(sort(levels))){
        radius<-sqrt(dfn*qf(level, dfn, dfd))
        add<-!level==max(levels)
        ellipse(coef, shape, radius, add=add, xlab=xlab, ylab=ylab,
            center.pch=center.pch, center.cex=center.cex, segments=segments, 
            col=col, lwd=lwd, lty=lty, las=las, ...)
        }
    }


confidence.ellipse.glm<-function(model, which.coef, levels=0.95, Scheffe=FALSE, 
        center.pch=19, center.cex=1.5, segments=51, xlab, ylab,
        las=par("las"), col=palette()[2], lwd=2, lty=1, ...){
    # last modified 20 Feb 2002 by J. Fox
    which.coef<-if(length(coefficients(model)) == 2) c(1,2)
                else{
                    if (missing(which.coef)){
                        if (has.intercept(model)) c(2,3) else c(1,2)
                        } else which.coef
                    }
    coef<-coefficients(model)[which.coef]
    xlab<-if (missing(xlab)) paste(names(coef)[1], "coefficient")
    ylab<-if (missing(ylab)) paste(names(coef)[2], "coefficient")
    df<-if (Scheffe) sum(df.terms(model)) else 2
    sumry<-summary(model, corr = FALSE)
    shape<-vcov(model)[which.coef, which.coef]
    for (level in rev(sort(levels))){
        radius<-sqrt(qchisq(level, df))
        add<-!level==max(levels)
        ellipse(coef, shape, radius, add=add, xlab=xlab, ylab=ylab,
            center.pch=center.pch, center.cex=center.cex, segments=segments,
            col=col, lwd=lwd, lty=lty, las=las, ...)
        }
    }
# Variance-Covariance matrices (J. Fox)

# last modified 9 Nov 02 by J. Fox

Var<-function(object, ...){
    UseMethod("Var")
    }
    
Var.lm<-function(object, diagonal=FALSE, ...){
    summary<-summary(object, corr=FALSE)
    V<-(summary$sigma^2)*summary$cov.unscaled
    if (diagonal) diag(V) else V
    }
    
Var.glm<-function(object, diagonal=FALSE, ...){
    summary<-summary(object, corr = FALSE)
    V<-summary$dispersion*summary$cov.unscaled
    if (diagonal) diag(V) else V
    }

Var.default<-function(object, diagonal=FALSE, ...){
    # last modified 12 Dec 2000 by J. Fox
    V<-var(object, ...)
    if (diagonal) diag(V) else V
    }

    
# Added-Variable plots (J. Fox)

# last modified 31 Jan 04 by J. Fox

avp<-function(...) av.plots(...)

av.plots<-function(model, variable, ask=missing(variable), one.page=!ask, ...){
    # last modified 23 Apr 2001 by J. Fox
    if (!missing(variable)){
        var<-if (is.character(variable) & 1==length(variable)) variable
            else deparse(substitute(variable))
        av.plot(model, var, ...)
        }
    else {
        vars<-colnames(model.matrix(model))
        if (ask) {
            repeat{
                selection<-menu(vars)
                if (selection==0) break
                else var<-vars[selection]
                av.plot(model, var, ...)
                }
            }
        else {
            if (one.page){
                save.mfrow <- par(mfrow=mfrow(length(vars)))
                on.exit(par(mfrow=save.mfrow))
                }
            for (var in vars) av.plot(model, var, ...)
            }
        }
    }


av.plot<-function (model, ...) {
    UseMethod("av.plot")
    }

av.plot.lm<-function(model, variable, labels=names(residuals(model)[!is.na(residuals(model))]), 
    identify.points=TRUE, las=par('las'), col=palette()[2], pch=1, lwd=2, main="Added-Variable Plot", ...){
    #last modified 20 Feb 2002 by J. Fox
    variable<-if (is.character(variable) & 1==length(variable)) variable
        else deparse(substitute(variable))
    mod.mat<-model.matrix(model)
    var.names<-colnames(mod.mat)
    var<-which(variable==var.names)
    if (0==length(var)) stop(paste(variable,"is not a column of the model matrix."))
    response<-response(model)
    responseName<-responseName(model)
    if (is.null(weights(model))) wt<-rep(1, length(response))
        else wt<-weights(model)
    res<-lsfit(mod.mat[,-var], cbind(mod.mat[,var], response), wt=wt,    
        intercept=FALSE)$residuals
    plot(res[,1], res[,2], xlab=paste(var.names[var],"| others"), 
        ylab=paste(responseName," | others"), main=main, las=las, col=col, pch=pch)
    abline(lsfit(res[,1], res[,2], wt=wt), col=col, lwd=lwd)
    if (identify.points) identify(res[,1], res[,2], labels)
    }


av.plot.glm<-function(model, variable, labels=names(residuals(model)[!is.na(residuals(model))]), 
    identify.points=TRUE, las=par("las"), col=palette()[2], pch=1, lwd=2, main="Added-Variable Plot",
    type=c("Wang", "Weisberg"), ...){
    #last modified 20 Feb 2002 by J. Fox
    type<-match.arg(type)
    variable<-if (is.character(variable) & 1==length(variable)) variable
        else deparse(substitute(variable))
    mod.mat<-model.matrix(model)
    var.names<-colnames(mod.mat)
    var<-which(variable==var.names)
    if (0==length(var)) stop(paste(variable,"is not a column of the model matrix."))
    response<-response(model)
    responseName<-responseName(model)
    wt<-model$prior.weights
    mod<-glm(response~mod.mat[,-var]-1, weights=wt, family=family(model))
    res.y<-residuals(mod, type="pearson")
    wt<-if (type=="Wang") wt*model$weights else wt
    res.x<-lsfit(mod.mat[,-var], mod.mat[,var], wt=wt,    
        intercept=FALSE)$residuals
    plot(res.x, res.y, xlab=paste(var.names[var],"| others"), 
        ylab=paste(responseName," | others"), main=main, las=las, col=col, pch=pch)
    abline(lsfit(res.x, res.y, wt=wt), col=col, lwd=lwd)
    if (identify.points) identify(res.x, res.y, labels)
    }
# Box-Cox power transformations, with automatic start (J. Fox)

# last modified 2 April 02 by J. Fox

bc<-function(x,p) box.cox(x,p)

box.cox<-function(x,p, start=0){
    # last modified 15 Dec 2000 by J. Fox
    min<-min(x, na.rm=TRUE)
    s<-if (missing(start) & (min <= 0)) nice(-min +.05*diff(quantile(x,c(.25,.75), na.rm=TRUE)), "up")
        else start
    if (missing(start) & s != 0) warning(paste("start = ", s, "added to data prior to transformation"))
    x<-x+s
    if (p==0) log(x)
        else (x^p-1)/p
    }
# multivariate unconditional Box-Cox transformations (J. Fox)

# last modified 15 April 03 by J. Fox
# (with bug fixes by S. Weisberg)

box.cox.powers<-function(X, start=NULL, hypotheses=NULL, ...){
    modified.power<-function(x, lambda, gm){
        if (lambda == 0) log(x)*gm
        else (gm^(1-lambda))*((x^lambda)-1)/lambda
        }
    neg.kernel.profile.logL<-function(X, lambda, gm){
        for (j in 1:ncol(X)){
            X[,j]<-modified.power(X[,j],lambda[j],gm[j])
            }
        (nrow(X)/2)*log(((nrow(X)-1)/nrow(X))*det(var(X)))
        }
    univ.neg.kernel.logL <- function(x, lambda, gm){
        x <- modified.power(x, lambda, gm)
        (length(x)/2)*log(((length(x)-1)/length(x))*var(x))
        }
    X<-as.matrix(X)
    nc <- ncol(X)
    if(any(X<=0)) stop("All values must be > 0")
    gm<-apply(X, 2, function(x) exp(mean(log(x))))
    if (is.null(start)) {
        start <- rep(1, nc)
        for (j in 1:nc){
            res<- optimize(
                f = function(lambda) univ.neg.kernel.logL(x=X[,j], lambda=lambda, gm=gm[j]),
                lower=-50, upper=+50)
            start[j] <- res$minimum
            }
        }
    res<-optim(start, neg.kernel.profile.logL, hessian=TRUE, method="L-BFGS-B", X=X, gm=gm, ...)
    result<-list()
    result$start<-start
    result$criterion<-res$value
    result$names<-colnames(X)
    result$lambda<-res$par
    result$stderr<-diag(sqrt(inv(res$hessian)))
    result$LR0<-2*(neg.kernel.profile.logL(X,rep(0,nc),gm)-res$value)
    result$LR1<-2*(neg.kernel.profile.logL(X,rep(1,nc),gm)-res$value)
    if (!is.null(hypotheses)) {
        for (i in 1:length(hypotheses)){
            if (length(hypotheses[[i]]) != nc) 
                stop(paste("hypothesis", i, "that powers =", hypotheses[[i]], "does not have", nc, "values"))
            hypotheses[[i]] <- list(test=2*(neg.kernel.profile.logL(X,hypotheses[[i]],gm)-res$value),
                hypothesis=hypotheses[[i]])
            }
        result$hypotheses <- hypotheses
        }
    result$return.code<-res$convergence
    if(result$return.code != 0) 
        warning(paste("Convergence failure: return code =",
            result$return.code))
    class(result)<-"box.cox.powers"
    result
    }
      
summary.box.cox.powers<-function(object, digits=4, ...){
    one<-1==length(object$lambda)
    cat(paste("Box-Cox", (if(one) "Transformation to Normality" else "Transformations to Multinormality"),"\n\n"))
    lambda<-object$lambda
    stderr<-object$stderr
    df<-length(lambda)
    result<-cbind(lambda,stderr,lambda/stderr,(lambda-1)/stderr)
    rownames(result)<-object$names
    colnames(result)<-c("Est.Power","Std.Err.",
        "Wald(Power=0)","Wald(Power=1)")
    if (one)rownames(result)<-""
    print(round(result,digits))
    cat(paste("\nL.R. test,", (if(one) "power" else "all powers"), "= 0: ",round(object$LR0,digits),"  df =",df,
        "  p =",round(1-pchisq(object$LR0,df),digits)))
    cat(paste("\nL.R. test,", (if(one) "power" else "all powers"), "= 1: ",round(object$LR1,digits),"  df =",df,
        "  p =",round(1-pchisq(object$LR1,df),digits),"\n"))
    if (!is.null(object$hypotheses)) {
        for (i in 1:length(object$hypotheses)){
            cat(paste("L.R. test, ", (if(one) "power " else "powers "), "= ", 
                paste(object$hypotheses[[i]]$hypothesis,collapse=" "),
                ":  ", round(object$hypotheses[[i]]$test,digits),"   df = ",df,
                "   p = ",round(1-pchisq(object$hypotheses[[i]]$test,df),digits),"\n", sep=""))
            }
        }
    invisible(object)
    }

print.box.cox.powers <- function(x, ...){
    lambda <- x$lambda
    names(lambda) <- x$names
    print(lambda)
    invisible(x)
    }
# constructed variable for Box-Cox transformation (J. Fox)

# last modified 2 April 02 by J. FOx

box.cox.var<-function(y) {
    geo.mean<-exp(mean(log(y),na.rm=TRUE))
    y*(log(y/geo.mean) - 1)
    }
# Box-Tidwell transformations (J. Fox)

# last modified 2 April 02 by J. Fox

box.tidwell<-function(y, ...){
    UseMethod("box.tidwell")
    }

box.tidwell.formula<-function(formula, other.x=NULL, data=NULL, subset, na.action=options()$na.action, 
    verbose=FALSE, tol=.001, max.iter=25, ...) {
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, sys.frame(sys.parent())))) 
        m$data <- as.data.frame(data)
    m$formula<-if (is.null(other.x)) formula
        else as.formula(paste(formula[2], "~", formula[3], "+", other.x[2]))
    m$max.iter<-m$tol<-m$verbose<-m$family<-m$other.x <- m$... <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.frame(sys.parent()))
    response <- attr(attr(mf, "terms"), "response")
    if (!response) stop(paste("No response variable in model."))
    X1<-model.matrix(formula, data=mf)[,-1]
    X2<-if (is.null(other.x)) NULL
        else model.matrix(other.x, data=mf)[,-1]
    y<-model.response(mf, "numeric")
    box.tidwell.default(y, X1, X2, max.iter=max.iter, tol=tol, verbose=verbose, ...)
    }

box.tidwell.default<-function(y, x1, x2=NULL, max.iter=25, tol=.001, verbose=FALSE, ...) {
    # last modified 19 Sept 02 by J. Fox
    x1<-as.matrix(x1)
    var.names<-if(is.null(colnames(x1))) 1:ncol(x1) else colnames(x1)
    k.x1<-length(var.names)
    x.log.x<-x1*log(x1)
    mod.1<-lm(y~cbind(x1, x2), ...)
    mod.2<-lm(y~cbind(x.log.x, x1, x2), ...)
    sumry<-summary(mod.2)
    seb<-sqrt(diag(vcov(mod.2)))
    t.vals<-((coefficients(mod.2))/seb)[2:(1+k.x1)]
    initial<-powers<-1+coefficients(mod.2)[2:(1+k.x1)]/coefficients(mod.1)[2:(1+k.x1)]
    pvalues<-2*(1-pnorm(abs(t.vals)))
    iter<-0
    last.powers<-1
    while ( (max(abs((powers-last.powers)/(powers+tol))) > tol) &
        (iter <= max.iter) ) {
        iter<-iter+1
        x1.p<-x1^matrix(powers, nrow=nrow(x1), ncol=ncol(x1), byrow=TRUE)
        x.log.x<-x1.p*log(x1.p)
        mod.1<-lm(y~cbind(x1.p, x2), ...)
        mod.2<-lm(y~cbind(x.log.x, x1.p, x2), ...)
        last.powers<-powers
        powers<-powers * 
            (1+coefficients(mod.2)[2:(1+k.x1)]/coefficients(mod.1)[2:(1+k.x1)])
        if (verbose) cat(" iter =", iter, "    powers =", powers, "\n")
        }
    if (iter > max.iter) warning("maximum iterations exceeded")
    result<-rbind(initial,t.vals, pvalues, powers)
    rownames(result)<-c("Initial Power","Score Statistic","p-value","MLE of Power")
    colnames(result)<-names(powers)<-var.names
    result<-list(result=result, iterations=iter)
    class(result)<-"box.tidwell"
    result
    }

print.box.tidwell<-function(x, digits=5, ...){ 
    # last modified 15 Dec 2000 by J. Fox  
    print(round(x$result, digits))
    cat("\niterations = ", x$iterations,"\n")
    }
  
# CERES plots (J. Fox)

# last modified 31 Jan 04 by J. Fox

ceres.plots<-function(model, variable, ask=missing(variable), one.page=!ask, span=.5, ...){
    # last modified 2 Aug 2001 by J. Fox
    if(!is.null(class(model$na.action)) && 
        class(model$na.action) == 'exclude') class(model$na.action) <- 'omit'
    if (!missing(variable)){
        var<-if (is.character(variable) & 1==length(variable)) variable
            else deparse(substitute(variable))
        ceres.plot(model, var, ...)
        }
    else {
        vars<-predictor.names(model)
        vars<-if (is.null(model$contrasts)) vars
            else vars[sapply(model$contrasts[vars], is.null)]
        if (0==length(vars)) stop("No covariates to plot.")
        if (any(attr(terms(model),"order")>1)) {
            stop("ceres plots not available for models with interactions.")
            }
        if (ask) {
            repeat{
                selection<-menu(c(paste("Change span = ",span),vars))
                if (selection==0) break
                if (selection==1) {
                    span<-eval(parse(text=readline(prompt="span: ")))
                    if ((!is.numeric(span)) || length(span)>1 || span<0
                        || span>1) stop("Span must be between 0 and 1")
                    }
                else {
                    var<-vars[selection-1]
                    ceres.plot(model, var, span=span)
                    }
                }
            }
        else {
            if (one.page){
                save.mfrow <- par(mfrow=mfrow(length(vars)))
                on.exit(par(mfrow=save.mfrow))
                }
            for (var in vars){ 
                 ceres.plot(model, var, span=span, ...)
                 }
            }
        }
    }


ceres.plot<-function (model, ...) {
    UseMethod("ceres.plot")
    }

ceres.plot.lm<-function(model, variable, line=TRUE, smooth=TRUE, span=.5, iter, 
    las=par("las"), col=palette()[2], pch=1, lwd=2, main="Ceres Plot", ...){
    # the lm method works with glm's too
    # last modified 2 Nov 2002 by J. Fox
    expand.model.frame <- function (model, extras, envir = environment(formula(model)),
        na.expand = FALSE){  # modified version of R base function
        f <- formula(model)
        data <- eval(model$call$data, envir)
        ff <- foo ~ bar + baz
        if (is.call(extras)) 
            gg <- extras
        else gg <- parse(text = paste("~", paste(extras, collapse = "+")))[[1]]
        ff[[2]] <- f[[2]]
        ff[[3]][[2]] <- f[[3]]
        ff[[3]][[3]] <- gg[[2]]
        if (!na.expand) {
            naa <- model$call$na.action
            subset <- model$call$subset
            rval <- if (is.null(data)) eval(call("model.frame", ff, # modified
                subset = subset, na.action = naa), envir)           #  lines
            else eval(call("model.frame", ff, data = data,          #
                subset = subset, na.action = naa), envir)           #
            }
        else {
            subset <- model$call$subset
            rval <- eval(call("model.frame", ff, data = data, subset = subset, 
                na.action = I), envir)
            oldmf <- model.frame(model)
            keep <- match(rownames(oldmf), rownames(rval))
            rval <- rval[keep, ]
            class(rval) <- "data.frame"
            }
        return(rval)
        }
    if(!is.null(class(model$na.action)) && 
        class(model$na.action) == 'exclude') class(model$na.action) <- 'omit'
    if (missing(iter)){
        iter<-if(("glm"==class(model)[1]) &&
                 ("gaussian"!=as.character(family(model))[1]))
                0
                else 3
            }    # use nonrobust smooth for non-gaussian glm
    require(modreg)
    var<-if (is.character(variable) & 1==length(variable)) variable
        else deparse(substitute(variable))
    mod.mat<-model.matrix(model)
    obs<-names(residuals(model))
    all.obs<-if (is.null(model$call$data)) obs else row.names(eval(model$call$data))
    xx<-rep(NA, length(all.obs))
    names(xx)<-all.obs
    vars<-predictor.names(model)
    if (is.na(match(var, vars))) stop(paste(var,"is not in the model."))
    if (!is.null(model$contrasts[[var]])) stop(paste(var,"is a factor."))
    vars<-vars[-match(var,vars)]
    if (any(attr(terms(model),"order")>1)) {
        stop("ceres plot not available for models with interactions.")
        }
    .x<-xvars<-NULL
    for (xvar in vars){
        if (is.null(model$contrasts[[xvar]])){
            xvars<-c(xvars,xvar)
            xx[obs]<-fitted.values(loess(as.formula(paste("mod.mat[,'",xvar,"']~mod.mat[,'",var,"']",sep=""))))
            .x<-cbind(.x, xx)
            }
        }
    if (is.null(xvars)) stop("There are no covariates.")
    n.x<-length(xvars)
    mf<-na.omit(expand.model.frame(model, all.vars(formula(model))))
    rownames(.x)<-all.obs
    mf$.x<-.x[obs,]
    aug.model <- update(model, . ~ . + .x, data=mf)
    aug.mod.mat<-model.matrix(aug.model)
    coef<-coefficients(aug.model)
    k<-length(coef)
    posn<-k:(k-n.x+1)
    partial.res<-residuals.glm(aug.model, "partial")[,var] +
        aug.mod.mat[,posn] %*% as.matrix(coef[posn])
    plot(mod.mat[,var], partial.res, xlab=var, col=col, pch=pch,
        ylab=paste("CERES Residual(",responseName(model),")", sep=""),
        main=main, las=las)
    if (line) abline(lm(partial.res~mod.mat[,var]), lty=2, lwd=lwd, col=col)
    if (smooth) {
        lines(lowess(mod.mat[,var], partial.res, iter=iter, f=span), lwd=lwd, col=col)
        }
    }                    

ceres.plot.glm<-function(model, ...){
  # last modified 14 Dec 2000
  ceres.plot.lm(model, ...)
  }
# Cook's Distance (J. Fox)

# last modified 27 Mar 03 by J. Fox

cookd <- function(model, ...) cooks.distance(model, ...)
# Component + Residual Plots (J. Fox)

# last modified 31 Jan 04 by J. Fox

crp<-function(...) cr.plots(...)

cr.plots<-function(model, variable, ask=missing(variable), one.page=!ask, span=.5, ...){
    # last modified 2 Aug 2001 by J. Fox
    if(!is.null(class(model$na.action)) && 
        class(model$na.action) == 'exclude') class(model$na.action) <- 'omit'
    if (!missing(variable)){
        var<-if (is.character(variable) & 1==length(variable)) variable
            else deparse(substitute(variable))
        cr.plot(model, var, ...)
        }
    else {
        vars<-predictor.names(model)
        if (0==length(vars)) stop("No covariates to plot.")
        else if (ask) {
            repeat{
                selection<-menu(c(paste("Change span = ",span),vars))
                if (selection==0) break
                if (selection==1) {
                    span<-eval(parse(text=readline(prompt="span: ")))
                    if ((!is.numeric(span)) || length(span)>1 || span<0
                        || span>1) stop("Span must be between 0 and 1")
                    }
                else {
                    var<-vars[selection-1]
                    cr.plot(model, var, span=span, ...)
                    }
                }
            }
        else {
            if (one.page){
                save.mfrow <- par(mfrow=mfrow(length(vars)))
                on.exit(par(mfrow=save.mfrow))
                    }
            for (var in vars){ 
                 cr.plot(model, var, span=span, ...)
                }
            }
        }
    }
    
    
cr.plot<-function (model, ...) {
    UseMethod("cr.plot")
    }


cr.plot.lm<-function(model, variable, order=1, line=TRUE, smooth=TRUE,
    iter, span=.5, las=par("las"), col=palette()[2], pch=1, lwd=2,
    main="Component+Residual Plot", ...) {
    # last modified 20 Feb 2002 by J. Fox
    # method also works for glm objects
    if(!is.null(class(model$na.action)) && 
        class(model$na.action) == 'exclude') class(model$na.action) <- 'omit'
    var<-if (is.character(variable) & 1==length(variable)) variable
        else deparse(substitute(variable))
    vars<-predictor.names(model)
    if (is.na(match(var, vars))) stop(paste(var,"is not in the model."))
    if (any(attr(terms(model),"order")>1)) {
        stop("C+R plots not available for models with interactions.")
        }
    if (!is.null(model$contrasts[[var]])){
        partial.res<-residuals.glm(model,"partial")
        .x<-model.frame(model)[,var]
        boxplot(partial.res[,var]~.x, xlab=var,
            ylab=paste("Component+Residual(", responseName(model),")", sep=""),
            main=main)
        return(invisible())
        }
    if (missing(iter)){
        iter<-if(("glm"==class(model)[1]) &&
                 ("gaussian"!=as.character(family(model))[1]))
                0
                else 3
            }    # use nonrobust smooth for non-gaussian glm
    .x<-if (df.terms(model, var)>1) predict(model, type="terms", term=var)
        else model.matrix(model)[,var]
    if (order==1){          # handle first-order separately for efficiency
        partial.res<-residuals.glm(model,"partial")
        plot(.x, partial.res[,var], xlab=var, 
            ylab=paste("Component+Residual(", responseName(model),")", sep=""),
            las=las, col=col, pch=pch, main=main)
        if (line) abline(lm(partial.res[,var]~.x), lty=2, lwd=lwd, col=col)
        if (smooth) {
            lines(lowess(.x, partial.res[,var], iter=iter, f=span), lwd=lwd, col=col)
            }
        }
        else {
            if (df.terms(model, var)>1) 
               stop(paste("Order", order, "C+R plot not available for a term with > 1 df:", var))
            aug.model<-update(model, 
                as.formula(paste(".~.-",var,"+poly(",var,",",order,")")))
            partial.res<-residuals.glm(aug.model, "partial")
            last<-ncol(partial.res)
            plot(.x, partial.res[,last], xlab=var, 
                ylab=paste("Component+Residual(", responseName(model),")", sep=""),
                las=las, col=col, pch=pch, main=main)
            if (line) abline(lm(partial.res[,last]~.x), lty=2, lwd=lwd, col=col)
            if (smooth) {
                lines(lowess(.x, partial.res[,last], iter=iter, f=span), lwd=lwd, col=col)
                }
            }          
    }

cr.plot.glm<-function(model, ...){
  # last modified 14 Dec 2000 by J. Fox
  cr.plot.lm(model, ...)
 }
# generalized Durbin-Watson statistic (J. Fox)

# last modified 9 Nov 02 by J. Fox

durbin.watson <- function(model, ...){
  UseMethod("durbin.watson")
  }

durbin.watson.lm <- function(model, max.lag=1, simulate=TRUE, reps=1000, 
    method=c("resample","normal"), 
    alternative=c("two.sided", "positive", "negative"), ...){
    method<-match.arg(method)
    alternative <- if (max.lag == 1) match.arg(alternative)
        else "two.sided"
    residuals<-residuals(model)
    if (any(is.na(residuals))) stop ('residuals include missing values')
    n<-length(residuals)
    r<-dw<-rep(0, max.lag)
    den<-sum(residuals^2)
    for (lag in 1:max.lag){
        dw[lag]<-(sum((residuals[(lag+1):n] - residuals[1:(n-lag)])^2))/den
        r[lag]<-(sum(residuals[(lag+1):n]*residuals[1:(n-lag)]))/den
        }
    if (!simulate){
        result<-list(r=r, dw=dw)
        class(result)<-"durbin.watson"
        result
        }
        else {
            S<-summary(model)$sigma
            X<-model.matrix(model)
            mu<-fitted.values(model)
            Y<-if (method == "resample") 
                matrix(sample(residuals, n*reps, replace=TRUE), n, reps) + matrix(mu, n, reps)
                else matrix(rnorm(n*reps, 0, S), n, reps) + matrix(mu, n, reps)
            E<-residuals(lm(Y~X-1))
            DW<-apply(E, 2, durbin.watson, max.lag=max.lag)
            if (max.lag == 1) DW <- rbind(DW)
            p<-rep(0, max.lag)
            if (alternative == 'two.sided'){
                for (lag in 1:max.lag) {
                    p[lag] <- (sum(dw[lag] < DW[lag,]))/reps
                    p[lag] <- 2*(min(p[lag], 1-p[lag]))
                    }
                }
            else if (alternative == 'positive'){
                for (lag in 1:max.lag) {
                    p[lag] <- (sum(dw[lag] > DW[lag,]))/reps
                    }
                }
            else {
                for (lag in 1:max.lag) {
                    p[lag] <- (sum(dw[lag] < DW[lag,]))/reps
                    }
                }
            result<-list(r=r, dw=dw, p=p, alternative=alternative)
            class(result)<-"durbin.watson"
            result
            }
    }

durbin.watson.default<-function(model, max.lag=1, ...){
    # in this case, "model" is the residual vectors
    if ( (!is.vector(model)) || (!is.numeric(model)) ) stop("requires vector of residuals")
    if (any(is.na(model))) stop ('residuals include missing values')
    n<-length(model)
    dw<-rep(0, max.lag)
    den<-sum(model^2)
    for (lag in 1:max.lag){
        dw[lag]<-(sum((model[(lag+1):n] - model[1:(n-lag)])^2))/den
        }
    dw
    }
    
print.durbin.watson<-function(x, ...){
    max.lag<-length(x$dw)
    result<- if (is.null(x$p)) cbind(lag=1:max.lag,Autocorrelation=x$r, "D-W Statistic"=x$dw)
            else cbind(lag=1:max.lag,Autocorrelation = x$r, "D-W Statistic" = x$dw, 
                  "p-value"= x$p)
    rownames(result)<-rep("", max.lag)
    print(result)
    cat(paste(" Alternative hypothesis: rho", if(max.lag > 1) "[lag]" else "",
        c(" != ", " > ", " < ")[which(x$alternative == c("two.sided", "positive", "negative"))],
        "0\n", sep=""))
    invisible(x)
    }
# Heteroscedasticity-corrected standard errors (White adjustment) (J. Fox)

hccm<-function(model, ...){
    #last modified 12 Dec 2000 by J. Fox
    UseMethod("hccm")
    }
 
hccm.lm<-function(model, type=c("hc3", "hc0", "hc1", "hc2", "hc4"), ...) {
    #last modified 6 Feb 2003 by J. Fox
    if (!is.null(weights(model))) stop("requires unweighted lm")
    type <- match.arg(type)
    sumry <- summary(model, corr = FALSE)
    s2 <- sumry$sigma^2
    V <- sumry$cov.unscaled
    if (type == FALSE) return(s2*V)
    e <- na.omit(residuals(model))
    X <- model.matrix(model)
    df.res <- df.residual(model)
    n <- length(e)
    h <- hat(X)
    p <- ncol(X)
    factor<-switch(type,
        hc0=1,
        hc1=df.res/n,
        hc2=1 - h,
        hc3=(1 - h)^2,
        hc4=(1 - h)^pmin(4, n*h/p))
    V %*% t(X) %*% apply(X, 2, "*", (e^2)/factor) %*% V
    }
    
hccm.default<-function(model, ...){
    #last modified 12 Dec 2000 by J. Fox
    stop("requires an lm object")
    }
# Leverage plots (J. Fox)

# last modified 31 Jan 04 by J. Fox

leverage.plots<-function(model, term.name, ask=missing(term.name), ...){
    # last modified 19 Dec 2000 by J. Fox
    if (!missing(term.name)){
        var<-if (is.character(term.name) & 1==length(term.name)) term.name
            else deparse(substitute(term.name))
        leverage.plot(model, term.name, ...)
        }
    else {
        term.names<-term.names(model)
        if (ask) {
            repeat{
                selection<-menu(term.names)
                if (selection==0) break
                else term.name<-term.names[selection]
                leverage.plot(model, term.name, ...)
                }
            }
        else {
            for (term.name in term.names) leverage.plot(model, term.name, ...)
            }
        }
    }


leverage.plot<-function (model, ...) {
    UseMethod("leverage.plot")
    }

leverage.plot.lm<-function(model, term.name, 
    labels=names(residuals(model)[!is.na(residuals(model))]), 
    identify.points=TRUE, las=par("las"), col=palette()[2], pch=1, lwd=2, main="Leverage Plot", ...){
    # last modified 19 Sept 2002
    term.name<-if (is.character(term.name) & 1==length(term.name)) term.name
        else deparse(substitute(term.name))
    b<-coefficients(model)
    e<-na.omit(residuals(model))
    p<-length(b)
    I.p<-diag(p)
    term.names<-term.names(model)
    term<-which(term.name==term.names)
    if (0==length(term)) stop(paste(term.name,"is not a term in the model."))
    responseName<-responseName(model)
    intercept<-has.intercept(model)
    assign<-model$assign
    X<-model.matrix(model)
    V<-vcov(model)
    wt<-if (is.null(weights(model))) rep(1, length(X[,1]))
        else weights(model)
    subs<-which(assign==term-intercept)
    hypothesis.matrix<-I.p[subs,]
    L<-if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix)
        else hypothesis.matrix
    u<-inv(L %*% V %*% t(L)) %*% L %*% b
    v.x<-X %*% V %*% t(L) %*% u
    v.y<-v.x + e
    plot(v.x, v.y, xlab=paste(term.names[term],"| others"), 
        ylab=paste(responseName," | others"), main=main,
        las=las, col=col, pch=pch)
    abline(lsfit(v.x, v.y, wt=wt), col=col, lwd=lwd)
    if (identify.points) identify(v.x, v.y, labels)
    }

leverage.plot.glm<-function(model, ...){
    # last modified 14 Dec 2000
    stop("leverage plot requires lm object")
    }
  
# Linear hypothesis tests for lm and glm (J. Fox)

# last modified 9 Nov 02

lht<-function(...) linear.hypothesis(...)

linear.hypothesis<-function (model, ...) {
    UseMethod("linear.hypothesis")
    }
    
linear.hypothesis.lm<-function(model, hypothesis.matrix, rhs=0, 
        summary.model=summary(model, corr = FALSE),
        white.adjust=FALSE, error.SS, error.df, ...) {
    # last modified by J.Fox 13 Dec 2000
    if (is.aliased(model)) stop ("One or more terms aliased in model.")
    s2<-if (missing(error.SS)) summary.model$sigma^2
        else error.SS/error.df
    V<-if (white.adjust==FALSE) summary.model$cov.unscaled
        else hccm(model, type=white.adjust)/s2
    b<-coefficients(model)
    L<-if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix)
        else hypothesis.matrix
    q<-nrow(L)
    SSH<-t(L %*% b - rhs) %*% inv(L %*% V %*% t(L)) %*% (L %*% b - rhs)
    f<-SSH/(q*s2)
    df<-if (missing(error.df)) model$df.residual
        else error.df
    p<-1-pf(f, q, df)
    result<-list(SSH=SSH[1,1], SSE=s2*df, f=f[1,1], Df=c(q, df), p=p[1,1])
    class(result)<-"F.test"
    result
    }

linear.hypothesis.glm<-function(model, hypothesis.matrix, rhs=0, 
        summary.model=summary(model, corr = FALSE), ...) {
    # last modified by J.Fox 13 Dec 2000
    if (is.aliased(model)) stop ("One or more terms aliased in model.")
    V<-summary.model$dispersion*summary.model$cov.unscaled
    b<-coefficients(model)
    L<-if (is.null(dim(hypothesis.matrix))) t(hypothesis.matrix)
        else hypothesis.matrix
    q<-nrow(L)
    Wald<-t(L %*% b - rhs) %*% inv(L %*% V %*% t(L)) %*% (L %*% b - rhs)
    p<-1-pchisq(Wald, q)
    result<-list(test="Wald Test",ChiSquare=Wald[1,1], Df=q, p=p[1,1])
    class(result)<-"chisq.test"
    result
    }
 

 print.chisq.test<-function(x, ...){
    title<-if (!is.null(x$test)) x$test else "Chisquare Test"
    cat(title,"\n")
    if (!is.null(x$formula)) cat(x$formula.name, 
        "formula:", as.character(x$formula), "\n")
    cat("Chisquare =", x$ChiSquare,"   Df =", x$Df,
        "    p =", x$p, "\n")
    invisible(x)
    }
 
 print.F.test<-function(x, ...){
    title<-if (!is.null(x$test)) x$test else "F-Test"
    cat(title,"\n")
    if (!is.null(x$formula)) cat(x$formula.name, 
        "formula:", as.character(x$formula), "\n")
    cat("SS =", x$SSH, "    SSE =", x$SSE, "    F =", x$f,
        " Df =", x$Df[1], "and", x$Df[2], "    p =", x$p, "\n")
    invisible(x)
    }
# logit transformation of proportion or percent (J. Fox)

# last modified 2 April 02

logit<-function(p, percents=max(p, na.rm=TRUE)>1, adjust){   
    if (percents) p<-p/100
    a<-if (missing(adjust)) {
        if (min(p, na.rm=TRUE)==0 | max(p, na.rm=TRUE)==1) .025 else 0
        }
        else adjust
    if (missing(adjust) & a != 0) warning(paste("Proportions remapped to (",
        a,",",1-a,")", sep=""))
    a<-1-2*a
    log((.50+a*(p-.50))/(1-(.50+a*(p-.50))))
    }
    
# number of bins for histogram by Freedman-Diaconis rule (J. Fox)

n.bins<-function(x, rule=c("freedman.diaconis","sturges","scott","simple")){
    #last modified 16 Dec 2000 by J. Fox
    rule<-match.arg(rule)
    x<-x[!is.na(x)]
    n<-length(x)
    Q<-quantile(x, c(.25,.75))
    X<-range(x)
    result<-switch(rule,
        freedman.diaconis=ceiling(n^(1/3)*(X[2]-X[1])/(2*(Q[2]-Q[1]))),
        sturges=ceiling(log(n,2)+1),
        scott=ceiling((X[2]-X[1])*(n^(1/3))/(3.5*sqrt(var(x)))),
        simple=floor(if (n > 100) 10*log(n,10) else 2*sqrt(n))
        )
    names(result)<-NULL
    result
    }
 
# score test of nonconstant variance (J. Fox)

# last modified 9 Nov 02 by J. Fox

ncv.test<-function(model, ...){
    # last modified 15 Dec 2000 by J. Fox
    UseMethod("ncv.test")
    }

ncv.test.lm<-function (model, var.formula, data=NULL, subset, na.action, ...) {
    # last modified 13 Nov 2001 by J. Fox
    if (!is.null(weights(model))) stop("requires unweighted linear model")
    if ((!is.null(class(model$na.action))) && class(model$na.action) == 'exclude') 
        model <- update(model, na.action=na.omit)
    sumry<-summary(model)
    residuals<-residuals(model)
    S.sq<-df.residual(model)*(sumry$sigma)^2/sum(!is.na(residuals))
    U<-(residuals^2)/S.sq
    if (missing(var.formula)) {
        mod<-lm(U~fitted.values(model))
        varnames<-"fitted.values"
        var.formula<-~fitted.values
        df<-1
        }
    else {
        if (missing(na.action)){
            na.action <- if (is.null(model$na.action)) options()$na.action
                else parse(text=paste('na.',class(mod$na.action), sep=''))
            }
        m <- match.call(expand.dots = FALSE)
        if (is.matrix(eval(m$data, sys.frame(sys.parent())))) 
            m$data <- as.data.frame(data)
        m$formula<-var.formula
        m$var.formula <- m$model <- m$... <- NULL
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, sys.frame(sys.parent()))
        response <- attr(attr(mf, "terms"), "response")
        if (response) stop(paste("Variance formula contains a response."))
        mf$U<-U
        .X<-model.matrix(as.formula(paste("U~",as.character(var.formula)[2],"-1")), data=mf)
        mod<-lm(U~.X)
        df<-sum(!is.na(coefficients(mod)))-1
        }
    SS<-anova(mod)$"Sum Sq"
    RegSS<-sum(SS)-SS[length(SS)]
    Chisq<-RegSS/2
    result<-list(formula=var.formula, formula.name="Variance", ChiSquare=Chisq, Df=df, 
        p=1-pchisq(Chisq, df), test="Non-constant Variance Score Test")
    class(result)<-"chisq.test"
    result
    }
    
ncv.test.glm<-function(model, ...){
    # last modified 15 Dec 2000 by J. Fox
    stop("requires lm object")
    }
# Bonferroni test for an outlier (J. Fox)

# last modified 29 Jan 04 by J. Fox

outlier.test<-function(model, ...){
    UseMethod("outlier.test")
    }

outlier.test.lm<-function(model, labels=names(rstud), ...){
    #last modified 13 Nov 2001 by J. Fox
    rstud<-abs(rstudent(model))
    labels<-if(is.null(labels)) seq(along=rstud) else labels
    if (length(rstud) != length(labels)) 
        stop("Number of labels does not correspond to number of residuals.")
    rstud.max<-max(rstud, na.rm=TRUE)
    which.max<-which(rstud==rstud.max)
    df<-df.residual(model)-1
    n<-sum(!is.na(rstud))
    p<-2*(1-pt(rstud.max,df))
    bp <- if (n*p <= 1) n*p else NA
    result<-c(rstud.max, df, p, bp)
    names(result)<-c("max|rstudent|", "df", "unadjusted p", "Bonferroni p")
    result<-list(test=result, obs=labels[which.max])
    class(result)<-"outlier.test"
    result
    }
    
outlier.test.glm<-function(model, labels=names(rstud), ...){
    #last modified 13 Nov 2001 by J. Fox
    rstud<-abs(rstudent(model))
    labels<-if(is.null(labels)) seq(along=rstud) else labels
    if (length(rstud) != length(labels)) 
        stop("Number of labels does not correspond to number of residuals.")
    rstud.max<-max(rstud, na.rm=TRUE)
    which.max<-which(rstud==rstud.max)
    n<-sum(!is.na(rstud))
    p<-2*(1-pnorm(rstud.max))
    bp <- if (n*p <= 1) n*p else NA
    result<-c(rstud.max, p, bp)
    names(result)<-c("max|rstudent|", "unadjusted p", "Bonferroni p")
    result<-list(test=result, obs=labels[which.max])
    class(result)<-"outlier.test"
    result
    }

    
print.outlier.test<-function(x, digits=options("digits")[[1]], ...){
    # last modified 29 Jan 2004 by J. Fox
    test<-signif(x$test, digits=digits)
    if (length(test) == 4){
        cat(paste("\nmax|rstudent| = ", test[1], ", degrees of freedom = ", test[2],
            ",\nunadjusted p = ", test[3], 
            ", Bonferroni p", if (is.na(test[4])) " > 1" else paste(" =", test[4]), "\n",
            sep=""))
        }
    else {
        cat(paste("\nmax|rstudent| = ", test[1],
            ",\nunadjusted p = ", test[2], 
            ", Bonferroni p", if (is.na(test[3])) " > 1" else paste(" =", test[3]), "\n",
            sep=""))
        }        
    if(length(x$obs)>1) cat("\nObservations:",x$obs,"\n")
      else cat("\nObservation:",x$obs,"\n")
    invisible(x)
    }
# panel function for use with coplot (J. Fox)

# last modified 2 April 02

panel.car<-function(x, y, col, pch, cex=1, span=.5, lwd=2,
    regression.line=lm, lowess.line=TRUE,...){
    # last modified 10 Dec 2001 by J. Fox
    points(x, y, col=col, pch=pch, cex=cex)
    if (is.function(regression.line)) reg.line(regression.line(y~x), 
        lty=2, lwd=lwd, col=col, ...)
    if (lowess.line) lines(lowess(na.omit(as.data.frame(cbind(x,y))), f=span), 
        col=col, lwd=lwd, ...)
    }
# Quantile-comparison plots (J. Fox)

# last modified 26 October 02 by J. Fox

qqp<-function(...) qq.plot(...)

qq.plot<-function(x, ...) {
    UseMethod("qq.plot")
    }
  
qq.plot.default<-function(x, distribution="norm", ylab=deparse(substitute(x)),
        xlab=paste(distribution, "quantiles"), main="", las=par("las"),
        envelope=.95, labels=FALSE, col=palette()[2], lwd=2, pch=1,
        line=c("quartiles", "robust", "none"), ...){
    # last modified 23 February 2003
    result <- NULL
    line<-match.arg(line)
    good<-!is.na(x)
    ord<-order(x[good])
    ord.x<-x[good][ord]
    q.function<-eval(parse(text=paste("q",distribution, sep="")))
    d.function<-eval(parse(text=paste("d",distribution, sep="")))
    n<-length(ord.x)
    P<-ppoints(n)
    z<-q.function(P, ...)
    plot(z, ord.x, xlab=xlab, ylab=ylab, main=main, las=las, col=col, pch=pch)
    if (line=="quartiles"){
        Q.x<-quantile(ord.x, c(.25,.75))
        Q.z<-q.function(c(.25,.75), ...)
        b<-(Q.x[2]-Q.x[1])/(Q.z[2]-Q.z[1])
        a<-Q.x[1]-b*Q.z[1]
        abline(a, b, col=col, lwd=lwd)
        }
    if (line=="robust"){
        if (!require("MASS")) stop("MASS package not available")
        coef<-coefficients(rlm(ord.x~z))
        a<-coef[1]
        b<-coef[2]
        abline(a,b)
        }
    if (line != 'none' & envelope != FALSE) {
        zz<-qnorm(1-(1-envelope)/2)
        SE<-(b/d.function(z, ...))*sqrt(P*(1-P)/n)
        fit.value<-a+b*z
        upper<-fit.value+zz*SE
        lower<-fit.value-zz*SE
        lines(z, upper, lty=2, lwd=lwd/2, col=col)
        lines(z, lower, lty=2, lwd=lwd/2, col=col)
        }
    if (labels[1]==TRUE & length(labels)==1) labels<-seq(along=z)
    if (labels[1] != FALSE) {
        selected<-identify(z, ord.x, labels[good][ord])
        result <- seq(along=x)[good][ord][selected]
        }
    if (is.null(result)) invisible(result) else sort(result)
    }
    
qq.plot.lm<-function(x, main="", xlab=paste(distribution, "Quantiles"),
    ylab=paste("Studentized Residuals(",deparse(substitute(x)),")",sep=""),
    distribution=c("t", "norm"), line=c("quartiles", "robust", "none"), las=par("las"),
    simulate=FALSE, envelope=.95, labels=names(rstudent), reps=100, 
    col=palette()[2], lwd=2, pch=1, ...){
    # last modified 23 Feb 2003
    result <- NULL
    distribution <- match.arg(distribution)
    line<-match.arg(line)
    rstudent<-rstudent(x)
    sumry <- summary.lm(x)
    res.df<-sumry$df[2]
    if(!simulate){
        if (distribution == 't')
            result <- qq.plot.default(rstudent, distribution='t', df=res.df-1, line=line,
                main=main, xlab=xlab, ylab=ylab, las=las, envelope=envelope, labels=labels, 
                col=col, lwd=lwd, pch=pch, ...)
        else
            result <- qq.plot.default(rstudent, distribution='norm', line=line,
                main=main, xlab=xlab, ylab=ylab, las=las, envelope=envelope, labels=labels, 
                col=col, lwd=lwd, pch=pch, ...) 
        }
    else {
        good <- !is.na(rstudent)
        n<-length(rstudent)
        rstudent <- na.omit(rstudent)
        ord<-order(rstudent)
        ord.x<-rstudent[ord]
        n<-length(ord)
        P<-ppoints(n)
        z<-if (distribution == 't') qt(P, df=res.df-1) else qnorm(P)
        plot(z, ord.x, xlab=xlab, ylab=ylab, main=main, las=las, pch=pch, col=col)
        yhat<-na.omit(fitted.values(x))
        S<-sumry$sigma
        Y<-matrix(yhat,n,reps)+matrix(rnorm(n*reps, sd=S),n,reps)
        X<-model.matrix(x)
        rstud<-apply(rstudent(lm(Y~X-1)),2,sort)
        lower<-apply(rstud,1,quantile,prob=(1-envelope)/2)
        upper<-apply(rstud,1,quantile,prob=(1+envelope)/2)
        lines(z, upper, lty=2, lwd=lwd/2, col=col)
        lines(z, lower, lty=2, lwd=lwd/2, col=col)
        if (line=="quartiles"){
            Q.x<-quantile(rstudent, c(.25,.75))
            Q.z <- if (distribution == 't') qt(c(.25,.75),df=res.df-1) else qnorm(c(.25,.75))
            b<-(Q.x[2]-Q.x[1])/(Q.z[2]-Q.z[1])
            a<-Q.x[1]-b*Q.z[1]
            abline(a, b, col=col, lwd=lwd)
            }
        if (line=="robust"){
            if (!require("MASS")) stop("MASS package not available")
            coef<-coefficients(rlm(ord.x~z))
            a<-coef[1]
            b<-coef[2]
            abline(a, b, col=col, lwd=lwd)
            }
        if (labels[1]==TRUE & length(labels)==1) labels<-seq(along=z)
        if (labels[1] != FALSE) {
            selected<-identify(z, ord.x, labels[ord])
            result <- (1:n)[good][ord][selected]
            }
        }
    if (is.null(result)) invisible(result) else sort(result)
    }
 
qq.plot.glm<-function(x, ...){
    stop("QQ plot for studentized residuals not available for glm")
    }
# recode function (J. Fox)
# last modified 2 April 2002

recode<-function(var, recodes, as.factor.result){
    recode.list<-rev(strsplit(gsub(" ","",recodes),";")[[1]])
    is.fac<-is.factor(var)
    if (missing(as.factor.result)) as.factor.result <- is.fac
    if (is.fac) var<-as.character(var)
    result<-var
    if (is.numeric(var)) {
        lo<-min(var, na.rm=TRUE)
        hi<-max(var, na.rm=TRUE)
        }
    for (term in recode.list){
        if (0<length(grep(":", term))) {
            range<-strsplit(strsplit(term, "=")[[1]][1],":")
            low<-eval(parse(text=range[[1]][1]))
            high<-eval(parse(text=range[[1]][2]))
            target<-eval(parse(text=strsplit(term, "=")[[1]][2]))
            result[(var>=low)&(var<=high)]<-target
            }
        else if (0<length(grep("else", term))) {
            target<-eval(parse(text=strsplit(term, "=")[[1]][2]))
            result[1:length(var)]<-target
            }
        else {
            set<-eval(parse(text=strsplit(term, "=")[[1]][1]))
            target<-eval(parse(text=strsplit(term, "=")[[1]][2]))
            for (val in set){
                if (is.na(val)) result[is.na(var)]<-target
                    else result[var==val]<-target
                }
            }
        }
    if (as.factor.result) result<-as.factor(result)
        else if (!is.numeric(result)) {
            result.valid <- na.omit(result)
            if (length(result.valid) == length(grep("[0-9]",result.valid)))
                result <- as.numeric(result)
            }
    result
    }
 
# draw regression line from model to extremes of fit (J. Fox)
 
reg.line<-function(mod, col=palette()[2], lwd=2, lty=1, ...){
    # last modified 2 Aug 2001 by J. Fox
    if(!is.null(class(mod$na.action)) && 
        class(mod$na.action) == 'exclude') class(mod$na.action) <- 'omit'
    coef<-coefficients(mod)
    if (length(coef) != 2) error(" Requires simple linear regression.")
    x<-model.matrix(mod)[,2]
    y<-fitted.values(mod)
    min<-which.min(x)
    max<-which.max(x)
    lines(c(x[min],x[max]),c(y[min],y[max]), col=col, lty=lty, lwd=lwd, ...)
    }
# fancy scatterplots  (J. Fox)

# last modified 15 July 2003

scatterplot<-function(x, ...){
    # last modified 28 Jan 2001 by J. Fox
    UseMethod("scatterplot", x)
    }
    
scatterplot.formula<-function (formula, data, xlab, ylab, subset, labels=FALSE, ...) {
    # last modified 6 Jan 2004 by J. Fox
    na.save <- options(na.action=na.omit)
    on.exit(options(na.save))
    na.pass<-function(dframe) dframe
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, sys.frame(sys.parent())))) 
        m$data <- as.data.frame(data)
    m$na.action <- na.pass
    m$labels <- NULL
    m$... <- NULL
    m$xlab <- m$ylab <- NULL
    m[[1]] <- as.name("model.frame")
    if (!inherits(formula, "formula") | length(formula) != 3) 
        stop("invalid formula")    
    formula<-as.character(c(formula))
    formula<-as.formula(sub("\\|", "+", formula))
    m$formula<-formula
    if (missing(data)){ 
        X <- na.omit(eval(m, parent.frame()))
        if (labels[1] != FALSE) labels<-labels[as.numeric(gsub("X","", row.names(X)))]
        }
    else{
        if (labels[1] != FALSE) row.names(data)<-labels
        X <- eval(m, parent.frame())
        if (labels[1] != FALSE) labels<-row.names(X)
        }
    names<-names(X)
    if (missing(xlab)) xlab<-names[2]
    if (missing(ylab)) ylab<-names[1]
    if (ncol(X) == 2) scatterplot(X[,2], X[,1],  xlab=xlab, ylab=ylab, 
            labels=labels, ...)
    else scatterplot(X[,2], X[,1], groups=X[,3], xlab=xlab, ylab=ylab, 
                labels=labels, ...)
    }


scatterplot.default<-function(x, y, smooth=TRUE, span=.5, reg.line=lm, boxplots="xy",
    xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), las=par("las"),
    lwd=1, labels=FALSE, log="", groups=FALSE, by.groups=!(groups[1]==FALSE), 
    ellipse=FALSE, levels=c(.5, .9), robust=FALSE,
    col=palette(), pch=1:n.groups, 
    legend.plot=length(levels(groups)) > 1, reset.par=TRUE, ...){
    # last modified 1 May 2003 by J. Fox
    lowess.line<-function(x, y, col) {
        x<-if (0==length(grep("x", log))) x else log(x)
        y<-if (0==length(grep("y", log))) y else log(y)
        valid<-!(is.na(x) | is.na(y))
        fit<-lowess(x[valid],y[valid],f=span)
        x<-if (0==length(grep("x", log))) fit$x else exp(fit$x)
        y<-if (0==length(grep("y", log))) fit$y else exp(fit$y)
        lines(x, y, lwd=lwd, col=col)
        }
    reg<-function(x, y, col){
        x<-if (0==length(grep("x", log))) x else log(x)
        y<-if (0==length(grep("y", log))) y else log(y)
        mod<-reg.line(y~x)
        y.hat<-fitted.values(mod)
        x<-model.matrix(mod)[,2]
        min<-which.min(x)
        max<-which.max(x)
        if (0==length(grep("x", log))){
            x1<-x[min]
            x2<-x[max]
            }
        else {
            x1<-exp(x[min])
            x2<-exp(x[max])
            }
        if (0==length(grep("y", log))){
            y1<-y.hat[min]
            y2<-y.hat[max]
            }
        else {
            y1<-exp(y.hat[min])
            y2<-exp(y.hat[max])
            }
        lines(c(x1,x2),c(y1,y2), lty=2, lwd=lwd, col=col)
        }
    hbox<-function(x){
        if (length(grep("x", log))==0){
            log.x<-""
            .x<-x
            }
        else {
            log.x<-"x"
            .x<-log(x)
            }
        plot(x, seq(0,1,length=length(x)), type="n", axes=FALSE, xlab="", ylab="", log=log.x)
        res<-boxplot.stats(.x, coef = 1.5, do.conf=FALSE)
        if (length(grep("x", log))!=0){
            res$stats<-exp(res$stats)
            if (!is.null(res$out)) res$out<-exp(res$out)
            }
        LW<-res$stats[1]
        Q1<-res$stats[2]
        M<-res$stats[3]
        Q3<-res$stats[4]
        UW<-res$stats[5]
        lines(c(Q1,Q1,Q3,Q3,Q1),c(0,1,1,0,0))
        lines(c(M,M),c(0,1))
        lines(c(LW,Q1),c(.5,.5))
        lines(c(Q3,UW),c(.5,.5))
        if (!is.null(res$out)) points(res$out,rep(.5, length(res$out)))
        }
    vbox<-function(y){
        if (length(grep("y", log))==0){
            log.y<-""
            .y<-y
            }
        else {
            log.y<-"y"
            .y<-log(y)
            }
        plot(seq(0,1,length=length(y)), y, type="n", axes=FALSE, xlab="", ylab="", log=log.y)
        res<-boxplot.stats(.y, coef = 1.5, do.conf=FALSE)
        if (length(grep("y", log))!=0){
            res$stats<-exp(res$stats)
            if (!is.null(res$out)) res$out<-exp(res$out)
            }
        LW<-res$stats[1]
        Q1<-res$stats[2]
        M<-res$stats[3]
        Q3<-res$stats[4]
        UW<-res$stats[5]
        lines(c(0,1,1,0,0),c(Q1,Q1,Q3,Q3,Q1))
        lines(c(0,1),c(M,M))
        lines(c(.5,.5),c(LW,Q1))
        lines(c(.5,.5),c(Q3,UW))
        if (!is.null(res$out)) points(rep(.5, length(res$out)),res$out)
        }
    mar<-par("mar")
    mfcol<-par("mfcol")
    if (reset.par) on.exit(par(mar=mar, mfcol=mfcol))
    if(FALSE==boxplots) boxplots<-""
    if (groups[1] != FALSE){
        if (labels[1] != FALSE){
            data<-na.omit(data.frame(groups,x,y,labels))
            groups<-data[,1]
            .x<-data[,2]
            .y<-data[,3]
            labels<-data[,4]
            }
        else {
            data<-na.omit(data.frame(groups,x,y))
            groups<-data[,1]
            .x<-data[,2]
            .y<-data[,3]
            }
        }
    else{
        .x<-x
        .y<-y
        }
    groups<-as.factor(if(FALSE == groups[1]) rep(1, length(.x)) else as.character(groups))
    layout(matrix(c(1,0,3,2),2,2),
        widths = c(5,95),
        heights= c(95,5))
    par(mar=c(mar[1],0,mar[3],0))
    if (length(grep("y",boxplots))>0) vbox(.y) else plot(0,0,xlab="",ylab="",axes=FALSE,type="n")
    par(mar=c(0,mar[2],0,mar[4]))
    if (length(grep("x",boxplots))>0) hbox(.x) else plot(0,0,xlab="",ylab="",axes=FALSE,type="n")
    par(mar=mar)
    plot(.x, .y, xlab=xlab, ylab=ylab, las=las, log=log, type="n", ...)
    n.groups<-length(levels(groups))
    if (n.groups >= length(col)) stop("number of groups exceeds number of available colors")
    for (i in 1:n.groups){
        subs<-groups==levels(groups)[i]
        points(.x[subs], .y[subs], pch=pch[i], col=col[i+1])
        if (smooth & by.groups) lowess.line(.x[subs], .y[subs], col=col[i+1])
        if (is.function(reg.line) & by.groups) reg(.x[subs], .y[subs], col=col[i+1])
        if (ellipse  & by.groups) data.ellipse(.x[subs], .y[subs], plot.points=FALSE, 
            levels=levels, col=col[i+1], robust=robust)
        }
    if (!by.groups){
        if (smooth) lowess.line(.x, .y, col=col[1])
        if (is.function(reg.line)) reg(.x, .y, col=col[1])
        if (ellipse) data.ellipse(.x, .y, plot.points=FALSE, levels=levels, col=col[1],
            robust=robust)
        }
    if(legend.plot) legend(locator(1), legend=levels(groups), 
        pch=pch, col=col[2:(n.groups+1)])
    if (labels[1]==TRUE & length(labels)==1) labels<-seq(along=z)
    indices<-if (labels[1] != FALSE) identify(.x, .y, labels)
    if (is.null(indices)) invisible(indices) else indices
    }

sp<-function(...) scatterplot(...)
# fancy scatterplot matrices (J. Fox)

# last modified: 2 Dec 03 by J. Fox

scatterplot.matrix<-function(x, ...){
    UseMethod("scatterplot.matrix")
    }

scatterplot.matrix.formula<-function (formula, data=NULL, subset,  ...) {
    # last modified 1 Feb 2001 by J. Fox
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, sys.frame(sys.parent())))) 
        m$data <- as.data.frame(data)
    m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m$formula<-NULL
    if (!inherits(formula, "formula") | length(formula) != 2) 
        stop("invalid formula")
    rhs <- formula[[2]]
    if ("|"!=deparse(rhs[[1]])){
        groups <- FALSE
        }
    else{
        groups <- TRUE
        formula<-as.character(c(formula))
        formula<-as.formula(sub("\\|", "+", formula))   
        }
    m$formula<-formula
    X <- eval(m, sys.frame(sys.parent()))
    if (!groups) scatterplot.matrix(X, ...)
        else{
        ncol<-ncol(X)
        scatterplot.matrix.default(X[,-ncol], groups=X[,ncol], ...)
        }
    }

scatterplot.matrix.default<-function(x, labels=colnames(x), 
    diagonal=c("density", "boxplot", "histogram", "qqplot", "none"), adjust=1, nclass,
    plot.points=TRUE, smooth=TRUE, span=.5, reg.line=lm, transform=FALSE,
    ellipse=FALSE, levels=c(.5, .9), robust=FALSE,
    groups=FALSE, by.groups=FALSE,
    col=palette(), pch=1:n.groups, lwd=1,
    legend.plot=length(levels(groups)) > 1, ...){
    # last modified 1 May 2003 by J. Fox
    if (groups[1] != FALSE){
        x<-na.omit(cbind(as.data.frame(groups),x))
        groups<-as.factor(as.character(x[,1]))
        x<-x[,-1]
        }
        else x<-na.omit(x)
    if (missing(nclass)) nclass<-n.bins(x[,1])
    reg<-function(x, y, col){
        mod<-reg.line(y~x)
        y.hat<-fitted.values(mod)
        x<-model.matrix(mod)[,2]
        min<-which.min(x)
        max<-which.max(x)
        lines(c(x[min],x[max]),c(y.hat[min],y.hat[max]), lty=2, lwd=lwd, col=col)
        }
    panel.density<-function(x){
        par(new=TRUE)
        plot(density(x, adjust=adjust), axes=FALSE, main="")
        points(x, rep(0,length(x)), pch="|", col=col[1])
        }
    panel.histogram<-function(x){
        par(new=TRUE)
        hist(x, main="", axes=FALSE, nclass=nclass, col=col[2])
        }
    panel.boxplot<-function(x){
        par(new=TRUE)
        boxplot(x, axes=FALSE, main="", col=col[2])
        }
    panel.qqplot<-function(x){
        par(new=TRUE)
        qqnorm(x, axes=FALSE, xlab="", ylab="", main="", col=col[1])
        qqline(x)
        }
    panel.blank<-function(x) NULL
    which.fn<-match(match.arg(diagonal), c("density", "boxplot", "histogram", "qqplot", "none"))
    diag<-list(panel.density, panel.boxplot, panel.histogram, panel.qqplot, panel.blank)[[which.fn]]
    groups<-as.factor(if(FALSE==groups[1]) rep(1, length(x[,1])) else groups)
    n.groups<-length(levels(groups))
    if (n.groups >= length(col)) stop("number of groups exceeds number of available colors")
    if (transform != FALSE | length(transform) == ncol(x)){
        if (transform == TRUE & length(transform) == 1) transform <- box.cox.powers(x)$lambda
        for (i in 1:ncol(x)){
            x[,i]<-box.cox(x[,i], transform[i])
            labels[i] <- paste(labels[i], "^(", round(transform[i],2), ")", sep="")
            }
        }          
    pairs(x, labels=labels,
        diag.panel=diag,
        panel=function(x, y, ...){ 
            for (i in 1:n.groups){
                subs<-groups==levels(groups)[i]
                if (plot.points) points(x[subs], y[subs], pch=pch[i], col=col[i+1])
                if (smooth & by.groups) lines(lowess(x[subs], y[subs]), col=col[i+1])
                if (is.function(reg.line) & by.groups) reg(x[subs], y[subs], col=col[i+1])
                if (ellipse  & by.groups) data.ellipse(x[subs], y[subs], plot.points=FALSE, 
                    levels=levels, col=col[i+1], robust=robust, lwd=1)
                }
            if (!by.groups){
                if (is.function(reg.line)) abline(reg.line(y~x),lty=2, lwd=lwd, col=col[1])
                if (smooth) lines(lowess(x,y, f=span), lwd=lwd, col=col[1])
                if (ellipse) data.ellipse(x, y, plot.points=FALSE, levels=levels, col=col[1],
                    robust=robust, lwd=1)
                }
            }
        )
    if(legend.plot) {
        frac<-1/ncol(x)
        legend(1 - .95*frac, 0.8*frac,
            legend=levels(groups), pch=pch, col=col[2:(n.groups+1)], 
            cex=cumprod(par("fin"))[2]*sqrt(frac)/(sqrt(n.groups)*20))
        }
    }

spm<-function(x, ...){
    scatterplot.matrix(x, ...)
    }            
# spread-level plots (J. Fox)

# last modified 2 April 02

slp<-function(x, ...) spread.level.plot(x, ...)

spread.level.plot<-function(x, ...) {
    UseMethod("spread.level.plot")
    }

spread.level.plot.default<-function(x, by, robust.line=any("MASS"==.packages(all=TRUE)), 
        start=0, xlab="Median", ylab="Hinge-Spread", las=par("las"),
        main=paste("Spread-Level Plot for", deparse(substitute(x)), 
        "by", deparse(substitute(by))), col=palette()[2], pch=1, lwd=2, ...)
    {
    #last modified 23 Feb 2003 by J. Fox
    good<-!(is.na(x) | is.na(by))
    if (sum(good) != length(x)) {
        warning("NAs ignored")
        x<-x[good]
        by<-by[good]
        }    
    min.x<-min(x)
    if (min.x <= -start){
        start<- nice(-min.x +.05*diff(quantile(x,c(.25,.75))), direction="up")
        warning(paste("Start =",start," added to avoid 0 or negative values."))
        }
    if (start !=0) {
        xlab<-paste(xlab, "+", signif(start, 5))
        x<-x+start
        }
    values<-unique(as.character(by))
    result<-matrix(0,length(values),4)
    dimnames(result)<-list(values,c("LowerHinge", "Median", "UpperHinge", "Hinge-Spread"))
    for (i in seq(along=values)){
        five<-fivenum(x[by==values[i]])
        result[i,]<-c(five[2:4],five[4]-five[2])
        }
    medians<-result[,2]
    spreads<-result[,4]
    plot(medians, spreads, log="xy", main=main, xlab=xlab, ylab=ylab, 
        las=las, pch=pch, col=col, ...)
    pos<-ifelse(medians>median(medians), 2, 4)
    text(medians, spreads, as.character(values), pos=pos, ...)
    if (robust.line){
        if (!require("MASS")) stop("MASS package not available")
        mod<-rlm(log(spreads)~log(medians))
        }
        else mod<-lm(log(spreads)~log(medians), ...)
    ord<-order(medians)
    first<-ord[1]
    last<-ord[length(ord)]
    lines(start+medians[c(first,last)], exp(fitted.values(mod)[c(first,last)]), 
        col=col, lwd=lwd, ...)
    p<-1-(coefficients(mod))[2]
    names(p)<-NULL
    result <- list(Statistics=result[ord,], PowerTransformation=p)
    class(result) <- 'spread.level.plot'
    result
    }
    
spread.level.plot.lm<-function(x, start=0, 
        robust.line=any("MASS"==.packages(all=TRUE)), 
        xlab="Fitted Values",
        ylab="Absolute Studentized Residuals", las=par("las"),
        main=paste("Spread-Level Plot for", deparse(substitute(x))),
        pch=1, col=palette()[2], lwd=2, ...)
    {
    #last modified 23 Feb 2003 by J. Fox
    resid<-na.omit(abs(rstudent(x)))
    fitval<-na.omit(fitted.values(x))
    min<-min(fitval)
    if (min <= -start) {
        start<- nice(-min +.05*diff(quantile(fitval,c(.25,.75))), direction='up')
        warning(paste("Start = ", start, 
            "added to fitted values to avoid 0 or negative values."))
        }
    if (start !=0) xlab<-paste(xlab, "+", signif(start, 5))
    plot(fitval+start, resid, log="xy", main=main, xlab=xlab, ylab=ylab, 
        las=las, col=col, pch=pch, ...)
    if (robust.line){
        if (!require("MASS")) stop("MASS package not available")
        mod<-rlm(log(resid)~log(fitval+start))
        }
        else mod<-lm(log(resid)~log(fitval+start), ...)
    first<-which.min(fitval) 
    last<-which.max(fitval) 
    lines((fitval+start)[c(first,last)], exp(fitted.values(mod)[c(first,last)]), 
        lwd=lwd, col=col, ...)
    p<-1-(coefficients(mod))[2]
    names(p)<-NULL
    result <- list(PowerTransformation=p)
    class(result) <- 'spread.level.plot'
    result
    }
  
spread.level.plot.formula<-function (formula, data=NULL, subset, na.action, 
    main=paste("Spread-Level Plot for", varnames[response], "by", varnames[-response]), ...) {
    if (missing(na.action)) 
        na.action <- options()$na.action
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, sys.frame(sys.parent())))) 
        m$data <- as.data.frame(data)
    m$... <- m$main <- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, sys.frame(sys.parent()))
    response <- attr(attr(mf, "terms"), "response")
    varnames <- names(mf)
    if (!response) stop ("No response variable specified")
    if (length(varnames)>2) stop("Right-hand side of model has more than one variable")
    x <- mf[[response]]
    by <- mf[[varnames[-response]]]
    spread.level.plot.default(x, by, main=main, ...)
    }
    
print.spread.level.plot <- function(x, ...){
    if (!is.null(x$Statistics)) print(x$Statistics, ...)
    cat('\nSuggested power transformation: ', x$PowerTransformation,'\n')
    invisible(x)
    }
# Plot optimal subsets regressions -- output from regsubsets
# function in leaps package

# last modified 23 Dec 2001 by J. Fox

subsets <- function(object, ...){
    UseMethod("subsets")
    }


subsets.regsubsets <- function(object, 
    names=abbreviate(object$xnames, minlength=abbrev), abbrev=1,
    min.size=1, max.size=length(names), legend,
    statistic=c("bic", "cp", "adjr2", "rsq", "rss"), las=par("las"), cex.subsets=1,
    ...) {
    # last modified 20 Feb 2002 by J. Fox
    if (missing(legend)) legend <- missing(names)
    sumry <- summary(object)
    incidence <- sumry$which
    if (object$xnames[1]=="(Intercept)"){
        if (missing(names)) names <- names[-1]
        incidence <- incidence[,-1]
        }
    statistic <- match.arg(statistic)
    stat <- switch(statistic,
        bic = sumry$bic,
        cp = sumry$cp,
        adjr2 = sumry$adjr2,
        rsq = sumry$rsq,
        rss = sumry$rss)
    subset.size <- as.numeric(rownames(incidence))
    select <- subset.size >= min.size & subset.size <= max.size
    subset.size <- subset.size[select]
    stat <- stat[select]
    incidence <- incidence[select, ]
    plot(c(min.size, max.size), range(stat), type="n", xlab="Subset Size", 
        ylab=paste("Statistic:", statistic), las=las, ...)
    for (i in seq(along=stat)){
        adj <- if (subset.size[i] == min.size) 0
                else if (subset.size[i] == max.size) 1
                    else .5
        text(subset.size[i], stat[i], 
            do.call("paste", c(as.list(names[incidence[i,]]),sep='-')),
            cex=cex.subsets, adj=adj)
        }
    if (legend) legend(locator(1),
        legend=apply(cbind(names, names(names)), 1, 
            function(x) do.call("paste", c(as.list(x), sep=": "))))
    invisible(NULL)
    }
    

    

# Utility functions (J. Fox)

    # last modified 31 Jan 04 by J. Fox

inv<-function(x) solve(x)


has.intercept<-function (model, ...) {
    UseMethod("has.intercept")
    }

has.intercept.default<-function(model, ...) any(names(coefficients(model))=="(Intercept)")



term.names<-function (model, ...) {
    UseMethod("term.names")
    }

term.names.default<-function (model, ...) {
    term.names<-labels(terms(model))
    if (has.intercept(model)) c("(Intercept)", term.names)
        else term.names
    }



predictor.names<-function(model, ...) {
    UseMethod("predictor.names")
    }
    
predictor.names.default<-function(model, ...){
    predictors<-attr(terms(model),"variables")
    as.character(predictors[3:length(predictors)])
    }



responseName<-function (model, ...) {
    UseMethod("responseName")
    }

responseName.default<-function (model, ...) deparse(attr(terms(model), "variables")[[2]])

response<-function(model, ...) {
    UseMethod("response")
    }

response.default<-function (model, ...) model.response(model.frame(model))

is.aliased<-function(model){
    !is.null(alias(model)$Complete)
    }

df.terms<-function(model, term, ...){
    UseMethod("df.terms")
    }


df.terms.default<-function(model, term, ...){
    if (is.aliased(model)) stop("Model has aliased term(s); df ambiguous.")
    if (!missing(term) && 1==length(term)){
        assign<-attr(model.matrix(model),"assign")
        which.term<-which(term==labels(terms(model)))
        if (0==length(which.term)) stop(paste(term, "is not in the model."))
        sum(assign==which.term)
        }
    else {
        terms<-if (missing(term)) labels(terms(model)) else term
        result<-numeric(0)
        for (term in terms) result<-c(result, Recall(model, term))
        names(result)<-terms
        result
        }
    }

 
 mfrow <- function(n, max.plots=0){
    # number of rows and columns for array of n plots
    if (max.plots != 0 & n > max.plots)
        stop(paste("number of plots =",n," exceeds maximum =", max.plots))
    rows <- round(sqrt(n))
    cols <- ceiling(n/rows)
    c(rows, cols)
    }


    
# Generalized Variance-Inflation Factors (J. Fox)

vif<-function(mod){
    #last modified 13 Dec 2000 by J. Fox
    UseMethod("vif")
    }

vif.lm<-function(mod) {
    #last modified 2 Dec 2003 by J. Fox
    if (!is.null(weights(mod))) stop("requires unweighted lm")
    if(!has.intercept(mod)) stop("requires model with intercept.")   
    terms<-term.names(mod)[-1]
    n.terms<-length(terms)
    if (n.terms < 2) stop("model contains fewer than 2 terms") 
    R<-cor(model.matrix(mod)[,-1])
    detR<-det(as.matrix(R))
    result<-matrix(0,n.terms,3)
    rownames(result)<-terms
    colnames(result)<-c("GVIF","Df","GVIF^(1/2Df)")
    assign<-mod$assign
    for (term in 1:n.terms){
        subs<-which(assign==term)-1
        result[term,1]<-det(as.matrix(R[subs,subs]))*
            det(as.matrix(R[-subs,-subs]))/detR
        result[term,2]<-length(subs)
        }
    if (all(result[,2]==1)) result<-result[,1]
        else result[,3]<-result[,1]^(1/(2*result[,2]))
    result
    }

vif.default<-function(mod){
    #last modified 13 Dec 2000 by J. Fox
    stop("requires lm object")
    }
# positions of names in a data frame (J. Fox)

# last modified 9 Mar 2001 by J. Fox

which.names<-function(names, object){
    row.names<-if (inherits(object, "data.frame")) row.names(object) else object
    check<-outer(row.names, names, '==')
    if (!all(matched <- apply(check, 2, any))) 
        warning(paste(paste(names[!matched], collapse=", "), "not matched"))
    which(apply(check, 1, any))
    }
