.packageName <- "DAAG"
"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(0, 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")
     }
     if(is.factor(obs)){
         lev <- levels(obs)
         hat <- lev[round(hat)+1]
         cvhat <- lev[round(cvhat)+1]
     }
     acc.internal <- sum(obs == hat)/m
     acc.cv <- sum(obs == 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, form.lm = formula(sale.price ~ area),
               m=3, dots = FALSE, seed = 29, plotit=TRUE, printit=TRUE)
{
     if(class(form.lm)=="call"|class(form.lm)=="formula")
         vars <- all.vars(form.lm)
     else if(class(form.lm)=="lm") vars <- all.vars(form.lm$call)
     else stop("form.lm must be formula or call or lm object")
     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))
     options(digits = 3)
     n <- dim(df)[1]
     rand <- sample(n)%%m + 1
     xv <- df[, xnam]
     yv <- df[, ynam]
     if(plotit){
         coltypes <- palette()[c(2, 3, 6, 1, 4:5,7)]
         if(m>7)coltypes <- c(coltypes,rainbow(m-7))
         ltypes <- 1:m
         ptypes <- 2:(m+1)
         plot(xv, yv, xlab = xnam, ylab = ynam, type = "n")
     }
     xval <- pretty(xv, n = 20)
     df.lm <- lm(yv ~ xv, data = df)
     if(printit){
         print(anova(df.lm))
         cat("\n")
     }
     sumss <- 0
     sumdf <- 0
     par(lwd = 2)
     for (i in sort(unique(rand))) {
         n.in <- (1:n)[rand != i]
         n.out <- (1:n)[rand == i]
         if(printit){
             cat("\nfold", i, "\n")
             cat("Observations in test set:", n.out, "\n")
         }
         ab <- lm(yv ~ xv, subset = n.in)$coef
         z <- xv[n.out]
         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
         if(plotit){
             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)
             lines(xval, yval, lwd = 2, col = coltypes[i], lty = 
ltypes[i])
     }
         num <- length(n.out)
         if(printit) print(xy, collab = rep("", num))
         ss <- sum(resid^2)
         sumss <- sumss + ss
         sumdf <- sumdf + num
         ms <- ss/num
         if(printit)
         cat("\nSum of squares =", round(ss, 2), "   Mean square =",
             round(ms, 2), "   n =", num, "\n")
     }
     if(printit) print(c("Overall ms" = sumss/sumdf))
     if(plotit){
         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)
     }
     invisible(c(ss=sumss, df=sumdf))
}

"leaftemp.all" <-
structure(list(glasshouse = structure(c(1, 2, 3, 1, 2, 3, 1, 
3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 3, 1, 2, 3, 1, 2, 3, 1, 
2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 2, 3, 1, 2, 3, 1, 2, 3, 
1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1), .Label = c("A", "B", 
"C"), class = "factor"), CO2level = structure(c(1, 2, 3, 1, 2, 
3, 1, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 
1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 
1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3), .Label = c("high", 
"low", "medium"), class = "factor"), day = structure(c(1, 1, 
1, 2, 2, 2, 13, 13, 16, 16, 16, 17, 17, 17, 18, 18, 18, 19, 19, 
19, 20, 20, 20, 21, 21, 21, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 
6, 7, 7, 7, 8, 8, 8, 9, 9, 9, 10, 10, 10, 11, 11, 11, 12, 12, 
12, 14, 14, 14, 15, 15, 15), .Label = c("0", "1", "10", "11", 
"12", "13", "14", "15", "16", "17", "18", "19", "2", "20", "21", 
"3", "4", "5", "6", "8", "9"), class = "factor"), light = c(1143.06, 
1143.06, 1143.06, 465.810555555556, 465.810555555556, 465.810555555556, 
117.610083333333, 117.610083333333, 498.158888888889, 498.158888888889, 
498.158888888889, 723.32, 723.32, 723.32, 847.731111111111, 847.731111111111, 
847.731111111111, 828.896666666667, 828.896666666667, 828.896666666667, 
907.578888888889, 907.578888888889, 907.578888888889, 1132.53555555556, 
1132.53555555556, 1132.53555555556, 1010.90944444444, 1010.90944444444, 
1010.90944444444, 1070.55888888889, 1070.55888888889, 1070.55888888889, 
730.34, 730.34, 730.34, 606.113888888889, 606.113888888889, 606.113888888889, 
692.985, 692.985, 692.985, 697.113888888889, 697.113888888889, 
697.113888888889, 165.826388888889, 165.826388888889, 165.826388888889, 
977.900555555556, 977.900555555556, 977.900555555556, 274.783333333333, 
274.783333333333, 274.783333333333, 843.156666666666, 843.156666666666, 
843.156666666666, 564.044444444444, 564.044444444444, 564.044444444444, 
874.895, 874.895, 874.895), CO2 = c(127.112222222222, 39.8548333333333, 
70.9381111111111, 128.404444444444, 40.9965555555556, 71.2677222222222, 
112.608333333333, 71.0375, 114.272777777778, 32.2556666666667, 
70.8896666666667, 112.19, 31.9886666666667, 70.4222222222222, 
123.253888888889, 32.1677777777778, 70.8019444444445, 123.132222222222, 
32.8816666666667, 71.0546666666667, 108.657777777778, 33.1490555555556, 
71.9444444444444, 121.948333333333, 33.8645555555556, 72.2855555555555, 
121.424444444444, 31.9138333333333, 71.8222222222222, 122.057222222222, 
33.1838888888889, 72.2288888888889, 122.036111111111, 31.5882222222222, 
71.8288888888889, 122.398333333333, 35.7767222222222, 72.4291111111111, 
111.953333333333, 34.6518333333333, 71.6806666666667, 121.244444444444, 
40.8168888888889, 63.2003333333333, 119.809444444444, 41.3131111111111, 
67.6875555555556, 121.669444444444, 33.6986111111111, 64.4362777777778, 
121.663888888889, 33.1251666666667, 64.0213888888889, 121.707222222222, 
32.5156666666667, 72.8094444444445, 121.511666666667, 34.0342777777778, 
72.7016666666667, 120.905555555556, 33.3232222222222, 72.4335555555556
), tempDiff = c(1.83503666666667, 1.54260444444444, 1.96211919191919, 
0.928792373737374, 0.680828888888889, 0.890423695286195, 0.0235372727272727, 
-0.0621770833333333, 1.09649186868687, 0.502876296296296, 0.646197063492063, 
1.27299222222222, 0.653779444444444, 1.05038015873016, 1.72356060606061, 
0.900343333333334, 1.07663827160494, 1.60395808080808, 0.752945, 
0.988385802469136, 1.89179747474747, 1.14646666666667, 1.61809646464647, 
2.30875313131313, 1.50452751322751, 2.18120555555556, 2.00672373737374, 
0.819447407407408, 1.89558444444444, 2.33886833333333, 0.98578888888889, 
2.05456833333333, 1.71393611111111, 0.603571111111111, 1.41697777777778, 
1.26059472222222, 0.483769747474748, 1.03244691358025, 1.96569027777778, 
1.89291666666667, 2.1033962962963, 1.72759212962963, 1.7236621399177, 
1.02497676767677, 0.128692592592593, 0.00947057613168727, 0.0596287878787879, 
1.72196574074074, 1.28687119341564, 1.18370484848485, 0.444533333333333, 
0.189314609053498, 0.34965, 1.46936481481481, 0.668390534979424, 
0.908201666666666, 1.00493240740741, 0.122529124579125, 0.855557222222222, 
1.5822837962963, 0.264571885521885, 1.00212878787879), BtempDiff = c(1.49645740740741, 
1.35521604938272, 1.94277986111111, 0.849521527777778, 0.59922, 
0.825777777777778, -0.0391199999999999, -0.110020833333333, 1.25168950617284, 
0.233696913580247, 0.851787037037037, 1.63848271604938, 0.484933950617284, 
1.31793024691358, 1.99215185185185, 0.98257361111111, 1.75550679012346, 
1.90427654320988, 0.976392361111111, 1.4900487654321, 2.42084888888889, 
1.47830808080808, 1.63841666666667, 3.20363246252205, 2.16055757575758, 
2.11160707070707, 2.73599259259259, 1.338734, 1.94301919191919, 
3.21515166666667, 1.60770202020202, 2.19160808080808, 2.24259222222222, 
0.749724242424242, 1.60530101010101, 1.6188537037037, 0.749551515151515, 
1.11210606060606, 2.46695, 1.92354090909091, 2.34125151515152, 
1.59447962962963, 1.50789413580247, 1.29171191358025, -0.000970987654320997, 
-0.00275259259259255, 0.107624444444444, 2.8524487654321, 1.25759462962963, 
1.87311133333333, 0.494446913580247, 0.104627037037037, 0.436306111111111, 
2.09427098765432, 0.723372592592593, 1.31268, 1.19819666666667, 
0.231627407407407, 0.887388383838384, 1.935055, 0.670589259259259, 
1.10185101010101), airTemp = c(26.0471666666667, 24.10275, 26.7115555555556, 
25.1351666666667, 24.8993055555556, 26.3836944444444, 26.47835, 
26.8169166666667, 24.3795833333333, 24.1021944444445, 25.7806666666667, 
24.5761666666667, 23.9912222222222, 25.8324722222222, 24.9788333333333, 
23.4645, 25.8215833333333, 25.8063055555556, 24.2576111111111, 
26.3183333333333, 26.0814722222222, 25.2733611111111, 23.9823888888889, 
26.3605, 25.4741111111111, 23.7405, 26.4659722222222, 26.2082666666667, 
23.9202777777778, 26.5336944444445, 26.175, 23.6020833333333, 
26.167, 25.79025, 23.9966666666667, 26.4223611111111, 26.0320277777778, 
25.2358611111111, 25.5579166666667, 24.6225, 21.61475, 26.2310555555556, 
26.4483518518519, 25.9719166666667, 27.8573611111111, 26.9790925925926, 
26.3131666666667, 25.4549722222222, 26.3252037037037, 25.8383333333333, 
27.1305555555555, 26.4931296296296, 25.5383055555556, 25.6840277777778, 
26.3027962962963, 26.4479722222222, 26.3876666666667, 26.5444259259259, 
25.2024166666667, 26.0148888888889, 26.4985185185185, 26.1942777777778
), vapPress = c(2.56387655012214, 1.87897327726481, 2.37594012913196, 
2.54675924264334, 2.19813069574783, 2.72418455805987, 2.17289080916864, 
2.20636547854048, 1.64423531148677, 1.75058608385587, 1.66677756965644, 
1.66564001099429, 1.84753955400845, 1.67464103532266, 1.81320379985348, 
1.69453750433538, 1.70920931125348, 1.85658816389914, 1.32817399450414, 
1.80331915368179, 1.57802231830817, 2.07118071003583, 1.87902346088399, 
1.94568003550132, 2.09596454161064, 1.74824473848148, 1.3832571195728, 
2.16984418267478, 1.90167686879526, 1.65704065495475, 2.13202245477493, 
1.81087852880404, 2.15938473600303, 2.25653220118401, 1.93234697139582, 
2.18800293395565, 2.38009355414251, 2.44610684101806, 2.29298641013283, 
1.9309989052843, 1.7238489414991, 2.32267858820212, 2.59938832192398, 
2.49291132094598, 2.70315398531423, 2.48110046200659, 2.45494863734698, 
2.04734130525711, 2.17445742957429, 1.85996759636093, 2.55818770574725, 
2.37955689130302, 2.38882886847067, 1.80296619038312, 1.93681891995772, 
1.43233402777916, 1.81772198968773, 1.77715975127671, 1.4638478809468, 
2.02776821561522, 2.10162050879381, 2.10954758814838)), .Names = c("glasshouse", 
"CO2level", "day", "light", "CO2", "tempDiff", "BtempDiff", "airTemp", 
"vapPress"), row.names = c("1", "2", "3", "4", "5", "6", "7", 
"8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", 
"19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", 
"30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", 
"41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", 
"52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "62"
), class = "data.frame")
"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, ratio = c(0.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)
         xpos <- par()$usr[1]
         ypos <- par()$usr[4]
         legend(xpos, ypos, lty = c(2, 1), col = c("black", "red"),
             cex = c(0.8, 0.8), legend = c("Control", "Treatment"),
             lwd = c(1, 2), bty = "n")
     }
     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
     f0[f0 < 0] <- 0
     f1[f1 < 0] <- 0
     fmin <- pmin(f0,f1)
     fmax <- max(fmin)
     subs <- match(fmax, fmin)
     xmid <- x01[subs]
     flow <- ratio[1]
     fhi <- ratio[2]
     lochoose <- x01<xmid & (f0<=flow*f1 | f1<=f0*flow)
     if(any(lochoose))
         xlim[1] <- max(x01[lochoose]) else xlim[1] <- min(x01)
     hichoose <- x01>xmid & (f0>=fhi*f1 | f1>=f0*fhi)
     if(any(hichoose))
         xlim[2] <- min(x01[hichoose]) else xlim[2] <- max(x01)
     if (plotit)
         axis(1, at = xlim, labels=paste(signif(xlim,4)), las=2)
     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)
}
