1compresid2way <- 2 function(aov, data=NULL, fac=1:2, 3 label = TRUE, numlabel = FALSE, xlab=NULL, ylab=NULL, main=NULL, 4 col=c(2,3,4,4),lty=c(1,1,2,4), pch=c(1,2)) 5{ 6 ## Zweck: forget-it-plot Autor: Stahel Datum: Dez 89 7 ## Arguments: 8 ## aov either a aov object with a formula of the form 9 ## y ~ a + b , where a and b are factors 10 ## or such a formula 11 ## data data frame containing a and b 12 ## fac the two factors used for plotting 13 ## label show levels of factors in the plot 14 ## numlabel show effects of factors in the plot 15 ## col,lty,pch colors, line types, plotting characters to be used 16 ## [1] positive residuals 17 ## [2] negative residuals 18 ## [3] grid 19 ## [4] labels 20 21 if (inherits(aov,"aov")) { 22 lform <- formula(aov) 23 if (is.null(data)) { 24 datanm <- as.character(aov$call)[3] 25 if (is.na(datanm)) 26 stop("no data found") 27 data <- eval(parse(text=datanm)) 28 } 29 } else { 30 if (!is.data.frame(data)) 31 stop("unsuitable argument data") 32 lform <- aov 33 aov <- aov(lform,data) 34 } 35 lmm <- model.frame(aov) 36 fac <- if (is.numeric(fac)) fac+1 else match(fac,names(lmm)) 37 if (any(is.na(fac))) 38 stop("factor(s) not found") 39 if (!all(vapply(lmm[,fac], is.factor, NA))) 40 stop("variables are not both factors") 41 ## coefficients, components of the fit 42 lcf <- dummy.coef(aov) 43 lic <- lcf[["(Intercept)"]] 44 if (is.na(lic)) lic <- 0 45 lia <- fac[1] 46 lib <- fac[2] 47 lfa <- lmm[,lia] 48 lfb <- lmm[,lib] 49 lcfa <- lcf[[lia]] 50 lcfb <- lcf[[lib]] 51 lmna <- min(lcfa) 52 lmnb <- min(lcfb) 53 lcfa <- lcfa-lmna 54 lcfb <- lcfb-lmnb 55 lic <- lic+lmna+lmnb 56 lefa <- lcfa[lfa] 57 lefb <- lcfb[lfb] 58 lfit <- lic+lefa+lefb 59 lfnames <- names(lmm)[c(lia,lib)] 60 lyname <- names(lmm)[1] 61 ly <- lfit+resid(aov) 62 ## prepare plot 63 lx <- lefb-lefa 64 if (is.null(main)) 65 main <- format(lform) 66 if (is.null(ylab)) 67 ylab <- lyname 68 if (is.null(xlab)) 69 xlab <- paste("-",paste(lfnames,collapse = " + ")) 70 lty <- rep(lty,length = 4) 71 if (length(pch) <= 1) pch <- rep(c(pch,pch,1),length = 2) 72 lrgy <- range(c(lfit, ly)) 73 lrgx <- range(lx) 74 lht <- 0.05 * diff(lrgy) 75 lwd <- 0.05 * diff(lrgx) 76 plot(lrgx+lwd*c(-1,1), lrgy+lwd*c(-1,1), type = "n", xlab = "", ylab = ylab) 77 mtext(main, 3, 1, 78 cex = par("cex.main"), col = par("col.main"), font = par("font.main")) 79 mtext(xlab,1, par("mgp")[1], at = 0) 80 ## residuals 81 li <- ly > lfit 82 if (any(li)) { 83 lpch <- if (length(pch) >= length(li)) pch[li] else pch[1] 84 segments(lx[li], lfit[li], lx[li], ly[li], lty = lty[1], col = col[1]) 85 points(lx[li], ly[li], col = col[1], pch = lpch) 86 } 87 li <- !li 88 if (any(li)) { 89 lpch <- if (length(pch) >= length(li)) pch[li] else pch[2] 90 segments(lx[li], lfit[li], lx[li], ly[li], lty = lty[2], col = col[2]) 91 points(lx[li], ly[li], col = col[2], pch = lpch) 92 } 93 ## grid 94 lmxa <- max(lcfa) 95 segments(lcfb, lic + lcfb, lcfb - lmxa, lic + lmxa + lcfb, 96 lty = lty[3], col = col[3]) 97 lmxb <- max(lcfb) 98 segments( - lcfa, lic + lcfa, lmxb - lcfa, lic + lmxb + lcfa, 99 lty = lty[3], col = col[3]) 100 ## labels 101 if(label) 102 text(c(lcfb - lmxa - lwd, lmxb - lcfa + lwd), 103 c(lmxa + lcfb, lmxb + lcfa) + lic + lht, 104 c(levels(lfb), levels(lfa)), col = col[4]) 105 if(numlabel) { 106 ldg <- - min(0, floor(log10(max(abs(lrgy)))) - 3) 107 text(c(lcfb + lwd, - lcfa - lwd), lic + c(lcfb, lcfa) - lht, 108 round(c(lcfb, lcfa), ldg), col = col[4]) 109 } 110 lcf <- list(lic,lcfa,lcfb) 111 names(lcf) <- c("(Intercept)",lfnames) 112 lcompy <- data.frame(ly,lefa,lefb) 113 names(lcompy) <- c(paste("part",lyname,sep = "."), 114 paste("eff",lfnames,sep = ".")) 115 invisible(list(compy = lcompy,coef = lcf)) 116} 117