Vijayan Padmanabhan
2011-Jan-11 06:45 UTC
[R] modified FAST Script from package SensoMineR for the R community - Reg
###Dear R users
###I have been using SensoMineR package from CRAN for most of my work in
sensory data analysis and from my usage experience, I encountered some
areas for improvement and considered ###modifying the function in
SensoMineR package for my personal use. I felt that it could be useful to
share this to the community for enabling adoption by other users where
they might require a similar ###functionality.
###Thanks to Dr.Husson and Dr.Le for making available the above package in
the first place.
###Basic utility delivered through the modified fast function: (Refer the
function "fastmod" below:)
##Plotting the most relevant 6 plots from "fast" function of
SensoMiner
Package in a single layout (Very useful when working with Sweave or
odfWeave, wherein the figure returned as result from the ##function
execution can't be more than one per code chunk). The nearest workaround
would mean saving each graphical output as a image and reinserting the
stored image of plots through multiple ##code chunks or a code chunk
executing image insert in loops.. a bit tedious i suppose!).
## Decluttering overlapping labels produced by plot.MCA and plot.MFA
function in SensoMineR (Refer the functions plot.MCA2 and plot.MFA2 for
this feature)
##The fastmod function includes a call to plot.MCA2 and plot.MFA2 as well
so the final output is also decluttered of overlapping labels, however
before calling the fastmod function a source or call to ##plot.MFA2 and
plot.MCA2 is required.
## library(maptools) need to be called before calling the functions.
###plot.MFA2 Function
plot.MFA2<-
function (x, axes = c(1, 2), choix = "ind", ellipse = NULL,
ellipse.par =
NULL,
lab.grpe = TRUE, lab.var = TRUE, lab.ind.moy = TRUE, lab.par = FALSE,
habillage = "ind", col.hab = NULL, invisible = NULL, partial =
NULL,
lim.cos2.var = 0, chrono = FALSE, xlim = NULL, ylim = NULL,
cex = 1, title = NULL, palette = NULL, new.plot = TRUE, ...)
{
res.mfa <- x
if (!inherits(res.mfa, "MFA"))
stop("non convenient data")
if (is.null(palette))
palette(c("black", "red", "green3",
"blue", "cyan", "magenta",
"darkgray", "darkgoldenrod",
"darkgreen", "violet",
"turquoise", "orange", "lightpink",
"lavender", "yellow",
"lightgreen", "lightgrey",
"lightblue", "darkkhaki",
"darkmagenta", "darkolivegreen",
"lightcyan", "darkorange",
"darkorchid", "darkred", "darksalmon",
"darkseagreen",
"darkslateblue", "darkslategray",
"darkslategrey",
"darkturquoise", "darkviolet",
"lightgray", "lightsalmon",
"lightyellow", "maroon"))
lab.x <- paste("Dim ", axes[1], " (",
signif(res.mfa$eig[axes[1],
2], 4), " %)", sep = "")
lab.y <- paste("Dim ", axes[2], " (",
signif(res.mfa$eig[axes[2],
2], 4), " %)", sep = "")
group <- res.mfa$call$group
nbre.grpe <- length(group)
type <- res.mfa$call$type
num.group.sup = NULL
if (!is.null(res.mfa$group$coord.sup)) {
num.group.sup <- res.mfa$call$num.group.sup
nbre.grpe.sup <- length(num.group.sup)
type.sup <- res.mfa$call$type[num.group.sup]
type.act <- type[-num.group.sup]
nbre.grpe <- nbre.grpe - length(num.group.sup)
}
if (choix == "axes") {
if (new.plot)
dev.new()
if (is.null(title))
title <- "Partial axes"
coord.axes <- res.mfa$partial.axes$coord[, axes, drop = FALSE]
plot(0, 0, xlab = lab.x, ylab = lab.y, xlim = c(-1.1,
1.1), ylim = c(-1.1, 1.1), col = "white", asp = 1,
cex = cex, main = title)
x.cercle <- seq(-1, 1, by = 0.01)
y.cercle <- sqrt(1 - x.cercle^2)
lines(x.cercle, y = y.cercle)
lines(x.cercle, y = -y.cercle)
abline(v = 0, lty = 2, cex = cex)
abline(h = 0, lty = 2, cex = cex)
if (habillage == "group") {
if (is.null(col.hab) | length(col.hab) < length(group)) {
col.hab <- 2:(length(group) + 1)
}
i = 1
couleur.axes <- col.hab[i]
auxil = strsplit(rownames(res.mfa$partial.axes$coord)[1],
".", fixed = TRUE)[[1]]
auxil2 = auxil[length(auxil)]
for (j in 2:nrow(res.mfa$partial.axes$coord)) {
auxil = strsplit(rownames(res.mfa$partial.axes$coord)[j],
".", fixed = TRUE)[[1]]
if (auxil2 != auxil[length(auxil)]) {
i = i + 1
auxil2 = auxil[length(auxil)]
}
couleur.axes <- c(couleur.axes, col.hab[i])
}
}
else {
couleur.axes <- NULL
for (i in 1:length(group)) couleur.axes <- c(couleur.axes,
rep("black", ncol(res.mfa$partial.axes$coord)))
}
for (v in 1:nrow(coord.axes)) {
arrows(0, 0, coord.axes[v, 1], coord.axes[v, 2],
length = 0.1, angle = 15, code = 2, col = couleur.axes[v])
if (abs(coord.axes[v, 1]) > abs(coord.axes[v, 2])) {
if (coord.axes[v, 1] >= 0)
pos <- 4
else pos <- 2
}
else {
if (coord.axes[v, 2] >= 0)
pos <- 3
else pos <- 1
}
text(coord.axes[v, 1], y = coord.axes[v, 2], labels =
rownames(coord.axes)[v],
pos = pos, col = couleur.axes[v])
}
if (habillage == "group") {
legend("topleft", legend =
rownames(res.mfa$group$Lg)[-length(rownames(res.mfa$group$Lg))],
text.col = unique(couleur.axes), cex = 0.8)
}
}
if (choix == "group") {
if (new.plot)
dev.new()
if (is.null(title))
title <- "Groups representation"
coord.actif <- res.mfa$group$coord[, axes, drop = FALSE]
if (!is.null(res.mfa$group$coord.sup))
coord.illu <- res.mfa$group$coord.sup[, axes, drop = FALSE]
if (is.null(col.hab)) {
col.hab = rep("darkred", nrow(coord.actif))
if (!is.null(res.mfa$group$coord.sup))
col.hab = c(col.hab, rep("darkolivegreen",
nrow(coord.illu)))
}
if (habillage == "group")
col.hab <- (2:(length(group) + 1))
plot(coord.actif, xlab = lab.x, ylab = lab.y, xlim = c(0,
1), ylim = c(0, 1), pch = 17, col =
col.hab[1:nrow(coord.actif)],
cex = cex, main = title, cex.main = cex * 1.2, asp = 1)
if (lab.grpe)
pointLabel(coord.actif[, 1], y = coord.actif[, 2], labels =
rownames(coord.actif),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.hab[1:nrow(coord.actif)])
if (!is.null(res.mfa$group$coord.sup)) {
points(coord.illu, pch = 17, col = col.hab[(nrow(coord.actif)
+
1):(nrow(coord.actif) + nrow(coord.illu))])
if (lab.grpe)
pointLabel(coord.illu[, 1], y = coord.illu[, 2], labels =
rownames(coord.illu),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,col =
col.hab[(nrow(coord.actif) +
1):(nrow(coord.actif) + nrow(coord.illu))])
}
}
if (choix == "var") {
if (new.plot)
dev.new()
test.invisible <- vector(length = 2)
if (!is.null(invisible)) {
test.invisible[1] <- match("actif", invisible)
test.invisible[2] <- match("sup", invisible)
}
else test.invisible <- rep(NA, 2)
col <- NULL
if (habillage == "group") {
if (is.null(col.hab) | length(col.hab) < length(group[type !=
"n"]))
col.hab <- 2:(length(group[type != "n"]) + 1)
for (i in 1:length(group[type != "n"])) col <- c(col,
rep(col.hab[i], group[type != "n"][i]))
}
else {
if (is.null(col.hab) | length(col.hab) < sum(group[type !=
"n"]))
col <- rep(1, sum(group[type != "n"]))
else col <- col.hab
}
if (is.null(title))
title <- "Correlation circle"
plot(0, 0, main = title, xlab = lab.x, ylab = lab.y,
xlim = c(-1.1, 1.1), ylim = c(-1.1, 1.1), col = "white",
asp = 1, cex = cex)
x.cercle <- seq(-1, 1, by = 0.01)
y.cercle <- sqrt(1 - x.cercle^2)
lines(x.cercle, y = y.cercle)
lines(x.cercle, y = -y.cercle)
abline(v = 0, lty = 2, cex = cex)
abline(h = 0, lty = 2, cex = cex)
if (habillage == "group" & is.na(test.invisible[1]) &
is.na(test.invisible[2]))
legend("topleft", legend =
rownames(res.mfa$group$Lg[-nrow(res.mfa$group$Lg),
])[type != "n"], text.col = col.hab, cex = 0.8)
if (habillage == "group" & is.na(test.invisible[1]) &
!is.na(test.invisible[2]))
legend("topleft", legend =
rownames(res.mfa$group$Lg[-c(num.group.sup,
nrow(res.mfa$group$Lg)), ])[type.act != "n"],
text.col = col.hab, cex = 0.8)
if (habillage == "group" & !is.na(test.invisible[1]) &
is.na(test.invisible[2]))
legend("topleft", legend =
rownames(res.mfa$group$Lg[num.group.sup,
])[type.sup != "n"], text.col = col.hab, cex = 0.8)
nrow.coord.var <- 0
if (!is.null(res.mfa["quanti.var"]$quanti.var$coord) &
is.na(test.invisible[1])) {
coord.var <- res.mfa$quanti.var$cor[, axes, drop = FALSE]
nrow.coord.var <- nrow(coord.var)
for (v in 1:nrow(coord.var)) {
if (sum(res.mfa$quanti.var$cos2[v, axes], na.rm = TRUE) >=
lim.cos2.var && !is.na(sum(res.mfa$quanti.var$cos2[v,
axes], na.rm = TRUE))) {
arrows(0, 0, coord.var[v, 1], coord.var[v,
2], length = 0.1, angle = 15, code = 2, col = col[v])
if (lab.var) {
if (abs(coord.var[v, 1]) > abs(coord.var[v,
2])) {
if (coord.var[v, 1] >= 0)
pos <- 4
else pos <- 2
}
else {
if (coord.var[v, 2] >= 0)
pos <- 3
else pos <- 1
}
pointLabel(coord.var[v, 1], y = coord.var[v, 2],
labels = rownames(coord.var)[v],
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,
col = col[v])
}
}
}
}
if (!is.null(res.mfa$quanti.var.sup$coord) &
is.na(test.invisible[2])) {
coord.var.sup <- res.mfa$quanti.var.sup$cor[, axes,
drop = FALSE]
for (q in 1:nrow(coord.var.sup)) {
print(sum(res.mfa$quanti.var.sup$cos2[q, axes],
na.rm = TRUE))
if (sum(res.mfa$quanti.var.sup$cos2[q, axes],
na.rm = TRUE) >= lim.cos2.var &&
!is.na(sum(res.mfa$quanti.var.sup$cos2[q,
axes], na.rm = TRUE))) {
arrows(0, 0, coord.var.sup[q, 1], coord.var.sup[q,
2], length = 0.1, angle = 15, code = 2, lty = 2,
col = col[nrow.coord.var + q])
if (lab.var) {
if (abs(coord.var.sup[q, 1]) > abs(coord.var.sup[q,
2])) {
if (coord.var.sup[q, 1] >= 0)
pos <- 4
else pos <- 2
}
else {
if (coord.var.sup[q, 2] >= 0)
pos <- 3
else pos <- 1
}
pointLabel(coord.var.sup[q, 1], y = coord.var.sup[q,
2], labels = rownames(coord.var.sup)[q],
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col
= col[nrow.coord.var + q])
}
}
}
}
par(mar = c(5, 4, 4, 2) + 0.1)
}
if (choix == "ind") {
test.invisible <- vector(length = 3)
if (!is.null(invisible)) {
test.invisible[1] <- match("ind", invisible)
test.invisible[2] <- match("ind.sup", invisible)
test.invisible[3] <- match("quali", invisible)
}
else test.invisible <- rep(NA, 3)
nb.ind.actif <- nrow(res.mfa$ind$coord)
nb.ind.illu <- 0
if (!is.null(res.mfa$ind.sup))
nb.ind.illu <- nrow(res.mfa$ind.sup$coord)
nb.ind <- nb.ind.actif + nb.ind.illu
coord.ind <- res.mfa$ind$coord[, axes, drop = FALSE]
coord.ind.partiel <- res.mfa$ind$coord.partiel[, axes,
drop = FALSE]
coord.ind.sup <- NULL
if (!is.null(res.mfa$ind.sup)) {
coord.ind.sup <- res.mfa$ind.sup$coord[, axes, drop = FALSE]
coord.ind.partiel.sup <- res.mfa$ind.sup$coord.partiel[,
axes, drop = FALSE]
}
coord.quali <- coord.quali.sup <- coord.quali.partiel <-
coord.quali.sup.partiel <- NULL
nrow.coord.quali <- 0
if (!is.null(res.mfa["quali.var"]$quali.var)) {
coord.quali <- res.mfa$quali.var$coord[, axes, drop = FALSE]
coord.quali.partiel <- res.mfa$quali.var$coord.partiel[,
axes, drop = FALSE]
nrow.coord.quali <- nrow(coord.quali)
}
if (!is.null(res.mfa["quali.var.sup"])) {
coord.quali.sup <- res.mfa$quali.var.sup$coord[,
axes, drop = FALSE]
coord.quali.partiel.sup <-
res.mfa$quali.var.sup$coord.partiel[,
axes, drop = FALSE]
}
group.ind.actif <- group.ind.sup <- group.quali <-
group.quali.sup
<- NULL
if (!is.null(partial)) {
if (length(partial) == 1) {
if (partial == "all") {
group.ind.actif <- 1:nrow(coord.ind)
if (!is.null(res.mfa$ind.sup))
group.ind.sup <- 1:nrow(coord.ind.sup)
if (!is.null(res.mfa["quali.var"]$quali.var))
group.quali <- 1:nrow(coord.quali)
if
(!is.null(res.mfa["quali.var.sup"]$quali.var.sup))
group.quali.sup <- 1:nrow(coord.quali.sup)
}
else {
for (i in 1:length(partial)) {
if (partial[i] %in% rownames(coord.ind))
group.ind.actif <- c(group.ind.actif,
grep(partial[i],
rownames(coord.ind)))
if (partial[i] %in% rownames(coord.ind.sup))
group.ind.sup <- c(group.ind.sup, grep(partial[i],
rownames(coord.ind.sup)))
if (partial[i] %in% rownames(coord.quali))
group.quali <- c(group.quali, grep(partial[i],
rownames(coord.quali)))
if (partial[i] %in% rownames(coord.quali.sup))
group.quali.sup <- c(group.quali.sup,
grep(partial[i],
rownames(coord.quali.sup)))
}
}
}
else {
for (i in 1:length(partial)) {
if (partial[i] %in% rownames(coord.ind))
group.ind.actif <- c(group.ind.actif, grep(partial[i],
rownames(coord.ind)))
if (partial[i] %in% rownames(coord.ind.sup))
group.ind.sup <- c(group.ind.sup, grep(partial[i],
rownames(coord.ind.sup)))
if (partial[i] %in% rownames(coord.quali))
group.quali <- c(group.quali, grep(partial[i],
rownames(coord.quali)))
if (partial[i] %in% rownames(coord.quali.sup))
group.quali.sup <- c(group.quali.sup, grep(partial[i],
rownames(coord.quali.sup)))
}
}
}
if (!is.null(ellipse)) {
coord.ellipse <- ellipse$res
npoint.ellipse <- ellipse$call
}
else coord.ellipse <- NULL
if (!is.null(ellipse.par)) {
coord.ellipse.par <- ellipse.par$res
npoint.ellipse.par <- ellipse.par$call
}
else coord.ellipse.par <- NULL
if (is.null(xlim)) {
xmin <- xmax <- 0
if (is.na(test.invisible[1]))
xmin <- min(xmin, coord.ind[, 1])
if (is.na(test.invisible[1]))
xmax <- max(xmax, coord.ind[, 1])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
xmin <- min(xmin, coord.ind.sup[, 1])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
xmax <- max(xmax, coord.ind.sup[, 1])
if (is.na(test.invisible[1]))
xmin <- min(xmin,
coord.ind.partiel[unlist(lapply(group.ind.actif,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (is.na(test.invisible[1]))
xmax <- max(xmax,
coord.ind.partiel[unlist(lapply(group.ind.actif,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
xmin <- min(xmin,
coord.ind.partiel.sup[unlist(lapply(group.ind.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
xmax <- max(xmax,
coord.ind.partiel.sup[unlist(lapply(group.ind.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
xmin <- min(xmin, coord.quali[, 1])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
xmax <- max(xmax, coord.quali[, 1])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
xmin <- min(xmin,
coord.quali.partiel[unlist(lapply(group.quali,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
xmax <- max(xmax,
coord.quali.partiel[unlist(lapply(group.quali,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
xmin <- min(xmin, coord.quali[, 1], coord.quali.sup[,
1])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
xmax <- max(xmax, coord.quali[, 1], coord.quali.sup[,
1])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
xmin <- min(xmin,
coord.quali.partiel.sup[unlist(lapply(group.quali.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
xmax <- max(xmax,
coord.quali.partiel.sup[unlist(lapply(group.quali.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
1])
xlim <- c(xmin, xmax) * 1.1
}
else {
xmin = xlim[1]
xmax = xlim[2]
}
if (is.null(ylim)) {
ymin <- ymax <- 0
if (is.na(test.invisible[1]))
ymin <- min(ymin, coord.ind[, 2])
if (is.na(test.invisible[1]))
ymax <- max(ymax, coord.ind[, 2])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
ymin <- min(ymin, coord.ind.sup[, 2])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
ymax <- max(ymax, coord.ind.sup[, 2])
if (is.na(test.invisible[1]))
ymin <- min(ymin,
coord.ind.partiel[unlist(lapply(group.ind.actif,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (is.na(test.invisible[1]))
ymax <- max(ymax,
coord.ind.partiel[unlist(lapply(group.ind.actif,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
ymin <- min(ymin,
coord.ind.partiel.sup[unlist(lapply(group.ind.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2]))
ymax <- max(ymax,
coord.ind.partiel.sup[unlist(lapply(group.ind.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
ymin <- min(ymin, coord.quali[, 2])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
ymax <- max(ymax, coord.quali[, 2])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
ymin <- min(ymin,
coord.quali.partiel[unlist(lapply(group.quali,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (!is.null(res.mfa["quali.var"]$quali.var) &
is.na(test.invisible[3]))
ymax <- max(ymax,
coord.quali.partiel[unlist(lapply(group.quali,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
ymin <- min(ymin, coord.quali[, 1], coord.quali.sup[,
2])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
ymax <- max(ymax, coord.quali[, 1], coord.quali.sup[,
2])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
ymin <- min(ymin,
coord.quali.partiel.sup[unlist(lapply(group.quali.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
if (!is.null(res.mfa$quali.var.sup) &
is.na(test.invisible[3]))
ymax <- max(ymax,
coord.quali.partiel.sup[unlist(lapply(group.quali.sup,
function(k) seq(nbre.grpe * (k - 1) + 1, length =
nbre.grpe))),
2])
ylim <- c(ymin, ymax) * 1.1
}
else {
ymin = ylim[1]
ymax = ylim[2]
}
if (habillage == "group") {
if (is.null(col.hab) | length(col.hab) != (nbre.grpe))
col.hab <- 2:(nbre.grpe + 1)
col.ind <- c(rep(1, nb.ind.actif), rep(col.hab, nb.ind.actif))
if (!is.null(res.mfa$ind.sup))
col.ind.sup <- c(rep(1, nb.ind - nb.ind.actif),
rep(col.hab, nb.ind - nb.ind.actif))
if (length(group[type == "n"]) != 0)
col.quali <- c(rep(1, sum(res.mfa$call$group.mod[type ==
"n"])), rep(col.hab, sum(res.mfa$call$group.mod[type
==
"n"])))
if (!is.null(res.mfa$quali.var.sup))
col.quali.sup <- c(rep(1,
sum(res.mfa$call$group.mod[num.group.sup][type.sup ==
"n"])), rep(col.hab,
sum(res.mfa$call$group.mod[num.group.sup][type.sup ==
"n"])))
if (!is.null(ellipse))
col.ellipse <- rep(1, nb.ind.actif)
if (!is.null(ellipse.par))
col.ellipse.par <- rep(col.hab, nb.ind.actif)
}
if (habillage == "ind") {
if (is.null(col.hab) | length(col.hab) != nb.ind) {
col.hab <- 1:nb.ind
}
col.ind <- c(col.hab[1:nb.ind.actif],
rep(col.hab[1:nb.ind.actif],
each = nbre.grpe))
if (!is.null(res.mfa$ind.sup))
col.ind.sup <- c(col.hab[(nb.ind.actif + 1):nb.ind],
rep(col.hab[(nb.ind.actif + 1):nb.ind], each =
nbre.grpe))
if (length(group[type == "n"]) != 0)
col.quali <- col.quali.sup <- rep("black", (1 +
nbre.grpe) * sum(res.mfa$call$group.mod[type ==
"n"]))
if (!is.null(ellipse))
col.ellipse <- col.hab[1:nb.ind.actif]
if (!is.null(ellipse.par))
col.ellipse.par <- rep(col.hab[1:nb.ind.actif],
each = nbre.grpe)
}
if ((habillage != "none") & (habillage != "ind")
& (habillage !=
"group")) {
group.act <- (1:length(group))
if (!is.null(num.group.sup))
group.act <- group.act[-num.group.sup]
nbre.modalite <- NULL
liste.quali <- NULL
for (i in group.act) {
if (type[i] == "n") {
for (k in 1:ncol(res.mfa$separate.analyses[[i]]$call$X))
nbre.modalite <- c(nbre.modalite,
nlevels(res.mfa$separate.analyses[[i]]$call$X[,
k]))
if (i == 1)
liste.quali <- c(liste.quali,
colnames(res.mfa$call$X[1:group[1]]))
else liste.quali <- c(liste.quali,
colnames(res.mfa$call$X[(sum(group[1:(i -
1)]) + 1):sum(group[1:i])]))
}
}
if (!is.null(num.group.sup)) {
for (i in num.group.sup) {
if (type[i] == "n") {
if (i == 1)
liste.quali <- c(liste.quali,
colnames(res.mfa$call$X[1:group[1]]))
else liste.quali <- c(liste.quali,
colnames(res.mfa$call$X[(sum(group[1:(i -
1)]) + 1):sum(group[1:i])]))
for (k in
1:ncol(res.mfa$separate.analyses[[i]]$call$X)) nbre.modalite <-
c(nbre.modalite,
nlevels(res.mfa$separate.analyses[[i]]$call$X[,
k]))
}
}
}
if (is.double(habillage))
nom.quali <- colnames(res.mfa$call$X)[habillage]
else nom.quali = habillage
if (!(nom.quali %in% liste.quali))
stop("The variable ", habillage, " is not
qualitative")
modalite <- levels(as.factor(res.mfa$call$X[, nom.quali]))
col.ind <- as.numeric(as.factor(res.mfa$call$X[,
nom.quali]))
if (is.null(col.hab) | length(col.hab) != length(modalite))
col.hab <- 2:(1 + length(modalite))
col.ind <- col.hab[col.ind]
if (!is.null(res.mfa$call$ind.sup)) {
col.ind.sup <- col.ind[res.mfa$call$ind.sup]
col.ind <- col.ind[-res.mfa$call$ind.sup]
col.ind.sup <- c(col.ind.sup, rep(col.ind.sup,
each = nbre.grpe))
}
col.ind <- c(col.ind, rep(col.ind, each = nbre.grpe))
col.ellipse <- col.ind[1:nb.ind.actif]
col.ellipse.par <- col.ind[-c(1:nb.ind.actif)]
indice.inf <- sum(nbre.modalite[0:(match(nom.quali,
liste.quali) - 1)]) + 1
indice.sup <- indice.inf + length(modalite) - 1
col.quali <- rep("black",
sum(res.mfa$call$group.mod[type ==
"n"]))
if (length(group[type == "n"]) != 0) {
for (i in 1:length(liste.quali)) {
if (liste.quali[i] == nom.quali)
col.quali[indice.inf:indice.sup] <- col.hab
}
}
col.quali <- c(col.quali, rep(col.quali, each = nbre.grpe))
col.quali.sup <- col.quali
}
if (habillage == "none")
col.ind <- col.ind.sup <- col.quali.sup <- col.quali <-
col.ellipse <- col.ellipse.par <- rep("black",
nb.ind * (nbre.grpe + 1))
if (new.plot)
dev.new(width = min(14, max(8, 8 * (xmax - xmin)/(ymax -
ymin))), height = 8)
if (is.null(title))
title <- "Individual factor map"
plot(0, 0, main = title, xlab = lab.x, ylab = lab.y,
xlim = xlim, ylim = ylim, col = "white", asp = 1,
cex = cex)
abline(v = 0, lty = 2, cex = cex)
abline(h = 0, lty = 2, cex = cex)
if (is.na(test.invisible[1])) {
points(coord.ind, pch = 20, col = col.ind[1:nb.ind.actif],
cex = cex)
if (lab.ind.moy)
pointLabel(coord.ind[, 1], y = coord.ind[, 2], labels =
rownames(coord.ind),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.ind[1:nb.ind.actif])
for (i in group.ind.actif) {
for (j in 1:nbre.grpe) {
points(coord.ind.partiel[(i - 1) * nbre.grpe +
j, ], cex = 0.8 * cex, col = col.ind[nb.ind.actif +
(i - 1) * nbre.grpe + j], pch = 20)
if (lab.par)
pointLabel(coord.ind.partiel[(i - 1) * nbre.grpe +
j, 1], y = coord.ind.partiel[(i - 1) *
nbre.grpe + j, 2], labels =
rownames(coord.ind.partiel)[(i -
1) * nbre.grpe + j],
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.ind[nb.ind.actif +
(i - 1) * nbre.grpe + j])
if (chrono) {
if (j > 1)
lines(c(coord.ind.partiel[(i - 1) * nbre.grpe +
(j - 1), 1], coord.ind.partiel[(i - 1) *
nbre.grpe + j, 1]), c(coord.ind.partiel[(i -
1) * nbre.grpe + (j - 1), 2], coord.ind.partiel[(i
-
1) * nbre.grpe + j, 2]), col = col.ind[i])
}
else lines(c(coord.ind[i, 1], coord.ind.partiel[(i -
1) * nbre.grpe + j, 1]), c(coord.ind[i, 2],
coord.ind.partiel[(i - 1) * nbre.grpe + j,
2]), col = col.ind[nb.ind.actif + (i -
1) * nbre.grpe + j], lty = j)
}
}
}
if (!is.null(res.mfa$ind.sup) & is.na(test.invisible[2])) {
points(coord.ind.sup, pch = 21, col = col.ind.sup[1:(nb.ind -
nb.ind.actif)], cex = cex)
if (lab.ind.moy)
pointLabel(coord.ind.sup[, 1], y = coord.ind.sup[,
2], labels = rownames(coord.ind.sup),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,
col = col.ind.sup[1:(nb.ind - nb.ind.actif)])
for (i in group.ind.sup) {
for (j in 1:nbre.grpe) {
points(coord.ind.partiel.sup[(i - 1) * nbre.grpe +
j, ], cex = 0.8 * cex, col = col.ind.sup[nb.ind -
nb.ind.actif + (i - 1) * nbre.grpe + j],
pch = 21)
if (lab.par)
pointLabel(coord.ind.partiel.sup[(i - 1) * nbre.grpe +
j, 1], y = coord.ind.partiel.sup[nb.ind +
(i - 1) * nbre.grpe + j, 2], labels =
rownames(coord.ind.partiel.sup)[(i -
1) * nbre.grpe + j],
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col = col.ind.sup[nb.ind
-
nb.ind.actif + (i - 1) * nbre.grpe + j])
if (chrono) {
if (j > 1)
lines(c(coord.ind.partiel.sup[(i - 1) *
nbre.grpe + (j - 1), 1], coord.ind.partiel.sup[(i
-
1) * nbre.grpe + j, 1]),
c(coord.ind.partiel.sup[(i -
1) * nbre.grpe + (j - 1), 2],
coord.ind.partiel.sup[(i -
1) * nbre.grpe + j, 2]), col =
col.ind[nb.ind.actif +
i])
}
else lines(c(coord.ind.sup[i, 1],
coord.ind.partiel.sup[(i -
1) * nbre.grpe + j, 1]), c(coord.ind.sup[i,
2], coord.ind.partiel.sup[(i - 1) * nbre.grpe +
j, 2]), col = col.ind.sup[nb.ind - nb.ind.actif +
(i - 1) * nbre.grpe + j], lty = j)
}
}
}
if (!is.null(coord.quali) & is.na(test.invisible[3])) {
points(coord.quali, pch = 15, col =
col.quali[1:nrow.coord.quali],
cex = cex)
if (lab.var)
pointLabel(coord.quali[, 1], y = coord.quali[, 2],
labels = rownames(coord.quali),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.quali[1:nrow.coord.quali])
for (i in group.quali) {
for (j in 1:nbre.grpe) {
points(coord.quali.partiel[(i - 1) * nbre.grpe +
j, ], pch = 15, col = col.quali[nrow.coord.quali +
(i - 1) * nbre.grpe + j], cex = cex * 0.8)
if (lab.var & lab.par)
pointLabel(coord.quali.partiel[(i - 1) * nbre.grpe +
j, 1], y = coord.quali.partiel[(i - 1) *
nbre.grpe + j, 2], labels =
rownames(coord.quali.partiel)[(i -
1) * nbre.grpe +
j],allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.quali[nrow.coord.quali +
(i - 1) * nbre.grpe + j])
if (chrono) {
if (j > 1)
lines(c(coord.quali.partiel[(i - 1) * nbre.grpe +
(j - 1), 1], coord.quali.partiel[(i -
1) * nbre.grpe + j, 1]), c(coord.quali.partiel[(i
-
1) * nbre.grpe + (j - 1), 2],
coord.quali.partiel[(i -
1) * nbre.grpe + j, 2]), col = col.quali[i])
}
else lines(c(coord.quali[i, 1], coord.quali.partiel[(i -
1) * nbre.grpe + j, 1]), c(coord.quali[i,
2], coord.quali.partiel[(i - 1) * nbre.grpe +
j, 2]), col = col.quali[nrow.coord.quali +
(i - 1) * nbre.grpe + j], lty = j)
}
}
}
if (!is.null(coord.quali.sup) & is.na(test.invisible[3])) {
points(coord.quali.sup, pch = 22, col =
col.quali.sup[1:nrow(coord.quali.sup)],
cex = cex)
if (lab.var)
pointLabel(coord.quali.sup[, 1], y = coord.quali.sup[,
2], labels = rownames(coord.quali.sup),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,
col = col.quali.sup[1:nrow(coord.quali.sup)])
for (i in group.quali.sup) {
for (j in 1:nbre.grpe) {
points(coord.quali.partiel.sup[(i - 1) * nbre.grpe +
j, ], pch = 22, col =
col.quali.sup[nrow(coord.quali.sup) +
(i - 1) * nbre.grpe + j], cex = cex * 0.8)
if (lab.var & lab.par)
pointLabel(coord.quali.partiel.sup[(i - 1) * nbre.grpe
+
j, 1], y = coord.quali.partiel.sup[(i -
1) * nbre.grpe + j, 2], labels =
rownames(coord.quali.partiel.sup)[(i -
1) * nbre.grpe + j],
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.quali.sup[nrow(coord.quali.sup) +
(i - 1) * nbre.grpe + j])
if (chrono) {
if (j > 1)
lines(c(coord.quali.partiel.sup[(i - 1) *
nbre.grpe + (j - 1), 1],
coord.quali.partiel.sup[(i -
1) * nbre.grpe + j, 1]),
c(coord.quali.partiel.sup[(i -
1) * nbre.grpe + (j - 1), 2],
coord.quali.partiel.sup[(i -
1) * nbre.grpe + j, 2]), col =
col.quali[nrow.coord.quali +
i])
}
else lines(c(coord.quali.sup[i, 1],
coord.quali.partiel.sup[(i -
1) * nbre.grpe + j, 1]), c(coord.quali.sup[i,
2], coord.quali.partiel.sup[(i - 1) * nbre.grpe +
j, 2]), col = col.quali.sup[nrow(coord.quali.sup) +
(i - 1) * nbre.grpe + j], lty = j)
}
}
}
if ((!is.null(partial)) & (habillage == "group"))
legend("topleft", legend =
rownames(res.mfa$group$Lg)[-c(num.group.sup,
length(rownames(res.mfa$group$Lg)))], lty =
1:length(rownames(res.mfa$group$Lg)[-c(num.group.sup,
length(rownames(res.mfa$group$Lg)))]), text.col = col.hab,
col = col.hab, cex = 0.8)
if ((!is.null(partial)) & (habillage != "group"))
legend("topleft", legend =
rownames(res.mfa$group$Lg)[-c(num.group.sup,
length(rownames(res.mfa$group$Lg)))], lty =
1:length(rownames(res.mfa$group$Lg)[-c(num.group.sup,
length(rownames(res.mfa$group$Lg)))]), cex = 0.8)
if ((habillage != "none") & (habillage != "ind")
& (habillage !=
"group"))
legend("topleft", legend = levels(res.mfa$call$X[,
habillage]), text.col = col.hab, cex = 0.8)
if (!is.null(coord.ellipse) & is.na(test.invisible[2])) {
for (e in 1:nb.ind.actif) {
debut <- ((nb.ind.actif - 1) * npoint.ellipse) +
1
fin <- debut + npoint.ellipse - 1
data.elli <- coord.ellipse[debut:fin, -1]
lines(data.elli[, 1], y = data.elli[, 2], col =
col.ellipse[e])
}
}
if (!is.null(coord.ellipse)) {
for (e in 1:nlevels(coord.ellipse[, 1])) {
data.elli <- coord.ellipse[(npoint.ellipse *
(e - 1) + 1):(npoint.ellipse * e), -1]
lines(data.elli[, 1], y = data.elli[, 2], col =
col.ellipse[e])
}
}
if (!is.null(coord.ellipse.par)) {
for (i in group.ind.actif) {
for (j in 1:nbre.grpe) {
ind.e <- (i - 1) * nbre.grpe + j
data.elli <- coord.ellipse.par[(npoint.ellipse.par *
(ind.e - 1) + 1):(npoint.ellipse.par * ind.e),
-1]
lines(data.elli[, 1], y = data.elli[, 2], col =
col.ellipse.par[ind.e],
lty = 2)
}
}
}
}
###plot.MCA2 Function
plot.MCA2<-
function (x, axes = c(1, 2), choix = "ind", xlim = NULL, ylim = NULL,
invisible = NULL, col.ind = "blue", col.var = "red",
col.quali.sup =
"darkgreen",
col.ind.sup = "darkblue", col.quanti.sup = "black",
label = "all",
cex = 1, title = NULL, habillage = "none", palette = NULL,
new.plot = TRUE, ...)
{
res.mca <- x
if (!inherits(res.mca, "MCA"))
stop("non convenient data")
if (is.null(palette))
palette(c("black", "red", "green3",
"blue", "cyan", "magenta",
"darkgray", "darkgoldenrod",
"darkgreen", "violet",
"turquoise", "orange", "lightpink",
"lavender", "yellow",
"lightgreen", "lightgrey",
"lightblue", "darkkhaki",
"darkmagenta", "darkolivegreen",
"lightcyan", "darkorange",
"darkorchid", "darkred", "darksalmon",
"darkseagreen",
"darkslateblue", "darkslategray",
"darkslategrey",
"darkturquoise", "darkviolet",
"lightgray", "lightsalmon",
"lightyellow", "maroon"))
lab.x = paste("Dim ", axes[1], " (",
signif(res.mca$eig[axes[1],
2], 4), "%)", sep = "")
lab.y = paste("Dim ", axes[2], " (",
signif(res.mca$eig[axes[2],
2], 4), "%)", sep = "")
if (choix == "ind") {
lab.ind <- lab.var <- lab.quali.sup <- lab.ind.sup <- FALSE
if (length(label) == 1 && label == "all")
lab.ind <- lab.var <- lab.quali.sup <- lab.ind.sup <-
TRUE
if ("ind" %in% label)
lab.ind <- TRUE
if ("var" %in% label)
lab.var <- TRUE
if ("quali.sup" %in% label)
lab.quali.sup <- TRUE
if ("ind.sup" %in% label)
lab.ind.sup <- TRUE
test.invisible <- vector(length = 5)
if (!is.null(invisible)) {
test.invisible[1] <- match("ind", invisible)
test.invisible[2] <- match("var", invisible)
test.invisible[3] <- match("quanti.sup", invisible)
test.invisible[4] <- match("ind.sup", invisible)
test.invisible[5] <- match("quali.sup", invisible)
}
else test.invisible <- rep(NA, 5)
coord.var <- res.mca$var$coord[, axes]
coord.ind <- res.mca$ind$coord[, axes]
coord.ind.sup <- coord.quali.sup <- NULL
if (!is.null(res.mca$ind.sup))
coord.ind.sup <- res.mca$ind.sup$coord[, axes]
if (!is.null(res.mca$quali.sup))
coord.quali.sup <- res.mca$quali.sup$coord[, axes]
if (is.null(xlim)) {
xmin <- xmax <- 0
if (is.na(test.invisible[1]))
xmin <- min(xmin, coord.ind[, 1])
if (is.na(test.invisible[1]))
xmax <- max(xmax, coord.ind[, 1])
if (is.na(test.invisible[4]))
xmin <- min(xmin, coord.ind.sup[, 1])
if (is.na(test.invisible[4]))
xmax <- max(xmax, coord.ind.sup[, 1])
if (is.na(test.invisible[2]))
xmin <- min(xmin, coord.var[, 1])
if (is.na(test.invisible[2]))
xmax <- max(xmax, coord.var[, 1])
if (is.na(test.invisible[5]))
xmin <- min(xmin, coord.quali.sup[, 1])
if (is.na(test.invisible[5]))
xmax <- max(xmax, coord.quali.sup[, 1])
xlim <- c(xmin, xmax) * 1.2
}
else {
xmin = xlim[1]
xmax = xlim[2]
}
if (is.null(ylim)) {
ymin <- ymax <- 0
if (is.na(test.invisible[1]))
ymin <- min(ymin, coord.ind[, 2])
if (is.na(test.invisible[1]))
ymax <- max(ymax, coord.ind[, 2])
if (is.na(test.invisible[4]))
ymin <- min(ymin, coord.ind.sup[, 2])
if (is.na(test.invisible[4]))
ymax <- max(ymax, coord.ind.sup[, 2])
if (is.na(test.invisible[2]))
ymin <- min(ymin, coord.var[, 2])
if (is.na(test.invisible[2]))
ymax <- max(ymax, coord.var[, 2])
if (is.na(test.invisible[5]))
ymin <- min(ymin, coord.quali.sup[, 2])
if (is.na(test.invisible[5]))
ymax <- max(ymax, coord.quali.sup[, 2])
ylim <- c(ymin, ymax) * 1.2
}
else {
ymin = ylim[1]
ymax = ylim[2]
}
if (habillage == "quali") {
aux = 1
col.var = NULL
for (j in res.mca$call$quali) {
col.var <- c(col.var, rep(aux, nlevels(res.mca$call$X[,
j])))
aux = aux + 1
}
if (!is.null(res.mca$call$quali.sup)) {
col.quali.sup = NULL
for (j in res.mca$call$quali.sup) {
col.quali.sup <- c(col.quali.sup, rep(aux,
nlevels(res.mca$call$X[, j])))
aux = aux + 1
}
}
}
if ((habillage != "none") & (habillage !=
"quali")) {
if (!is.factor(res.mca$call$X[, habillage]))
stop("The variable ", habillage, " is not
qualitative")
col.ind <- as.numeric(as.factor(res.mca$call$X[,
habillage]))
n.mod <- nlevels(as.factor(res.mca$call$X[, habillage]))
col.ind.sup <- col.ind[res.mca$call$ind.sup]
if (!is.null(res.mca$call$ind.sup))
col.ind <- col.ind[-res.mca$call$ind.sup]
}
titre = title
if (is.null(title))
titre <- "MCA factor map"
if (is.na(test.invisible[1]) | is.na(test.invisible[2]) |
is.na(test.invisible[4]) | is.na(test.invisible[5])) {
if (new.plot)
dev.new(width = min(14, max(8, 8 * (xmax - xmin)/(ymax -
ymin))), height = 8)
plot(0, 0, main = titre, xlab = lab.x, ylab = lab.y,
xlim = xlim, ylim = ylim, col = "white", asp = 1,
cex = cex)
abline(v = 0, lty = 2, cex = cex)
abline(h = 0, lty = 2, cex = cex)
if (is.na(test.invisible[1])) {
points(coord.ind, pch = 16, col = col.ind, cex = cex)
if (lab.ind)
pointLabel(coord.ind[, 1], y = coord.ind[, 2], labels =
rownames(coord.ind),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.ind, cex = cex)
}
if (is.na(test.invisible[2])) {
points(coord.var[, 1], y = coord.var[, 2], pch = 17,
col = col.var, cex = cex)
if (lab.var)
pointLabel(coord.var[, 1], y = coord.var[, 2], labels =
rownames(coord.var),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,col =
col.var, cex = cex)
}
if (!is.null(res.mca$quali.sup) & is.na(test.invisible[5])) {
points(coord.quali.sup[, 1], y = coord.quali.sup[,
2], pch = 17, col = col.quali.sup, cex = cex)
if (lab.quali.sup)
pointLabel(coord.quali.sup[, 1], y = coord.quali.sup[,
2], labels = rownames(coord.quali.sup),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,
col = col.quali.sup, cex = cex)
}
if (!is.null(res.mca$ind.sup) & is.na(test.invisible[4])) {
points(coord.ind.sup[, 1], y = coord.ind.sup[,
2], pch = 16, col = col.ind.sup, cex = cex)
if (lab.ind.sup)
pointLabel(coord.ind.sup[, 1], y = coord.ind.sup[,
2], labels = rownames(coord.ind.sup),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,
col = col.ind.sup, cex = cex)
}
if ((habillage != "none") & (habillage !=
"quali") &
(is.na(test.invisible[1]) | is.na(test.invisible[2])))
legend("topleft", legend = levels(res.mca$call$X[,
habillage]), text.col = 1:n.mod, cex = 0.8)
}
}
if (choix == "quanti.sup") {
if (!is.null(res.mca$quanti.sup)) {
if (new.plot)
dev.new()
if (is.null(title))
title <- "Supplementary variables on the MCA factor
map"
plot(0, 0, main = title, xlab = paste("Dim ", axes[1],
" (", signif(res.mca$eig[axes[1], 2], 4),
"%)",
sep = ""), ylab = paste("Dim ", axes[2],
" (",
signif(res.mca$eig[axes[2], 2], 4), "%)", sep =
""),
xlim = c(-1.1, 1.1), ylim = c(-1.1, 1.1), col =
"white",
asp = 1, cex = cex)
abline(v = 0, lty = 2, cex = cex)
abline(h = 0, lty = 2, cex = cex)
x.cercle <- seq(-1, 1, by = 0.01)
y.cercle <- sqrt(1 - x.cercle^2)
lines(x.cercle, y = y.cercle)
lines(x.cercle, y = -y.cercle)
for (v in 1:nrow(res.mca$quanti.sup$coord)) {
arrows(0, 0, res.mca$quanti.sup$coord[v, axes[1]],
res.mca$quanti.sup$coord[v, axes[2]], length = 0.1,
angle = 15, code = 2, col = col.quanti.sup)
if (abs(res.mca$quanti.sup$coord[v, axes[1]]) >
abs(res.mca$quanti.sup$coord[v, axes[2]])) {
if (res.mca$quanti.sup$coord[v, axes[1]] >=
0)
pos <- 4
else pos <- 2
}
else {
if (res.mca$quanti.sup$coord[v, axes[2]] >=
0)
pos <- 3
else pos <- 1
}
if ((!is.null(label)) && (label == "all" |
"quanti.sup"
%in%
label)) {
pointLabel(res.mca$quanti.sup$coord[v, axes[1]],
y = res.mca$quanti.sup$coord[v, axes[2]],
labels = rownames(res.mca$quanti.sup$coord)[v],
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE,cex =
cex, col = col.quanti.sup)
}
}
}
}
if (choix == "var") {
lab.var <- lab.quali.sup <- FALSE
if (length(label) == 1 && label == "all")
lab.var <- lab.quali.sup <- TRUE
if ("var" %in% label)
lab.var <- TRUE
if ("quali.sup" %in% label)
lab.quali.sup <- TRUE
test.invisible <- vector(length = 2)
if (!is.null(invisible)) {
test.invisible[1] <- match("var", invisible)
test.invisible[2] <- match("quali.sup", invisible)
}
else test.invisible <- rep(NA, 2)
if (new.plot)
dev.new()
if (is.null(title))
title <- "Variables representation"
coord.actif <- res.mca$var$eta2[, axes]
if (!is.null(res.mca$quali.sup$eta2))
coord.illu <- res.mca$quali.sup$eta2[, axes, drop = FALSE]
if (is.na(test.invisible[1])) {
plot(coord.actif, xlab = lab.x, ylab = lab.y, xlim = c(0,
1), ylim = c(0, 1), pch = 20, col = col.var,
cex = cex, main = title, cex.main = cex * 1.2,
asp = 1)
if (lab.var)
pointLabel(coord.actif[, 1], y = coord.actif[, 2],
labels = rownames(coord.actif),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col = col.var)
}
if ((!is.null(res.mca$quali.sup$eta2)) &&
(is.na(test.invisible[2]))) {
if (!is.na(test.invisible[1]))
plot(coord.illu, xlab = lab.x, ylab = lab.y,
xlim = c(0, 1), ylim = c(0, 1), pch = 20, col =
col.quali.sup,
cex = cex, main = title, cex.main = cex * 1.2,
asp = 1)
else points(coord.illu, pch = 20, col = col.quali.sup)
if (lab.quali.sup)
pointLabel(coord.illu[, 1], y = coord.illu[, 2], labels =
rownames(coord.illu),
allowSmallOverlap=FALSE,trace=FALSE,doPlot=TRUE, col =
col.quali.sup)
}
}
## fastmod function
fastmod<-function (don, alpha = 0.05, mot_min = 2, graph = TRUE, ncp = 5,
B = 200)
{
don = as.data.frame(don)
I = nrow(don)
J = ncol(don)
for (i in 1:J) {
don[, i] = as.factor(don[, i])
}
acm = MCA(don, graph = F, ncp = ncp)
if (graph) {
layout(rbind(c(1,1,2,2,3,3),c(4,4,5,5,6,6)))
##plot.MCA2(acm, choix = "ind", invisible =
"var",new.plot=FALSE)
plot.MCA2(acm, choix = "ind", invisible =
"ind",new.plot=FALSE)
plot.MCA2(acm, choix = "ind",new.plot=FALSE)
}
X = 0.05
tab = as.matrix(acm$var$v.test)
vtestmean1 = mean(tab[, 1])
vtestmean2 = mean(tab[, 2])
vtestsd1 = sd(tab[, 1])
vtestsd2 = sd(tab[, 2])
seuil1 = vtestmean1 + vtestsd1
seuil2 = vtestmean2 + vtestsd2
modext = which(abs(tab[, 1]) >= seuil1 | abs(tab[, 2]) >=
seuil2)
tab2 = which(abs(tab[, 1]) < seuil1 & abs(tab[, 2]) < seuil2)
modmoy = tab2[sample(1:length(tab2), X * length(tab2))]
mod_kept = cbind(t(modext), t(modmoy))
res = acm
res$var$coord = acm$var$coord[mod_kept, ]
res$var$cos2 = acm$var$cos2[mod_kept, ]
res$var$contrib = acm$var$contrib[mod_kept, ]
res$var$v.test = acm$var$v.test[mod_kept, ]
if (graph) {
##plot.MCA2(res, choix = "ind", invisible =
"ind",new.plot=FALSE)
}
compte = matrix(0, I, I)
for (i in 1:J) {
for (j in 1:I) {
for (k in j:I) {
if (don[j, i] == don[k, i]) {
compte[j, k] = compte[j, k] + 1
}
}
}
}
for (i in 1:I) {
for (j in i:I) {
compte[j, i] = compte[i, j]
}
}
colnames(compte) = rownames(compte) = rownames(don)
chi2_t = function(x, y) {
obs = table(x, y)
chi = matrix(NA, length(levels(x)), length(levels(y)))
for (i in 1:length(levels(x))) {
for (j in 1:length(levels(y))) {
chi[i, j] = (obs[i, j] - (sum(obs[i, ]) * sum(obs[,
j])/length(x)))^2/(sum(obs[i, ]) * sum(obs[,
j])/length(x))
}
}
chi2 = sum(rowSums(chi))
return(chi2)
}
cramer = function(x, y) {
chi2 = chi2_t(x, y)
n = length(x)
p = length(levels(x))
q = length(levels(y))
m = min(p - 1, q - 1)
V = sqrt(chi2/(n * m))
return(V)
}
res = matrix(NA, J, J)
for (i in 1:J) {
for (j in i:J) {
res[i, j] = res[j, i] = cramer(don[, i], don[, j])
}
}
colnames(res) = rownames(res) = colnames(don)
afc = CA(res, graph = F)
ord = order(afc$row$coord[, 1])
res2 = res[ord, ]
res2 = res2[, ord]
afm = MFA(don, group = rep(1, J), type = rep("n", J), graph = F,
name.group = colnames(don))
if (graph) {
plot.MFA2(afm, choix = "group",new.plot=FALSE)
}
ordre_prod = order(acm$ind$coord[, 1])
out = matrix(NA, I, J)
lev = rep(NA, J)
for (i in 1:J) {
lev[i] = length(levels(don[, i]))
}
tdc = tab.disjonctif(don)
gp = 0
for (i in 1:J) {
conc = cbind(c(1:lev[i]), acm$var$coord[(1 + gp):(gp +
lev[i]), 1])
o = order(conc[, 2])
conc2 = cbind(conc[o, ], c(1:lev[i]))
o2 = order(conc2[, 1])
conc3 = conc2[o2, ]
out[, i] = tdc[, (1 + gp):(gp + lev[i])] %*% conc3[,
3]
gp = gp + lev[i]
}
out = data.frame(out)
for (i in 1:J) {
out[, i] = as.factor(out[, i])
}
catego_num2 = out[ordre_prod, ]
catego_num2 = catego_num2[, ord]
rownames(catego_num2) = rownames(don)[ordre_prod]
colnames(catego_num2) = colnames(don)[ord]
compte2 = compte[ordre_prod, ]
compte2 = compte2[, ordre_prod]
lev2 = as.factor(lev)
if (graph) {
##x11()
plot(lev2, main = "Number of groups formed from sorting
tasks")
}
out1 = matrix(NA, (I * J), 4)
lev = rep(NA, J)
for (i in 1:J) {
lev[i] = length(levels(don[, i]))
}
tdc = tab.disjonctif(don)
gp = 0
for (i in 1:J) {
out1[((i - 1) * I + 1):(i * I), 1:2] = tdc[, (1 + gp):(gp +
lev[i])] %*% acm$var$coord[(1 + gp):(gp + lev[i]),
1:2]
gp = gp + lev[i]
}
prod = rep(rownames(don), J)
jug = rep(colnames(don), each = I)
out2 = data.frame(out1)
out2[, 3] = prod
out2[, 4] = jug
out2[, 3] = as.factor(out2[, 3])
out2[, 4] = as.factor(out2[, 4])
d12 = acm$ind$coord[, 1:2]
pr = rownames(don)
ju = rep("0", I)
out22 = data.frame(d12, pr, ju)
colnames(out22) = colnames(out2)
out3 = rbind(out22, out2)
out3[, 3] = as.factor(out3[, 3])
out3[, 4] = as.factor(out3[, 4])
out4 = out3
out4[-c(1:I), 1] = out3[-c(1:I), 1]/sqrt(acm$eig[1, 1])
out4[-c(1:I), 2] = out3[-c(1:I), 2]/sqrt(acm$eig[2, 1])
out5 = out4
out5$moyen = out5
sim = simulation(out5, nbsimul = B)
if (graph) {
##x11()
plotellipse(sim, alpha = alpha, eig = signif(acm$eig,
4))
}
texte = matrix(NA, (I * J), 3)
texte = data.frame(texte)
texte[, 1] = rep(rownames(don), J)
texte[, 2] = rep(colnames(don), each = I)
for (i in 1:J) {
texte[((I * (i - 1)) + 1):(I * i), 3] = paste(don[, i])
}
nbp = strsplit(summary(don, maxsum = max(lev)), ":")
agg = rep(0, J * max(lev))
for (i in 1:(J * max(lev))) {
agg[i] = nbp[[i]][2]
}
agg2 = na.omit(agg)
agg2 = as.factor(agg2)
if (graph) {
##x11()
plot(agg2, main = "Number of products per group")
}
acm_call = list(X = acm$call$X, marge.col = acm$call$marge.col,
marge.row = acm$call$marge.row, ncp = acm$call$ncp, quali =
acm$call$quali,
name.group = afm$call$name.group, sim = sim)
group_afm = list(coord = afm$group$coord, cos2 = afm$group$cos2,
contrib = afm$group$contrib)
res = list(eig = acm$eig, var = acm$var, ind = acm$ind, group =
group_afm,
call = acm_call, cooccur = compte2, reord = catego_num2,
cramer = res2)
class(res) <- c("catego", "list ")
return(res)
}
Regards
Vijayan Padmanabhan
"What is expressed without proof can be denied without proof" -
Euclide.
Can you avoid printing this?
Think of the environment before printing the email.
-------------------------------------------------------------------------------
Please visit us at www.itcportal.com
******************************************************************************
This Communication is for the exclusive use of the intended recipient (s) and
shall
not attach any liability on the originator or ITC Ltd./its Subsidiaries/its
Group
Companies. If you are the addressee, the contents of this email are intended for
your
use only and it shall not be forwarded to any third party, without first
obtaining
written authorisation from the originator or ITC Ltd./its Subsidiaries/its Group
Companies. It may contain information which is confidential and legally
privileged
and the same shall not be used or dealt with by any third party in any manner
whatsoever without the specific consent of ITC Ltd./its Subsidiaries/its Group
Companies.
[[alternative HTML version deleted]]
Apparently Analagous Threads
Wisdom of the Ancients
