"bestset.noise" <-
function(m = 100, n = 40)
{
require(leaps)
    y <- rnorm(m)
    xx <- matrix(rnorm(m * n), ncol = n)
dimnames(xx)<-list(NULL, paste("V",1:n,sep=""))
    u <- regsubsets(xx, y, method = "exhaustive", nvmax = 3, nbest = 1)
    best3 <- summary(u)$which[3,-1]
    u1 <- lm(y ~ xx[,best3])
    print(summary(u1, corr = FALSE))
    invisible(u1)
}
"bounce" <-
     function (x, d)
{
     ord <- order(x)
     xsort <- x[ord]
     n <- length(x)
     xnew <- xsort
     if (n > 1) {
         i1 <- 1
         while (i1 < n) {
             x1 <- xsort[i1]
             i2 <- i1 + 1
             for (j in i2:n) {
                 nobounce <- TRUE
                 jn <- n - j + i2
                 dj <- xsort[jn] - x1
                 dsought <- (jn - i1) * d
                 if (dj < dsought) {
                     jot <- (dsought - dj)/2
                     for (k in i1:jn) xnew[k] <- x1 - jot + (k -
                                                             i1) * d
                     i1 <- jn + 1
                     nobounce <- FALSE
                     break
                 }
             }
             if (nobounce)
                 i1 <- i1 + 1
         }
         if (min(diff(xnew)) < d * 0.999) {
             n1 <- (1:(n - 1))[diff(xnew) < d]
             cat("Error in bounce().  Improperly separated points are:",
                 fill = TRUE)
             cat(paste(n1, ":", n1 + 1, sep = ""), fill = TRUE)
             cat(paste(xnew[n1], ":", xnew[n1 + 1], sep = ""),
                 fill = TRUE)
         }
     }
     x[ord] <- xnew
     x
}
"component.residual" <-
function (lm.obj = mice12.lm, which = 1, xlab = "Component", ylab = "C+R") 
{
res <- residuals(lm.obj)
data <- model.matrix(lm.obj)
if (var(data[,1]) == 0) {data <- data[, -1]
lm.obj$coef <- lm.obj$coef[-1]
}
bx <- lm.obj$coef[which]
plot(data[,which], bx*data[,which]+res, xlab = xlab, ylab = ylab)
panel.smooth(data[,which], bx*data[,which]+res) 
}
"cv.binary" <-
function(obj=frogs.glm, rand=NULL, nfolds=10, print.details=TRUE){
data <- obj$data
m <- dim(data)[1]
if(is.null(rand))rand <- sample(nfolds, m, replace=TRUE)
form <- formula(obj)
yvar <- all.vars(form)[1]
obs <- data[,yvar]
ival<-unique(rand)
fam <- obj$family$family
hat <- predict(glm(form,data,family=fam), type="response")
cvhat <- rep(NA,length(rand))
if(print.details)cat("\nFold: ")
for(i in ival){
if(print.details)cat("",i)
if (i%%20==0)cat("\n")
here<-i!=rand
i.glm <- glm(form, data=data[here,], family=fam)
cvhat[!here]<-predict(i.glm, newdata=data[!here,],
  family=fam, type="response")
}
acc.internal <- sum(obs==round(hat))/m
acc.cv <- sum(obs==round(cvhat))/m
if(print.details){
cat("\nInternal estimate of accuracy =", round(acc.internal, 3))
cat("\nCross-validation estimate of accuracy =", round(acc.cv, 3))
cat("\n")
}
invisible(list(cv=cvhat, internal=hat, acc.internal=acc.internal, acc.cv=acc.cv))
}
"cv.lm" <-
function(df = houseprices, m = 3, form.lm =formula(sale.price ~ area), dots=FALSE, seed=29)
{
    vars <- all.vars(form.lm)
    ynam <- vars[1]
    xnam <- vars[2]
    if(!is.null(seed))set.seed(seed)
    oldpar<-par(mar=par()$mar-c(1,0,2,0))
    on.exit(par(oldpar))
    coltypes <- c(2, 3, 6)
    ltypes <- 1:3
    ptypes <- 2:4
    options(digits=3)
    n <- dim(df)[1]
    rand <- sample(n)%%m+1
    xv <- df[, xnam]
    yv <- df[, ynam]
    plot(xv, yv, xlab = xnam, ylab = ynam, type = "n")
    xval <- pretty(xv, n = 20)
    df.lm <- lm(yv ~ xv, data=df)
    print(anova(df.lm))
    cat("\n")
    sumss<-0
    sumdf<-0
    par(lwd=2)
    for(i in sort(unique(rand))) {
        cat("\nfold", i, "\n")
        n.in <- (1:n)[rand != i]
        n.out <- (1:n)[rand == i]
        cat("Observations in test set:", n.out, "\n")
        ab <- lm(yv ~ xv, subset = n.in)$coef
        z <- xv[n.out]
        points(xv[n.out], yv[n.out], col=coltypes[i], pch = ptypes[i], cex = 1.25)
        if(dots)
            points(xv[n.out], yv[n.out], col = coltypes[i], pch = 16)
        pred <- ab[1] + ab[2] * z
        resid <- yv[n.out] - pred
        xy <- data.frame(rbind(z,pred, yv[n.out], resid
            ), row.names=c(xnam,"Predicted", ynam,"Residual"))
        yval <- ab[1] + ab[2] * xval
        lines(xval, yval, lwd = 2, col = coltypes[i], lty=ltypes[i])
        num <- length(n.out)
        print(xy,collab=rep("",num))
        ss <- sum(resid^2)
        sumss<-sumss+ss
        sumdf<-sumdf+num
        ms <- ss/num
        cat("\nSum of squares =", round(ss, 2), "   Mean square =", 
            round(ms, 2), "   n =", num, "\n")
    }
    print(c("Overall ms"=sumss/sumdf))
    topleft<-par()$usr[c(1,4)]
    par(lwd=1)
    legend(topleft[1],topleft[2],legend=paste("Fold",1:m),pch=ptypes,
        lty=ltypes,col=coltypes, cex=0.75)
    par(col = 1)
 }
"onesamp" <-
function(dset = corn, x = "unsprayed", y = "sprayed", xlab = NULL, ylab = NULL, 
	dubious = NULL, conv = NULL, dig = 2)
{
	if(!is.null(conv))
		dset <- round(dset * conv, 1)
	xlabel <- xlab
	ylabel <- ylab
	if(is.null(xlabel))
		xlabel <- x
	if(is.null(ylabel))
		ylabel <- y
	xname <- x
	yname <- y
	xv <- dset[, xname]
	yv <- dset[, yname]
	omit <- is.na(xv) | is.na(yv)
	if(!is.null(dubious))
		omit[dubious] <- TRUE
	ylim <- range(c(xv[!omit], yv[!omit]))
	xlim <- ylim
	plot(dset[!omit, xname], dset[!omit, yname], pch = 1, lwd = 2, xlab = 
		xlabel, ylab = ylabel, xlim = xlim, ylim = ylim)
	if(sum(omit) != 0) {
		points(dset[omit, xname], dset[omit, yname], pch = 4)
	}
	abline(0, 1)
	xmid <- mean(par()$usr[1:2])
	ymid <- mean(par()$usr[3:4])
	chw <- par()$cxy[1]
	chh <- par()$cxy[2]
	d <- dset[!omit, yname] - dset[!omit, xname]
	dbar <- mean(d)
	se <- sqrt(var(d)/length(d))
	xpos <- xmid - 3.0 * chw
	ypos <- ymid - 3.0*chh
	lines(c(xpos, xpos), c(ypos - se/2, ypos + se/2), lwd = 2)
	lines(c(xpos - chw/4, xpos + chw/4), rep(ypos + se/2, 2), lwd = 2)
	lines(c(xpos - chw/4, xpos + chw/4), rep(ypos - se/2, 2), lwd = 2)
	text(xpos + chw/2, ypos, paste("SED =", format(round(se, dig))), adj = 
		0)
	abline(dbar, 1, lty = 2)
	n <- dim(dset)[1]
	if(sum(omit) > 0)
		sex <- sqrt(var(dset[ - omit, xname])/n)
	else sex <- sqrt(var(dset[, xname])/n)
	if(sum(omit) > 0)
		sey <- sqrt(var(dset[ - omit, yname])/n)
	else sey <- sqrt(var(dset[, yname])/n)
	axis(3, at = c(xmid - sex/2, xmid + sex/2), labels = FALSE)
	axis(4, at = c(ymid - sey/2, ymid + sey/2), labels = FALSE)
	mtext(side = 3, line = 0.75, text = paste("SE =", format(round(sex, dig
		))), at = xmid, adj = 0.5)
	mtext(side = 4, line = 0.75, text = paste("SE =", format(round(sey, dig
		))), at = ymid, adj = 0.5, srt = 90)
	if(sum(omit) > 0)
		cat("\n", yname, sqrt(var(dset[ - omit, yname])), sqrt(var(dset[
			 - omit, xname])), "\n")
	else cat("\n", yname, sqrt(var(dset[, yname])), sqrt(var(dset[, xname])
			), sqrt(var(d)), "\n")
	if(sum(omit) > 0)
		r <- cor(dset[ - omit, yname], dset[ - omit, xname])
	else r <- cor(dset[, yname], dset[, xname])
	topleft <- par()$usr[c(1, 4)] + c(chw/4,  - chh/3)
	mtext(side=3,line=0.15, paste("r =", format(round(r, 4))), 
adj = 1.1, cex=0.75
		)
	print(t.test(d))
	invisible()
}
"onet.permutation" <-
function(x=pair65$heated-pair65$ambient, nsim=2000, plotit=TRUE){
oldpar<-par(mar=par()$mar-c(1,0,1,0))
on.exit(par(oldpar))
n <- length(x)
dbar <- mean(x)
absx <- abs(x)
z <- array(,nsim)
  for(i in 1:nsim){
    mn <- sample(c(-1,1),n,replace=TRUE)
    xbardash <- mean(mn*abs(x))
    z[i] <- xbardash
  }
pval <- (sum(z >= abs(dbar)) + sum (z <= -abs(dbar)))/nsim
if(plotit){plot(density(z), xlab="", main="", yaxs="i", cex.axis=0.8, bty="L")
abline(v=dbar)
abline(v=-dbar, lty=2)
mtext(side=3,line=0.5, text=expression(bar(d)), at=dbar)
mtext(side=3,line=0.5, text=expression(-bar(d)), at=-dbar)}
print(signif(pval,3))
invisible()
}
"oneway.plot" <-
function (obj = rice.aov, axisht = 6, xlim=NULL, xlab=NULL,
              lsdht = 1.5, hsdht = 0.5, textht=axisht-2.5,
              oma=rep(1,4), angle=80, alpha = 0.05)
{
    if(prod(par()$mfrow)==1){
          opar <- par(mar = rep(0, 4), oma = oma, xpd=TRUE)
          on.exit(par(mar=opar$mar,oma=opar$oma,xpd=FALSE))
      } else
      {par(xpd=TRUE)
       on.exit(par(xpd=FALSE))
   }
    b <- coef(obj)
    est <- b[1] + c(0, b[-1])
    sed <- summary.lm(obj)$coef[-1, 2]
    sed.min <- min(sed)
    sed.max <- max(sed)
    sed.rms <- sqrt(mean(sed.min^2 + sed.max^2))
    if (sed.max - sed.min > 0.1 * sed.rms) {
        show.sed <- FALSE
        cat("\nDesign is unbalanced.  SEDs depend on the treatments compared.\n")
    }
    if(is.null(xlim)){xlim <- range(est)
                      xlim <- xlim + c(-0.05, 0.05) * diff(xlim)
                  }
    plot(xlim[1], 0, xlim = xlim, ylim = c(0, 1), type="n", axes=FALSE,
         xlab="", ylab="", mgp=c(2,0.5,0))
    axisht <- axisht-round(par()$mar[1])
    textht <- textht-round(par()$mar[1])
    lsdht <- lsdht-round(par()$mar[1])
    hsdht <- hsdht-round(par()$mar[1])
    chh <- par()$cxy[2]*par()$cex
    chw <- par()$cxy[1]*par()$cex
    lines(xlim, rep(axisht*chh, 2))
    axis(1, tck = 0.02, pos = axisht*chh, at = est, labels = FALSE)
    axis(1, pos = axisht*chh)
    if(!is.null(xlab)) text(mean(par()$usr[1:2]), textht*chh,
                            labels=xlab)
    trtnam <- all.names(obj$call$formula)[3]
    trtlev <- obj$xlevels[[trtnam]]
    xpos <- bounce(est, d = chw)
    text(xpos, rep(axisht*chh, length(xpos)) + 0.85 * chh, trtlev,
         srt =  angle, adj = 0)
    df <- obj$df
    talpha <- qt(1 - alpha/2, df)
    lsd <- talpha * sed.rms
    tukey <- qtukey(1 - alpha, nmeans = length(est), df)/sqrt(2)
    hsd <- tukey * sed.rms
    est.min <- min(est)
    est.max <- max(est)
    adjtxt <- 0
    if (est[1] + hsd <= est.max) {
        hsdlim <- c(est[1], est[1] + hsd)
        lsdlim <- c(est[1], est[1] + lsd)
    }
    else if (est[1] - hsd >= est.min) {
        hsdlim <- c(est[1] - hsd, est[1])
        lsdlim <- c(est[1] - lsd, est[1])
        adjtxt <- 1
    }
    else {
        hsdlim <- c(est[1], est[1] + hsd)
        lsdlim <- c(est[1], est[1] + lsd)
    }
    if(!is.null(lsdht)){
        lines(lsdlim, rep(lsdht*chh, 2))
        text(lsdlim[2 - adjtxt] + (0.5 - adjtxt) * chw, lsdht*chh, "LSD",
             adj = adjtxt)}
    if(!is.null(hsdht)){
        lines(hsdlim, rep(hsdht*chh, 2))
        text(hsdlim[2 - adjtxt] + (0.5 - adjtxt) * chw, hsdht*chh, "Tukey HSD",
             adj = adjtxt)}
    print(par()$mfg)
    invisible()
}
"overlap.density" <-
function(x0, x1, frac=c(.05, 20), plotit=TRUE){
n0 <- length(x0)
n1 <- length(x1)
d0 <- density(x0)
d1 <- density(x1)
f0 <- d0$y*n0
f1 <- d1$y*n1
xlim <- range(c(d0$x,d1$x),na.rm=TRUE)
ylim <- range(c(f0,f1))
ylim[2] <- ylim[2] + 0.1 * diff(ylim)
if(plotit){
plot(d1$x, f1, xlim=xlim, xlab="Score", xaxt="n", yaxs="i", ylim=ylim,
    ylab="Density x total frequency", main="", col=2, type="l", lty=1,lwd=2, bty="n")
lines(d0$x, f0, lwd=2, lty=2)
mtext(side=3,line=.75,"A",adj=0)
xpos <- par()$usr[1]
ypos <- par()$usr[4]
legend(xpos, ypos,lty=c(2,1), col=c("black","red"), cex=c(.8,.8),
    legend=c("Control","Treatment"),lwd=c(1,2),bty="n")
}
# We now need densities that are evaluated at the same x-values
d0 <- density(x0, from=xlim[1], to=xlim[2])
d1 <- density(x1, from=xlim[1], to=xlim[2])
x01 <- d0$x
f0 <- d0$y * n0
f1 <- d1$y * n1
eps <- .Machine$double.eps
f0[f0<eps] <- eps
f1[f1<eps] <- eps
xlim[1] <- min(x01[f1/f0 < frac[2] & f0/f1<frac[2]])
xlim[2] <- max(x01[f1/f0 > frac[1] & f0/f1>frac[1]])
if(plotit)axis(1, at=xlim)
invisible(xlim)
}
panel.corr <- function(data,...){
                x<-data$x
                y<-data$y
                points(x, y, pch = 16)
                chh <- par()$cxy[2]
                x1 <- min(x)
                y1 <- max(y) - chh/4
                r1 <- cor(x, y)
                text(x1, y1, paste(round(r1, 3)), cex = 0.8, adj = 0)
        }

"panelplot" <-
function(data,panel=points,totrows=3,totcols=2,oma=rep(2.5,4),
    par.strip.text=NULL){
    opar <- par(mfrow = c(totrows, totcols), mar=rep(0,4),
    oma= oma, new = FALSE)
    on.exit(par(opar))
if(!is.null(par.strip.text))
 {
 cex.strip<-par.strip.text$cex
 stripfac<-(par()$cin[2]/par()$pin[2])*cex.strip*1.0
 }
 else stripfac<-0
fac<-names(data)
if(is.null(fac))fac<-1:length(data)
nseq<-1:length(fac)
plot.new()
for(index in nseq){
    ilev<-fac[index]
    lis<-data[[ilev]]
        i <- totrows - ((index - 1)%/%totcols)
        j <- (index - 1)%%totcols + 1
        par(mfg = c(i, j, totrows, totcols))
    xlim<-lis$xlim
    ylim<-lis$ylim
        if(stripfac>0) 
          {strip.text <- fac[index] 
       ylim[2]<-ylim[2]+diff(ylim)*stripfac
       }
    else strip.text<-NULL
    plot.new()
    plot.window(unique(xlim),unique(ylim))
        if(!is.null(strip.text)){
        chh<-par()$cxy[2]
        ht<-par()$usr[4]- 0.725*chh
        abline(h=ht)
        xmid<-mean(par()$usr[1:2])
        text(xmid,ht+chh*0.35,strip.text,cex=cex.strip)
    }
    box()
    panel(lis,nrows=i,ncols=j)
    }
}
"pause" <-
function () 
{
    cat("Pause. Press <Enter> to continue...")
    readline()
    invisible()
}
"powerplot" <-
function(expr="x^2",xlab="x",ylab="y"){
   invtxt <- switch(expr, "x^2"="sqrt(y)","x^4"="y^0.25",
  "exp(x)"="log(x)","sqrt(x)"="y^2","x^0.25"="y^4",
  "log(x)"="exp(y)")
    x <- (1:60)/6
    y <- eval(parse(text=expr))
    form <- formula(paste("~",expr))
    dy <- deriv(form,"x")
    x0 <- min(x)+diff(range(x))*0.4
    y0 <- eval(parse(text=expr),list(x=x0))
    b <- eval(dy, list(x=x0))
    b <- attr(b,"gradient")
    plot(x, y, type = "n", xlab = "", ylab = "")
    lines(x,y,type="l",lwd=2,col=2)
    chh <- par()$cxy[2]
    theta <- atan(b*diff(par()$usr[1:2])/diff(par()$usr[3:4]))*180/pi
    mtext(side=1,line=2.5, xlab, cex=1)
    mtext(side=2,line=2.5, ylab, cex=1)
    funexpr <- parse(text=paste("y ==",expr))
    text(x0, y0+chh/2, funexpr, srt=theta,cex=1.5)
    invexpr <- parse(text=invtxt)[[1]]
    titletxt <- substitute(paste(tx, tilde(y) == invexpr),
    list(tx="Replace y by ", invexpr=invexpr))
    mtext(side=3,line=0.5,titletxt)
}
"qreference" <-
function(test=NULL, mu = 10, sigma = 1, m = 50, nrep = 5, 
             seed=NULL, nrows=NULL, cex.points=0.65, cex.strip=0.75)
{
    library(lattice)
    if(!is.null(seed))set.seed(seed)
    if(!is.null(test)){
        testnam <- deparse(substitute(test))
        m <- length(test);
        av <- mean(test); sdev <- sd(test)
        fac <- factor(c(rep(testnam, m),
                        paste("reference", rep(1:(nrep-1), rep(m, (nrep-1))))))
        fac <- relevel(fac, ref=testnam)}
    if(is.null(nrows)) nrows <- floor(sqrt(nrep))
    ncols <- ceiling(nrep/nrows)
    if(is.null(test)){
        xy <- data.frame(y = rnorm(m*nrep, mu, sigma),
                         fac=factor(rep(1:nrep, rep(m, nrep))))
        qq <- qqmath(~y|fac, data=xy, par.strip.text=list(cex=0),
                     layout=c(ncols,nrows), xlab="",ylab="", aspect=1,
                     cex=cex.points)}
    else{
        xy <- data.frame(y = c(test, rnorm(m*(nrep-1), av, sdev)), fac=fac)
        qq <- qqmath(~y|fac, data=xy, layout=c(ncols,nrows), aspect=1,
                     xlab="",ylab="", cex=cex.points, pch=16,
                     par.strip.text=list(cex=cex.strip))}
    
    print(qq)
}
"show.colors" <-
function(type=c("singles", "shades", "grayshades"), order.cols=TRUE){
type <- type[1]
oldpar <- par(mar=c(.75, .75,1.5, .75))
on.exit(par(oldpar))
order.cols <- order.cols & require(mva)
unique.colors <- function(){
    colnam <- colors()
    vector.code <- apply(col2rgb(colnam),2,function(x)x[1]+x[2]*1000+x[3]*10000)
    unique.code <- unique(vector.code)
    sub <- match(unique.code, vector.code)
    colnam[sub]
}
plotshades <- function(x=1, start=1, nlines=14, numlabels=FALSE, colmat, colnam){
    endlines <- min(start+nlines-1, length(colnam))
    colrange <- start:endlines
    nlines <- length(colrange)
    points(rep(x:(x+4), rep(nlines,5)), nlines+1.25-rep(1:nlines, 5), 
        col=as.vector(colmat[colrange,]), pch=15, cex=2.95)
    text(rep(x-0.25,nlines), nlines+1.25-(1:nlines), colnam[colrange], 
        adj=0, col=paste(colnam[1:10],"4",sep=""), cex=0.8, xpd=TRUE)
    text((x+1):(x+4), rep(nlines+0.95,4), 1:4, cex=0.75)
}
plotcols <- function(x=1, start=1, wid=5, nlines, numlabels=FALSE, colvec=loners){
    nlines <- min(nlines, length(colvec)-start+1)
    colrange <- start:(start+nlines-1)
    xleft <- rep(x, nlines)
    xright <- xleft+wid
    ybottom <- nlines+1-(1:nlines)
    ytop <- ybottom+1
    rect(xleft, ybottom, xright, ytop, col=colvec[colrange], xpd=TRUE)
    colvals <- lapply(colvec[colrange], function(x){z<-col2rgb(x)/256; 0.4*(1-(1-z)^2)+0.6*(1-z)^2})
    colvals <- sapply(colvals, function(x)rgb(x[1],x[2],x[3]))
    text(rep(x+0.25, nlines), nlines-(1:nlines)+1.5, colvec[colrange],
        col=colvals,  adj=0, cex=0.8, xpd=TRUE)
}
classify.colors <- function(colr, colset=loners){
    require(MASS)
    gsub <- grep("green",colr)
    rsub <- grep("red",colr)
    bsub <- grep("blue",colr)
    colxyz <- t(col2rgb(colr[c(rsub,gsub,bsub)]))
    colxyz <- data.frame(colxyz, rep(c("red","green","blue"), c(length(rsub),length(gsub),length(bsub))))
    names(colxyz)<- c("red","green","blue","gp")
    col.lda <- lda(gp ~ red+green+blue, data=colxyz)
    colrgb <- data.frame(t(col2rgb(colset)))
    names(colrgb) <- c("red", "green", "blue")
    newcol <- predict(col.lda, newdata=colrgb)
    newcol
}
allcols <- unique.colors()
gray <- as.logical(match(substring(allcols,1,4), "gray", nomatch=0))
grayshades <- allcols[gray]
nongray <- allcols[!gray]
nlast <- nchar(nongray)
five <- substring(nongray,nlast,nlast) %in% c("1","2","3","4")
fivers <- unique(substring(nongray[five],1,nlast[five]-1))
fiveshades <- outer(fivers,c("","1","2","3","4"),
    function(x,y)paste(x,y,sep=""))
subs <- match(nongray, fiveshades, nomatch=0)
loners <- nongray[subs==0]
print(c(length(loners),length(fiveshades)))
ncolm <- switch(type, singles=3, shades=4, gray=4)
nlines <- switch(type, singles=ceiling(length(loners)/3), 
    shades=ceiling(length(fivers)/4), gray=ceiling(length(grayshades)/4))


plot(c(1,21.5), c(1,nlines+1), type="n", axes=FALSE, xlab="", ylab="")
heading <- switch(type, singles="Colors that do not have shades",
 shades="Colors that have 4 or 5 shades", gray="Shades of gray")
mtext(side=3, line=-0.25, heading, at=1, adj=0)

# arrange <- function(colvec){
#    require(mva)
#    xyz <- t(sweep(col2rgb(colvec),1,c(.2126, .7152, .0722),"*"))
#    red <- xyz[,1]
#    green <- xyz[,2]
#    blue <- xyz[,3]   
#    scores <- (red+blue+400)*(green>165)+ (red+green+200)*(red>25)*(green<165)
#        +(green+blue)*(red<25)*(green>165)
#    ord <- order(scores)
#    ord}
arrange <- function(colvec){
newcols <- classify.colors(colr=c(loners,fiveshades), colset=colvec)
n1 <- 1:length(colvec)
blue <- n1[newcols$class=="blue"]
green <- n1[newcols$class=="green"]
red <- n1[newcols$class=="red"]
colblue <- colvec[blue]
colred <- colvec[red]
colgreen <- colvec[green]
ordblue <- order(apply(sweep(col2rgb(colblue),1,c(.2126, .7152, .0722),"*"),2,sum))
ordred <- order(apply(sweep(col2rgb(colred),1,c(.2126, .7152, .0722),"*"),2,sum))
ordgreen <- order(apply(sweep(col2rgb(colgreen),1,c(.2126, .7152, .0722),"*"),2,sum))
c(red[ordred], green[ordgreen], blue[ordblue])
}

if(order.cols){
z <- arrange(colvec=loners)
loners <- loners[z]
z <- arrange(colvec=fiveshades[,3])
fivers <- fivers[z]
fiveshades <- fiveshades[z, ]
}

if(type=="singles"){
plotcols(nlines=nlines, wid=6.5)
plotcols(x=8, nlines=nlines, wid=6.5, start=nlines+1)
plotcols(x=15, nlines=nlines, wid=6.5, start=2*nlines+1, numlabels=TRUE)
}
if(type=="gray"){
plotcols(colvec=grayshades, wid=5, nlines=nlines)
plotcols(x=6.25, colvec=grayshades, wid=5, nlines=nlines, start=nlines+1)
plotcols(x=11.5, colvec=grayshades, wid=5, nlines=nlines, start=2*nlines+1, numlabels=TRUE)
plotcols(x=16.75, colvec=grayshades, wid=5, nlines=nlines, start=3*nlines+1, numlabels=TRUE)
}
if(type=="shades"){
plotshades(nlines=nlines, colmat=fiveshades, colnam=fivers)
plotshades(x=6.5, start=nlines+1, nlines=nlines,colmat=fiveshades,colnam=fivers)
plotshades(x=12, start=2*nlines+1, nlines=nlines, numlabels=TRUE, colmat=fiveshades, colnam=fivers)
plotshades(x=17.5, start=3*nlines+1, nlines=nlines, numlabels=TRUE,colmat=fiveshades, colnam=fivers)
}
invisible(list(singles=loners, shades=fiveshades, grayshades=grayshades))
}
"simulate.linear" <-
function(sd = 2, npoints=5, nrep=4, nsets=200, type="xy", seed=21)
{
    if(!is.null(seed))set.seed(seed)
    nval <- npoints*nrep
    tmp <- data.frame(x = rep(1:npoints, rep(nrep, npoints)))
    p.aov <- array(0, nsets)
    p.slope <- array(0, nsets)
        for(i in 1:nsets) {
        tmp$y <- 100 + 0.8 * tmp$x + rnorm(nval, 0, sd)
        u <- lm(y ~ factor(x), data = tmp)
        z <- summary.aov(u)
        p.aov[i] <- z[[1]][1,"Pr(>F)"]
        u <- lm(y ~ x, data = tmp)
        z1 <- summary(u)
        p.slope[i] <- z1$coef[2, 4]
     }
     logit <- function(p)log(p/(1-p))
     x <- logit(p.aov)
     y <- logit(p.slope)
     xlim <- range(c(x,y), na.rm = TRUE)
     if(type=="xy"){
        oldpar <- par(mar = par()$mar - c(.5, 0, 2, 0), mgp = c(2.75, 0.5, 0))
        on.exit(par(oldpar))
        plot(x, y, xlim=xlim, ylim=xlim, xlab="", ylab="", cex=0.75, 
            axes=FALSE, main="")
        pval <- c(0.001, 0.01, 0.1, 0.5, 0.9)
        xpos <- logit(pval)
        axis(1, at=xpos, labels=paste(pval))
        axis(2, at=xpos, labels=paste(pval))
        box()
        mtext(side=1, line=2.5, "p-value: Qualitative aov comparison")
        mtext(side=2, line=2.5, "p-value: Test for linear trend")    
        abline(0, 1)
        } else 
        if(type=="density"){
        oldpar <- par(mfrow=c(1,2), mar = par()$mar - c(.5, 0, 2, 0), mgp = c(2.75, 0.5, 0))
        on.exit(par(oldpar))
        denx <- density(x)
        deny <- density(y)
        ylim <- c(0, max(c(denx$y, deny$y)))
        plot(denx, type="l", xlim=xlim, ylim = ylim, axes=FALSE, yaxs="i", main="",
            xlab="Density curves - 2 sets of p-values")
        topleft <- par()$usr[c(1,4)]
        legend(x=topleft[1], y=topleft[2], lty=c(1,2), legend=c("aov","linear"), bty="n")
        pval <- c(0.001, 0.01, 0.1, 0.5, 0.9)
        xpos <- logit(pval)
        axis(1, at=xpos, labels=paste(pval))
        lines(deny, lty=2)
        plot(density(x-y), main="", xlab="Difference in p-values, logit scale", 
            bty="n", yaxs="i")
        axis(1)
        }
     frac <- sum(p.slope<p.aov)/nsets
     cat("\nProportion of datasets where linear p-value < aov p-value =", frac, "\n")
    invisible()
}
"twot.permutation" <-
function(x1=two65$ambient, x2=two65$heated, nsim=2000, plotit=TRUE){
# oldpar<-par(mar=par()$mar-c(1,0,1,0))
# on.exit(par(oldpar))
n1 <- length(x1)
n2<-length(x2)
n<-n1+n2
x<-c(x1,x2)
dbar <- mean(x2)-mean(x1)
z <- array(,nsim)
  for(i in 1:nsim){
    mn <- sample(n,n2,replace=FALSE)
    dbardash <- mean(x[mn]) - mean(x[-mn])
    z[i] <- dbardash
  }
pval <- (sum(z >= abs(dbar)) + sum (z <= -abs(dbar)))/nsim
if(plotit){plot(density(z), xlab="", main="", yaxs="i", ylim=c(0,0.08), cex.axis=0.8)
abline(v=dbar)
abline(v=-dbar, lty=2)
mtext(side=3,line=0.5, text=expression(bar(x[2])-bar(x[1])), at=dbar)
mtext(side=3,line=0.5, text=expression(-(bar(x[2])-bar(x[1]))), at=-dbar)}
print(signif(pval,3))
invisible()
}
"vif" <-
function(obj, digits=5){
Qr <- obj$qr
if (is.null(obj$terms) || is.null(Qr)) 
        stop("invalid 'lm' object:  no terms or qr component")
tt <- terms(obj)
hasintercept <- attr(tt, "intercept") > 0
p <- Qr$rank
if(hasintercept) p1 <- 2:p else p1 <- 1:p
R <- Qr$qr[p1,p1, drop=FALSE]
if(length(p1)>1) R[row(R)>col(R)] <- 0
Rinv <- qr.solve(R)
vv <- apply(Rinv, 1, function(x)sum(x^2))
ss <- apply(R, 2, function(x)sum(x^2))
vif <- ss*vv
signif(vif, digits)
}
