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 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
|
wca <- function (x, ...) UseMethod("wca")
"wca.dudi" <- function (x, fac, scannf = TRUE, nf = 2, ...) {
if (!inherits(x, "dudi"))
stop("Object of class dudi expected")
if (!is.factor(fac))
stop("factor expected")
lig <- nrow(x$tab)
if (length(fac) != lig)
stop("Non convenient dimension")
cla.w <- tapply(x$lw, fac, sum)
mean.w <- function(x, w, fac, cla.w) {
z <- x * w
z <- tapply(z, fac, sum)/cla.w
return(z)
}
tabmoy <- apply(x$tab, 2, mean.w, w = x$lw, fac = fac,
cla.w = cla.w)
tabw <- unlist(tapply(x$lw, fac, sum))
tabw <- tabw/sum(tabw)
tabwit <- x$tab - tabmoy[fac, ]
res <- as.dudi(tabwit, x$cw, x$lw, scannf = scannf, nf = nf,
call = match.call(), type = "wit")
res$ratio <- sum(res$eig)/sum(x$eig)
U <- as.matrix(res$c1) * unlist(res$cw)
U <- data.frame(as.matrix(x$tab) %*% U)
row.names(U) <- row.names(x$tab)
names(U) <- names(res$li)
res$ls <- U
U <- as.matrix(res$c1) * unlist(res$cw)
U <- data.frame(t(as.matrix(x$c1)) %*% U)
row.names(U) <- names(x$li)
names(U) <- names(res$li)
res$as <- U
res$tabw <- tabw
res$fac <- fac
class(res) <- c("within", "dudi")
return(res)
}
"within" <- function (dudi, fac, scannf = TRUE, nf = 2) {
.Deprecated("wca", "ade4", "To avoid some name conflicts, the 'within' function is now deprecated. Please use 'wca' instead")
res <- wca(x=dudi, fac=fac, scannf = scannf, nf = nf)
res$call <- match.call()
return(res)
}
"plot.within" <- function (x, xax = 1, yax = 2, ...) {
if (!inherits(x, "within"))
stop("Use only with 'within' objects")
if ((x$nf == 1) || (xax == yax)) {
return(invisible())
}
if (xax > x$nf)
stop("Non convenient xax")
if (yax > x$nf)
stop("Non convenient yax")
fac <- x$fac
def.par <- par(no.readonly = TRUE)
on.exit(par(def.par))
layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3),
respect = TRUE)
par(mar = c(0.2, 0.2, 0.2, 0.2))
s.arrow(x$c1, xax = xax, yax = yax, sub = "Canonical weights",
csub = 2, clabel = 1.25)
s.arrow(x$co, xax = xax, yax = yax, sub = "Variables",
csub = 2, clabel = 1.25)
scatterutil.eigen(x$eig, wsel = c(xax, yax))
s.class(x$ls, fac, xax = xax, yax = yax, sub = "Scores and classes",
csub = 2, clabel = 1.5, cpoint = 2)
s.corcircle(x$as, xax = xax, yax = yax, sub = "Inertia axes",
csub = 2, cgrid = 0, clabel = 1.25)
s.class(x$li, fac, xax = xax, yax = yax, axesell = FALSE,
clabel = 0, cstar = 0, sub = "Common centring", csub = 2)
}
"print.within" <- function (x, ...) {
if (!inherits(x, "within"))
stop("to be used with 'within' object")
cat("Within analysis\n")
cat("call: ")
print(x$call)
cat("class: ")
cat(class(x), "\n")
cat("\n$nf (axis saved) :", x$nf)
cat("\n$rank: ", x$rank)
cat("\n$ratio: ", x$ratio)
cat("\n\neigen values: ")
l0 <- length(x$eig)
cat(signif(x$eig, 4)[1:(min(5, l0))])
if (l0 > 5)
cat(" ...\n\n")
else cat("\n\n")
sumry <- array("", c(5, 4), list(1:5, c("vector", "length",
"mode", "content")))
sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths")
sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths")
sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "class weigths")
sumry[5, ] <- c("$fac", length(x$fac), mode(x$fac), "factor for grouping")
print(sumry, quote = FALSE)
cat("\n")
sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow",
"ncol", "content")))
sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "array class-variables")
sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "supplementary row coordinates")
sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "inertia axis onto within axis")
print(sumry, quote = FALSE)
cat("\n")
}
summary.within <- function(object, ...){
thetitle <- "Within-class analysis"
cat(thetitle)
cat("\n\n")
NextMethod()
appel <- as.list(object$call)
dudi <- eval.parent(appel$x)
cat(paste("Total unconstrained inertia (", deparse(appel$x),
"): ", sep = ""))
cat(signif(sum(dudi$eig), 4))
cat("\n\n")
cat(paste("Inertia of", deparse(appel$x), "independent of",
deparse(appel$fac), "(%): "))
cat(signif(object$ratio * 100, 4))
cat("\n\n")
}
|