R/SimultAnR.R In SimultAnR: Correspondence and Simultaneous Analysis

Documented in CorrAnplot.CorrAnplot.SimAnSimAnsummary.CorrAnsummary.SimAn

################################################################################
#R# #####               SimultAnR (Simultaneous Analysis) Package              #####
#S# #####               SimultAn  (Simultaneous Analysis) Package              #####
################################################################################
### The package includes six functions:
### CorrAn <- function(data, sr = NA, sc = NA, nd = 2, dp = 2)
### SimAn <- function(data, G, acg, weight = 2, nameg = NA, sr = NA, sc = NA,
###    nd = 2, dp = 2)
### summary.CorrAn <- function(object, ...)
### summary.SimAn <- function(object, ...)
### plot.CorrAn <- function(x, s1 = 1, s2 = 2, ...)
### plot.SimAn <- function(x, s1 = 1, s2 = 2, ...)

#R# Cambiar ginverse por solve
#R# Cambiar is.missing por is.na
#R# Cambiar CAres[, g] por CAres[[g]]
#R# Cambiar CAres[, h] por CAres[[h]]
#R# Cambiar CAres[, 1] por CAres[[1]]

################################################################################
#####               CorrAn function: Correspondence Analysis               #####
################################################################################
CorrAn <- function(data, sr = NA, sc = NA, nd = 2, dp = 2, oar = 1, oac = 1,
multiple = 0)
{
# -------------------------------------------------------------------
#  The CorrAn function computes the correspondence analysis of the
#  selected data.
#
# Arguments
#   data     Data set
#   sr       Indices of supplementary rows
#   sc       Indices of supplementary columns
#   nd       Number of dimensions in results
#   dp       Number of digits in results
#   oar      Output for active rows
#   oac      Output for active columns
#   multiple     ZZZ
#
#   summary.CorrAn
#   plot.CorrAn
#
# -------------------------------------------------------------------
# Reference
#      Zarraga, A. and Goitisolo, B.
#        Simultaneous Analysis is S-PLUS. The SimultAn Package.
#        submitted for publication, 2010.
# -------------------------------------------------------------------
cat("\n \n")
### some legends
if(multiple == 0 ) {
legend100fi <- "100fi"
legendF<- "F"
legend100fj <- "100fj"
legendG <- "G"
legendsr <- "No supplementary rows"
legendsc <- "No supplementary columns"
}
### multiple
if(multiple == 1 ) {
#D      temp <- sr
#D      sr <- sc
#D      sc <- temp
#D      temp <- oar
#D      oar <- oac
#D      oac <- temp
#D      data <- t(data)
legend100fi <- "100fj"
legendF<- "G"
legend100fj <- "100fi"
legendG <- "F"
legendsr <- "No supplementary columns"
legendsc <- "No supplementary rows"
}
### input
datafa <- as.matrix(data)
### Isr
if(is.na(sr[1])) {
Isr <- 0
I <- nrow(datafa)   }
else {
Isr <- length(sr)
I <- nrow(datafa) - Isr   }
### Jsc
if(is.na(sc[1])) {
Jsc <- 0
J <- ncol(datafa)   }
else {
Jsc <- length(sc)
J <- ncol(datafa) - Jsc   }
### Active data
if(Isr != 0) {
if(Jsc != 0) {
datafaA <- datafa[ - sr, - sc]   }
else {
datafaA <- datafa[ - sr, ]   }   }
else {
if(Jsc != 0) {
datafaA <- datafa[, - sc]   }
else {
datafaA <- datafa   }   }
namei <- labels(datafaA)[[1]]
namej <- labels(datafaA)[[2]]
### supplementary rows
nameisr <- labels(datafa)[[1]][sr]
datafasr <- matrix(0, Isr, J)
if(Isr != 0) {
if(Jsc != 0) {
datafasr[, ] <- as.matrix(datafa[sr, - sc])   }
else {
datafasr[, ] <- datafa[sr, ]   }   }
else {
datafasr[, ] <- 0   }
### supplementary columns
namejsc <- labels(datafa)[[2]][sc]
datafasc <- matrix(0, I, Jsc)
if(Jsc != 0) {
if(Isr != 0) {
datafasc[, ] <- datafa[ - sr, sc]   }
else {
datafasc[, ] <- datafa[, sc]   }   }
else {
datafasc[, ] <- 0   }
### active analysis
### frequency matrix
Fd <- datafaA/sum(datafaA)
fi <- apply(Fd, 1, sum)
fj <- apply(Fd, 2, sum)
I <- length(fi)
J <- length(fj)
### Number of axes
ndim <- min(I, J, nd)
########## ########## ########## ########## ########## ########## ###########
### Matrix to diagonalize
temp <- sweep(Fd, 1, fi, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
temp <- sweep(temp, 2, fj, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
temp <- sweep(temp - 1 , 1, sqrt(fi), FUN = "*")
X <- sweep(temp , 2, sqrt(fj), FUN = "*")
if(I >= J) {
A <- t(X) %*% X   }
else {
A <- (X) %*% t(X)   }
### eigen values, inertias and percentages
eigall <- eigen(A)\$values
totalin <- sum(eigall)
names(totalin) <- "Total inertia"
porin <- eigall/totalin
poracuin <- cumsum(porin)
eig <- eigall[1:ndim]
fe <- sqrt(solve(diag(abs(eig))))
resin <- cbind(Re(round(eigall, dp + 5)), Re(round(100 * porin, dp + 5)),
Re(round(100 * poracuin, dp + 5)))
dimnames(resin) <- list(paste("s=", 1:length(eigall), sep = ""),
c("values", "percentage", "cumulated"))
### eigen vectors
temp1 <- eigen(A)\$vectors[, 1:ndim]
temp2 <- abs(diag(t(temp1) %*% temp1))
if(I >= J) {
U <- t(t(temp1)/sqrt(temp2))
V <- X %*% U %*% fe   }
else {
V <- t(t(temp1)/sqrt(temp2))
U <- t(X) %*% V %*% fe  }
########## ########## ########## ########## ########## ########## ###########
####################### rows  ###############################################
### Projections
Fs <- sweep(X %*% U, 1, sqrt(fi), FUN = "/")
Fs <- replace(Fs, is.na(Fs), 0)
dimnames(Fs) <- list(namei, paste(legendF, 1:ndim, sep = ""))
####################### other results for rows (if oar = 1) #################
if(oar != 0) {
### contributions of the points to the dimensions
ctai <- t(t((Fs * Fs) * fi)/eig)
### distances
temp <- sweep(Fd, 1, fi, FUN = "/")
temp <- sweep(temp, 2, fj, FUN = "-")
temp <- temp^2
temp <- sweep(temp, 2, fj, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
d2i <- apply(temp, 1, sum)
### squared correlations
ctri <- (Fs * Fs)/d2i
ctri <- replace(ctri, is.na(ctri), 0)
### results of rows
resi <- cbind(Re(round(100 * fi, dp)), Re(round(d2i, dp)),
Re(round(Fs, dp)), Re(round(100 * ctai, dp)),
Re(round(ctri, dp)))
dimnames(resi) <- list(namei,
c(legend100fi, "d2", paste(legendF, 1:ndim, sep = ""),
paste("ctr", 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
}
if(oar == 0) {
resi = d2i <- "option oar = 0"   }
### end rows
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
####################### columns #############################################
if(oac != 0) {
### Projections
Gs <- sweep(t(X) %*% V, 1, sqrt(fj), FUN= "/")
Gs <- replace(Gs, is.na(Gs), 0)
dimnames(Gs) <- list(namej, paste(legendG, 1:ndim, sep = ""))
### contributions of the points to the dimensions
ctaj <- t(t((Gs * Gs) * fj)/eig)
### distances
temp <- sweep(Fd, 2, fj, FUN = "/")
temp <- sweep(temp, 1, fi, FUN = "-")
temp <- temp^2
temp <- sweep(temp, 1, fi, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
d2j <- apply(temp, 2, sum)
### squared correlations
ctrj <- (Gs * Gs)/d2j
ctrj <- replace(ctrj, is.na(ctrj), 0)
### results of  columns
resj <- cbind(Re(round(100 * fj, dp)), Re(round(d2j, dp)),
Re(round(Gs, dp)), Re(round(100 * ctaj, dp)),
Re(round(ctrj, dp)))
dimnames(resj) <- list(namej,
c(legend100fj, "d2", paste(legendG, 1:ndim, sep = ""),
paste("ctr", 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
}
if (oac == 0) {
resj = Gs = d2j <- "Option oac = 0"   }
### end columns
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
### supplementary rows
if(Isr == 0) {
Fssr = nameisr = fisr = d2isr = Xsr <- 0
resisr <- legendsr   }
if(Isr != 0) {
Fdsr <- as.matrix(datafasr/sum(datafaA))
fisr <- apply(Fdsr, 1, sum)
Isr <- length(fisr)
### matrix supplementary rows
Xsr <- matrix(0, Isr, J)
for(i in 1:Isr) {
for(j in 1:J) {
Xsr[i, j] <- (sqrt(fisr[i]) * (Fdsr[i, j] / fisr[i] -
fj[j])) / sqrt(fj[j])   }   }
Xsr[!is.finite(Xsr)] <- 0
dimnames(Xsr) <- list(nameisr, namej)
### projections supplementary rows
Fssr <- sweep(Xsr %*% U, 1, sqrt(fisr), FUN = "/")
Fssr <- replace(Fssr, is.na(Fssr), 0)
dimnames(Fssr) <- list(nameisr, paste(legendF, 1:ndim, sep = ""))
### distances and squared correlations supplementary rows
temp <- sweep(Fdsr, 1, fisr, FUN = "/")
temp <- sweep(temp, 2, fj, FUN = "-")
temp <- temp^2
temp <- sweep(temp, 2, fj, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
d2isr <- apply(temp, 1, sum)
ctrisr <- Fssr^2 / d2isr
ctrisr <- replace(ctrisr, is.na(ctrisr), 0)
dimnames(ctrisr) <- list(nameisr, NULL)
## results supplementary rows
resisr <- Re(round(cbind(100 * fisr, as.matrix(d2isr), Fssr, ctrisr), dp))
dimnames(resisr) <- list(nameisr, c(legend100fi, "d2",
paste(legendF, 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))   }
### end supplementary rows
########## ########## ########## ########## ########## ########## ###########
#### supplementary columns
if(Jsc == 0) {
Gssc = namejsc = fjsc = d2jsc <- 0
resjsc <- legendsc   }
if(Jsc != 0) {
Fdsc <- datafasc/sum(datafaA)
fjsc <- apply(Fdsc, 2, sum)
Jsc <- length(fjsc)
### Matrix supplementary columns
Xsc <- matrix(0, I, Jsc)
for(i in 1:I) {
for(j in 1:Jsc) {
Xsc[i, j] <- (Fdsc[i, j] / fjsc[j]) - fi[i]   }   }
### projections supplementary columns
Gssc <- sweep(t(Xsc) %*% V, 1, sqrt(fjsc), FUN= "/")
Gssc <- replace(Gssc, is.na(Gssc), 0)
dimnames(Gssc) <- list(namejsc, paste(legendG, 1:ndim, sep = ""))
### distances and squared correlations supplementary columns
temp <- sweep(Fdsc, 2, fjsc, FUN = "/")
temp <- sweep(temp, 1, fi , FUN = "-")
temp <- temp^2
temp <- sweep(temp, 1, fi, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
d2jsc <- apply(temp, 2, sum)
ctrjsc <- Gssc^2 / d2jsc
ctrjsc <- replace(ctrjsc, is.na(ctrjsc), 0)
dimnames(ctrjsc) <- list(namejsc, NULL)
## results supplementary columns
resjsc <- Re(round(cbind(100 * fjsc, as.matrix(d2jsc), Gssc, ctrjsc), dp))
dimnames(resjsc) <- list(namejsc, c(legend100fj, "d2",
paste(legendG, 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))   }
### end supplementary columns
########## ########## ########## ########## ########## ########## ###########
CorrAn.output <- list(totalin = totalin, eig = eig, resin = resin, resi = resi,
resj = resj, resisr = resisr, resjsc = resjsc,
X = X, totalk = sum(datafaA),
I = I, namei = namei, fi = fi, Fs = Fs, d2i = d2i,
J = J, namej = namej, fj = fj, Gs = Gs, d2j = d2j,
Isr = Isr, nameisr = nameisr, fisr = fisr, Fssr = Fssr, d2isr = d2isr,
Xsr = Xsr,
Jsc = Jsc, namejsc = namejsc, fjsc = fjsc, Gssc = Gssc, d2jsc = d2jsc)
class(CorrAn.output) <- "CorrAn"
return(CorrAn.output)
}
### End CorrAn: Correspondence Analysis
################################################################################

################################################################################
#####               SimAn function: Simultaneous Analysis                  #####
################################################################################
SimAn <- function(data, G, acg, weight = 2, nameg = NA, sr = NA, sc = NA,
nd = 2, dp = 2, oar = 1, oac = 1, multiple = 0, arg)
{
# -------------------------------------------------------------------
#  Simultaneous analysis is a factorial method developed for the
#  joint treatment of a set of several data tables, especially
#  frequency tables whose row margins are different, for example when
#  the tables are from different samples or different time points,
#  without modifying the internal structure of each table.
#  In the data tables  rows must refer to the same entities, but
#  columns may be different.
#
# Arguments
#   data     Data set
#   G        Number of tables to be jointly analyzed
#   acg      List of number of the active columns for each table
#   weight   Weighting on each table
#   nameg    Prefix for identifying partial rows and tables
#   sr       Indices of supplementary rows
#   sc       Indices of supplementary columns
#   nd       Number of dimensions in results
#   dp       Number of digits in results
#   oar      Output for active rows
#   oac      Output for active columns
#   multiple     ZZZ
#
#   summary.SimAn
#   plot.SimAn
#
# -------------------------------------------------------------------
# Reference
#      Zarraga, A. and Goitisolo, B.
#         Simultaneous Analysis is S-PLUS. The SimultAn Package.
#         submitted for publication, 2010.
# -------------------------------------------------------------------
cat("\n \n")
if(multiple != 0 && multiple != 1 ) {
cat("\n Only values 0 and 1 for option multiple \n")
stop()   }
### some legends
legendpi <- "pi"
legend100fig <- "100fig"
legendrows <- "overall rows"
legendF<- "F"
legend100fjg <- "100fjg"
legendG <- "G"
legendsr <- "No supplementary rows"
legendsc <- "No supplementary columns"
### multiple
if(multiple == 1 ) {
temp <- sr
sr <- sc
sc <- temp
temp <- oar
oar <- oac
oac <- temp
data <- t(data)
acg <- arg
legendpi <- "pj"
legend100fig <- "100fjg"
legendrows <- "overall columns"
legendF<- "G"
legend100fjg <- "100fig"
legendG <- "F"
legendsr <- "No supplementary columns"
legendsc <- "No supplementary rows"
}
### input
datafa <- as.matrix(data)
### Isr
if(is.na(sr[1])) {
Isr <- 0
I <- nrow(datafa)
nameic <- labels(datafa)[[1]]   }
else {
Isr <- length(sr)
I <- nrow(datafa) - Isr
nameic <- labels(datafa)[[1]][ - sr]
nameicsr <- labels(datafa)[[1]][sr]   }
### names of groups
if(is.na(nameg[1])) {
nameg <- paste(legendG, 1:G, sep = "")   }
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
### separate CA
### oar = 1 Fs necessary for rCASA
CAres <- vector("list", G)
names(CAres) <- paste("Table_", 1:G, sep = "")
for(g in 1:G) {
Jg <- length(acg[g][[1]])
if(!is.na(sc[1])) {
tablag <- datafa[, c(acg[g][[1]], sc)]
scg <- c((1 + Jg):(ncol(tablag)))   }
else {
tablag <- datafa[, c(acg[g][[1]])]
scg <- NA   }
dimnames(tablag)[[1]] <- paste(nameg[g], labels(tablag)[[1]], sep = "")
CAres[[g]] <- CorrAn(tablag, sr = sr, sc = scg, nd = nd, dp = dp,
oar = oar, oac = oac, multiple = multiple)
#      names(CAres[[g]]) <- c("totalin", "eig", "resin",
#         "resi", "resj", "resisr", "resjsc", "X", "totalk",
#         "I", "namei", "fi", "Fs", "d2i",
#         "J", "namej", "fj", "Gs", "d2j",
#         "Isr", "nameisr", "fisr", "Fssr", "d2isr", "Xsr",
#         "Jsc", "namejsc", "fjsc", "Gssc", "d2jsc")
}
### end separate CA
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
### start simultaneous analysis
J <- 0
for(g in G:1) {
J <- CAres[[g]]\$J + J   }
ndim <- min(I, J, nd)
### number of the columns belonging to each group (for allFs, allGs and ctag)
cJ <- c()
for(g in G:1) {
cJ <- c(CAres[[g]]\$J, cJ)   }
ndimJgm1 <- c(0)
for(g in G:1) {
ndimJgm1[g + 1] <- sum(cJ[1:g])   }
### max Jg (for allGs)
maxJg <- 0
for(g in G:1) {
maxJg <- max(maxJg, CAres[[g]]\$J)   }
### names of rows (nameig) and columns (namej)
nameig <- c()
for(g in G:1) {
nameig <- c(CAres[[g]]\$namei, nameig)   }
namej <- c()
for(g in G:1) {
namej <- c(CAres[[g]]\$namej, namej)   }
### weighting of tables: 0=1/1st eig separate; 1=1; 2=1/totalin
alphag <- c()
if(weight == 1) {
alphag <- rep(1, G)   }
if(weight == 2) {
for(g in G:1) {
alphag <- c(1/CAres[[g]]\$eig[[1]], alphag)   }   }
if(weight == 3) {
for(g in G:1) {
alphag <- c(1/CAres[[g]]\$totalin, alphag)   }   }
### weights of overall rows (pic); partial (fiG) and columns (fj)
rfi <- array(0, c(I, G))
for(g in G:1) {
rfi[, g] <- sqrt(CAres[[g]]\$fi)   }
srfi <- apply(rfi, 1, sum)
pic <- srfi^2
fiG <- c()
for(g in G:1) {
fiG <- c(CAres[[g]]\$fi, fiG)   }
fj <- c()
for(g in G:1) {
fj <- c(CAres[[g]]\$fj, fj)   }
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
### matrix to diagonalize
X <- c()
for(g in G:1) {
X <- cbind(sqrt(alphag[g]) * CAres[[g]]\$X, X)   }
if(I >= J) {
A <- t(X) %*% X   }
else {
A <- (X) %*% t(X)   }
### eigen values, inertias and percentages
eigall <- eigen(A)\$values
totalin <- sum(eigall)
porin <- eigall/totalin
poracuin <- cumsum(porin)
eig <- eigall[1:ndim]
fe <- sqrt(solve(diag(abs(eig))))
resin <- cbind(Re(round(eigall, dp + 5)), Re(round(100 * porin, dp + 5)),
Re(round(100 * poracuin, dp + 5)))
dimnames(resin) <- list(paste("s=", 1:length(eigall), sep = ""),
c("values", "percentage", "cumulated"))
### eigen vectors
temp1 <- eigen(A)\$vectors[, 1:ndim]
temp2 <- abs(diag(t(temp1) %*% temp1))
if(I >= J) {
U <- t(t(temp1)/sqrt(temp2))
V <- X %*% U %*% fe   }
else {
V <- t(t(temp1)/sqrt(temp2))
U <- t(X) %*% V %*% fe   }
### end diagonalization
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
####################### rows  ###############################################
### projections of overall rows
Fsic <- sweep(X %*% U, 1, sqrt(pic), FUN = "/")
Fsic <- replace(Fsic, is.na(Fsic), 0)
dimnames(Fsic) <- list(nameic, paste(legendF, 1:ndim, sep = ""))
### projections of partial rows (Fsig) and allFs for graphs
allFs <- array(0, c(I, ndim, G + 1))
dimnames(allFs) <- list(nameic, paste(legendF, 1:ndim, sep = ""),
c(paste("Table ", nameg, sep = ""), legendrows))
for(g in 1:G) {
temp <- X[, (1 + ndimJgm1[g]):ndimJgm1[g + 1]] %*%
U[(1 + ndimJgm1[g]):ndimJgm1[g + 1], ]
allFs[, , g] <- sweep(temp, 1, sqrt(CAres[[g]]\$fi), FUN= "/")   }
allFs[, , G + 1] <- Fsic
Fsig <- c()
for(g in G:1) {
Fsig <- rbind(allFs[, , g], Fsig)   }
dimnames(Fsig) <- list(nameig, paste(legendF, 1:ndim, sep = ""))
####################### other results for rows (if oar = 1) #################
if (oar != 0) {
### contributions of the points to the dimensions
temp <- sweep(Fsic^2, 1, pic, FUN = "*")
ctaic <- sweep(temp, 2, eig, FUN = "/")
### distances
d2ig <- c()
for(g in G:1) {
d2ig <- c((alphag[g]) * CAres[[g]]\$d2i, d2ig)   }
d2ic <- 0
for(g in G:1) {
d2ic <- c(((alphag[g]) * (CAres[[g]]\$fi/pic) * CAres[[g]]\$d2i) +
d2ic)   }
d2ic <- replace(d2ic, is.na(d2ic), 0)
### squared correlations
ctric <- (Fsic^2)/d2ic
ctric <- replace(ctric, is.na(ctric), 0)
ctrig <- (Fsig^2)/d2ig
ctrig[!is.finite(ctrig)] <- 0
### results
resic <- cbind(Re(round(pic, dp)), Re(round(d2ic, dp)),
Re(round(Fsic, dp)), Re(round(100 * ctaic, dp)),
Re(round(ctric, dp)))
dimnames(resic) <- list(nameic, c(legendpi, "d2", paste(legendF, 1:ndim, sep = ""),
paste("ctr", 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
resig <- cbind(Re(round(100 * fiG, dp)), Re(round(d2ig, dp)),
Re(round(Fsig, dp)), Re(round(ctrig, dp)))
dimnames(resig) <- list(nameig, c(legend100fig, "d2",
paste(legendF, 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
}
### end rows
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
####################### columns #############################################
### projections of columns
Gs <- sweep(t(X) %*% V, 1, sqrt(fj), FUN= "/")
Gs <- replace(Gs, is.na(Gs), 0)
dimnames(Gs) <- list(namej, paste(legendG, 1:ndim, sep = ""))
### contributions of the points to the dimensions
temp <- sweep(Gs^2, 1, fj, FUN = "*")
ctaj <- sweep(temp, 2, eig, FUN = "/")
### contributions of the groups to the dimensions
ctag <- c()
for(g in G:1) {
ctajg <- ctaj[(1 + ndimJgm1[g]):ndimJgm1[g + 1], ]
ctag <- rbind(apply(ctajg, 2, sum), ctag)   }
ctag <- Re(round(ctag, dp))
dimnames(ctag) <- list(paste("Table", nameg[1:G]),
paste("Axis ", 1:ndim, sep = ""))
####################### other results for columns (if oac = 1) ##############
if (oac != 0) {
### allGs (Projections of columns) for graphs
allGs <- array(0, c(maxJg, ndim, G))
for(g in G:1) {
allGs[(1:CAres[[g]]\$J), , g] <- Gs[(1 + ndimJgm1[g]):ndimJgm1[g + 1], ]
}
### without names. Not possible different names for each table in array
### distances
d2j <- c()
for(g in G:1) {
d2j <- c((alphag[g]) * matrix(CAres[[g]]\$d2j), d2j)   }
### squared correlations
ctrj <- (Gs^2)/d2j
ctrj <- replace(ctrj, is.na(ctrj), 0)
### results
resj <- cbind(Re(round(100 * fj, dp)), Re(round(d2j, dp)),
Re(round(Gs, dp)), Re(round(100 * ctaj, dp)),
Re(round(ctrj, dp)))
dimnames(resj) <- list(namej,
c(legend100fjg, "d2", paste(legendG, 1:ndim, sep = ""),
paste("ctr", 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
}
### end columns
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
####################### groups ##############################################
### projections of the groups
Fsg <- t(eig * t(ctag))
Fsg <- Re(round(Fsg, dp))
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
####################### relation among factors of CA, SA ####################
### relation between the overall rows and the partial rows
riig <- matrix(0, G, ndim)
for(is in 1:ndim) {
temp <- as.matrix(allFs[, is, G + 1])
temp2 <- sweep(temp, 1, srfi, FUN = "*")
for(g in 1:G) {
temp <- as.matrix(allFs[, is, g])
temp1 <- sweep(temp, 1, rfi[, g], FUN = "*")
varsg <- t(temp1) %*% temp1
riig[g,is] <- t((1 / sqrt(varsg[1,1])) * temp1) %*%
((1/sqrt(eig[is])) * temp2)   }   }
riig <- Re(round(riig, dp))
dimnames(riig) <- list(paste("Table", nameg[1:G]),
paste("Axis ", 1:ndim, sep = ""))
### relation between CA axes and SA axes
rCASA <- array(0, c(ndim, ndim, G))
for(is in 1:ndim) {
temp <- as.matrix(allFs[, is, G + 1])
temp2 <- sweep(temp, 1, srfi, FUN = "*")
for(g in 1:G) {
ndimcs <- min((I-1), ((CAres[[g]]\$J)-1), ndim)
for(sp in 1:ndimcs) {
if(CAres[[g]]\$eig[sp]>0 & eig[is]>0) {
temp <- as.matrix(CAres[[g]]\$Fs[, sp])
temp1 <- sweep(temp, 1, rfi[, g], FUN = "*")
rCASA[sp, is, g] <- t((1 / sqrt(CAres[[g]]\$eig[sp])) * temp1) %*%
((1/sqrt(eig[is])) * temp2)   }   }   }   }
dimnames(rCASA) <- list(paste("CA Axis", 1:ndim), paste("SA Axis", 1:ndim),
paste("Table", nameg[1:G]))
rCASA <- Re(round(rCASA, dp))
### relation between separate CA axes
rCACA <- array(0, c(ndim, ndim, G * (G - 1) / 2))
namegh <- c(1:(G * (G - 1) / 2))
gh <- 1
for(g in 1:G) {
ndimis <- min((I-1), ((CAres[[g]]\$J)-1), ndim)
for(h in 1:G) {
ndimsp <- min((I-1), ((CAres[[h]]\$J)-1), ndim)
if (g < h) {
for(is in 1:ndimis) {
temp <- as.matrix(CAres[[g]]\$Fs[, is])
temp2 <- sweep(temp, 1, rfi[, g], FUN = "*")
for(sp in 1:ndimsp) {
if(CAres[[g]]\$eig[is]>0 & CAres[[h]]\$eig[sp]>0) {
temp <- as.matrix(CAres[[h]]\$Fs[, sp])
temp1 <- sweep(temp, 1, rfi[, h], FUN = "*")
rCACA[sp, is, gh] <-
t((1/sqrt(CAres[[h]]\$eig[sp])) * temp1) %*%
((1/sqrt(CAres[[g]]\$eig[is])) * temp2)
namegh[gh] <- paste("Table", nameg[g], "Table", nameg[h])
}   }   }
gh <- gh + 1
}   }   }
rCACA <- Re(round(rCACA, dp))
dimnames(rCACA) <- list(paste("CA Axis", 1:ndim), paste("CA Axis", 1:ndim),
namegh)
### end relation among factors of CA, SA
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
### supplementary rows
if(is.na(sr[1])) {
resicsr = resigsr = Fsicsr = Fsigsr = allFssr = nameicsr <-
legendsr
Isr = 0   }
if(!is.na(sr[1])) {
Isr <- length(sr)
fisr <- c()
for(g in G:1) {
fisr <- c(CAres[[g]]\$fisr, fisr)   }
nameigsr <- c()
### names of supplementary rows
for(g in G:1) {
nameigsr <- c(CAres[[g]]\$nameisr, nameigsr)   }
rfisr <- array(0, c(Isr, G))
for(g in G:1) {
rfisr[, g] <- sqrt(CAres[[g]]\$fisr)   }
srfisr <- c(rep(0, Isr))
for(g in G:1) {
srfisr <- rfisr[, g] + srfisr   }
picsr <- srfisr^2
### Xsr
Xsr <- c()
for(g in G:1) {
Xsr <- cbind(sqrt(alphag[g]) * CAres[[g]]\$Xsr, Xsr)   }
### projections
Fsicsr <- sweep(Xsr %*% U, 1, sqrt(picsr), FUN = "/")
Fsicsr <- replace(Fsicsr, is.na(Fsicsr), 0)
dimnames(Fsicsr) <- list(nameicsr, paste(legendF, 1:ndim, sep = ""))
### projections of partial rows (Fsigsr) and allFssr for graphs
allFssr <- array(0, c(Isr, ndim, G + 1))
dimnames(allFssr) <- list(nameicsr, paste(legendF, 1:ndim, sep = ""),
c(paste("Table ", nameg, sep = ""), legendrows))
for(g in 1:G) {
temp <- Xsr[, (1 + ndimJgm1[g]):ndimJgm1[g + 1]] %*%
U[(1 + ndimJgm1[g]):ndimJgm1[g + 1], ]
allFssr[, , g] <- sweep(temp, 1, sqrt(CAres[[g]]\$fisr), FUN= "/")   }
allFssr[, , G + 1] <- Fsicsr
Fsigsr <- c()
for(g in G:1) {
Fsigsr <- rbind(allFssr[, , g], Fsigsr)   }
dimnames(Fsigsr) <- list(nameigsr, paste(legendF, 1:ndim, sep = ""))
### contributions of the points to the dimensions
temp <- sweep(Fsicsr^2, 1, picsr, FUN = "*")
ctaicsr <- sweep(temp, 2, eig, FUN = "/")
### distances
d2igsr <- c()
for(g in G:1) {
d2igsr <- c((alphag[g]) * CAres[[g]]\$d2isr, d2igsr)   }
d2icsr <- 0
for(g in G:1) {
d2icsr <- c(((alphag[g]) * (CAres[[g]]\$fisr/picsr) *
CAres[[g]]\$d2isr) + d2icsr)   }
d2icsr <- replace(d2icsr, is.na(d2icsr), 0)
### squared correlations
ctricsr <- (Fsicsr^2)/d2icsr
ctricsr <- replace(ctricsr, is.na(ctricsr), 0)
ctrigsr <- (Fsigsr^2)/d2igsr
ctrigsr[!is.finite(ctrigsr)] <- 0
### results supplementary rows
resicsr <- cbind(Re(round(picsr, dp)), Re(round(d2icsr, dp)),
Re(round(Fsicsr, dp)), Re(round(ctricsr, dp)))
dimnames(resicsr) <- list(nameicsr, c(legendpi, "d2",
paste(legendF, 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
resigsr <- cbind(Re(round(100 * fisr, dp)), Re(round(d2igsr, dp)),
Re(round(Fsigsr, dp)), Re(round(ctrigsr, dp)))
dimnames(resigsr) <- list(nameigsr, c(legend100fig, "d2",
paste(legendF, 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))   }
### end supplementary rows
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
#### supplementary columns
if(is.na(sc[1])) {
allresjsc = allGssc = Gssc = namejsc <- legendsc
Jsc = 0   }
if(!is.na(sc[1])) {
### allresjsc, allGssc
Jsc <- length(sc)
datafasc <- matrix(0, I, Jsc)
if(!is.na(sr[1])) {
datafasc <- as.matrix(datafa[ - sr, sc])   }
else {
datafasc <- as.matrix(datafa[, sc])   }
#      namejscorig <- labels(datafasc)[[2]]
namejscorig <- labels(datafa)[[2]][sc]
allGssc <- array(0, c(Jsc, ndim, G))
allresjsc <- 0
Gssc <- array(0, c(1, ndim))
for(g in G:1) {
namejsc <- paste(nameg[g], namejscorig, sep = "")
Fdsc <- datafasc/CAres[[g]]\$totalk
fjsc <- apply(Fdsc, 2, sum)
fisc <- CAres[[g]]\$fi
temp <- sweep(Fdsc, 2, fjsc, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
temp <- sweep(temp, 1, fisc, FUN = "-")
temp <- sweep(temp, 1, sqrt(fisc), FUN = "/")
temp <- replace(temp, is.na(temp), 0)
Xsc <- sqrt(alphag[g]) * temp
Gsgsc <- t(Xsc) %*% V
dimnames(Gsgsc) <- list(namejsc, paste(legendG, 1:ndim, sep = ""))
temp <- sweep(Fdsc, 2, fjsc, FUN = "/")
temp <- sweep(temp, 1, fisc , FUN = "-")
temp <- temp^2
temp <- sweep(temp, 1, fisc, FUN = "/")
temp <- replace(temp, is.na(temp), 0)
d2jsc <- apply(temp, 2, sum)
ctrjsc <- Gsgsc^2 / d2jsc
ctrjsc[!is.finite(ctrjsc)] <- 0
dimnames(ctrjsc) <- list(namejsc, NULL)
### results supplementary columns
resjsc <- Re(round(cbind(100 * fjsc, as.matrix(d2jsc), Gsgsc, ctrjsc),
dp))
dimnames(resjsc) <- list(namejsc, c(legend100fjg, "d2",
paste(legendG, 1:ndim, sep = ""), paste("cor", 1:ndim, sep = "")))
### end results supplementary columns
allresjsc <- rbind(resjsc, allresjsc)
allGssc[(1:Jsc), , g] <- Gsgsc
Gssc <- rbind(Gsgsc, Gssc)
dimnames(allGssc) <- list(CAres[[g]]\$namejsc,
paste(legendG, 1:ndim, sep = ""),
c(paste("Table ", nameg, sep = "")))   }
allresjsc <- allresjsc[1:nrow(allresjsc) - 1, ]
Gssc <- Gssc[1:nrow(Gssc) - 1, ]
}
### end supplementary columns
########## ########## ########## ########## ########## ########## ###########
########## ########## ########## ########## ########## ########## ###########
### oar and oac of elements needed for other things (ctag, riig, ...)
if(oar == 0) {
resic = resig = Fsic = Fsig = allFs <- "option oar = 0"
#      for (g in 1:G) {
#      CAres[[g]]\$resi = CAres[[g]]\$ctai =
#         CAres[[g]]\$ ctri <- "option oar = 0"   }
}
if(oac == 0) {
resj = Gs = allGs <- "option oac = 0"   }
########## ########## ########## ########## ########## ########## ###########
if(multiple == 1) {
for (g in 1:G){
CAres[[g]]\$X <-t(CAres[[g]]\$X)
names(CAres[[g]]) <- c("totalin", "eig", "resin",
"resj", "resi", "resjsc", "resisr", "X", "totalk",
"J", "namej", "fj", "Gs", "d2j",
"I", "namei", "fi", "Fs", "d2i",
"Jsc", "namejsc", "fjsc", "Gssc", "d2jsc", "Xsc",
"Isr", "nameisr", "fisr", "Fssr", "d2isr")
}
SimAn.output <- list(totalin = totalin,
resin = resin, resi = resj, resj = resic, resjg = resig,
Fsg = Fsg, ctrg = ctag, rjjg = riig, rCACA = rCACA, rCASA = rCASA,
Fs = Gs, Gs = Fsic, Gsjg = Fsig, allFs = allGs,  allGs = allFs,
J = I, maxIg = maxJg, G = G, namej = nameic, nameg = nameg,
resisr = allresjsc, resjsc = resicsr,
resjgsc = resigsr,
Fssr = Gssc, Gssc = Fsicsr,
Gsjgsc = Fsigsr,
allFssr = allGssc, allGssc = allFssr,
Isr = Jsc, Jsc = Isr,
nameisr = namejsc, namejsc = nameicsr,
CAres = CAres,
multiple = multiple)   }
########## ########## ########## ########## ########## ########## ###########
if(multiple == 0) {
SimAn.output <- list(totalin = totalin,
resin = resin, resi = resic, resj = resj, resig = resig,
Fsg = Fsg, ctrg = ctag, riig = riig, rCACA = rCACA, rCASA = rCASA,
Fs = Fsic, Gs = Gs, Fsig = Fsig, allFs = allFs, allGs = allGs,
I = I, maxJg = maxJg, G = G, namei = nameic, nameg = nameg,
#namejg = namejg,
#d2g = d2g, resg = resg, Lgh = Lgh, d2gh = d2gh,
resisr = resicsr, resjsc = allresjsc,
resigsr = resigsr,
Fssr = Fsicsr, Gssc = Gssc,
Fsigsr = Fsigsr,
allFssr = allFssr, allGssc = allGssc,
Isr = Isr, Jsc = Jsc,
nameisr = nameicsr, namejsc = namejsc,
CAres = CAres,
multiple = multiple)   }
class(SimAn.output) <- "SimAn"
return(SimAn.output)
}
### end SimAn: Simultaneous Analysis
################################################################################

#RyS#
################################################################################
#####               Summary of CorrAn                                      #####
################################################################################
summary.CorrAn <- function(object, oar = 1, oac = 1, ...)
{
# -------------------------------------------------------------------
#  This function summarizes the results of CorrAn.
#
# Arguments
#   object   The output of the correspondence analysis (class "CorrAn")
#   oar      Output for active rows
#   oac      Output for active columns
#
#   CorrAn
#   plot.CorrAn
#
# -------------------------------------------------------------------
# Reference
#      Zarraga, A. and Goitisolo, B.
#        Simultaneous Analysis is S-PLUS. The SimultAn Package.
#        submitted for publication, 2010.
# -------------------------------------------------------------------
cat("\n \n")
CAres <- object
if (oar == 0) { CAres\$resi <- "option oar = 0" }
if (oac == 0) { CAres\$resj <- "option oac = 0" }
CAR <- list("CA table" = "CA table",
"Total inertia" = CAres\$totalin,
"Eigenvalues and percentages of inertia" = CAres\$resin,
"Output for rows" = CAres\$resi,
"Output for columns" = CAres\$resj,
"Output for supplementary rows" = CAres\$resisr,
"Output for supplementary columns" = CAres\$resjsc)
return(CAR = CAR)
}
### end summary.CorrAn: Summary of Correspondence Analysis
################################################################################

#RyS
################################################################################
#####               Summary of SimAn                                       #####
################################################################################
summary.SimAn <- function(object, oar = 1, oac = 1, ...)
{
# -------------------------------------------------------------------
#  This function summarizes the results of SimAn.
#
# Arguments
#   object   The output of the simultaneous analysis (class "SimAn")
#   oar      Output for active rows
#   oac      Output for active columns
#
#   SimAn
#   plot.SimAn
#
# -------------------------------------------------------------------
# Reference
#      Zarraga, A. and Goitisolo, B.
#         Simultaneous Analysis is S-PLUS. The SimultAn Package.
#         submitted for publication, 2010.
# -------------------------------------------------------------------
cat("\n \n")
ASG <- object
### CA
CAres <- ASG\$CAres
G <- ASG\$G
multiple <- ASG\$multiple
if (oar == 0) {
for(g in 1:G) {CAres[[g]]\$resi <- "option oar = 0"}   }
if (oac == 0) {
for(g in 1:G) {CAres[[g]]\$resj <- "option oac = 0"}   }
CAR <- vector("list", G)
names(CAR) <- paste("CA", ASG\$nameg)
for(g in 1:G) {
CAR[[g]] <- list(CAres[[g]]\$totalin, CAres[[g]]\$resin, CAres[[g]]\$resi,
CAres[[g]]\$resj, CAres[[g]]\$resisr, CAres[[g]]\$resjsc)
names(CAR[[g]]) <- c("Total inertia",
"Eigenvalues and percentages of inertia", "Output for rows",
"Output for columns", "Output for supplementary rows",
"Output for supplementary columns")   }
### SA
if (oar == 0) {
ASG\$resi <- "option oar = 0"
ASG\$resig <- "option oar = 0"   }
if (oac == 0) {ASG\$resj <- "option oac = 0"}
if (multiple == 1) {
SAR <- list("Total inertia" = ASG\$totalin,
"Eigenvalues and percentages of inertia" = ASG\$resin,
"Output for rows" = ASG\$resi,
"Output for columns" = ASG\$resj,
"Output for partial columns" = ASG\$resjg,
"Projections of tables" = ASG\$Fsg,
"Contributions of tables to SA" = ASG\$ctrg,
"Relation between overall and partial columns" = ASG\$rjjg,
"Relation between factors of separate CA" = ASG\$rCACA,
"Relation between factors of CA and SA" = ASG\$rCASA,
"Output for supplementary rows" = ASG\$resisr,
"Output for supplementary columns" = ASG\$resjsc,
"Output for supplementary partial columns" = ASG\$resjgsc )
}
if (multiple == 0) {
SAR <- list("Total inertia" = ASG\$totalin,
"Eigenvalues and percentages of inertia" = ASG\$resin,
"Output for rows" = ASG\$resi,
"Output for columns" = ASG\$resj,
"Output for partial rows" = ASG\$resig,
"Projections of tables" = ASG\$Fsg,
"Contributions of tables to SA" = ASG\$ctrg,
"Relation between overall and partial rows" = ASG\$riig,
"Relation between factors of separate CA" = ASG\$rCACA,
"Relation between factors of CA and SA" = ASG\$rCASA,
"Output for supplementary rows" = ASG\$resisr,
"Output for supplementary columns" = ASG\$resjsc,
"Output for supplementary partial rows" = ASG\$resigsr )
}
### output CA y SA
return(list(CAR = CAR, SAR = SAR))
}
### end summary.SimAn: Summary of Simultaneous Analysis
################################################################################

################################################################################
#####               plot.CorrAn: Graphs for CorrAn                        ######
################################################################################
#R# plot.CorrAn <- function(x, s1 = 1, s2 = 2, screen = TRUE, ...)
#S# plot.CorrAn <- function(x, s1 = 1, s2 = 2, screen = FALSE, ...)
plot.CorrAn <- function(x, s1 = 1, s2 = 2, screen = TRUE, oar = 1, oac = 1, ...)
{
# -------------------------------------------------------------------
#  Graphical display of correspondence analysis results in two
#  dimensions.
#
# Arguments
#   x       The output of the correspondence analysis (class "CorrAn")
#   s1      Dimension to plot on horizontal axis
#   s2      Dimension to plot on vertical axis
#   screen  TRUE for R and FALSE for S-plus
#   oar     Output for active rows
#   oac     Output for active columns
#
#   CorrAn
#   summary.CorrAn
#
# -------------------------------------------------------------------
# Reference
#      Zarraga, A. and Goitisolo, B.
#         Simultaneous Analysis is S-PLUS. The SimultAn Package.
#         submitted for publication, 2010.
# -------------------------------------------------------------------
cat("\n \n")
if(oar == 0 && oac == 0) {
cat ("\n ***************************************************  \n")
cat ("\n WARNING \n")
cat ("\n Options oar=0 and oac=0. No active elements to plot. \n")
cat ("\n ***************************************************  \n")
}

#R# opcion screen=TRUE
#S# quitar opcion screen=TRUE
SAPplot <- function(x, y)
{
plot(x, y, type = "n",
#S#            axes = T,
axes = T,
xlab = paste("  "),
ylab = paste("  "),
col = 1,
#S#            cex = 0.5)
cex = 0.5)
}
SAPtitle <- function(titulo, titsub, s1, s2, resin)
{
title(titulo,
#S#         axes = F,
col = 1,
#S#          cex = 1.2)
cex = 1.2)
title("",
#S#         axes = F,
xlab = paste("Axis ", s1, "   (", resin[s1, 2], "%)   "),
ylab = paste("Axis ", s2, "   (", resin[s2, 2], "%)   "),
col = 1,
#S#         cex = 1)
cex = 1)
#R#         mtext(titsub, side = 3, line = 0.4, outer = FALSE)
#S#         mtext(titsub, side = 3, line = 1, outer = F)
mtext(titsub, side = 3, line = 1, outer = F)
}
SAPplotpuntos <- function(puntos, gra, s1, s2, etiq,
colg = 2,
SAPpch)
{
points(c(puntos[gra, s1]), c(puntos[gra, s2]),
pch = SAPpch,
col = colg,
#S#            cex = 0.7)
cex = 0.7)
text(c(puntos[gra, s1]), c(puntos[gra, s2]),
c(paste("  ", etiq[gra], sep = "")),
col = colg,
#S#            cex = 0.7)
cex = 0.7)
}
### Graph options
#R#    par(cex = 1, cex.axis = .6, cex.lab = 1, cex.main = 1.2, cex.sub = 1)
#R#    colg <- c(rep(2:8, 10))
#R#    pchg <- c(rep(c(15, 17, 18, 19), 10))
#R#    pchgs <- c(rep(c(0, 2, 5, 1), 10))
#S#    cex = 1, cex.axis = .6, cex.lab = 1, cex.main = 1.2, cex.sub = 1
#RS    colg.F.CA  y colg.sr.CA    #R 1 #S 16
colg <- 2                        # color groups
pchg <- 15                       # pch groups
pchgs <- 0                       # pch groups supplementary elements
colg.F.CA <-  1                  # color rows
colg.sr.CA <- 1                  # color supplementary rows
pchg.F.CA <- 24                  # pch rows
pchg.sr.CA <- 4                  # pch supplementary rows
### Input
CAres <- x
names(CAres) <- c("totalin", "eig", "resin", "resi", "resj",
"resisr", "resjsc",
"X", "totalk",
"I", "namei", "fi", "Fs", "d2i",
"J", "namej", "fj", "Gs", "d2j",
"Isr", "nameisr", "fisr", "Fssr", "d2isr",
"Xsr",
"Jsc", "namejsc", "fjsc", "Gssc", "d2jsc")
if (oar != 0 && class(CAres\$Fs) == "character" ) {
cat ("\n ***************************************************  \n")
cat ("\n WARNING \n")
cat ("\n option oar = 1 in plot but oar = 0 in results of CorrAn \n" )
cat ("\n ***************************************************  \n")    }
if (oac != 0 && class(CAres\$Gs) == "character" ) {
cat ("\n ***************************************************  \n")
cat ("\n WARNING \n")
cat("\n option oac = 1 in plot but oac = 0 in results of CorrAn \n" )
cat ("\n ***************************************************  \n")    }

titulinparc <- "CA"
###
### dimensions
I <- CAres\$I
Isr <- CAres\$Isr
Jsc <- CAres\$Jsc
J <- CAres\$J
###
nameic <- CAres\$namei
nameicsr <- CAres\$nameisr
#######################   CA active   #######################################
if(oar != 0 || oac != 0) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulinparc, sep = "")
titsub <- "Active elements"
puntosplot <- c()
if (oar != 0 && class(CAres\$Fs) != "character" ) {
namei <- CAres\$namei
puntosplot <- rbind(puntosplot, CAres\$Fs)   }
if (oac != 0 && class(CAres\$Gs) != "character" ) {
puntosplot <- rbind(puntosplot, CAres\$Gs)   }
if (length(puntosplot) != 0) {
resin <- round(CAres\$resin, 2)
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
if (oar != 0 && class(CAres\$Fs) != "character" ) {
SAPplotpuntos(puntos = CAres\$Fs, gra = c(1:I), s1, s2,
etiq = CAres\$namei, colg = 1, SAPpch = pchg.F.CA)   }
if (oac != 0 && class(CAres\$Gs) != "character" ) {
SAPplotpuntos(puntos = CAres\$Gs,
gra = c(1:CAres\$J), s1, s2, etiq = CAres\$namej,
SAPpch = pchg)   }   }
}
#######################   CA active + supplementary   #######################
if(Isr != 0 || Jsc != 0) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulinparc, sep = "")
titsub <- "Active and supplementary elements"
resin <- round(CAres\$resin, 2)
puntosplot <- c()
if (oar != 0 && class(CAres\$Fs) != "character" ) {
namei <- CAres\$namei
puntosplot <- rbind(puntosplot, CAres\$Fs)   }
if (oac != 0 && class(CAres\$Gs) != "character" ) {
puntosplot <- rbind(puntosplot, CAres\$Gs)   }
if (Isr != 0) {
puntosplot <- rbind(puntosplot, CAres\$Fssr)   }
if (Jsc != 0) {
puntosplot <- rbind(puntosplot, CAres\$Gssc)   }
### plot
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
if (oar != 0 && class(CAres\$Fs) != "character" ) {
SAPplotpuntos(puntos = CAres\$Fs, gra = c(1:I), s1, s2,
etiq = CAres\$namei, colg = colg.F.CA,
SAPpch = pchg.F.CA)   }
if (oac != 0 && class(CAres\$Gs) != "character" ) {
SAPplotpuntos(puntos = CAres\$Gs,
gra = c(1:CAres\$J), s1, s2, etiq = CAres\$namej,
SAPpch = pchg)   }
if (Isr != 0) {
puntos <- CAres\$Fssr
SAPplotpuntos(puntos = puntos, gra = c(1:Isr), s1, s2,
etiq = CAres\$nameisr, colg = colg.sr.CA,
SAPpch = pchg.sr.CA)   }
if (Jsc != 0) {
puntos <- CAres\$Gssc
SAPplotpuntos(puntos = puntos,
gra = c(1:CAres\$Jsc), s1, s2,
etiq = CAres\$namejsc, SAPpch = pchgs)   }   }
else {   }
}
### end plot.CorrAn
################################################################################

################################################################################
#####               plot.SimAn: Graphs for SimAn                          ######
################################################################################
#R# plot.SimAn <- function(x, s1 = 1, s2 = 2, screen = TRUE, ...)
#S# plot.SimAn <- function(x, s1 = 1, s2 = 2, screen = FALSE, ...)
plot.SimAn <- function(x, s1 = 1, s2 = 2, screen = TRUE, oar = 1, oac = 1, ... )
{
# -------------------------------------------------------------------
#  Graphical representation of simultaneous analysis.
#
# Arguments
#   x       The output of the simultaneous analysis (class "SimAn")
#   s1      Dimension to plot on horizontal axis
#   s2      Dimension to plot on vertical axis
#   screen  TRUE for R and FALSE for S-plus
#   oar     Output for active rows
#   oac     Output for active columns
#
#   SimAn
#   summary.SimAn
#
# -------------------------------------------------------------------
# Reference
#      Zarraga, A. and Goitisolo, B.
#        Simultaneous Analysis is S-PLUS. The SimultAn Package.
#        submitted for publication, 2010.
# -------------------------------------------------------------------
cat("\n \n")
if(oar == 0 && oac == 0) {
cat ("\n ***************************************************  \n")
cat ("\n WARNING \n")
cat ("\n Options oar=0 and oac=0. No active elements to plot. \n")
cat ("\n ***************************************************  \n")   }
SAPplot <- function(x, y)
{
plot(x, y, type = "n",
xlab = paste("  "),
ylab = paste("  "),
col = 1,
cex = 0.5)
}
SAPtitle <- function(titulo, titsub, s1, s2, resin)
{
title(titulo,
col = 1,
cex = 1.2)
title("",
xlab = paste("Axis ", s1, "   (", resin[s1, 2], "%)   "),
ylab = paste("Axis ", s2, "   (", resin[s2, 2], "%)   "),
col = 1,
cex = 1)
#R#       mtext(titsub, side = 3, line = 0.4, outer = FALSE)
#S#       mtext(titsub, side = 3, line = 1, outer = F)
mtext(titsub, side = 3, line = 1, outer = F)
}
SAPplotpuntos <- function(g, puntos, gra, s1, s2, etiq,
colg = c(rep(2:8, 10)),
SAPpch)
{
points(c(puntos[gra, s1]), c(puntos[gra, s2]),
pch = SAPpch[g],
col = colg[g],
cex = 0.7)
text(c(puntos[gra, s1]), c(puntos[gra, s2]),
c(paste("  ", etiq[gra], sep = "")),
col = colg[g],
cex = 0.7)
}
### Input
ASG <- x
G <- ASG\$G
multiple <- ASG\$multiple
########## ########## ########## ########## ########## ########## ###########
if(multiple == 1) {
for (g in 1:G){
ASG\$CAres[[g]]\$X <-t(ASG\$CAres[[g]]\$X)
names(ASG\$CAres[[g]]) <- c("totalin", "eig", "resin",
"resi", "resj", "resisr", "resjsc", "X", "totalk",
"I", "namei", "fi", "Fs", "d2i",
"J", "namej", "fj", "Gs", "d2j",
"Isr", "nameisr", "fisr", "Fssr", "d2isr", "Xsr",
"Jsc", "namejsc", "fjsc", "Gssc", "d2jsc")   }
names(ASG) <- c("totalin", "resin", "resj", "resic", "resig",
"Fsg", "ctag", "riig", "rCACA", "rCASA",
"Gs", "Fs", "Fsig", "allGs",  "allFs",
"I", "maxJg", "G", "namei", "nameg",
"allresjsc", "resicsr",
"resigsr",
"Gssc", "Fssr",
"Fsigsr",
"allGssc", "allFssr",
"Jsc", "Isr",
"namejsc", "nameisr",
"CAres",
"multiple")
}
########## ########## ########## ########## ########## ########## ###########
if(multiple == 0) {
if (oar == 1 && class(ASG\$Fs) == "character" ) {
cat("\n ***************************************************  \n")
cat("\n WARNING \n")
cat("\n option oar = 1 in plot but oar = 0 in results of SimAn \n" )
cat("\n ***************************************************  \n")   }
if (oac == 1 && class(ASG\$Gs) == "character" ) {
cat("\n ***************************************************  \n")
cat("\n WARNING \n")
cat("\n option oac = 1 in plot but oac = 0 in results of SimAn \n" )
cat("\n ***************************************************  \n")   }
}
if(multiple == 1) {
if (oar == 1 && class(ASG\$Fs) == "character" ) {
cat("\n ***************************************************  \n")
cat("\n WARNING \n")
cat("\n option oar = 1 in plot but oar = 0 in results of SimAn \n" )
cat("\n ***************************************************  \n")   }
if (oac == 1 && class(ASG\$Gs) == "character" ) {
cat("\n ***************************************************  \n")
cat("\n WARNING \n")
cat("\n option oac = 1 in plot but oac = 0 in results of SimAn \n" )
cat("\n ***************************************************  \n")   }
}
### Graph options
#R#    par(cex = 1, cex.axis = .6, cex.lab = 1, cex.main = 1.2, cex.sub = 1)
#R#    colg <- c(rep(2:8, 10))
#R#    pchg <- c(rep(c(15, 17, 18, 19), 10))
#R#    pchgs <- c(rep(c(0, 2, 5, 1), 10))
#S#    cex = 1, cex.axis = .6, cex.lab = 1, cex.main = 1.2, cex.sub = 1
#S#    colg <- c(rep(2:5, 10))
#S#    pchg <- c(rep(c(15, 16, 17, 18, 19), 10))
#S#    pchgs <- c(rep(c(0, 1, 2, 5, 6), 10))
#RS   colg.F.CA  y colg.sr.CA    #R 1 #S 16
colg <- c(rep(2:15, 10))                   # color groups
pchg <- c(rep(c(15, 16, 17, 18, 19), 10))  # pch groups
pchgs <- c(rep(c(0, 1, 2, 5, 6), 10))      # pch groups supplem. elements
colg.F.CA <-  rep(1, G + 1)                # color columns CA
colg.sr.CA <- rep (1, G + 1)               # color supplementary columns CA
pchg.F.CA <- rep (24, G + 1)               # pch Columnas CA
pchg.sr.CA <- rep (4, G + 1)               # pch supplementary columns
###
titulin <- "SA"
titulinparc <- "CA"
### CA
CAres <- ASG\$CAres
J <- 0
for(g in G:1) {
J <- CAres[[g]]\$J + J}
### Dimensions
I <- ASG\$I
Jg <- ASG\$maxJg
ndim <- ncol(ASG\$Fsg)
Isr <- ASG\$Isr
Jsc <- ASG\$Jsc
### Names
###
nameic <- ASG\$namei
nameicsr <- ASG\$nameisr
namegroup <- ASG\$nameg
### Data from separate CA
if (oar != 0) {
Fsgroups <- array(0, c(I, ndim, G))
for(g in G:1) {
Fsgroups[, , g] <- CAres[[g]]\$Fs   }   }
if (oac != 0) {
Gsgroups <- array(0, c(Jg, ndim, G))
for(g in G:1) {
Gsgroups[1:CAres[[g]]\$J, , g] <- CAres[[g]]\$Gs   }   }
if(Isr != 0) {
Fsgroupssr <- array(0, c(Isr, ndim, G))
for(g in G:1) {
Fsgroupssr[, , g] <- CAres[[g]]\$Fssr   }   }
if(Jsc != 0) {
Gsgroupssc <- array(0, c(Jsc, ndim, G))
for(g in G:1) {
Gsgroupssc[1:CAres[[g]]\$Jsc, , g] <- CAres[[g]]\$Gssc   }   }
### Data from SA
if (oar != 0) {
Fsic <- ASG\$Fs
Fsig <- ASG\$Fsig
allFs <- ASG\$allFs   }
if (oac != 0) {
Gs <- ASG\$Gs
allGs <- ASG\$allGs   }
if(Isr != 0) {
Fsicsr <- ASG\$Fssr
Fsigsr <- ASG\$Fsigsr
allFssr <- ASG\$allFssr   }
if(Jsc != 0) {
Gssc <- ASG\$Gssc
allGssc <- ASG\$allGssc   }
### Data from SA for groups (square plot) and correlations CA and SA (circle)
eig <- ASG\$resin[, 1]
ctag <- ASG\$ctrg
Fsg <- ASG\$Fsg
fact <- ASG\$rCASA
###################   CA active   ###########################################
if(oar != 0 || oac != 0) {
for(g in 1:G) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulinparc, ": Table ", namegroup[g], sep = "")
titsub <- "Active elements"
puntosplot <- c()
if (oar != 0 && class(ASG\$Fs) != "character" ) {
namei <- CAres[[g]]\$namei
puntosplot <- rbind(puntosplot, Fsgroups[, , g])   }
if (oac != 0 && class(ASG\$Gs) != "character" ) {
puntosplot <- rbind(puntosplot, Gsgroups[1:CAres[[g]]\$J, , g])   }
if (length(puntosplot) != 0) {
resin <- round(CAres[[g]]\$resin, 2)
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
if (oar != 0 && class(ASG\$Fs) != "character" ) {
SAPplotpuntos(g, puntos = Fsgroups[, , g], gra = c(1:I), s1, s2,
etiq = CAres[[g]]\$namei, colg = colg.F.CA, SAPpch = pchg.F.CA)   }
if(oac != 0 && class(ASG\$Gs) != "character" ) {
SAPplotpuntos(g, puntos = Gsgroups[1:CAres[[g]]\$J, , g],
gra = c(1:CAres[[g]]\$J), s1, s2, etiq = CAres[[g]]\$namej,
SAPpch = pchg)   }   }
}   }
###################   CA active + supplementary   ###########################
if(Isr != 0 || Jsc != 0) {
for(g in 1:G) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulinparc, ": Table ", namegroup[g], sep = "")
titsub <- "Active and supplementary elements"
resin <- round(CAres[[g]]\$resin, 2)
puntosplot <- c()
if (oar != 0 && class(ASG\$Fs) != "character" ) {
namei <- CAres[[g]]\$namei
puntosplot <- rbind(puntosplot, Fsgroups[, , g])   }
if (oac != 0 && class(ASG\$Gs) != "character" ) {
puntosplot <- rbind(puntosplot, Gsgroups[1:CAres[[g]]\$J, , g])   }
if(Isr != 0) {
puntosplot <- rbind(puntosplot, Fsgroupssr[ , , g])   }
if(Jsc != 0) {
puntosplot <- rbind(puntosplot,
Gsgroupssc[1:CAres[[g]]\$Jsc, , g])   }
### Plot
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
if (oar != 0 && class(ASG\$Fs) != "character" ) {
SAPplotpuntos(g, puntos = Fsgroups[, , g], gra = c(1:I), s1, s2,
etiq = CAres[[g]]\$namei, colg = colg.F.CA, SAPpch = pchg.F.CA)   }
if(oac != 0 && class(ASG\$Gs) != "character" ) {
SAPplotpuntos(g, puntos = Gsgroups[1:CAres[[g]]\$J, , g],
gra = c(1:CAres[[g]]\$J), s1, s2, etiq = CAres[[g]]\$namej,
SAPpch = pchg)   }
if(Isr != 0) {
puntos <- matrix(0, Isr, ndim)
puntos[1:Isr, ] <- Fsgroupssr[1:Isr, , g]
SAPplotpuntos(g, puntos = puntos, gra = c(1:Isr), s1, s2,
etiq = CAres[[g]]\$nameisr, colg = colg.sr.CA,
SAPpch = pchg.sr.CA)   }
if(Jsc != 0) {
puntos <- matrix(0, CAres[[g]]\$Jsc, ndim)
puntos[1:CAres[[g]]\$Jsc, ] <- Gsgroupssc[1:CAres[[g]]\$Jsc, , g]
SAPplotpuntos(g, puntos = puntos, gra = c(1:CAres[[g]]\$Jsc),
s1, s2, etiq = CAres[[g]]\$namejsc, SAPpch = pchgs)   }   }   }
else {   }
###################   SA   ##################################################
resin <- round(ASG\$resin, 2)
###################   SA Fsic   #############################################
if (oar != 0 && class(ASG\$Fs) != "character" ) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Overall rows", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Overall columns", sep = "")   }
titsub <- "Active elements"
puntosplot <- allFs[, , (G + 1)]
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
SAPplotpuntos(g = G + 1, puntos = allFs[, , (G + 1)], gra = c(1: I),
s1, s2, etiq = nameic, SAPpch = pchg)   }
###################   SA Gsj   ##############################################
if (oac != 0 && class(ASG\$Gs) != "character" ) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Columns", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Rows", sep = "")   }
titsub <- "Active elements"
puntosplot <- Gs
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
for(g in 1:G) {
SAPplotpuntos(g, puntos = allGs[1:CAres[[g]]\$J, , g],
gra = c(1:CAres[[g]]\$J), s1, s2, etiq = CAres[[g]]\$namej,
SAPpch = pchg)   }   }
###################   SA Fsic + Gsj   #######################################
if (oar != 0 && class(ASG\$Fs) != "character" &&
oac != 0 && class(ASG\$Gs) != "character") {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Overall rows and columns", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Rows and overall columns", sep = "")   }
titsub <- "Active elements"
puntosplot <- rbind(allFs[, , (G + 1)], Gs)
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
SAPplotpuntos(g = G + 1, puntos = allFs[, , (G + 1)], gra = c(1:I),
s1, s2, etiq = nameic, SAPpch = pchg)
if(oac == 1) {
for(g in 1:G) {
SAPplotpuntos(g, puntos = allGs[1:CAres[[g]]\$J, , g],
gra = c(1:CAres[[g]]\$J), s1, s2, etiq = CAres[[g]]\$namej,
SAPpch = pchg)   }   }   }
###################   SA Fsic + Fsig   ######################################
if (oar != 0 && class(ASG\$Fs) != "character") {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Overall and partial rows", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Overall and partial columns", sep = "")   }
titsub <- "Active elements"
puntosplot <- allFs
SAPplot(puntosplot[, s1, ], puntosplot[, s2, ])
SAPtitle(titulo, titsub, s1, s2, resin)
SAPplotpuntos(G + 1, puntos = allFs[, , (G + 1)], gra = c(1:I), s1, s2,
etiq = nameic, SAPpch = pchg)
for(g in 1:G) {
SAPplotpuntos(g, puntos = allFs[, , g], gra = c(1:I), s1, s2,
etiq = c(paste(namegroup[g], nameic, sep = "")), SAPpch = pchg)   }
}
###################   end SA active   #######################################
###################   SA Fsic + Fsicsr   ####################################
if(Isr != 0) {
if(screen == TRUE) {dev.new()}
###
titulo <- paste(titulin, ": Overall rows", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Overall columns", sep = "")   }
titsub <- "Active and supplementary elements"
g <- G + 1
puntosplot <- c()
if (oar != 0 && class(ASG\$Fs) != "character") {
puntosplot <- rbind(puntosplot, allFs[, , (G + 1)])   }
puntosplot <- rbind(puntosplot, allFssr[, , (G + 1)])
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
### Fsic
if (oar != 0 && class(ASG\$Fs) != "character") {
puntos <- allFs[, , (G + 1)]
etiq <- c(nameic)
SAPplotpuntos(G + 1, puntos = allFs[, , (G + 1)], gra = c(1:I),
s1, s2, etiq = nameic, SAPpch = pchg)   }
### Fsicsr
puntos <- matrix(0, Isr, ndim)
puntos[1:Isr, ] <- allFssr[1:Isr, , (G + 1)]
SAPplotpuntos(G + 1, puntos = puntos, gra = c(1:Isr),
s1, s2, etiq = nameicsr, SAPpch = pchgs)   }
else {   }
###################   SA Gsj + Gsjsc   ######################################
if(Jsc != 0) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Columns", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Rows", sep = "")   }
titsub <- "Active and supplementary elements"
puntosplot <- c()
if (oac != 0 && class(ASG\$Gs) != "character") {
puntosplot <- rbind(puntosplot, Gs)   }
puntosplot <- rbind(puntosplot, Gssc)
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
if (oac != 0 && class(ASG\$Gs) != "character") {
for(g in 1:G) {
SAPplotpuntos(g, puntos = allGs[1:CAres[[g]]\$J, , g],
gra = c(1:CAres[[g]]\$J), s1, s2, etiq = CAres[[g]]\$namej,
SAPpch = pchg)   }   }
for(g in 1:G) {
puntos <- matrix(0, Jsc, ndim)
puntos[1:Jsc, ] <- allGssc[1:Jsc, , g]
SAPplotpuntos(g, puntos = puntos, gra = c(1:Jsc), s1, s2,
etiq = paste(namegroup[g], CAres[[g]]\$namejsc, sep = ""),
SAPpch = pchgs)   }   }
else {   }
###################   SA Fsic + Fsicsr + Gsj + Gsjsc   ######################
if(Isr != 0 || Jsc != 0) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Overall rows and columns", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Rows and overall columns", sep = "")   }
titsub <- "Active and supplementary elements"
puntosplot <- c()
if (oar != 0 && class(ASG\$Fs) != "character") {
puntosplot <- rbind(puntosplot, allFs[, , (G + 1)])   }
if (oac != 0 && class(ASG\$Gs) != "character") {
puntosplot <- rbind(puntosplot, Gs)   }
if(Isr != 0) {
puntosplot <- rbind(puntosplot, allFssr[, , (G + 1)])   }
if(Jsc != 0) {
puntosplot <- rbind(puntosplot, Gssc)   }
### Plot
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
if (oar != 0 && class(ASG\$Fs) != "character") {
SAPplotpuntos(g = G + 1, puntos = allFs[, , (G + 1)], gra = c(1:I),
s1, s2, etiq = nameic, SAPpch = pchg)   }
if (oac != 0 && class(ASG\$Gs) != "character") {
for(g in 1:G) {
SAPplotpuntos(g, puntos = allGs[1:CAres[[g]]\$J, , g],
gra = c(1:CAres[[g]]\$J), s1, s2,
etiq = CAres[[g]]\$namej, SAPpch = pchg)   }   }
if(Isr != 0) {
puntos <- matrix(0, Isr, ndim)
puntos[1:Isr, ] <- allFssr[1:Isr, , (G + 1)]
SAPplotpuntos(g = G + 1, puntos = puntos,
gra = c(1:Isr), s1, s2, etiq = nameicsr, SAPpch = pchgs)   }
if(Jsc != 0) {
for(g in 1:G) {
puntos <- matrix(0, Jsc, ndim)
puntos[1:Jsc, ] <- allGssc[1:Jsc, , g]
SAPplotpuntos(g, puntos = puntos, gra = c(1:Jsc), s1, s2,
etiq = paste(namegroup[g], CAres[[g]]\$namejsc, sep = ""),
SAPpch = pchgs)   }   }   }
else {   }
###################   SA Fsic + Fsig + Fsicsr + Fsigsr   ####################
if(Isr != 0) {
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Overall and partial rows", sep = "")
if(multiple == 1) {
titulo <- paste(titulin, ": Overall and partial columns", sep = "")   }
titsub <- "Active and supplementary elements"
### puntosplot rbind(allFs, allFssr) don't work
puntosplot <- rbind(Fsicsr, Fsigsr)
if (oar != 0 && class(ASG\$Fs) != "character") {
puntosplot <- rbind(Fsic, Fsig, puntosplot)   }
SAPplot(puntosplot[, s1], puntosplot[, s2])
SAPtitle(titulo, titsub, s1, s2, resin)
### Active
if (oar != 0 && class(ASG\$Fs) != "character") {
puntos <- allFs
etiq <- c(nameic)
SAPplotpuntos(G + 1, puntos = allFs[, , (G + 1)], gra = c(1:I),
s1, s2, etiq = nameic, SAPpch = pchg)
for(g in 1:G) {
SAPplotpuntos(g, puntos = allFs[, , g], gra = c(1:I), s1, s2,
etiq = c(paste(namegroup[g], nameic, sep = "")),
SAPpch = pchg)   }   }
### Supplementary
puntos <- allFssr
etiq <- c(nameicsr)
### Fcsr
points(c(puntos[, s1, (G + 1)]), c(puntos[, s2, (G + 1)]),
pch =pchgs[G + 1], col = colg[G + 1], cex = 0.7)
text(c(puntos[, s1, (G + 1)]), c(puntos[, s2, (G + 1)]),
c(paste("  ", etiq, sep = "")), col = colg[G + 1], adj = 0, cex = 0.7)
### Fgsr
for(g in 1:G) {
points(c(puntos[, s1, g]), c(puntos[, s2, g]), pch =pchgs[g],
col = colg[g], cex = 0.7)
text(c(puntos[, s1, g]), c(puntos[, s2, g]),
c(paste("  ", namegroup[g], etiq, sep = "")),
col = colg[g], adj = 0, cex = 0.7 )   }   }
else {   }
###################   end SA active + suplemmentary   #######################
###################   Fsg y SA + CA (sqauare & circle)   ####################
###################   SA Fsg (square)   #####################################
if(screen == TRUE) {dev.new()}
titulo <- paste(titulin, ": Tables", sep = "")
puntosplot <- Fsg
puntos <- Fsg
etiq <- namegroup
oldpar <- par(pin = c(5, 5), las = 1)
plot(puntosplot[, s1], puntosplot[, s2], type = "n",
xlab = paste("  "), ylab = paste("  "),
col = 1, xlim = c(0, 1), ylim = c(0, 1), cex = 0.5)
title(titulo, col = 1, cex = 1.2)
title("",
xlab = paste("Axis ", s1, "   (", resin[s1, 2], "%)    "),
ylab = paste("Axis ", s2, "   (", resin[s2, 2], "%)    "),
adj = 1, col = 1)
for(g in 1:G) {
points(c(puntos[g, s1]), c(puntos[g, s2]), pch =pchg[g], col = colg[g],
cex = 0.7)
text(c(puntos[g, s1]), c(puntos[g, s2]),
c(paste("  ", etiq[g], sep = "")), col = colg[g], adj = 0,
cex = 0.7)   }
par(oldpar)
###################   SA + CA (circle)   ####################################
if(screen == TRUE) {dev.new()}
titulo <- "Relation between factors of CA and SA"
puntosplot <- fact
puntos <- fact
etiq <- namegroup
### Circle
z <- seq(0, 2 * pi, length = 1000)
x <- sin(z)
y <- cos(z)
oldpar <- par(pin = c(5, 5), las = 1)
#RS FALSE F   plot(x, y, type = "l", axes = FALSE, xlab = "", ylab = "")
plot(x, y, type = "l", axes = FALSE, xlab = "", ylab = "")
#RS FALSE F   axis(1, pos = 0, labels = FALSE)
axis(1, pos = 0, labels = FALSE)
#RS FALSE F   axis(2, pos = 0, labels = FALSE)
axis(2, pos = 0, labels = FALSE)
title(titulo, col = 1, cex = 1.2)
title("",
xlab = paste("Axis ", s1, "   (", resin[s1, 2], "%)    "),
ylab = paste("Axis ", s2, "   (", resin[s2, 2], "%)    "),
adj = 1, col = 1)
for(sac in 1:2) {
for(g in 1:G) {
points(c(puntos[sac, s1, g]), c(puntos[sac, s2, g]), pch =pchg[g],
col = colg[g], cex = 0.7)
#S#          arrows(x1 = 0, y1 = 0, x2 = c(puntos[sac, s1, g]), y2 = c(puntos[sac, s2, g]), col = colg[g], size = 0.2)
#R#          arrows(x0 = 0, y0 = 0, x1 = c(puntos[sac, s1, g]), y1 = c(puntos[sac, s2, g]), col = colg[g], lwd=1.5)
#SR          arrows(0, 0, c(puntos[sac, s1, g]), c(puntos[sac, s2, g]), col = colg[g], lwd = 1.5)
arrows(0, 0, c(puntos[sac, s1, g]), c(puntos[sac, s2, g]),
col = colg[g],
lwd = 1.5)
text(c(puntos[sac, s1, g]), c(puntos[sac, s2, g]),
c(paste("  F", sac, "(", etiq[g], ")", sep = "")), col = colg[g],
adj = 0, cex = 0.7)   }   }
### Volver a pin originales (no grafico redondo)
par(oldpar)
cat ("\n")
###################   fin Fsg y SA + CA (square & circle)   #################
}
### End plot.SimAn
################################################################################

################################################################################
#####               End of SimultAnR (Simultaneous Analysis) Package       #####
################################################################################

Try the SimultAnR package in your browser

Any scripts or data that you put into this service are public.

SimultAnR documentation built on May 29, 2017, 10:59 a.m.