Nothing
cnca <- function(fespecies, fvambientales)
{
if(missing(fvambientales))
{
msg<-("ERROR: this function requires two matrices as arguments")
tkmessageBox(message=msg)
stop(" this function requires two matrices as arguments")
}#end if(missing(fvambientales))
if(dim(fespecies)[1]!=dim(fvambientales)[1])
{
msg<-("ERROR: the same number of rows in both matrices is required")
tkmessageBox(message=msg)
stop("the same number of rows in both matrices is required")
}#end if(dim(fespecies)[1]!=dim(fvambientales)[1])
transforma <- function(tipo, matriz)
{
if (tipo=="Subtract the global mean"){
Xstd <- as.matrix(matriz)
media <- mean(Xstd)
Xstd <- Xstd-media
}#end if (tipo=="Subtract the global mean")
if (tipo=="Column centering"){
Xstd <- as.matrix(matriz)
Xstd <-apply(matriz, 2, function(x){x-mean(as.matrix(x))})
}#end if (tipo=="Column centering")
if (tipo=="Standardize columns"){
Xstd <- as.matrix(matriz)
Xstd <-apply(matriz, 2, function(x){(x-mean(as.matrix(x)))/sqrt(var(as.matrix(x)))})
}#end if (tipo=="Standardize columns")
if (tipo=="Row centering"){
Xstd <- as.matrix(matriz)
Xstd <-apply(matriz, 1, function(x){x-mean(as.matrix(x))})
Xstd <- t(Xstd)
}#end if (tipo=="Row centering")
if (tipo=="Standardize rows"){
Xstd <- as.matrix(matriz)
Xstd <-apply(matriz, 1, function(x){(x-mean(as.matrix(x)))/sqrt(var(as.matrix(x)))})
Xstd <- t(Xstd)
}#end if (tipo=="Standardize rows")
if (tipo=="Double centering"){
Xstd <- as.matrix(matriz)
mediac <- colMeans(Xstd)
mediaf <- rowMeans(Xstd)
globalm <- mean(Xstd)
mediafm <- array(unlist(rep(rowMeans(Xstd), dim(Xstd)[2])), dim=dim(Xstd))
mediacm <- t(array(unlist(rep(colMeans(Xstd), dim(Xstd)[1])), dim=c(dim(Xstd)[2],dim(Xstd)[1])))
Xstd <- Xstd - mediafm - mediacm +globalm
}#end if (tipo=="Double centering")
if (tipo=="Raw data"){
Xstd <- as.matrix(matriz)
}#end if (tipo=="Raw data")
rownames(Xstd) <- rownames(matriz)
return(Xstd)
}# end transforma
ex.cnca<-function(fespecies, fvambientales, nejes, Numbercuant, Numbermixto, tChoice)
{
##We save the dimensions
dimespec <- dim(fespecies)
dimvambien <- dim(fvambientales)
##We create the data matrices
especies <- array(data=unlist(fespecies), dim=c(dimespec[1],(dimespec[2])))
vambientales <- array(data=unlist(fvambientales),dim=c(dimvambien[1],(dimvambien[2])))
vambientalesst<-vambientales
vambientalesst[,1:Numbercuant] <- transforma(tChoice, vambientales[,1:Numbercuant])
##labels
textlugares <- rownames(fespecies)
textespecies <- colnames(fespecies)
textvariables <- colnames(fvambientales)
vambientalesst <- array(data=unlist(vambientalesst),dim=c(dim(vambientalesst)))
mixtas <- vambientalesst[,-c(1:Numbercuant)]
##We sum all elements of species
sumatotal <- sum(especies)
Fe <- especies/sumatotal
fn <- array(dim=c(dimespec[1],1))
##We calculate the marginal totals and we save it in fn and fq
Idq <- as.matrix(rep(1,times=dimespec[2]))
fn <- Fe%*%Idq
Idn <- as.matrix(rep(1,times=dimespec[1]))
fq <- t(Fe)%*%Idn
#Matrix whose diagonal is the marginals fn
Dn <- diag(as.vector(t(fn)))
#Dn <- diag(rep(1/dimespec[1], times=dimespec[1]))
invD <- ginv(Dn)
Dq <- diag(as.vector(t(fq)))
invDq <- ginv(Dq)
P <- invD%*%Fe
Pb <- P-(Idn%*%t(fq))
covar <- t(vambientalesst)%*%Dn%*%vambientalesst
descovar <- La.svd(covar)
Pi <- vambientalesst%*%ginv(covar)%*%t(vambientalesst)%*%Dn
Pbest <- Pi%*%Pb
##########################################################################################
###Singular Value Decomposition of Pbest
##########################################################################################
descpbest <- La.svd(Pbest,nu=nejes,nv=nejes)
##########################################################################################
###Singular Value Decomposition of Lp
##########################################################################################
Fb <- Fe-(fn%*%t(fq))
L <- t(Fb)%*%vambientalesst
Lp <- (descovar$u%*%diag((descovar$d)^(-1/2))%*%descovar$v)%*%t(L)
descom <- svd(Lp)
suma2valprop <- sum((descom$d[1:length(descom$d)])^2)
sumaRvalprop <- sum((descom$d)^2)
inerciatot <- (descom$d[1:length(descom$d)])^2/sumaRvalprop
desclp <- svd(Lp)
V <- diag(desclp$d[1:nejes])
Tn <- desclp$v[,1:nejes]
A <- desclp$u[,1:nejes]
#A <- Lp %*% Tn %*% solve(V)
#RV<<-Pbest %*% Tn
R<- Pbest %*% Tn %*% solve(V)
#R <- descpbest$u
#V<-diag(descpbest$d[1:nejes])
#Tn<-t(descpbest$v)
###########################################################################################
##Principal coordinates of sites
###########################################################################################
colugares<- Pbest %*% Tn
###########################################################################################
##Standard coordinates of species
###########################################################################################
coespecies<- Tn
###########################################################################################
##Mixed data
###########################################################################################
Idcuant <- diag(rep(1,times=Numbercuant))
if(Numbermixto>0)
{
NAinv <- ginv(diag(as.vector(t(mixtas)%*%Dn%*%t(t(rep(1,times=dimespec[1]))))))
N <- rbind(
cbind(Idcuant,array(rep(0,times=dim(Idcuant)[1]*dim(NAinv)[2]),dim=c(dim(Idcuant)[1],dim(NAinv)[2]))),
cbind(array(rep(0,times=dim(NAinv)[1]*dim(Idcuant)[2]),dim=c(dim(NAinv)[1],dim(Idcuant)[2])),NAinv)
)
}else{
N <- Idcuant
}
###########################################################################################
##Principal coordinates of environmental variables
###########################################################################################
covambien <- N%*%((descovar$u%*%(diag(descovar$d)^(1/2))%*%descovar$v))%*%A%*%V
##########################################################################
#### Contributions and qualities of representation
##########################################################################
ejes <- sapply(1:nejes,f<-function(x){paste("Axis", x)})
####Contributions of the sites
colugarescuad <- (Pbest %*% desclp$v)^2
fixi <- Dn %*% colugarescuad
Calphai <- fixi[,1:nejes]
coespeciescuad <- (desclp$v%*%diag(desclp$d))^2
Calphak <- coespeciescuad[,1:nejes]
for (i in 1:nejes)
{
# fixi[,i] <- fn[i]*colugarescuad[,i]
Calphai[,i] <- (fixi[,i]*1000)/(diag(V)[i])^2
####Contributions of the species
Calphak[,i] <- (coespeciescuad[,i]*1000)/(diag(V)[i])^2
}#end for (i in 1:nejes)
rownames(Calphai) <- textlugares
colnames(Calphai) <- ejes
rownames(Calphak) <- textespecies
colnames(Calphak) <- ejes
####qualities of representation respect to the projected space
variabilidadps <- sum(desclp$d^2)
calidadpst <- diag(V)^2/variabilidadps
calidadps <- t(calidadpst)*1000
colnames(calidadps) <- ejes
####qualities of representation respect to the original space
descomPb<-svd(Dn^(1/2)%*%Pb)
variabilidados <- sum((descomPb$d)^2)
calidadost <- diag(V)[1:nejes]^2/variabilidados
calidados <- t(calidadost)*1000
colnames(calidados) <- ejes
colugarescuados<-(Pb%*%descomPb$v)^2
coespeciescuados<-(t(Pb)%*%Dn^(1/2)%*%descomPb$u)^2
qalphaips <- (t(apply(colugarescuad,1,function(x){x/sum(x)}))*1000)[,1:nejes]
dalphaios <- (t(apply(colugarescuados,1,function(x){x/sum(x)}))*1000)[,1:nejes]
qalphakps <- (t(apply(coespeciescuad,1,function(x){x/sum(x)}))*1000)[,1:nejes]
qalphakos <- (t(apply(coespeciescuados,1,function(x){x/sum(x)}))*1000)[,1:nejes]
rownames(qalphaips) <- textlugares
colnames(qalphaips) <- ejes
rownames(dalphaios) <- textlugares
colnames(dalphaios) <- ejes
rownames(qalphakps) <- textespecies
colnames(qalphakps) <- ejes
rownames(qalphakos) <- textespecies
colnames(qalphakos) <- ejes
##### retained inertia
eigencuad <- (diag(V))^2
inertia <- cbind(eigencuad,eigencuad)
inertia[,1] <- (eigencuad/sum(eigencuad))*100
inertia[,2] <- cumsum(inertia[,1])
colnames(inertia) <- c("Retained inertia (%)","Cumulative retained inertia(%)")
coindividuosnam <- as.data.frame(coespecies)
rownames(coindividuosnam) <- textespecies
colnames(coindividuosnam) <- ejes
covariablesnam <- as.data.frame(covambien)
rownames(covariablesnam) <- textvariables
colnames(covariablesnam) <- ejes
colugaresnam <- as.data.frame(colugares)
rownames(colugaresnam) <- textlugares
colnames(colugaresnam) <- ejes
results<-list(colugares=colugares, coespecies=coespecies, covambien=covambien, colugaresnam=colugaresnam, covariablesnam=covariablesnam, coindividuosnam=coindividuosnam, ejes=ejes, Calphai=Calphai,
Calphak=Calphak, calidadps=calidadps, calidados=calidados, qalphaips=qalphaips, qalphakos=qalphakos, qalphakps=qalphakps,
dalphaios=dalphaios, inertia=inertia, descom=descom, inerciatot=inerciatot, valpro=descom$d)
return(results)
}
ex.cca<-function(fespecies, fvambientales, nejes, Numbercuant, Numbermixto, tChoice)
{
dimespec <- dim(fespecies)
dimvambien <- dim(fvambientales)
##We create the data matrices
especies <- array(data=unlist(fespecies), dim=c(dimespec[1],(dimespec[2])))
vambientales <- array(data=unlist(fvambientales),dim=c(dimvambien[1],(dimvambien[2])))
vambientalesst<-vambientales
vambientalesst[,1:Numbercuant] <- transforma(tChoice, vambientales[,1:Numbercuant])
##labels
textlugares <- rownames(fespecies)
textespecies <- colnames(fespecies)
textvariables <- colnames(fvambientales)
vambientalesst <- array(data=unlist(vambientalesst),dim=c(dim(vambientalesst)))
mixtas <- vambientalesst[,-c(1:Numbercuant)]
##We sum all elements of species
sumatotal <- sum(especies)
Fe <- especies/sumatotal
fn <- array(dim=c(dimespec[1],1))
##We calculate the marginal totals and we save it in fn and fq
Idq <- as.matrix(rep(1,times=dimespec[2]))
fn <- Fe%*%Idq
Idn <- as.matrix(rep(1,times=dimespec[1]))
fq <- t(Fe)%*%Idn
#Matrix whose diagonal is the marginals fn
Dn <- diag(as.vector(t(fn)))
# Dn <- diag(rep(1/dimespec[1], times=dimespec[1]))
invD <- ginv(Dn)
Dq <- diag(as.vector(t(fq)))
invDq <- ginv(Dq)
covar <- t(vambientalesst)%*%Dn%*%vambientalesst
descovar <- La.svd(covar)
##center species matrix
rsum<-rowSums(Fe)
csum <- colSums(Fe)
# Fe<- Fe-(rsum%*%t(csum))
W <- (invDq %*% t(Fe)-t(rsum%*%t(csum))) %*% vambientalesst
Wdesc <- Dq^(1/2) %*% W %*% (descovar$u%*%(solve(diag(descovar$d)^(1/2)))%*%descovar$v)
##########################################################################################
###Singular Value Decomposition of Wdesc
##########################################################################################
descom <- La.svd(Wdesc)
R <- descom$u[,1:nejes]
V <- diag(descom$d[1:nejes])
Tn <- t(descom$v)[,1:nejes]
suma2valprop <- sum((descom$d[1:length(descom$d)])^2)
sumaRvalprop <- sum((descom$d)^2)
inerciatot <- (descom$d[1:length(descom$d)])^2/sumaRvalprop
###########################################################################################
##Principal coordinates of sites
###########################################################################################
colugares<- vambientalesst %*% (descovar$u%*%(solve(diag(descovar$d)^(1/2)))%*%descovar$v) %*% Tn
###########################################################################################
##Standard coordinates of species
###########################################################################################
coespecies<- invDq^(1/2) %*% R %*% V
###########################################################################################
##Mixed data
###########################################################################################
Idcuant <- diag(rep(1,times=Numbercuant))
if(Numbermixto>0)
{
NAinv <- ginv(diag(as.vector(t(mixtas)%*%Dn%*%t(t(rep(1,times=dimespec[1]))))))
N <- rbind(
cbind(Idcuant,array(rep(0,times=dim(Idcuant)[1]*dim(NAinv)[2]),dim=c(dim(Idcuant)[1],dim(NAinv)[2]))),
cbind(array(rep(0,times=dim(NAinv)[1]*dim(Idcuant)[2]),dim=c(dim(NAinv)[1],dim(Idcuant)[2])),NAinv)
)
}else{
N <- Idcuant
}
###########################################################################################
##Standar coordinates of environmental variables
###########################################################################################
covambien <- N %*% ((descovar$u%*%(diag(descovar$d)^(1/2))%*%descovar$v)) %*% Tn %*% V
##########################################################################
#### Contributions and qualities of representation
##########################################################################
ejes <- sapply(1:nejes,f<-function(x){paste("Axis", x)})
# Pbest <- (invDq %*% t(Fe)-t(rsum%*%t(csum))) - R %*% V %*% t((descovar$u%*%(solve(diag(descovar$d)^(1/2)))%*%descovar$v) %*% Tn) %*% t(vambientalesst) %*% Dn
# Pbest <- t(Pbest)
Pbest<-invD^(1/2) %*% (Fe-(rsum%*%t(csum))) %*% invDq^(1/2)
Rp <- svd(Pbest)#,nu=nejes,nv=nejes)
colugaresos <- Rp$u%*%diag(Rp$d)
PHIu <-Rp$u
coespeciesos <- invDq^(1/2)%*%Rp$v%*%diag(Rp$d)
GAHu<- invDq^(1/2)%*%Rp$v
####Contributions of the sites
colugarescuad <-Dn %*% (vambientalesst %*% (descovar$u%*%(solve(diag(descovar$d)^(1/2)))%*%descovar$v) %*% t(descom$v)%*%diag(descom$d))^2
Calphai <- colugarescuad[,1:nejes]
coespeciescuad <- Dq %*% (invDq^(1/2) %*% descom$u %*% diag(descom$d))^2
Calphak <- coespeciescuad[,1:nejes]
colugarescuados <-(Dn %*% colugaresos)^2
Calphaios <- colugarescuados[,1:nejes]
coespeciescuados <- (Dq %*% coespeciesos)^2
Calphakos <- coespeciescuados[,1:nejes]
for (i in 1:nejes)
{
Calphai[,i] <- (colugarescuad[,i]*1000)/(diag(V)[i])^2
####Contributions of the species
Calphak[,i] <- (coespeciescuad[,i]*1000)/(diag(V)[i])^2
Calphaios[,i] <- (colugarescuados[,i]*1000)/(Rp$d[i])^2
####Contributions of the species
Calphakos[,i] <- (coespeciescuados[,i]*1000)/(Rp$d[i])^2
}#end for (i in 1:nejes)
rownames(Calphai) <- textlugares
colnames(Calphai) <- ejes
rownames(Calphak) <- textespecies
colnames(Calphak) <- ejes
####qualities of representation respect to the projected space
variabilidadps <- sum(descom$d^2)
calidadpst <- diag(V)^2/variabilidadps
calidadps <- t(calidadpst)*1000
colnames(calidadps) <- ejes
####qualities of representation respect to the original space
variabilidados <- sum(Rp$d)
calidadost <- Rp$d[1:nejes]/variabilidados
calidados <- t(calidadost)*1000
colnames(calidados) <- ejes
qalphaips <- (t(apply(colugarescuad,1,function(x){x/sum(x)}))*1000)[,1:nejes]
dalphaios <- (t(apply(colugarescuados,1,function(x){x/sum(x)}))*1000)[,1:nejes]
qalphakps <- (t(apply(coespeciescuad,1,function(x){x/sum(x)}))*1000)[,1:nejes]
qalphakos <- (t(apply(coespeciescuados,1,function(x){x/sum(x)}))*1000)[,1:nejes]
rownames(qalphaips) <- textlugares
colnames(qalphaips) <- ejes
rownames(dalphaios) <- textlugares
colnames(dalphaios) <- ejes
rownames(qalphakps) <- textespecies
colnames(qalphakps) <- ejes
rownames(qalphakos) <- textespecies
colnames(qalphakos) <- ejes
##### retained inertia
eigencuad <- (diag(V))^2
inertia <- cbind(eigencuad,eigencuad)
inertia[,1] <- (eigencuad/sum(eigencuad))*100
inertia[,2] <- cumsum(inertia[,1])
colnames(inertia) <- c("Retained inertia (%)","Cumulative retained inertia(%)")
coindividuosnam <- as.data.frame(coespecies)
rownames(coindividuosnam) <- textespecies
colnames(coindividuosnam) <- ejes
covariablesnam <- as.data.frame(covambien)
rownames(covariablesnam) <- textvariables
colnames(covariablesnam) <- ejes
colugaresnam <- as.data.frame(colugares)
rownames(colugaresnam) <- textlugares
colnames(colugaresnam) <- ejes
results<-list(colugares=colugares, coespecies=coespecies, covambien=covambien, colugaresnam=colugaresnam, covariablesnam=covariablesnam, coindividuosnam=coindividuosnam, ejes=ejes,
Calphai=Calphai, Calphak=Calphak, calidadps=calidadps, calidados=calidados, qalphaips=qalphaips, qalphakos=qalphakos, qalphakps=qalphakps,
dalphaios=dalphaios, inertia=inertia,
descom=descom, inerciatot=inerciatot, valpro=descom$d)
return(results)
}
ex.coia<-function(fespecies, fvambientales, nejes, tChoice, Numbercuant)
{
##We save the dimensions
dimespec <- dim(fespecies)
dimvambien <- dim(fvambientales)
##We create the data matrices
especies <- array(data=unlist(fespecies), dim=c(dimespec[1],(dimespec[2])))
especies <- transforma("Column centering", especies)
vambientales <- array(data=unlist(fvambientales),dim=c(dimvambien[1],(dimvambien[2])))
vambientalesst <- transforma (tChoice, vambientales[,1:Numbercuant])
##labels
textlugares <- rownames(fespecies)
textespecies <- colnames(fespecies)
textvariables <- colnames(fvambientales)
##We sum all elements of species
sumatotal <- sum(especies)
Fe <- especies/sumatotal
fvam <-fvambientales/sum(fvambientales)
fn <- array(dim=c(dimespec[1],1))
##We calculate the marginal totals and we save it in fn and fq
Idq <- as.matrix(rep(1,times=dimespec[2]))
fn <- Fe%*%Idq
Idn <- as.matrix(rep(1,times=dimespec[1]))
fq <- t(Fe)%*%Idn
fp <- t(fvam)%*%Idn
#Matrix whose diagonal is the marginals fn
#Dn <- diag(as.vector(t(fn)))
Dn <- diag(rep(1/dimespec[1], times=dimespec[1]))
Dn2<-diag(sqrt(diag(Dn)))
invD <- ginv(Dn)
Dq <- diag(as.vector(t(fq)))
invDq <- ginv(Dq)
Dp <- diag(as.vector(t(fp)))
invDp <- ginv(Dp)
# ##center species matrix
# rsum<-rowSums(Fe)
# csum <- colSums(Fe)
# Fe<- Fe-(rsum%*%t(csum))
#
intertabla <- t(fespecies) %*% Dn %*% vambientalesst
colnames(intertabla)<- colnames(fvambientales)
# extrae los vectores singulares por la izquierda y por la derecha para las dos
#matrices y para la coinercia
descomx <- svd(Dn2 %*% vambientalesst, nu=nejes, nv=nejes)
UX <- solve(Dn2) %*% (descomx$u) %*% diag(1/sqrt(diag(t(descomx$u)%*%(descomx$u))))
VX <- (descomx$v) %*% diag(1/sqrt(diag(t(descomx$v)%*%(descomx$v))))
descomy <- svd(Dn2 %*% especies, nu=nejes, nv=nejes)
UY <- solve(Dn2) %*% (descomy$u) %*% diag(1/sqrt(diag(t(descomy$u)%*%(descomy$u))))
VY <- (descomy$v) %*% diag(1/sqrt(diag(t(descomy$v)%*%(descomy$v))))
descom <- svd(intertabla, nu=nejes, nv=nejes)
Ucoia <- (descom$u) %*% diag(1/sqrt(diag(t(descom$u)%*%(descom$u))))
Vcoia <- (descom$v) %*% diag(1/sqrt(diag(t(descom$v)%*%(descom$v))))
Xaxes <- t(VX) %*% Vcoia
Yaxes <- t(VY)%*%Ucoia
suma2valprop <- sum((descom$d[1:length(descom$d)])^2)
sumaRvalprop <- sum((descom$d)^2)
inerciatot <- (descom$d[1:length(descom$d)])^2/sumaRvalprop
# calcula las coordenadas
rowx <- vambientalesst %*% VX
colx <- t(vambientalesst) %*% Dn %*% UX
rowy <- especies %*% VY
coly <- t(especies) %*% Dn %*% UY
colugaresz <- vambientalesst %*% Vcoia
covambien <- t(intertabla) %*% Ucoia
colugaresy <- especies %*% Ucoia
coespecies <- intertabla %*% Vcoia
##########################################################################
#### Contributions and qualities of representation
##########################################################################
ejes <- sapply(1:nejes,f<-function(x){paste("Axis", x)})
coindividuosnam <- as.data.frame(coespecies)
rownames(coindividuosnam) <- textespecies
colnames(coindividuosnam) <- ejes
covariablesnam <- as.data.frame(covambien)
rownames(covariablesnam) <- textvariables
colnames(covariablesnam) <- ejes
colugaresnamz <- as.data.frame(colugaresz)
rownames(colugaresnamz) <- textlugares
colnames(colugaresnamz) <- ejes
colugaresnamy <- as.data.frame(colugaresy)
rownames(colugaresnamy) <- textlugares
colnames(colugaresnamy) <- ejes
results<-list(colugaresz=colugaresz, colugaresy=colugaresy, coespecies=coespecies,
covambien=covambien, colugaresnamz=colugaresnamz, colugaresnamy=colugaresnamy,
covariablesnam=covariablesnam, coindividuosnam=coindividuosnam, ejes=nejes,
descom=descom, inerciatot=inerciatot, valpro=descom$d, Xaxes=Xaxes, Yaxes=Yaxes)
return(results)
}
calc_inerciatot<-function(fespecies, fvambientales, tChoice, tipocca, Numbercuant)
{
##We save the dimensions
dimespec <- dim(fespecies)
dimvambien <- dim(fvambientales)
##We create the data matrices
especies <- array(data=unlist(fespecies), dim=c(dimespec[1],(dimespec[2])))
vambientales <- array(data=unlist(fvambientales),dim=c(dimvambien[1],(dimvambien[2])))
vambientalesst<-vambientales
vambientalesst[,1:Numbercuant] <- transforma(tChoice, vambientales[,1:Numbercuant])
##We sum all elements of species
sumatotal <- sum(especies)
Fe <- especies/sumatotal
fn <- array(dim=c(dimespec[1],1))
##We calculate the marginal totals and we save it in fn and fq
Idq <- as.matrix(rep(1,times=dimespec[2]))
fn <- Fe%*%Idq
Idn <- as.matrix(rep(1,times=dimespec[1]))
fq <- t(Fe)%*%Idn
#Matrix whose diagonal is the marginals fn
Dn <- diag(as.vector(t(fn)))
#Dn <- diag(rep(1/dimespec[1], times=dimespec[1]))
invD <- ginv(Dn)
Dq <- diag(as.vector(t(fq)))
invDq <- ginv(Dq)
covar <- t(vambientalesst)%*%Dn%*%vambientalesst
descovar <- La.svd(covar)
##########################################################################################
###Singular Value Decomposition of Lp
##########################################################################################
if(tipocca=="CNCA")
{
Fb <- Fe-(fn%*%t(fq))
L <- t(Fb)%*%vambientalesst
Lp <- ((descovar$u%*%(solve(diag(descovar$d)^(1/2)))%*%descovar$v))%*%t(L)
descom <- svd(Lp)#,nu=nejes,nv=nejes)
}else{
if(tipocca=="CCA")
{
rsum<-rowSums(Fe)
csum <- colSums(Fe)
# Fe<- Fe-rsum%*%t(csum)
W <- (invDq %*% t(Fe)-t(rsum%*%t(csum))) %*% vambientalesst
Wdesc <- Dq^(1/2) %*% W %*% (descovar$u%*%(solve(diag(descovar$d)^(1/2)))%*%descovar$v)
##########################################################################################
###Singular Value Decomposition of Wdesc
##########################################################################################
descom <- svd(Wdesc)
}else{
intertabla <- t(especies) %*% Dn %*% vambientalesst
descom <-svd(intertabla)
}
}
suma2valprop <- sum((descom$d[1:length(descom$d)])^2)
sumaRvalprop <- sum((descom$d)^2)
inerciatot <- (descom$d[1:length(descom$d)])^2/sumaRvalprop
return(list(descom=descom, inerciatot=inerciatot))
}
resample_bootes<-function(fespecies)
{
mientorno <- new.env()
dimespec<-dim(fespecies)
#deshacer tabla de contingencia
especvector<-paste("e", 1:dimespec[2], sep="")
for(z in 1:dimespec[2])
{
esvec<-c()
for(j in 1: dimespec[1])
{
esvec<-c(esvec, rep(j,fespecies[j,z]))
}
assign(especvector[z], esvec, envir=mientorno)
}
##### resample
especresample<-array(rep(0,dimespec[1]*dimespec[2]), dim=dimespec)
for(z in 1:dimespec[2])
{
columresam<-get(especvector[z], envir=mientorno)
indices <- sample(1:length(columresam), replace = T)
columresam<-columresam[indices]
columna<-table(columresam)
for (j in 1:length(columna))
{
especresample[as.numeric(rownames(columna)[j]),z]<-columna[j]
}
}
colnames(especresample)<-colnames(fespecies)
rownames(especresample)<-rownames(fespecies)
return(especresample)
}# end resample_bootes<-function(fespecies)
cal.ic <- function (muestra, liminf, limsup, valorobs, muestrajack, niter)
{
c.mean <- mean (muestra)
se <- sd(muestra)
sesgo <- c.mean - valorobs
t.ic <- se * (-qt(liminf,(length(muestra)-1)))
ic.t <- c(c.mean - t.ic, c.mean + t.ic)
ic.p <- quantile (muestra,c(liminf, limsup), na.rm=TRUE)
z0 <- qnorm(length(muestra[which(muestra<valorobs)])/as.numeric(niter))
dent <- mean(muestrajack)- muestrajack
acc <- sum(dent * dent * dent)/(6 * (sum(dent * dent))^1.5)
alpha1 <- qnorm(liminf)
alpha2 <- qnorm(limsup)
zalpha1 <- pnorm(z0 + (z0 + alpha1)/(1 - acc * (z0 + alpha1)))
zalpha2 <- pnorm(z0 + (z0 + alpha2)/(1 - acc * (z0 + alpha2)))
ic.bca <- quantile (muestra,c(zalpha1, zalpha2), na.rm=TRUE)
return(c(c.mean, se,sesgo,ic.t, ic.p, ic.bca))
}#end cal.ic <- function (muestra, liminf, limsup, valorobs)
#############################################################################
### Informative window
#############################################################################
symbolos <- c("*",".", "o","O","0","+","-","|","%","#")
nejes<-3
dim1<-1
dim2<-2
dim3<-3
dim1ant<-1
dim2ant<-2
simChoicel <- NULL
Namesit <- NULL
Namespe <- NULL
Namevar <- NULL
Namemixto <- NULL
Numbercuant <- NULL
Numbermixto <- NULL
dimespec <-NULL
dimvambien <-NULL
especies <-NULL
vambientales <-NULL
vambientalesst <-NULL
simlugares <-NULL
simespecies <-NULL
simvariables <-NULL
anteriorx <- NULL
anteriory <- NULL
xCoords <- NULL
yCoords <- NULL
xCoordsp <- NULL
yCoordsp <- NULL
zCoords <- NULL
datos <- NULL
textos <- NULL
datosr <- NULL
textosr <- NULL
simbolos <- NULL
colores <-NULL
indexClosest <- NULL
indexLabeled <- NULL
indexLabeledaux <- NULL
parPlotSize <- NULL
usrCoords <- NULL
tChoice <- "Raw data"
img <- NULL
imgbar <- NULL
descom <- NULL
inerciatot <- NULL
Dn <- NULL
fq <- NULL
fn <- NULL
Fe <- NULL
Idn <- NULL
Lp <- NULL
colugares <- NULL
coespecies <- NULL
covambien <- NULL
ejes <- NULL
indicee <- NULL
Namee <- NULL
Cexe <- 1
NameVale <- NULL
NameCexe <- NULL
Choicee <- NULL
colore <- NULL
simChoicee <- NULL
indicev <- NULL
Namev <- NULL
NameValv <- NULL
Cexv <- 1
NameCexv <- NULL
Choicev <- NULL
colorv <- NULL
simChoicev <- NULL
indicei <- NULL
Namei <- NULL
NameVali <- NULL
Cexi <- 1
NameCexi <- NULL
Choicei <- NULL
colori <- NULL
simChoicei <- NULL
entry.Cexi <- NULL
entry.Namei <- NULL
indicel <- NULL
Namel <- NULL
NameVall <- NULL
Cexl <- 1
NameCexl <- NULL
Choicel <- NULL
colorl <- NULL
simChoicel <- NULL
entry.Cexl <- NULL
cblugares <- "0"
cbVal <- NULL
cblablugares <- "0"
hescale <- "1.5"
vescale <- "1.5"
labelsVec <- NULL
sizesVec <- NULL
simChoice <- NULL
textvariables <- c()
textespecies <- c()
textlugares <- c()
colvariablesp <- c()
colespeciesp <- c()
collugaresp <- c()
proj <- "normal"
Choiceproj<- 0
niter <- 1000
alphaic <- 95
cCalphaiVal <- NULL
cCalphakVal <- NULL
ccalidadpsVal <- NULL
ccalidadosVal <- NULL
cqalphaipsVal <- NULL
cdalphaiosVal <- NULL
cqalphakpsVal <- NULL
cqalphakosVal <- NULL
cccaVal <- NULL
iner <- NULL
colugaresnam <- NULL
covariablesnam <- NULL
coindividuosnam <- NULL
Calphai <- NULL
Calphak <- NULL
calidadps <- NULL
calidados <- NULL
qalphaips <- NULL
qalphakps <- NULL
qalphakos <- NULL
dalphaios <- NULL
inertia <- NULL
colugaresz <- NULL
colugaresy <- NULL
colugaresnamz <- NULL
colugaresnamy <- NULL
Xaxes <- NULL
Yaxes <- NULL
colugzaux <- NULL
colugyaux <- NULL
cexejes <- NULL
entry.limix1 <- NULL
entry.limix2 <- NULL
entry.limiy1 <- NULL
entry.limiy2 <- NULL
datost <- NULL
#ccoindividuosnamVal <- NULL
#ccovariablesnamVal <- NULL
#ccolugaresnamVal <- NULL
ceigenVal <- NULL
cpdfVal <- NULL
cepsVal <- NULL
ccaVal <- NULL
typecoia <- "sg"
tit_graph <- "Graph"
Limix1 <-tclVar("0")
Limix2 <-tclVar("0")
Limiy1 <-tclVar("0")
Limiy2 <-tclVar("0")
colorescoor <- c("skyblue","red","green","blue","yellow","pink","orange", "navyblue",
"violet", "brown", "grey", "navyblue", "darkgreen", "papayawhip", "paleturquoise", "purple",
"seagreen", "azure", "coral", "springgreen", "steelblue", "plum", "orchid",
"lemonchiffon", "lavender", "honeydew", "gold", "deeppink", "darksalmon", "darkmagenta")
winfor <- tktoplevel()
tkwm.title(winfor,"Two Tables Analyses")
fontHeading <- tkfont.create(family="times",size=24,weight="bold",slant="italic")
fontTextLabel <- tkfont.create(family="times",size=12)
fontFixedWidth <- tkfont.create(family="courier",size=12)
tkpack(tklabel(winfor,text="Two Tables Analyses",font=fontHeading, foreground = "blue"))
frameprin<-tkframe(winfor, relief = "ridge", borderwidth = 2, background = "white")
framecnca<-tkframe(frameprin, relief = "ridge", borderwidth = 2, background = "white")
frameot<-tkframe(frameprin, relief = "ridge", borderwidth = 2, background = "white")
ccca <- tkradiobutton(frameot)
ccnca <- tkradiobutton(framecnca)
ccoia <- tkradiobutton(frameot)
rbccaValue <- tclVar("CNCA")
tkconfigure(ccca,variable=rbccaValue,value="CCA")
tkconfigure(ccnca,variable=rbccaValue,value="CNCA")
tkconfigure(ccoia,variable=rbccaValue,value="COIA")
tkpack(tklabel(framecnca, text="Canonical Non-Symmetrical Correspondence Analysis (CNCA)",
font=fontTextLabel, foreground = "blue"), ccnca,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
tkpack(tklabel(frameot, text="Canonical Correspondence Analysis (CCA)"), ccca,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
tkpack(tklabel(frameot, text="Coinertia Analysis (COIA)"), ccoia,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
tkpack(framecnca, frameot, expand = "TRUE", side="left", fill="both")
tkpack(frameprin, frameot, expand = "TRUE", side="top", fill="both")
##We save the dimensions
dimespec <- dim(fespecies)
dimvambien <- dim(fvambientales)
###########################################################################################
##We create the vectors of the labels
###########################################################################################
textlugares <- rownames(fespecies)
textespecies <- colnames(fespecies)
textvariables <- colnames(fvambientales)
###########################################################################################
##We create the vectors of the colors
###########################################################################################
collugares <- rep("green",dimespec[1])
colespecies <- rep("blue",dimespec[2])
colvariables <- rep("red",dimvambien[2])
collugaresp <- rep("grey",dimespec[1])
colespeciesp <- rep("grey",dimespec[2])
colvariablesp <- rep("grey",dimvambien[2])
###########################################################################################
##We create the vectors of the symbols
###########################################################################################
simlugares <- rep("*",dimespec[1])
simespecies <- rep("+",dimespec[2])
simvariables <- rep(" ",dimvambien[2])
###########################################################################################
##We create the vectors of the character size
###########################################################################################
cexlugares <- rep(1,dimespec[1])
cexespecies <- rep(1,dimespec[2])
cexvariables <- rep(1,dimvambien[2])
OnOKinf <- function()
{
#############################################################################
### Names of label window
#############################################################################
cccaVal <<- as.character(tclvalue(rbccaValue))
if((cccaVal=="CCA" | cccaVal=="CNCA") & (dim(fespecies)[1]<dim(fespecies)[2]) & (dim(fvambientales)[1]<dim(fvambientales)[2]))
{
msg<-("ERROR: the number of rows is less than the number of columns. The best method for this analysis is the Coinertia Analysis.")
tkmessageBox(message=msg)
tkdestroy(winfor)
stop("the number of rows is less than the number of columns. The best method for this analysis is the Coinertia Analysis")
}#end if((cccaVal=="CCA" | cccaVal=="CNCA") & (dim(fespecies)[1]<dim(fespecies)[2]) & (dim(fvambientales)[1]<dim(fvambientales)[2]))
tkdestroy(winfor)
wnames <- tktoplevel()
tkwm.title(wnames,"Enter names")
OnOKnames <- function()
{
Namesit <<- tclvalue(sitesname)
Namespe <<- tclvalue(speciesname)
Namevar <<- tclvalue(variablesname)
if(cccaVal!="COIA")
{
#Namemixto <<- tclvalue(mixto)
Numbercuant <<- tclvalue(ncuant)
Numbermixto <<- tclvalue(nmixto)
Numbermixto <<- as.numeric(Numbermixto)
Numbercuant <<- as.numeric(Numbercuant)
if((Numbercuant+Numbermixto)!=dim(fvambientales)[2])
{
msg<-("ERROR: Total number of variables not equal to sum of cuantitatives and categorical variables")
tkmessageBox(message=msg)
stop("Total number of variables not equal to sum of cuantitatives and categorical variables")
}#end if(dim(fespecies)[1]!=dim(fvambientales)[1])
}else{
Numbercuant<<-dimvambien[2]
Numbermixto<<-0
}
tkdestroy(wnames)
#####Window to change labels and colors#######
tt <- tktoplevel()
tkwm.title(tt,"Options")
#####Dropdown menu #############################
topMenuopt <- tkmenu(tt)
tkconfigure(tt, menu = topMenuopt)
fileMenutrans <- tkmenu(topMenuopt, tearoff = FALSE)
tkadd(fileMenutrans,"command",label="Subtract the global mean",command=function() tChoice<<-"Subtract the global mean")
tkadd(fileMenutrans,"command",label="Column centering",command=function() tChoice<<-"Column centering")
tkadd(fileMenutrans,"command",label="Standardize columns",command=function() tChoice<<-"Standardize columns")
tkadd(fileMenutrans,"command",label="Row centering",command=function() tChoice<<-"Row centering")
tkadd(fileMenutrans,"command",label="Standardize rows",command=function() tChoice<<-"Standardize rows")
tkadd(fileMenutrans,"command",label="Double Centering",command=function() tChoice<<-"Double centering")
tkadd(fileMenutrans,"command",label="Raw data",command=function() tChoice<<-"Raw data")
tkadd(topMenuopt,"cascade",label="Transformations",menu=fileMenutrans)
#### List of transformations
framett<-tkframe(tt, relief = "flat", borderwidth = 2, background = "white")
framett1<-tkframe(framett, relief = "ridge", borderwidth = 2, background = "white")
framett2<-tkframe(framett, relief = "ridge", borderwidth = 2, background = "white")
framett3<-tkframe(framett, relief = "ridge", borderwidth = 2, background = "white")
framett4<-tkframe(framett, relief = "ridge", borderwidth = 2)#, background = "grey3")
framet1<-tkframe(framett1, relief = "ridge", borderwidth = 2, background = "white")
frametext1<-tkframe(framett1, relief = "flat", borderwidth = 2, background = "white")
frameok1<-tkframe(framett1, relief = "ridge", borderwidth = 2, background = "white")
framecol1<-tkframe(framett1, relief = "flat", borderwidth = 2, background = "white")
framecol11<-tkframe(framecol1, relief = "flat", borderwidth = 2, background = "white")
framecol12<-tkframe(framecol1, relief = "flat", borderwidth = 2, background = "white")
framename1<-tkframe(framett1, relief = "flat", borderwidth = 2, background = "white")
framename11<-tkframe(framename1, relief = "flat", borderwidth = 2, background = "white")
framename12<-tkframe(framename1, relief = "flat", borderwidth = 2, background = "white")
framecex1<-tkframe(framett1, relief = "flat", borderwidth = 2, background = "white")
framecex11<-tkframe(framecex1, relief = "flat", borderwidth = 2, background = "white")
framecex12<-tkframe(framecex1, relief = "flat", borderwidth = 2, background = "white")
frames1<-tkframe(framett1, relief = "flat", borderwidth = 2, background = "white")
frames11<-tkframe(frames1, relief = "flat", borderwidth = 2, background = "white")
frames12<-tkframe(frames1, relief = "flat", borderwidth = 2, background = "white")
framet2<-tkframe(framett2, relief = "ridge", borderwidth = 2, background = "white")
frametext2<-tkframe(framett2, relief = "flat", borderwidth = 2, background = "white")
frameok2<-tkframe(framett2, relief = "ridge", borderwidth = 2, background = "white")
framecol2<-tkframe(framett2, relief = "flat", borderwidth = 2, background = "white")
framecol21<-tkframe(framecol2, relief = "flat", borderwidth = 2, background = "white")
framecol22<-tkframe(framecol2, relief = "flat", borderwidth = 2, background = "white")
framename2<-tkframe(framett2, relief = "flat", borderwidth = 2, background = "white")
framename21<-tkframe(framename2, relief = "flat", borderwidth = 2, background = "white")
framename22<-tkframe(framename2, relief = "flat", borderwidth = 2, background = "white")
framecex2<-tkframe(framett2, relief = "flat", borderwidth = 2, background = "white")
framecex21<-tkframe(framecex2, relief = "flat", borderwidth = 2, background = "white")
framecex22<-tkframe(framecex2, relief = "flat", borderwidth = 2, background = "white")
frames2<-tkframe(framett2, relief = "flat", borderwidth = 2, background = "white")
frames21<-tkframe(frames2, relief = "flat", borderwidth = 2, background = "white")
framet3<-tkframe(framett3, relief = "ridge", borderwidth = 2, background = "white")
frametext3<-tkframe(framett3, relief = "flat", borderwidth = 2, background = "white")
frameok3<-tkframe(framett3, relief = "ridge", borderwidth = 2, background = "white")
framecol3<-tkframe(framett3, relief = "flat", borderwidth = 2, background = "white")
framecol31<-tkframe(framecol3, relief = "flat", borderwidth = 2, background = "white")
framecol32<-tkframe(framecol3, relief = "flat", borderwidth = 2, background = "white")
framename3<-tkframe(framett3, relief = "flat", borderwidth = 2, background = "white")
framename31<-tkframe(framename3, relief = "flat", borderwidth = 2, background = "white")
framename32<-tkframe(framename3, relief = "flat", borderwidth = 2, background = "white")
framecex3<-tkframe(framett3, relief = "flat", borderwidth = 2, background = "white")
framecex31<-tkframe(framecex3, relief = "flat", borderwidth = 2, background = "white")
framecex32<-tkframe(framecex3, relief = "flat", borderwidth = 2, background = "white")
frames3<-tkframe(framett3, relief = "flat", borderwidth = 2, background = "white")
frames31<-tkframe(frames3, relief = "flat", borderwidth = 2, background = "white")
frames32<-tkframe(frames3, relief = "flat", borderwidth = 2, background = "white")
framet4<-tkframe(framett4, relief = "flat", borderwidth = 2)#, background = "white")
frametext4<-tkframe(framett4, relief = "flat", borderwidth = 2)#, background = "white")
frameok4<-tkframe(framett4, relief = "flat", borderwidth = 2)#, background = "white")
framett4aux<-tkframe(framett4, relief = "ridge", borderwidth = 2)#, background = "white")
framett4auxgs<-tkframe(framett4, relief = "ridge", borderwidth = 2)#, background = "white")
framecol4<-tkframe(framett4aux, relief = "flat", borderwidth = 2)#, background = "white")
framecol41<-tkframe(framecol4, relief = "flat", borderwidth = 2)#, background = "white")
framecol42<-tkframe(framecol4, relief = "flat", borderwidth = 2)#, background = "white")
framename4<-tkframe(framett4aux, relief = "flat", borderwidth = 2)#, background = "white")
framename41<-tkframe(framename4, relief = "flat", borderwidth = 2)#, background = "white")
framename42<-tkframe(framename4, relief = "flat", borderwidth = 2)#, background = "white")
framehvtitle<-tkframe(framett4auxgs, relief = "flat", borderwidth = 2)#, background = "white")
framehv<-tkframe(framett4auxgs, relief = "flat", borderwidth = 2)#, background = "white")
framehvnames<-tkframe(framehv, relief = "flat", borderwidth = 2)#, background = "white")
framehnames<-tkframe(framehvnames, relief = "flat", borderwidth = 2)#, background = "white")
framevnames<-tkframe(framehvnames, relief = "flat", borderwidth = 2)#, background = "white")
framehvtext<-tkframe(framehv, relief = "flat", borderwidth = 2)#, background = "white")
framehtext<-tkframe(framehvtext, relief = "flat", borderwidth = 2)#, background = "white")
framevtext<-tkframe(framehvtext, relief = "flat", borderwidth = 2)#, background = "white")
framecex4<-tkframe(framett4aux, relief = "flat", borderwidth = 2)#, background = "white")
framecex41<-tkframe(framecex4, relief = "flat", borderwidth = 2)#, background = "white")
framecex42<-tkframe(framecex4, relief = "flat", borderwidth = 2)#, background = "white")
frames4<-tkframe(framett4, relief = "flat", borderwidth = 2)#, background = "white")
frames41<-tkframe(frames4, relief = "flat", borderwidth = 2)#, background = "white")
framegraphic<-tkframe(tt, relief = "flat", borderwidth = 2, background = "white")
##### Checkbox to show the axes or not #######
cb <- tkcheckbutton(framecol42)
cbValue <- tclVar("0")
tkconfigure(cb,variable=cbValue)
##### Checkbox to show the sites or not #######
cbl <- tkcheckbutton(framename42)
cblug <- tclVar("0")
tkconfigure(cbl,variable=cblug)
##### Checkbox to show the labels of the sites or not #######
cbll <- tkcheckbutton(framecex42)
cblablug <- tclVar("0")
tkconfigure(cbll,variable=cblablug)
##We save the dimensions
dimespec <- dim(fespecies)
if(Numbermixto>0)
{
mixtas<-array(dim=c(dimespec[1],1))
for (i in 1:Numbermixto)
{
factoresmix<-unique(fvambientales[,as.numeric(Numbercuant)+i])
for(j in 1:length(factoresmix))
{
linea<-ifelse(fvambientales[,Numbercuant+i]==factoresmix[j], 1,0)
linea<-as.data.frame(linea)
colnames(linea)<-paste(colnames(fvambientales)[as.numeric(Numbercuant)+i],factoresmix[j],sep="-")
mixtas<-cbind(mixtas,linea)
}
}
mixtas<-mixtas[,-1]
fvambientales <- cbind(fvambientales[,1:Numbercuant],mixtas)
}
dimvambien <- dim(fvambientales)
###########################################################################################
##We create the vectors of the labels
###########################################################################################
textlugares <- rownames(fespecies)
textespecies <- colnames(fespecies)
textvariables <- colnames(fvambientales)
###########################################################################################
##We create the vectors of the colors
###########################################################################################
collugares <- rep("green",dimespec[1])
colespecies <- rep("blue",dimespec[2])
colvariables <- rep("red",dimvambien[2])
collugaresp <- rep("grey",dimespec[1])
colespeciesp <- rep("grey",dimespec[2])
colvariablesp <- rep("grey",dimvambien[2])
###########################################################################################
##We create the vectors of the symbols
###########################################################################################
simlugares <- rep("*",dimespec[1])
simespecies <- rep("+",dimespec[2])
simvariables <- rep(" ",dimvambien[2])
###########################################################################################
##We create the vectors of the character size
###########################################################################################
cexlugares <- rep(1,dimespec[1])
cexespecies <- rep(1,dimespec[2])
cexvariables <- rep(1,dimvambien[2])
##### List of species###########################
scre <- tkscrollbar(framet1, repeatinterval=5, command=function(...)tkyview(tle,...))
tle<-tklistbox(framet1,height=6,width=42,selectmode="multiple",yscrollcommand=function(...)tkset(scre,...),background="white")
tkpack(tklabel(frametext1,text=Namespe),side="left",expand = "TRUE",fill="both")
for (i in 1:(dimespec[2]))
{
tkinsert(tle,"end",textespecies[i])
}#end for (i in 1:(dimespec[2]))
tkselection.set(tle,0) # Indexing starts at zero.
OnOKe <- function()
{
Choicee <<- textespecies[as.numeric(tkcurselection(tle))+1]
##### Color of the selected variable #############
indicee<<-as.numeric(tkcurselection(tle))+1
colore <<- colespecies[indicee[1]]
tkconfigure(canvase,bg=colore)
##### Text of the selected variable###############
Namee <<- tclVar(textespecies[indicee[1]])
tkconfigure(entry.Namee,textvariable=Namee)
##### Size of the selected variable###############
Cexe <<- tclVar(cexespecies[indicee[1]])
tkconfigure(entry.Cexe,textvariable=Cexe)
}#end OnOKe <- function()
OK.bute <-tkbutton(frameok1,text=" OK ",command=OnOKe)
tkpack(tle,scre,expand = "TRUE", side="left", fill = "both")
tkpack.configure(scre,side="left")
tkpack(OK.bute,expand = "TRUE", side="left", fill = "both")
tkfocus(tt)
#######Color#######################################
indicee <- as.numeric(tkcurselection(tle))+1
colore <<- colespecies[indicee[1]]
canvase <- tkcanvas(framecol11,width="57",height="20",bg=colore)
ChangeColore <- function()
{
colore <<- tclvalue(tcl("tk_chooseColor",initialcolor=colespecies[indicee[1]],title="Choose a color"))
if (nchar(colore)>0)
{
tkconfigure(canvase,bg=colore)
colespecies[indicee]<<-colore
}#end if (nchar(colore)>0)
}#end ChangeColore <- function()
ChangeColor.buttone<- tkbutton(framecol12,text="Change Color",command=ChangeColore,width=4)
tkpack(canvase,expand = "TRUE", side="left", fill = "both")
tkpack(ChangeColor.buttone,expand = "TRUE", side="left", fill = "both")
######Labels ###################################
Namee <- textespecies[indicee[1]]
entry.Namee <-tkentry(framename11,width="10",textvariable=Namee, bg="white")
OnOKle <- function()
{
NameVale <<- tclvalue(Namee)
textespecies[indicee[1]] <-NameVale
#####Values of listbox###############################
for (i in 1:(dimespec[2]))
{
tkdelete(tle,0)
}#end for (i in 1:(dimespec[2]))
for (i in (1:(dimespec[2])))
{
tkinsert(tle,"end",textespecies[i])
}#end for (i in (1:(dimespec[2])))
}#end OnOKle <- function()
OK.butle <-tkbutton(framename12,text="Change label",command=OnOKle,width=4)
tkbind(entry.Namee, "<Return>",OnOKle)
tkpack(entry.Namee,expand = "TRUE", side="left", fill = "both")
tkpack(OK.butle,expand = "TRUE", side="left", fill = "both")
###### Sizes ###################################
Cexe <- cexespecies[indicee[1]]
entry.Cexe <-tkentry(framecex11,width="10",textvariable=Cexe, bg="white")
OnOKce <- function()
{
NameCexe <<- tclvalue(Cexe)
cexespecies[indicee] <<-NameCexe
}#end OnOKce <- function()
OK.butce <-tkbutton(framecex12,text="Change size",command=OnOKce,width=4)
tkbind(entry.Cexe, "<Return>",OnOKce)
tkpack(entry.Cexe,expand = "TRUE", side="left", fill = "both")
tkpack(OK.butce,expand = "TRUE", side="left", fill = "both")
######Symbols###################################
comboBoxe <- tkwidget(frames11,"ComboBox",editable=FALSE,values=symbolos,width=7, background="white")
chang.syme <- function()
{
simChoicee <<- symbolos[as.numeric(tclvalue(tcl(comboBoxe,"getvalue")))+1]
simespecies[indicee] <<-simChoicee
}#end chang.syme <- function()
Change.symbole <-tkbutton(frames12,text="Change symbol",command=chang.syme,width=4)
tkpack(comboBoxe,side="left",expand="TRUE", fill="both")
tkpack(Change.symbole,side="left",expand="TRUE", fill="both")
##### List of environmental v. ###########################
scrv <- tkscrollbar(framet2, repeatinterval=5, command=function(...)tkyview(tlv,...))
tlv<-tklistbox(framet2,height=6,width=42,selectmode="multiple",yscrollcommand=function(...)tkset(scrv,...),background="white")
tkpack(tklabel(frametext2,text=Namevar),side="left",expand = "TRUE",fill="both")
for (i in (1:(dimvambien[2])))
{
tkinsert(tlv,"end",textvariables[i])
}#end for (i in (1:(dimvambien[2])))
tkselection.set(tlv,0) # Indexing starts at zero.
OnOKv <- function()
{
Choicev <<- textvariables[as.numeric(tkcurselection(tlv))+1]
##### Color of the selected variable #############
indicev<<-as.numeric(tkcurselection(tlv))+1
colorv <<- colvariables[indicev[1]]
tkconfigure(canvasv,bg=colorv)
##### Text of the selected variable ###############
Namev <<- tclVar(textvariables[indicev[1]])
tkconfigure(entry.Namev,textvariable=Namev)
##### Size of the selected variable ###############
Cexv <<- tclVar(cexvariables[indicev[1]])
tkconfigure(entry.Cexv,textvariable=Cexv)
}#end OnOKv <- function()
OK.butv <-tkbutton(frameok2,text=" OK ",command=OnOKv)
tkpack(OK.butv,expand = "TRUE", side="left", fill = "both")
Graphics <- function()
{
tkdestroy(tt)
hescale <<- tclvalue(entryvalueh)
vescale <<- tclvalue(entryvaluev)
barvp<-tktoplevel()
tkwm.title(barvp,"Eigenvalues")
plotbar<-function()
{
iner <<- calc_inerciatot(fespecies, fvambientales, tChoice, cccaVal,Numbercuant)
inerciatot <<- iner[[2]]
barplot(iner[[1]]$d, col="blue", xlab="", ylab="", names.arg=round(inerciatot, digits=2))
}#end plotbar<-function()
imgbar <- tkrplot(barvp,fun=plotbar,hscale=as.numeric(hescale),vscale=as.numeric(vescale))
msginertia <- "Proportion of inertia explained by each axis:"
for (i in 1:length(iner[[1]]$d))
{
msginertia <- paste(msginertia, "\n",i, "\t", round(inerciatot[i]*100, digits=2), "%")
}#end for (i in 1:length(iner[[1]]$d))
tk2tip(imgbar, msginertia)
Onaxis <- function()
{
nejes <- tclvalue(numaxis)
nejes <- as.numeric(nejes)
if (nejes > length(iner[[1]]$d))
{
msg <- paste("The maximum number of dimensions is ",length(iner[[1]]$d))
tkmessageBox(message=msg)
}else{
tkdestroy(barvp)
nejes <- as.integer(nejes)
if (cccaVal=="CNCA")
{
cnca_res <- ex.cnca(fespecies, fvambientales, nejes, Numbercuant, Numbermixto, tChoice)
colugares <<- cnca_res$colugares
coespecies <<- cnca_res$coespecies
covambien <<- cnca_res$covambien
colugaresnam <<-cnca_res$colugaresnam
covariablesnam <<- cnca_res$covariablesnam
coindividuosnam <<-cnca_res$coindividuosnam
ejes <<- cnca_res$ejes
Calphai <<- cnca_res$Calphai
Calphak <<- cnca_res$Calphak
calidadps <<- cnca_res$calidadps
calidados <<- cnca_res$calidados
qalphaips <<- cnca_res$qalphaips
qalphakos <<- cnca_res$qalphakos
qalphakps <<- cnca_res$qalphakps
dalphaios <<- cnca_res$dalphaios
inertia <<-cnca_res$inertia
descom <<- cnca_res$descom
inerciatot <<- cnca_res$inerciatot
}else{
if(cccaVal=="CCA")
{
cca_res <- ex.cca(fespecies, fvambientales, nejes, Numbercuant, Numbermixto, tChoice)
colugares <<- cca_res$colugares
coespecies <<- cca_res$coespecies
covambien <<- cca_res$covambien
colugaresnam <<-cca_res$colugaresnam
covariablesnam <<- cca_res$covariablesnam
coindividuosnam <<-cca_res$coindividuosnam
ejes <<- cca_res$ejes
Calphai <<- cca_res$Calphai
Calphak <<- cca_res$Calphak
calidadps <<- cca_res$calidadps
calidados <<- cca_res$calidados
qalphaips <<- cca_res$qalphaips
qalphakos <<- cca_res$qalphakos
qalphakps <<- cca_res$qalphakps
dalphaios <<- cca_res$dalphaios
inertia <<-cca_res$inertia
descom <<- cca_res$descom
inerciatot <<- cca_res$inerciatot
}else{
coia_res <- ex.coia(fespecies, fvambientales, nejes, tChoice,Numbercuant)
colugaresz <<- coia_res$colugaresz
colugaresy <<- coia_res$colugaresy
coespecies <<- coia_res$coespecies
covambien <<- coia_res$covambien
colugaresnamz <<-coia_res$colugaresnamz
colugaresnamy <<-coia_res$colugaresnamy
covariablesnam <<- coia_res$covariablesnam
coindividuosnam <<-coia_res$coindividuosnam
ejes <<- coia_res$ejes
inerciatot <<- coia_res$inerciatot
Xaxes <<- coia_res$Xaxes
Yaxes <<- coia_res$Yaxes
}
}
cat("File saved in: ",file="Results.txt")
cat(getwd(),file="temp.txt")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
if(cccaVal!="COIA")
{
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("Proportion of inertia explained by each axis (projected space):\n",file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(calidadps, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("Proportion of inertia explained by each axis (original space):\n",file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(calidados, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("CONTRIBUTIONS:\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste("Contributions of", Namesit,"to each factor:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(Calphai, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste("Contributions of", Namespe,"to each factor:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(Calphak, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("Relative contributions of factors to elements:\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namesit,"respect to projected space:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(qalphaips, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namesit,"respect to original space:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(dalphaios, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namespe,"respect to projected space:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(qalphakps, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namespe,"respect to original space:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(qalphakos, digits=3),file="temp.txt", sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namespe,"coordinates:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(coindividuosnam, digits=3),file="temp.txt",sep="\t",dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namevar,"coordinates:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(covariablesnam, digits=3), file="temp.txt", sep="\t", dec=",")
file.append("Results.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat(paste(Namesit,"coordinates:\n"),file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(colugaresnam, digits=3), file="temp.txt", sep="\t", dec=",")
file.append("Results.txt","temp.txt")
}
cat("\n",file="temp.txt")
file.append("Results.txt","temp.txt")
cat("Eigen values: \n",file="temp.txt")
file.append("Results.txt","temp.txt")
write.table(round(iner[[1]]$d, digits=3), file="temp.txt", sep="\t", dec=",")
file.append("Results.txt","temp.txt")
file.show("Results.txt")
file.remove("temp.txt")
###########################################################################################
##Rescale
###########################################################################################
if(cccaVal!="COIA")
{
sumalugares <- sum(colugares^2)
sumaespecies <- sum(coespecies^2)
sumavariables <- sum(covambien^2)
#slg <- sumalugares/(dim(colugares)[1])
sesp <- sumaespecies/(dim(coespecies)[1])
svar <- sumavariables/(dim(covambien)[1])
scfev <- ((svar/sesp)^(1/2))^(1/2)
#scflv <- ((slg/sesp)^(1/2))^(1/2)
coespecies <- coespecies*scfev
covambien <- covambien/scfev
#colugares <- (colugares/scflv)*scfev
datos <- rbind(coespecies,covambien,colugares)
limix <- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
textos <- datos
datosr <- rbind(coespecies,covambien)
textosr <- datosr
simbolos <<- c(simespecies, simvariables, simlugares)
}else{
if(typecoia=="sg")
{
datos <<-rbind(colugaresy, colugaresz)
textos <<-colugaresy
for (d in 1:ejes)
{
dimension <- cbind(colugaresy[,d], colugaresz[,d])
textos[,d]<<-rowMeans(dimension)
}
}
if(typecoia=="eg")
{
datos<<-coespecies
textos<<-datos
}
if(typecoia=="vg")
{
datos<<-covambien
textos<<-datos
}
limix <- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
}
centro <- c(0,0)
################ Show axes or not
cbVal <<- as.character(tclvalue(cbValue))
if(cccaVal!="COIA")
{
cblugares <<- as.character(tclvalue(cblug))
cblablugares <<- as.character(tclvalue(cblablug))
}
wgr <- tktoplevel()
tkwm.title(wgr,"Graph")
parPlotSize <- c()
usrCoords <- c()
normalLine <- function(variableele, colorele, coordenadas, colorcoor)
{
A <- variableele
B <- centro
slopeAB <- (B[[2]] - A[[2]])/(B[[1]] - A[[1]])
slopeNorm <- -1/slopeAB
a <- A[[2]] - slopeAB * A[[1]]
b<-c()
xintersect<-c()
yintersect<-c()
for(i in 1:dim(coordenadas)[1])
{
b[i] <- coordenadas[i,2] - slopeNorm * coordenadas[i,1]
xintersect[i] <- (b[i] - a)/(slopeAB - slopeNorm)
yintersect[i] <- b[i] + slopeNorm * xintersect[i]
}#end for (i in 1:dim(coordenadas)[1])
abline(a =a,b=slopeAB, col=colorele, lwd=3)
for(i in 1:dim(coordenadas)[1])
segments(xintersect[i], yintersect[i], coordenadas[i,1], coordenadas[i,2],lty=2, col=colorcoor[i])
} #end normalLine
plotFunction <- function(screen=TRUE)
{
tclvalue(Limix1) <- limix[1]
tclvalue(Limix2) <- limix[2]
tclvalue(Limiy1) <- limiy[1]
tclvalue(Limiy2) <- limiy[2]
if(cccaVal!="COIA")
{
################ Show sites or not
if ((cblugares=="1")|(cblablugares=="1")){
xCoords <<- textos[,dim1]
yCoords <<- textos[,dim2]
if(nejes>2)
zCoords <<- textos[,dim3]
if (cblablugares=="1"){
labelsVec <<- c(textespecies, textvariables,textlugares)
sizesVec <<- c(cexespecies, cexvariables,cexlugares)
}else{
labelsVec <<- c(textespecies, textvariables)
sizesVec <<- c(cexespecies, cexvariables)
}#end if (cblablugares=="1")
colores <<- c(colespecies,colvariables,collugares)
}else{
xCoords <<- textosr[,dim1]
yCoords <<- textosr[,dim2]
if(nejes>2)
zCoords <<- textosr[,dim3]
labelsVec <<- c(textespecies, textvariables)
sizesVec <<- c(cexespecies, cexvariables)
colores <<- c(colespecies,colvariables)
}#end if (cblugares=="1")
if (is.null(indexLabeled))
indexLabeled <<- c(1:length(xCoords))
indexLabeledaux <- c()
labeledPoints <- list()
params <- par(bg="white")
if ((cblugares=="1")|(cblablugares=="1")){
xCoords<<-textos[,dim1]
yCoords<<-textos[,dim2]
plot(datos[,c(dim1,dim2)], main= tit_graph, type="n",xlab=paste(round(inerciatot[dim1]*100, digits=2),"%"),ylab=paste(round(inerciatot[dim2]*100,digits=2),"%"), asp=1/1, xlim = limix * 1.05, ylim = limiy * 1.05)
}else{
xCoords<<-textosr[,dim1]
yCoords<<-textosr[,dim2]
plot(datosr[,c(dim1,dim2)],main= tit_graph, type="n",xlab=paste(round(inerciatot[dim1]*100, digits=2),"%"),ylab=paste(round(inerciatot[dim2]*100,digits=2),"%"), asp=1/1, xlim = limix * 1.05, ylim = limiy * 1.05)
}#end if (cblugares=="1")
if (proj=="normal")
{
points(coespecies[,dim1],coespecies[,dim2],pch=simespecies, col=colespecies)
arrows(centro[1],centro[2],covambien[1:Numbercuant,dim1],covambien[1:Numbercuant,dim2],col=colvariables[1:Numbercuant],lty=1, length=0.08)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
if ((cblugares=="1")|(cblablugares=="1")){
points(colugares[,dim1],colugares[,dim2],pch=simlugares, col=collugares)
}#end if (cblugares=="1")
if (length(indexLabeled)>0)
{
for (i in 1:length(indexLabeled))
{
indexClosest <- indexLabeled[i]
text(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= colores[indexClosest], cex= as.numeric(sizesVec[indexClosest]))
}#end for
if(Numbermixto>0)
{
rangosup<-length(textespecies)+Numbercuant+1
rangoinf<-length(textespecies)+length(textvariables)
for(i in rangoinf:rangosup)
{
boxed.labels(xCoords[i],yCoords[i],labels=labelsVec[i], col= colores[i], cex= as.numeric(sizesVec)[i],border = colores[i])
}#end for
}#end if
}#end if
}else{
colvariablesp[Choiceproj] <-colvariables[Choiceproj]
if(proj=="e")
{
indexLabeledp<-c(1:(length(textespecies)+length(textvariables)))
coloresp<-c(colespecies, colvariablesp)
points(coespecies[,dim1],coespecies[,dim2],pch=simespecies, col=colespecies)
points(covambien[1:Numbercuant,dim1],covambien[1:Numbercuant,dim2],col=colvariablesp[1:Numbercuant])
if(cbVal=="1")
{
abline(h=centro[2],v=centro[1],lty="dotted")
}
if (length(indexLabeledp)>0)
{
for (i in 1:length(indexLabeledp))
{
indexClosest <- indexLabeledp[i]
text(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= coloresp[indexClosest], cex= as.numeric(sizesVec)[indexClosest])
}#end for
if(Numbermixto>0)
{
rangosup<-length(textespecies)+Numbercuant+1
rangoinf<-length(textespecies)+length(textvariables)
for(i in rangoinf:rangosup)
{
boxed.labels(xCoords[i],yCoords[i],labels=labelsVec[i], col= coloresp[i], cex= as.numeric(sizesVec)[i],border = coloresp[i])
}#end for
}#end if
}#end if
normalLine(covambien[Choiceproj,c(dim1,dim2)], colvariables[Choiceproj], coespecies[,c(dim1,dim2)], colespecies)
}else{
if(cblugares=="1" | cblablugares=="1")
{
indexLabeledp<-c((1+length(textespecies)):(length(textespecies)+length(textvariables)+length(textlugares)))
coloresp<-c(colespecies, colvariablesp, collugares)
points(colugares[,dim1],colugares[,dim2],pch=simlugares, col=collugares)
points(covambien[1:Numbercuant,dim1],covambien[1:Numbercuant,dim2],col=colvariablesp[1:Numbercuant])
if(cbVal=="1")
{
abline(h=centro[2],v=centro[1],lty="dotted")
}
if (length(indexLabeledp)>0)
{
for (i in (1:length(indexLabeledp)))
{
indexClosest <- indexLabeledp[i]
text(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= coloresp[indexClosest], cex= as.numeric(sizesVec)[indexClosest])
}#end for
if(Numbermixto>0)
{
rangosup<-length(textespecies)+Numbercuant+1
rangoinf<-length(textespecies)+length(textvariables)
for(i in rangoinf:rangosup)
{
boxed.labels(xCoords[i],yCoords[i],labels=labelsVec[i], col= coloresp[i], cex= as.numeric(sizesVec)[i],border = coloresp[i])
}#end for
}#end if
}#end if
normalLine(covambien[Choiceproj,c(dim1,dim2)], colvariables[Choiceproj], colugares[,c(dim1,dim2)], collugares)
}else{
proj<<-"normal"
points(coespecies[,dim1],coespecies[,dim2],pch=simespecies, col=colespecies)
arrows(centro[1],centro[2],covambien[1:Numbercuant,dim1],covambien[1:Numbercuant,dim2],col=colvariables[1:Numbercuant],lty=1, length=0.08)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
if ((cblugares=="1")|(cblablugares=="1")){
points(colugares[,dim1],colugares[,dim2],pch=simlugares, col=collugares)
}#end if (cblugares=="1")
if (length(indexLabeled)>0)
{
for (i in 1:length(indexLabeled))
{
indexClosest <- indexLabeled[i]
text(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= colores[indexClosest], cex= as.numeric(sizesVec[indexClosest]))
}#end for
if(Numbermixto>0)
{
rangosup<-length(textespecies)
rangoinf<-Numbercuant+1
for(i in rangoinf:rangosup)
{
boxed.labels(xCoords[i],yCoords[i],labels=labelsVec[i], col= colores[i], cex= as.numeric(sizesVec)[i],border = colores[i])
}#end for
}#end if
}#end if
}#end if
}#end if (proj=="e")
}#end if (proj=="normal")
}else{
xCoords <<- textos[,dim1]
yCoords <<- textos[,dim2]
if(nejes>2)
zCoords <<- textos[,dim3]
if (is.null(indexLabeled))
indexLabeled <<- c(1:length(xCoords))
indexLabeledaux <- c()
labeledPoints <- list()
params <- par(bg="white")
plot(datos[,c(dim1,dim2)], main= tit_graph, type="n",xlab=paste(round(inerciatot[dim1]*100, digits=2),"%"),ylab=paste(round(inerciatot[dim2]*100,digits=2),"%"), asp=1/1, xlim = limix * 1.05, ylim = limiy * 1.05)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
if((typecoia=="eg"))
{
labelsVec <<- textespecies
sizesVec <<- cexespecies
colores <<- colespecies
arrows(centro[1],centro[2],datos[,dim1],datos[,dim2],col=colores,lty=1, length=0.08)
}
if((typecoia=="vg"))
{
labelsVec <<- textvariables
sizesVec <<- cexvariables
colores <<- colvariables
arrows(centro[1],centro[2],datos[,dim1],datos[,dim2],col=colores,lty=1, length=0.08)
}
if(typecoia=="sg")
{
labelsVec <<- textlugares
sizesVec <<- cexlugares
colores <<- collugares
colugyaux <<- datos[1:length(textlugares),]
colugzaux <<- datos[-(1:length(textlugares)),]
arrows(colugzaux[,dim1],colugzaux[,dim2],colugyaux[,dim1],colugyaux[,dim2],col=colores,lty=1, length=0.08)
}
if(typecoia=="ef")
{
labelsVec <<- paste("Axis", 1:nejes)
cexejes<<-rep(1,length(ejes))
sizesVec <<- cexejes
xCoords<<-datos[,dim1]
yCoords<<-datos[,dim2]
colores <<- rep("black", times=nejes)
plot(0,0, type="n", xlim=c(-1,1), ylim=c(-1,1), asp=1/1, main=paste(Namespe, " axes"), xlab="", ylab="")
draw.circle(0,0,1, border="black", lty=1,lwd=1)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
arrows(centro[1],centro[2],datos[,dim1],datos[,dim2],lty=1, length=0.08)
}
if(typecoia=="vf")
{
labelsVec <<- paste("Axis", 1:nejes)
cexejes<<-rep(1,length(ejes))
sizesVec <<- cexejes
xCoords<<-datos[,dim1]
yCoords<<-datos[,dim2]
colores <<- rep("black", times=nejes)
plot(0,0, type="n", xlim=c(-1,1), ylim=c(-1,1), asp=1/1, main=paste(Namespe, " axes"), xlab="", ylab="")
draw.circle(0,0,1, border="black", lty=1,lwd=1)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
arrows(centro[1],centro[2],datos[,dim1],datos[,dim2],lty=1, length=0.08)
}
if (length(indexLabeled)>0)
{
for (i in 1:length(indexLabeled))
{
indexClosest <- indexLabeled[i]
if(typecoia=="sg")
{
boxed.labels(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= colores[indexClosest], cex= as.numeric(sizesVec[indexClosest]),border = colores[indexClosest])
}else{
if(typecoia%in% c("ef", "vf"))
{
text(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= colores[indexClosest], cex= as.numeric(sizesVec[indexClosest]), pos=1)
}else{
text(xCoords[indexClosest],yCoords[indexClosest],labels=labelsVec[indexClosest], col= colores[indexClosest], cex= as.numeric(sizesVec[indexClosest]))
}
}
}#end for
}#end if
}
parPlotSize <<- par("plt")
usrCoords <<- par("usr")
par(params)
}#end plotFunction <- function(screen=TRUE)
img <- tkrplot(wgr,fun=plotFunction,hscale=as.numeric(hescale),vscale=as.numeric(vescale))
framedim1<-tkframe(wgr, relief = "ridge", borderwidth = 2, background = "whitesmoke", height=40)
framecomb<-tkframe(framedim1, relief = "ridge", borderwidth = 2, background = "whitesmoke", height=40)
framescal<-tkframe(framedim1, relief = "ridge", borderwidth = 2, background = "whitesmoke", height=40)
framescala<-tkframe(framescal, relief = "ridge", borderwidth = 2, background = "whitesmoke", height=40)
framescalb<-tkframe(framescal, relief = "ridge", borderwidth = 2, background = "whitesmoke", height=40)
framerefr<-tkframe(framedim1, relief = "ridge", borderwidth = 2, background = "whitesmoke", height=40)
comboBoxdim1 <- tkwidget(framecomb,"ComboBox",editable=FALSE,values=rep(1:nejes),width=15, text= dim1, background="white")
comboBoxdim2 <- tkwidget(framecomb,"ComboBox",editable=FALSE,values=rep(1:nejes),width=15, text= dim2, background="white")
if (nejes>2)
comboBoxdim3 <- tkwidget(framecomb,"ComboBox",editable=FALSE,values=rep(1:nejes),width=15, text= dim3, background="white")
chang.symdim1 <- function()
{
dim1 <<-as.numeric(tclvalue(tcl(comboBoxdim1,"getvalue")))+1
dim2 <<-as.numeric(tclvalue(tcl(comboBoxdim2,"getvalue")))+1
if (nejes>2)
dim3 <<-as.numeric(tclvalue(tcl(comboBoxdim3,"getvalue")))+1
if((dim1==dim1ant)&(dim2==dim2ant))
{
limix[1] <<- as.numeric(tclvalue(Limix1))
limix[2] <<- as.numeric(tclvalue(Limix2))
limiy[1] <<- as.numeric(tclvalue(Limiy1))
limiy[2] <<- as.numeric(tclvalue(Limiy2))
}else{
dim1ant<<-dim1
dim2ant<<-dim2
if (((cblugares=="1")|(cblablugares=="1"))|cccaVal=="COIA")
{
limix <<- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <<- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
}else{
limix <<- round(c(min(datosr[,dim1],0), max(datosr[,dim1],0)), digits=2)
limiy <<- round(c(min(datosr[,dim2],0), max(datosr[,dim2],0)), digits=2)
}
}
tkrreplot(img)
}#end chang.symdim1 <- function()
Change.symboldim1 <-tkbutton(framerefr,text="Refresh",command=chang.symdim1, bg= "lightblue", width=15, foreground = "navyblue")
if(nejes>2){
tkpack(tklabel(framecomb, text="Select X, Y and Z axes numbers:"), expand="FALSE", side= "top", fill ="both")
tkpack(comboBoxdim1, comboBoxdim2, comboBoxdim3, side="top", fill="x")
}
Limix1 <- tclVar(limix[1])
entry.limix1 <<-tkentry(framescalb,width=10,textvariable=Limix1, bg="white")
tkconfigure(entry.limix1,textvariable=Limix1)
tkbind(entry.limix1, "<Return>",chang.symdim1)
Limix2 <- tclVar(limix[2])
entry.limix2 <<-tkentry(framescalb,width=10,textvariable=Limix2, bg="white")
tkconfigure(entry.limix2,textvariable=Limix2)
tkbind(entry.limix2, "<Return>",chang.symdim1)
Limiy1 <- tclVar(limiy[1])
entry.limiy1 <<-tkentry(framescalb,width=10,textvariable=Limiy1, bg="white")
tkconfigure(entry.limiy1,textvariable=Limiy1)
tkbind(entry.limiy1, "<Return>",chang.symdim1)
Limiy2 <- tclVar(limiy[2])
entry.limiy2 <<-tkentry(framescalb,width=10,textvariable=Limiy2, bg="white")
tkconfigure(entry.limiy2,textvariable=Limiy2)
tkbind(entry.limiy2, "<Return>",chang.symdim1)
tkpack(tklabel(framescala, text="-X"),
tklabel(framescala, text="+X"),
tklabel(framescala, text="-Y"),
tklabel(framescala, text="+Y"),
expand = "TRUE",side="top", fill="both")
tkpack(entry.limix1,entry.limix2,entry.limiy1,entry.limiy2,side="top", expand="TRUE", fill="both")
tkpack(tklabel(framescal, text="Zoom:"), expand = "TRUE",side="top", fill="both")
tkpack(framescala, framescalb, side="left", expand ="TRUE", fill="both")
tkpack(Change.symboldim1, side="top", expand="TRUE", fill="both")
tkpack(framecomb, framescal, framerefr, side="top", expand="TRUE", fill="both")
tkpack(framedim1, side="left", expand="FALSE", fill="x")
tkpack(img, side="top", expand="TRUE", fill="both")
labelClosestPointd <- function(xClick,yClick,imgXcoords,imgYcoords)
{
squared.Distance <- (xClick-imgXcoords)^2 + (yClick-imgYcoords)^2
indexClosest <<- which.min(squared.Distance)
mm<-tktoplevel()
tkwm.title(mm, labelsVec[indexClosest])
framemm1<-tkframe(mm, relief = "groove", borderwidth = 2, background = "white")
if(indexClosest<=length(labelsVec))
{
framemm2<-tkframe(mm, relief = "groove", borderwidth = 2, background = "white")
framemm3<-tkframe(mm, relief = "groove", borderwidth = 2, background = "white")
}
framemm4<-tkframe(mm, relief = "groove", borderwidth = 2, background = "white")
colori <- colores[indexClosest]
canvasi <- tkcanvas(framemm1,width="70",height="20",bg=colori)
ChangeColori <- function()
{
colori <<- tclvalue(tcl("tk_chooseColor",initialcolor=colores[indexClosest],title="Choose a color"))
if (nchar(colori)>0)
{
tkconfigure(canvasi,bg=colori)
colores[indexClosest]<<-colori
if(cccaVal!="COIA")
{
if (cblugares=="1"){
colespecies<<-colores[1:length(colespecies)]
colvariables<<-colores[(length(colespecies)+1):(length(colespecies)+length(colvariables))]
collugares<<-colores[(length(colespecies)+length(colvariables)+1):(length(colespecies)+length(colvariables)+length(collugares))]
}else{
colespecies<<-colores[1:length(colespecies)]
colvariables<<-colores[(length(colespecies)+1):(length(colespecies)+length(colvariables))]
}#end if (cblugares=="1")
}else{
if(typecoia=="sg")
{
collugares<<-colores
}else{
if((typecoia=="eg")|(typecoia=="ef"))
{
colespecies<<-colores
}else{
if((typecoia=="vg")|(typecoia=="vf"))
{
colvariables<<-colores
}
}
}
}
}#end if (nchar(colori)>0)
tkrreplot(img)
tkdestroy(mm)
}#end ChangeColori <- function()
ChangeColor.buttoni<- tkbutton(framemm1,text="Change Color",command=ChangeColori,width=12)
tkpack(canvasi,ChangeColor.buttoni,expand = "TRUE", side="left", fill = "both")
if(indexClosest<=length(labelsVec))
{
Namei <<- labelsVec[indexClosest]
tclvalue(Namei) <<- labelsVec[indexClosest]
entry.Namei <<-tkentry(framemm2,width="11",textvariable=Namei, bg="white")
NameVali <<- Namei
OnOKli <- function()
{
NameVali <<- tclvalue(Namei)
labelsVec[indexClosest]<<-NameVali
if(cccaVal!="COIA")
{
if (cblablugares=="1"){
textespecies <<-labelsVec[1:length(textespecies)]
textvariables <<-labelsVec[(length(textespecies)+1):(length(textespecies)+length(textvariables))]
textlugares <<-labelsVec[(length(textespecies)+length(textvariables)+1):(length(textespecies)+length(textvariables)+length(collugares))]
}else{
textespecies <<-labelsVec[1:length(textespecies)]
textvariables <<-labelsVec[(length(textespecies)+1):(length(textespecies)+length(textvariables))]
}#end if (cblugares=="1")
}else{
if(typecoia=="sg")
{
textlugares<<-labelsVec
}else{
if((typecoia=="eg")|(typecoia=="ef"))
{
textespecies<<-labelsVec
}else{
if((typecoia=="vg")|(typecoia=="vf"))
{
textvariables<<-labelsVec
}
}
}
}
tkrreplot(img)
tkdestroy(mm)
}#end OnOKli <- function()
OK.butli <-tkbutton(framemm2,text="Change label",command=OnOKli,width=12)
tkbind(entry.Namei, "<Return>",OnOKli)
tkpack(entry.Namei,OK.butli,expand = "TRUE", side="left", fill = "both")
Cexi <<- sizesVec[indexClosest]
tclvalue(Cexi) <<- sizesVec[indexClosest]
entry.Cexi <<-tkentry(framemm3,width="11",textvariable=Cexi, bg="white")
NameCexi <<- Cexi
OnOKci <- function()
{
NameCexi <<- tclvalue(Cexi)
sizesVec[indexClosest]<<-NameCexi
if(cccaVal!="COIA")
{
if (cblablugares=="1"){
cexespecies <<-sizesVec[1:length(cexespecies)]
cexvariables <<-sizesVec[(length(cexespecies)+1):(length(cexespecies)+length(cexvariables))]
cexlugares <<-sizesVec[(length(cexespecies)+length(cexvariables)+1):(length(cexespecies)+length(cexvariables)+length(cexlugares))]
}else{
cexespecies <<-sizesVec[1:length(cexespecies)]
cexvariables <<-sizesVec[(length(cexespecies)+1):(length(cexespecies)+length(cexvariables))]
}#end if (cblugares=="1")
}else{
if(typecoia=="sg")
{
cexlugares<<-sizesVec
}else{
if((typecoia=="eg")|(typecoia=="ef"))
{
cexespecies<<-sizesVec
}else{
if((typecoia=="vg")|(typecoia=="vf"))
{
cexvariables<<-sizesVec
}
}
}
}
tkrreplot(img)
tkdestroy(mm)
}#end OnOKci <- function()
OK.butci <-tkbutton(framemm3,text="Change size",command=OnOKci,width=12)
tkbind(entry.Cexi, "<Return>",OnOKci)
tkpack(entry.Cexi,OK.butci,expand = "TRUE", side="left", fill = "both")
}
if(cccaVal!="COIA")
comboBox <- tkwidget(framemm4,"ComboBox",editable=FALSE,values=symbolos,width=8, text= simbolos[indexClosest], background="white")
chang.sym <- function()
{
if(cccaVal!="COIA")
{
simChoice <<-symbolos[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
simbolos[indexClosest]<<-simChoice
if (cblugares=="1"){
simespecies <<-simbolos[1:length(simespecies)]
simvariables <<-simbolos[(length(simespecies)+1):(length(simespecies)+length(simvariables))]
simlugares <<-simbolos[(length(simespecies)+length(simvariables)+1):(length(simespecies)+length(simvariables)+length(collugares))]
}else{
simespecies <<-simbolos[1:length(simespecies)]
simvariables <<-simbolos[(length(simespecies)+1):(length(simespecies)+length(simvariables))]
}#end if (cblugares=="1")
}
tkrreplot(img)
tkdestroy(mm)
}#end chang.sym <- function()
if(cccaVal!="COIA")
{
if(indexClosest %in% c(length(simespecies)+1):(length(simespecies)+length(simvariables)))
{}else{
Change.symbol <-tkbutton(framemm4,text="Change symbol",command=chang.sym,width=12)
tkpack(comboBox,Change.symbol,side="left",expand="TRUE", fill="both")
}
}
if(proj=="normal")
{
if(indexClosest<= length(labelsVec))
{
tkpack(framemm1,framemm2,framemm3,framemm4, expand = "TRUE", side="top", fill = "both")
}else{
tkpack(framemm1,framemm4, expand = "TRUE", side="top", fill = "both")
}
}else{
tkpack(framemm1,framemm2, expand = "TRUE", side="top", fill = "both")
}
if(cccaVal=="COIA")
{
tkpack(framemm1,framemm2,framemm3, expand = "TRUE", side="top", fill = "both")
}
}#end labelClosestPointd <- function(xClick,yClick,imgXcoords,imgYcoords)
#############################################################################
### Functions to save the graph
#############################################################################
SaveFileJPG <- function() {
FileName <- tclvalue(tkgetSaveFile(filetypes = "{{Jpeg files} {.jpg .jpeg}} {{All files} *}"))
if (nchar(FileName)) {
nn <- nchar(FileName)
if (nn < 5 || substr(FileName, nn - 3, nn) != ".jpg")
FileName <- paste(FileName, ".jpg", sep = "")
jpeg(FileName, width = 8, height = 8, units = "in", res = 96, quality = 100)
plotFunction(screen = FALSE)
dev.off()
}#end if (nchar(FileName))
}#end SaveFileJPG <- function()
SaveFilePDF <- function() {
FileName <- tclvalue(tkgetSaveFile(filetypes = "{{PDF files} {.pdf}} {{All files} *}"))
if (nchar(FileName)) {
nn <- nchar(FileName)
if (nn < 5 || substr(FileName, nn - 3, nn) != ".pdf")
FileName <- paste(FileName, ".pdf", sep = "")
pdf(FileName, width = 7, height = 7, useDingbats=FALSE)
plotFunction(screen = FALSE)
dev.off()
}#end if (nchar(FileName))
}#end SaveFilePDF <- function()
SaveFileeps <- function() {
FileName <- tclvalue(tkgetSaveFile(filetypes = "{{Eps files} {.eps}} {{All files} *}"))
if (nchar(FileName)) {
nn <- nchar(FileName)
if (nn < 5 || substr(FileName, nn - 3, nn) != ".eps")
FileName <- paste(FileName, ".eps", sep = "")
postscript(FileName, width = 8, height = 8)
plotFunction(screen = FALSE)
dev.off()
}#end if (nchar(FileName))
}#end SaveFilePng <- function()
SaveFilePng <- function() {
FileName <- tclvalue(tkgetSaveFile(filetypes = "{{Png files} {.png}} {{All files} *}"))
if (nchar(FileName)) {
nn <- nchar(FileName)
if (nn < 5 || substr(FileName, nn - 3, nn) != ".png")
FileName <- paste(FileName, ".png", sep = "")
png(FileName, width = 8, height = 8, units = "in", res = 96)
plotFunction(screen = FALSE)
dev.off()
}#end if (nchar(FileName))
}#end SaveFilePng <- function()
g3d<-function()
{
if (nejes>2)
{
bg3d("white")
aspect3d("iso")
lims <- par3d("bbox")
if (cbVal=="1"){
axes3d()
}#end if (cbVal=="1")
if(cccaVal!="COIA")
{
if (cblugares=="1"){
zCoords<<-datos[,dim3]
if(cblablugares=="1"){
labelsVec3d <-c(textespecies, textvariables, textlugares)
sizesVec3d <-c(cexespecies, cexvariables, cexlugares)
}else{
labelsVec3d <-c(textespecies, textvariables, rep("", times =length(textlugares)))
sizesVec3d <-c(cexespecies, cexvariables, rep("", times =length(cexlugares)))
}#end if(cblablugares=="1")
}else{
zCoords<<-datosr[,dim3]
labelsVec3d <-c(textespecies, textvariables)
sizesVec3d <-c(cexespecies, cexvariables)
}#end if (cblugares=="1")
points3d(xCoords,yCoords,zCoords, color=colores)
texts3d(xCoords, yCoords, zCoords,labelsVec3d,color=colores, cex = as.numeric(sizesVec3d))
for (i in 1:(dim(covambien)[1]))
{
linea <-rbind(covambien[i,c(dim1, dim2, dim3)],c(0,0,0))
segments3d(linea[,1],linea[,2], linea[,3],color=colvariables[i])
}#end for (i in 1:(dim(covambien)[1]))
}else{
xCoords<<-datos[,dim1]
yCoords<<-datos[,dim2]
zCoords<<-datos[,dim3]
labelsVec3d <-labelsVec
sizesVec3d <-sizesVec
if(typecoia=="sg")
{
points3d(xCoords,yCoords,zCoords, color=colores)
colugyaux <<- datos[1:length(textlugares),]
colugzaux <<- datos[-(1:length(textlugares)),]
for (i in 1:(dim(colugyaux)[1]))
{
linea <-rbind(colugyaux[i,c(dim1, dim2, dim3)],colugzaux[i,c(dim1, dim2, dim3)])
segments3d(linea[,1],linea[,2], linea[,3],color=colores[i])
}#end for (i in 1:(dim(colugyaux)[1]))
texts3d(textos[,1], textos[,2], textos[,3],labelsVec3d,color=colores, cex = as.numeric(sizesVec3d))
}
if(typecoia=="eg" | typecoia=="vg")
{
for (i in 1:(dim(datos)[1]))
{
linea <-rbind(datos[i,c(dim1, dim2, dim3)],c(0,0,0))
segments3d(linea[,1],linea[,2], linea[,3],color=colores[i])
}#end for (i in 1:(dim(datos)[1]))
texts3d(textos[,1], textos[,2], textos[,3],labelsVec3d,color=colores, cex = as.numeric(sizesVec3d))
}
if(typecoia=="ef" | typecoia=="vf")
{
rgl.bg(sphere=TRUE, color=c("white","green"), lit=FALSE, back="lines" )
for (i in 1:(dim(datos)[1]))
{
linea <-rbind(datos[i,c(dim1, dim2, dim3)],c(0,0,0))
segments3d(linea[,1],linea[,2], linea[,3],color=colores[i])
}#end for (i in 1:(dim(datos)[1]))
texts3d(textos[,1], textos[,2], textos[,3],labelsVec3d,color=colores, cex = as.numeric(sizesVec3d))
}
}
rgl.bringtotop()
}else{
msg <- "You have selected less than 3 dimensions. 3D-graph not available"
tkmessageBox(message=msg)
}#end if (nejes>2)
}#end g3d<-function()
bootcnca<-function()
{
wboot<-tktoplevel()
tkwm.title(wboot,"Bootstrap")
#### Frames
framewi<-tkframe(wboot, relief = "flat", borderwidth = 2, background = "white")
framewi1<-tkframe(framewi, relief = "ridge", borderwidth = 2, background = "white")
framewi2<-tkframe(framewi, relief = "ridge", borderwidth = 2, background = "white")
framewi21<-tkframe(framewi2, relief = "ridge", borderwidth = 2, background = "white")
framewi21i<-tkframe(framewi21, relief = "ridge", borderwidth = 2, background = "white")
framewi21a<-tkframe(framewi21, relief = "ridge", borderwidth = 2, background = "white")
framewi21f<-tkframe(framewi21, relief = "ridge", borderwidth = 2, background = "white")
framewi21ft<-tkframe(framewi21f, relief = "ridge", borderwidth = 2, background = "white")
framewi21fb<-tkframe(framewi21f, relief = "ridge", borderwidth = 2, background = "white")
framewi21fl<-tkframe(framewi21fb, relief = "ridge", borderwidth = 2, background = "white")
framewi21fr<-tkframe(framewi21fb, relief = "ridge", borderwidth = 2, background = "white")
framewi22<-tkframe(framewi2, relief = "flat", borderwidth = 2, background = "white")
framewi22c<-tkframe(framewi22, relief = "flat", borderwidth = 2, background = "white")
framewi22l<-tkframe(framewi22, relief = "flat", borderwidth = 2, background = "white")
framewi221c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi222c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi223c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi224c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi225c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi226c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi227c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi228c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi229c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi2210c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi2211c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi2212c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi2213c<-tkframe(framewi22c, relief = "flat", borderwidth = 2, background = "white")
framewi221l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi222l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi223l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi224l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi225l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi226l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi227l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi228l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi229l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi2210l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi2211l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi2212l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewi2213l<-tkframe(framewi22l, relief = "flat", borderwidth = 2, background = "white")
framewigr<-tkframe(wboot, relief = "flat", borderwidth = 2, background = "white")
fontHeading <- tkfont.create(family="times",size=24,weight="bold",slant="italic")
fontFixedWidth <- tkfont.create(family="courier",size=12)
tkpack(tklabel(framewi1, text=" "), expand = "TRUE", side="left",expand="TRUE", fill = "both")
tkpack(tklabel(framewi1,text="BOOTSTRAP",font=fontHeading, foreground = "blue"), expand = "TRUE", side="left", fill = "both")
tkpack(tklabel(framewi1, text=" "), expand = "TRUE", side="left",expand="TRUE", fill = "both")
######Iterations ###################################
Niter <- tclVar(niter)
entry.Niter <-tkentry(framewi21i,width=10,textvariable=Niter, bg="white")
tkconfigure(entry.Niter,textvariable=Niter)
tkpack(tklabel(framewi21i, text="Number of resamples"),entry.Niter, expand = "TRUE", side="left", fill = "both")
######alpha confidence intervals ###################################
Nalpha <- tclVar(alphaic)
entry.Nalpha <-tkentry(framewi21a,width=10,textvariable=Nalpha, bg="white")
tkconfigure(entry.Nalpha,textvariable=Nalpha)
tkpack(tklabel(framewi21a, text="Confidence Level "),entry.Nalpha, expand = "TRUE", side="left", fill = "both")
tkpack(framewi21fl, framewi21fr, expand = "TRUE",side="left", fill="both")
tkpack(framewi21ft, framewi21fb, expand = "TRUE",side="top", fill="both")
tkpack(framewi21i, framewi21a, framewi21f, expand = "TRUE",side="top", fill="both")
###### Parameters to estimate ###################################
tkpack(tklabel(framewi221l, text="Calculate confidence intervals for:"), expand = "TRUE", side="left",expand="TRUE", fill = "both")
tkpack(tklabel(framewi221c, text=" "), expand = "TRUE", side="left",expand="TRUE", fill = "both")
##### Checkbox Contributions to namesit #######
cCalphai <- tkcheckbutton(framewi222c)
cCalphaiValue <- tclVar("0")
tkconfigure(cCalphai,variable=cCalphaiValue)
##### Checkbox Contributions to namespe #######
cCalphak <- tkcheckbutton(framewi223c)
cCalphakValue <- tclVar("0")
tkconfigure(cCalphak,variable=cCalphakValue)
##### Checkbox Proportion of inertia explained by each axis (projected space) #######
ccalidadps <- tkcheckbutton(framewi224c)
ccalidadpsValue <- tclVar("0")
tkconfigure(ccalidadps,variable=ccalidadpsValue)
##### Checkbox Proportion of inertia explained by each axis (original space) #######
ccalidados <- tkcheckbutton(framewi225c)
ccalidadosValue <- tclVar("0")
tkconfigure(ccalidados,variable=ccalidadosValue)
##### Checkbox Qualities of representation relative to Namesit respect to projected space #######
cqalphaips <- tkcheckbutton(framewi226c)
cqalphaipsValue <- tclVar("0")
tkconfigure(cqalphaips,variable=cqalphaipsValue)
##### Checkbox Qualities of representation relative to Namesit respect to original space #######
cdalphaios <- tkcheckbutton(framewi227c)
cdalphaiosValue <- tclVar("0")
tkconfigure(cdalphaios,variable=cdalphaiosValue)
##### Checkbox Qualities of representation relative to Namespe respect to projected space #######
cqalphakps <- tkcheckbutton(framewi228c)
cqalphakpsValue <- tclVar("0")
tkconfigure(cqalphakps,variable=cqalphakpsValue)
##### Checkbox Qualities of representation relative to Namespe respect to original space #######
cqalphakos <- tkcheckbutton(framewi229c)
cqalphakosValue <- tclVar("0")
tkconfigure(cqalphakos,variable=cqalphakosValue)
tkpack(tklabel(framewi21ft,text="Save files as:"),
expand = "FALSE", side="top",expand="TRUE", fill = "both")
cpdf <- tkradiobutton(framewi21fl)
cpdfb <- tkradiobutton(framewi21fl)
rbpdfValue <- tclVar("Color pdf")
tkconfigure(cpdf,variable=rbpdfValue,value="Color pdf")
tkconfigure(cpdfb,variable=rbpdfValue,value="Black and white pdf")
tkpack(tklabel(framewi21fl,text="Color pdf"),cpdf,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
tkpack(tklabel(framewi21fl,text="Black and white pdf"),cpdfb,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
ceps <- tkradiobutton(framewi21fr)
cepsb <- tkradiobutton(framewi21fr)
rbepsValue <- tclVar("Color eps")
tkconfigure(ceps,variable=rbepsValue,value="Color eps")
tkconfigure(cepsb,variable=rbepsValue,value="Black and white eps")
tkpack(tklabel(framewi21fr,text="Color eps"),ceps,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
tkpack(tklabel(framewi21fr,text="Black and white eps"),cepsb,
expand = "FALSE", side="top",expand="TRUE", fill = "both")
##### Checkbox Eigenvalues #######
ceigen <- tkcheckbutton(framewi2213c)
ceigenValue <- tclVar("0")
tkconfigure(ceigen,variable=ceigenValue)
tkpack( tklabel(framewi222l, text=paste("-Contributions to factor of", Namesit), anchor="nw"),
tklabel(framewi223l, text=paste("-Contributions to factor of", Namespe), anchor="nw"),
tklabel(framewi224l, text="-Proportion of inertia explained (projected space)", anchor="nw"),
tklabel(framewi225l, text="-Proportion of inertia explained (original space)", anchor="nw"),
tklabel(framewi226l, text=paste("-Relative contribution of each factor to ", Namesit, "respect to projected space"), anchor="nw"),
tklabel(framewi227l, text=paste("-Relative contribution of each factor to ", Namesit, "respect to original space"), anchor="nw"),
tklabel(framewi228l, text=paste("-Relative contribution of each factor to ", Namespe, "respect to projected space"), anchor="nw"),
tklabel(framewi229l, text=paste("-Relative contribution of each factor to ", Namespe, "respect to original space"), anchor="nw"),
tklabel(framewi2213l, text="-Eigenvalues", anchor="nw"),
expand = "FALSE", side="top",expand="TRUE", fill = "both")
tkpack(cCalphai,cCalphak,ccalidadps,ccalidados,cqalphaips,cdalphaios,cqalphakps,cqalphakos,
ceigen,
expand = "TRUE",side="top", fill="both")
tkpack(framewi221l,framewi222l,framewi223l,framewi224l,framewi225l,framewi226l,framewi227l,framewi228l,framewi229l,
framewi2213l, expand = "TRUE",side="top", fill="both")
tkpack(framewi221c,framewi222c,framewi223c,framewi224c,framewi225c,framewi226c,framewi227c,framewi228c,framewi229c,
framewi2213c, expand = "TRUE",side="top", fill="both")
tkpack(framewi22c, framewi22l, expand = "TRUE",side="left", fill="both")
OnOKboot<-function()
{
tkdestroy(wboot)
niter <<- tclvalue(Niter)
alphaic <<- tclvalue(Nalpha)
cCalphaiVal <<- as.character(tclvalue(cCalphaiValue))
cCalphakVal <<- as.character(tclvalue(cCalphakValue))
ccalidadpsVal <<- as.character(tclvalue(ccalidadpsValue))
ccalidadosVal <<- as.character(tclvalue(ccalidadosValue))
cqalphaipsVal <<- as.character(tclvalue(cqalphaipsValue))
cdalphaiosVal <<- as.character(tclvalue(cdalphaiosValue))
cqalphakpsVal <<- as.character(tclvalue(cqalphakpsValue))
cqalphakosVal <<- as.character(tclvalue(cqalphakosValue))
ceigenVal <<- as.character(tclvalue(ceigenValue))
cpdfVal <<- as.character(tclvalue(rbpdfValue))
cepsVal <<- as.character(tclvalue(rbepsValue))
# jakknife submuestra
jakespecies <- vector("list",(sum(fespecies)-1))
z<-1
for(i in 1:dim(fespecies)[1])
{
for (j in 1:dim(fespecies)[2])
{
if(fespecies[i,j]>0)
{
for (k in 1:(fespecies[i,j]))
{
especaux<-as.matrix(fespecies)
especaux[i,j]<-fespecies[i,j]-1
jakespecies[[z]]<-especaux
z<-z+1
}
}
}
}
## muestra bootstrap
especiesrep<-rep(list(fespecies),niter)
especresample<-lapply(especiesrep, resample_bootes)
if(cccaVal=="CNCA")
{
bootresult<-mapply(ex.cnca, especresample, fvambientales=rep(list(fvambientales),niter), nejes=nejes, Numbercuant=Numbercuant, Numbermixto=Numbermixto, tChoice=tChoice)
}else{
bootresult<-mapply(ex.cca, especresample, fvambientales=rep(list(fvambientales),niter), nejes=nejes, Numbercuant=Numbercuant, Numbermixto=Numbermixto, tChoice=tChoice)
}
eigenalm<-bootresult[19,]
calidadpsalm<-bootresult[10,]
calidadosalm<-bootresult[11,]
Calphakalm<-bootresult[9,]
qalphakpsalm<-bootresult[14,]
qalphakosalm<-bootresult[13,]
Calphaialm<-bootresult[8,]
qalphaipsalm<-bootresult[12,]
dalphaiosalm<-bootresult[15,]
if(cccaVal=="CNCA")
{
maresult<-mapply(ex.cnca, jakespecies, fvambientales=rep(list(fvambientales),sum(fespecies)), nejes=nejes, Numbercuant=Numbercuant, Numbermixto=Numbermixto, tChoice=tChoice)
}else{
maresult<-mapply(ex.cca, jakespecies, fvambientales=rep(list(fvambientales),sum(fespecies)), nejes=nejes, Numbercuant=Numbercuant, Numbermixto=Numbermixto, tChoice=tChoice)
}
descomjackr<-maresult[19,]
calidadpsjackr<-maresult[10,]
calidadosjackr<-maresult[11,]
Calphakjackr<-maresult[9,]
qalphakpsjackr<-maresult[14,]
qalphakosjackr<-maresult[13,]
Calphaijackr<-maresult[8,]
qalphaipsjackr<-maresult[12,]
dalphaiosjackr<-maresult[15,]
####crear vectores con coordenadas de variables
coorvarrot<-bootresult[3,]
coorvarrot<-array(c(unlist(covambien),unlist(coorvarrot)), dim=c(dim(fvambientales)[2], nejes, as.numeric(niter)+1))
out.var<-procGPA(coorvarrot, reflect=TRUE, distances=FALSE, pcaoutput=FALSE)
plot(out.var$rotated[,dim1,], out.var$rotated[,dim2,], type="n", main=paste("Bootstrap Coordinates (", Namevar, ")"), xlab=paste("Dimension", dim1), ylab=paste("Dimension", dim2), asp=1/1)
for(i in 1:dim(covariablesnam)[1])
{
points(out.var$rotated[i,dim1,],out.var$rotated[i,dim2,], col=colorescoor[i], pch=20)
}
abline(v=0)
abline(h=0)
for(i in 1:dim(covariablesnam)[1])
{
hpts <- chull(t(out.var$rotated[i,c(dim1,dim2),]))
hpts <- c(hpts, hpts[1])
lines(t(out.var$rotated[i,c(dim1,dim2),hpts]), col=colorescoor[i])
}
text(out.var$rotated[,dim1,1], out.var$rotated[,dim2,1], labels=textvariables)
####crear vectores con coordenadas de especies
coorsperot<-bootresult[2,]
coorsperot<-array(c(unlist(coespecies), unlist(coorsperot)), dim=c(dim(fespecies)[2], nejes, as.numeric(niter)+1))
out.spe<-procGPA(coorsperot, reflect=TRUE, distances=FALSE, pcaoutput=FALSE)
plot(out.spe$rotated[,dim1,], out.spe$rotated[,dim2,], type="n", main=paste("Bootstrap Coordinates (", Namespe, ")"), xlab=paste("Dimension", dim1), ylab=paste("Dimension", dim2), asp=1/1)
for(i in 1:dim(coindividuosnam)[1])
{
points(out.spe$rotated[i,dim1,],out.spe$rotated[i,dim2,], col=colorescoor[i], pch=20)
}
abline(v=0)
abline(h=0)
for(i in 1:dim(coindividuosnam)[1])
{
hpts <- chull(t(out.spe$rotated[i,c(dim1,dim2),]))
hpts <- c(hpts, hpts[1])
lines(t(out.spe$rotated[i,c(dim1,dim2),hpts]), col=colorescoor[i])
}
text(out.spe$rotated[,dim1,1], out.spe$rotated[,dim2,1], labels=textespecies)
####crear vectores con coordenadas de lugares
coorlugrot<-bootresult[1,]
coorlugrot<-array(c(unlist(colugares),unlist(coorlugrot)), dim=c(dim(fvambientales)[1], nejes, as.numeric(niter)+1))
out.sit<-procGPA(coorlugrot, reflect=TRUE, distances=FALSE, pcaoutput=FALSE)
plot(out.sit$rotated[,dim1,], out.sit$rotated[,dim2,], type="n", main=paste("Bootstrap Coordinates (", Namesit, ")"), xlab=paste("Dimension", dim1), ylab=paste("Dimension", dim2), asp=1/1)
for(i in 1:dim(colugaresnam)[1])
{
points(out.sit$rotated[i,dim1,],out.sit$rotated[i,dim2,], col=colorescoor[i], pch=20)
}
abline(v=0)
abline(h=0)
for(i in 1:dim(colugaresnam)[1])
{
hpts <- chull(t(out.sit$rotated[i,c(dim1,dim2),]))
hpts <- c(hpts, hpts[1])
lines(t(out.sit$rotated[i,c(dim1,dim2),hpts]), col=colorescoor[i])
}
text(out.sit$rotated[,dim1,1], out.sit$rotated[,dim2,1], labels=textlugares)
#########################################################################
### Guardar resultados
#########################################################################
cat("File saved in: ",file="Resultsbootstrap.txt")
cat(getwd(),file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
alphaic <<- tclvalue(Nalpha)
alphaic <<- as.numeric(alphaic)
liminf <- (1 - alphaic*0.01) / 2
limsup <- 1 - (1 - alphaic*0.01) / 2
titulo <-c("Obs. Value","Mean","SE","Bias","IC t-boot inf","IC t-boot sup","IC perc inf","IC perc sup","IC BCa inf","IC BCa sup")
### Eigenvalues
if (ceigenVal=="1")
{
calc.ceigen <-c()
ceigen.mean <-c()
se.ceigen <-c()
sesgo.ceigen <-c()
ic.t.ceigeninf <-c()
ic.t.ceigensup <-c()
ic.p.ceigeninf <-c()
ic.p.ceigensup <-c()
ic.bca.ceigeninf <-c()
ic.bca.ceigensup <-c()
for (i in 1:length(eigenalm[[1]]))
{
calc.ceigen <-cal.ic(sapply(eigenalm, function(x) x[i]), liminf, limsup, descom$d[i], sapply(descomjackr, function(x) x[i]), niter)
ceigen.mean <- c(ceigen.mean, calc.ceigen[1])
se.ceigen <- c(se.ceigen,calc.ceigen[2])
sesgo.ceigen <- c(sesgo.ceigen,calc.ceigen[3])
ic.t.ceigeninf <- c(ic.t.ceigeninf,calc.ceigen[4])
ic.t.ceigensup <- c(ic.t.ceigensup,calc.ceigen[5])
ic.p.ceigeninf <- c(ic.p.ceigeninf,calc.ceigen[6])
ic.p.ceigensup <- c(ic.p.ceigensup,calc.ceigen[7])
ic.bca.ceigeninf <- c(ic.bca.ceigeninf,calc.ceigen[8])
ic.bca.ceigensup <- c(ic.bca.ceigensup,calc.ceigen[9])
pdf(paste("Histogram of eigenvalue", i, ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(sapply(eigenalm, function(x) x[i]), main="Histogram", xlab=paste("Eigenvalue", i))
if(cpdfVal=="Color pdf")
{
abline(v=ceigen.mean[i], lwd=2, col="blue")
abline(v=descom$d[i], lty =2, lwd=2, col="red")
}else{
abline(v=ceigen.mean[i], lwd=2)
abline(v=descom$d[i], lty =2, lwd=2)
}
qqnorm(sapply(eigenalm, function(x) x[i]))
dev.off()
postscript(paste("Histogram of eigenvalue", i, ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(sapply(eigenalm, function(x) x[i]), main="Histogram", xlab=paste("Eigenvalue", i))
if(cepsVal=="Color eps")
{
abline(v=ceigen.mean[i], lwd=2, col="blue")
abline(v=descom$d[i], lty =2, lwd=2, col="red")
}else{
abline(v=ceigen.mean[i], lwd=2)
abline(v=descom$d[i], lty =2, lwd=2)
}
qqnorm(sapply(eigenalm, function(x) x[i]))
dev.off()
}#end for (i in 1:length(eigenalm))
calc.ceigen <-array(cbind(descom$d, ceigen.mean, se.ceigen, sesgo.ceigen, ic.t.ceigeninf, ic.t.ceigensup, ic.p.ceigeninf, ic.p.ceigensup, ic.bca.ceigeninf, ic.bca.ceigensup),
dim=c(length(descom$d),10))
calc.ceigen <- as.data.frame(calc.ceigen)
colnames(calc.ceigen) <- titulo
nombreseig<-c()
for (i in 1: length(descom$d))
{
nombreseig <-c(nombreseig, paste("Eigenvalue",i, sep=""))
}#end for (i in 1: length(descom$d))
rownames(calc.ceigen) <- nombreseig
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Eigenvalues: \n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.ceigen, digits=3), file="temp.txt", sep="\t", dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end if (ceigenVal=="1")
### calidadps
if (ccalidadpsVal=="1")
{
calc.ccalps <-c()
ccalps.mean <-c()
se.ccalps <-c()
sesgo.ccalps <-c()
ic.t.ccalpsinf <-c()
ic.t.ccalpssup <-c()
ic.p.ccalpsinf <-c()
ic.p.ccalpssup <-c()
ic.bca.ccalpsinf <-c()
ic.bca.ccalpssup <-c()
for (i in 1:length(calidadpsalm[[1]]))
{
calc.ccalps <-cal.ic(sapply(calidadpsalm, function(x) x[i]), liminf, limsup, calidadps[i], sapply(calidadpsjackr, function(x) x[i]), niter)
ccalps.mean <- c(ccalps.mean, calc.ccalps[1])
se.ccalps <- c(se.ccalps,calc.ccalps[2])
sesgo.ccalps <- c(sesgo.ccalps,calc.ccalps[3])
ic.t.ccalpsinf <- c(ic.t.ccalpsinf,calc.ccalps[4])
ic.t.ccalpssup <- c(ic.t.ccalpssup,calc.ccalps[5])
ic.p.ccalpsinf <- c(ic.p.ccalpsinf,calc.ccalps[6])
ic.p.ccalpssup <- c(ic.p.ccalpssup,calc.ccalps[7])
ic.bca.ccalpsinf <- c(ic.bca.ccalpsinf,calc.ccalps[8])
ic.bca.ccalpssup <- c(ic.bca.ccalpssup,calc.ccalps[9])
pdf(paste("Histogram of inertia by axis (PS)", i, ".pdf", sep = ""), height = 500, width = 500, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(sapply(calidadpsalm, function(x) x[i]),main="Histogram", xlab=paste("Axis", i))
if(cpdfVal=="Color pdf")
{
abline(v=ccalps.mean[i], lwd=2, col="blue")
abline(v=calidadps[i], lty =2, lwd=2, col="red")
}else{
abline(v=ccalps.mean[i], lwd=2)
abline(v=calidadps[i], lty =2, lwd=2)
}
qqnorm(sapply(calidadpsalm, function(x) x[i]))
dev.off()
postscript(paste("Histogram of inertia by axis (PS)", i, ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(sapply(calidadpsalm, function(x) x[i]),main="Histogram", xlab=paste("Axis", i))
if(cepsVal=="Color eps")
{
abline(v=ccalps.mean[i], lwd=2, col="blue")
abline(v=calidadps[i], lty =2, lwd=2, col="red")
}else{
abline(v=ccalps.mean[i], lwd=2)
abline(v=calidadps[i], lty =2, lwd=2)
}
qqnorm(sapply(calidadpsalm, function(x) x[i]))
dev.off()
}#end for (i in 1:length(calidadpsalm))
calc.ccalps <-array(cbind(t(calidadps), ccalps.mean, se.ccalps, sesgo.ccalps, ic.t.ccalpsinf, ic.t.ccalpssup, ic.p.ccalpsinf, ic.p.ccalpssup, ic.bca.ccalpsinf, ic.bca.ccalpssup),
dim=c(length(calidadps),10))
calc.ccalps <- as.data.frame(calc.ccalps)
colnames(calc.ccalps) <- titulo
nombrescalps<-c()
for (i in 1: length(calidadps))
{
nombrescalps <-c(nombrescalps, paste("Axis",i, sep=""))
}#end for (i in 1: length(calidadps))
rownames(calc.ccalps) <- nombrescalps
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Proportion of inertia explained by each axis (PS): \n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.ccalps, digits=3), file="temp.txt", sep="\t", dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end if (ccalpsVal=="1")
### calidados
if (ccalidadosVal=="1")
{
calc.ccalos <-c()
ccalos.mean <-c()
se.ccalos <-c()
sesgo.ccalos <-c()
ic.t.ccalosinf <-c()
ic.t.ccalossup <-c()
ic.p.ccalosinf <-c()
ic.p.ccalossup <-c()
ic.bca.ccalosinf <-c()
ic.bca.ccalossup <-c()
for (i in 1:length(calidadosalm[[1]]))
{
calc.ccalos <-cal.ic(sapply(calidadosalm, function(x) x[i]), liminf, limsup, calidados[i], sapply(calidadosjackr, function(x) x[i]), niter)
ccalos.mean <- c(ccalos.mean, calc.ccalos[1])
se.ccalos <- c(se.ccalos,calc.ccalos[2])
sesgo.ccalos <- c(sesgo.ccalos,calc.ccalos[3])
ic.t.ccalosinf <- c(ic.t.ccalosinf,calc.ccalos[4])
ic.t.ccalossup <- c(ic.t.ccalossup,calc.ccalos[5])
ic.p.ccalosinf <- c(ic.p.ccalosinf,calc.ccalos[6])
ic.p.ccalossup <- c(ic.p.ccalossup,calc.ccalos[7])
ic.bca.ccalosinf <- c(ic.bca.ccalosinf,calc.ccalos[8])
ic.bca.ccalossup <- c(ic.bca.ccalossup,calc.ccalos[9])
pdf(paste("Histogram of inertia by axis (OS)", i, ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(sapply(calidadosalm, function(x) x[i]),main="Histogram", xlab=paste("Axis", i))
if(cpdfVal=="Color pdf")
{
abline(v=ccalos.mean[i], lwd=2, col="blue")
abline(v=calidados[i], lty =2, lwd=2, col="red")
}else{
abline(v=ccalos.mean[i], lwd=2)
abline(v=calidados[i], lty =2, lwd=2)
}
qqnorm(sapply(calidadosalm, function(x) x[i]))
dev.off()
postscript(paste("Histogram of inertia by axis (OS)", i, ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(sapply(calidadosalm, function(x) x[i]),main="Histogram", xlab=paste("Axis", i))
if(cepsVal=="Color eps")
{
abline(v=ccalos.mean[i], lwd=2, col="blue")
abline(v=calidados[i], lty =2, lwd=2, col="red")
}else{
abline(v=ccalos.mean[i], lwd=2)
abline(v=calidados[i], lty =2, lwd=2)
}
qqnorm(sapply(calidadosalm, function(x) x[i]))
dev.off()
}#end for (i in 1:length(calidadosalm))
calc.ccalos <-array(cbind(t(calidados), ccalos.mean, se.ccalos, sesgo.ccalos, ic.t.ccalosinf, ic.t.ccalossup, ic.p.ccalosinf, ic.p.ccalossup, ic.bca.ccalosinf, ic.bca.ccalossup),
dim=c(length(calidados),10))
calc.ccalos <- as.data.frame(calc.ccalos)
colnames(calc.ccalos) <- titulo
nombrescalos<-c()
for (i in 1: length(calidados))
{
nombrescalos <-c(nombrescalos, paste("Axis",i, sep=""))
}#end for (i in 1: length(calidados))
rownames(calc.ccalos) <- nombrescalos
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Proportion of inertia explained by each axis (OS): \n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.ccalos, digits=2), file="temp.txt", sep="\t", dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end if (ccalosVal=="1")
### Calphak
if (cCalphakVal=="1")
{
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Contributions to", Namespe, ":",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
for(i in 1: dim(Calphak)[1])
{
calc.ccalk <-c()
ccalk.mean <-c()
se.ccalk <-c()
sesgo.ccalk <-c()
ic.t.ccalkinf <-c()
ic.t.ccalksup <-c()
ic.p.ccalkinf <-c()
ic.p.ccalksup <-c()
ic.bca.ccalkinf <-c()
ic.bca.ccalksup <-c()
for (j in 1:dim(Calphak)[2])
{
calphakaux <- sapply(Calphakalm, function(x) x[i,j])
calc.ccalk <-cal.ic(calphakaux, liminf, limsup, Calphak[i,j], sapply(Calphakjackr, function(x) x[i,j]), niter)
ccalk.mean <- c(ccalk.mean, calc.ccalk[1])
se.ccalk <- c(se.ccalk, calc.ccalk[2])
sesgo.ccalk <- c(sesgo.ccalk,calc.ccalk[3])
ic.t.ccalkinf <- c(ic.t.ccalkinf,calc.ccalk[4])
ic.t.ccalksup <- c(ic.t.ccalksup,calc.ccalk[5])
ic.p.ccalkinf <- c(ic.p.ccalkinf,calc.ccalk[6])
ic.p.ccalksup <- c(ic.p.ccalksup,calc.ccalk[7])
ic.bca.ccalkinf <- c(ic.bca.ccalkinf,calc.ccalk[8])
ic.bca.ccalksup <- c(ic.bca.ccalksup,calc.ccalk[9])
pdf(paste("Histogram of contributions to ", textespecies[i]," of axis ", j, ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(calphakaux, main="Histogram", xlab=paste("Contribution to ", textespecies[i],"\n of axis ", j))
if(cpdfVal=="Color pdf")
{
abline(v=ccalk.mean[j], lwd=2, col="blue")
abline(v=Calphak[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=ccalk.mean[j], lwd=2)
abline(v=Calphak[i,j], lty =2, lwd=2)
}
qqnorm(calphakaux)
dev.off()
postscript(paste("Histogram of contributions to ", textespecies[i]," of axis ", j, ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(calphakaux, main="Histogram", xlab=paste("Contribution to ", textespecies[i],"\n of axis ", j))
if(cepsVal=="Color eps")
{
abline(v=ccalk.mean[j], lwd=2, col="blue")
abline(v=Calphak[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=ccalk.mean[j], lwd=2)
abline(v=Calphak[i,j], lty =2, lwd=2)
}
qqnorm(calphakaux)
dev.off()
}#end for (j in 1:dimCalphak)[2])
calc.ccalk <-array(cbind(unlist(Calphak[i,]), ccalk.mean, se.ccalk, sesgo.ccalk, ic.t.ccalkinf, ic.t.ccalksup, ic.p.ccalkinf, ic.p.ccalksup, ic.bca.ccalkinf, ic.bca.ccalksup),
dim=c(nejes,10))
calc.ccalk <- as.data.frame(calc.ccalk)
colnames(calc.ccalk) <- titulo
rownames(calc.ccalk) <- ejes
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat(textespecies[i],"\n", file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.ccalk, digits=2),file="temp.txt", sep="\t",dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end for(i in 1: dim(Calphak)[1])
}#end if (cCalphakVal=="1")
### qalphakps
if (cqalphakpsVal=="1")
{
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Contributions of ", Namespe, " (PS):",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
for(i in 1: dim(qalphakps)[1])
{
calc.cqkps <-c()
cqkps.mean <-c()
se.cqkps <-c()
sesgo.cqkps <-c()
ic.t.cqkpsinf <-c()
ic.t.cqkpssup <-c()
ic.p.cqkpsinf <-c()
ic.p.cqkpssup <-c()
ic.bca.cqkpsinf <-c()
ic.bca.cqkpssup <-c()
for (j in 1:dim(qalphakps)[2])
{
qalphakpsaux <- sapply(qalphakpsalm, function(x) x[i,j])
calc.cqkps <-cal.ic(qalphakpsaux, liminf, limsup, qalphakps[i,j], sapply(qalphakpsjackr, function(x) x[i,j]), niter)
cqkps.mean <- c(cqkps.mean, calc.cqkps[1])
se.cqkps <- c(se.cqkps, calc.cqkps[2])
sesgo.cqkps <- c(sesgo.cqkps,calc.cqkps[3])
ic.t.cqkpsinf <- c(ic.t.cqkpsinf,calc.cqkps[4])
ic.t.cqkpssup <- c(ic.t.cqkpssup,calc.cqkps[5])
ic.p.cqkpsinf <- c(ic.p.cqkpsinf,calc.cqkps[6])
ic.p.cqkpssup <- c(ic.p.cqkpssup,calc.cqkps[7])
ic.bca.cqkpsinf <- c(ic.bca.cqkpsinf,calc.cqkps[8])
ic.bca.cqkpssup <- c(ic.bca.cqkpssup,calc.cqkps[9])
pdf(paste("Histogram of contribution of ", textespecies[i]," (PS)", ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(qalphakpsaux,main="Histogram", xlab=paste("Contribution of ", textespecies[i]," (PS)"))
if(cpdfVal=="Color pdf")
{
abline(v=cqkps.mean[j], lwd=2, col="blue")
abline(v=qalphakps[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqkps.mean[j], lwd=2)
abline(v=qalphakps[i,j], lty =2, lwd=2)
}
qqnorm(qalphakpsaux)
dev.off()
postscript(paste("Histogram of contribution of ", textespecies[i]," (PS)", ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(qalphakpsaux,main="Histogram", xlab=paste("Contribution of ", textespecies[i]," (PS)"))
if(cepsVal=="Color eps")
{
abline(v=cqkps.mean[j], lwd=2, col="blue")
abline(v=qalphakps[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqkps.mean[j], lwd=2)
abline(v=qalphakps[i,j], lty =2, lwd=2)
}
qqnorm(qalphakpsaux)
dev.off()
}#end for (j in 1:dim (qalphakps)[2])
calc.cqkps <-array(cbind(unlist(qalphakps[i,]), cqkps.mean, se.cqkps, sesgo.cqkps, ic.t.cqkpsinf, ic.t.cqkpssup, ic.p.cqkpsinf, ic.p.cqkpssup, ic.bca.cqkpsinf, ic.bca.cqkpssup),
dim=c(nejes,10))
calc.cqkps <- as.data.frame(calc.cqkps)
colnames(calc.cqkps) <- titulo
rownames(calc.cqkps) <- ejes
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat(textespecies[i],"\n", file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.cqkps, digits=2),file="temp.txt", sep="\t",dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end for(i in 1: dim(qalphakps)[1])
}#end if (cqalphakpsVal=="1")
### qalphakos
if (cqalphakosVal=="1")
{
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Contributions of ", Namespe, " (OS):",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
for(i in 1: dim(qalphakos)[1])
{
calc.cqkos <-c()
cqkos.mean <-c()
se.cqkos <-c()
sesgo.cqkos <-c()
ic.t.cqkosinf <-c()
ic.t.cqkossup <-c()
ic.p.cqkosinf <-c()
ic.p.cqkossup <-c()
ic.bca.cqkosinf <-c()
ic.bca.cqkossup <-c()
for (j in 1:dim(qalphakos)[2])
{
qalphakosaux <- sapply(qalphakosalm, function(x) x[i,j])
calc.cqkos <-cal.ic(qalphakosaux, liminf, limsup, qalphakos[i,j], sapply(qalphakosjackr, function(x) x[i,j]), niter)
cqkos.mean <- c(cqkos.mean, calc.cqkos[1])
se.cqkos <- c(se.cqkos, calc.cqkos[2])
sesgo.cqkos <- c(sesgo.cqkos,calc.cqkos[3])
ic.t.cqkosinf <- c(ic.t.cqkosinf,calc.cqkos[4])
ic.t.cqkossup <- c(ic.t.cqkossup,calc.cqkos[5])
ic.p.cqkosinf <- c(ic.p.cqkosinf,calc.cqkos[6])
ic.p.cqkossup <- c(ic.p.cqkossup,calc.cqkos[7])
ic.bca.cqkosinf <- c(ic.bca.cqkosinf,calc.cqkos[8])
ic.bca.cqkossup <- c(ic.bca.cqkossup,calc.cqkos[9])
pdf(paste("Histogram of contribution of ", textespecies[i]," (OS)", ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(qalphakosaux,main="Histogram", xlab=paste("Contribution of ", textespecies[i]," (OS)"))
if(cpdfVal=="Color pdf")
{
abline(v=cqkos.mean[j], lwd=2, col="blue")
abline(v=qalphakos[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqkos.mean[j], lwd=2)
abline(v=qalphakos[i,j], lty =2, lwd=2)
}
qqnorm(qalphakosaux)
dev.off()
postscript(paste("Contribution of ", textespecies[i]," (OS)", ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(qalphakosaux,main="Histogram", xlab=paste("Contribution of ", textespecies[i]," (OS)"))
if(cepsVal=="Color eps")
{
abline(v=cqkos.mean[j], lwd=2, col="blue")
abline(v=qalphakos[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqkos.mean[j], lwd=2)
abline(v=qalphakos[i,j], lty =2, lwd=2)
}
qqnorm(qalphakosaux)
dev.off()
}#end for (j in 1:dim (qalphakos)[2])
calc.cqkos <-array(cbind(unlist(qalphakos[i,]), cqkos.mean, se.cqkos, sesgo.cqkos, ic.t.cqkosinf, ic.t.cqkossup, ic.p.cqkosinf, ic.p.cqkossup, ic.bca.cqkosinf, ic.bca.cqkossup),
dim=c(nejes,10))
calc.cqkos <- as.data.frame(calc.cqkos)
colnames(calc.cqkos) <- titulo
rownames(calc.cqkos) <- ejes
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat(textespecies[i],"\n", file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.cqkos, digits=2),file="temp.txt", sep="\t",dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end for(i in 1: dim(qalphakos)[1])
}#end if (cqalphakosVal=="1")
### Calphai
if (cCalphaiVal=="1")
{
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Contributions to", Namesit, ":",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
for(i in 1: dim(Calphai)[1])
{
calc.ccali <-c()
ccali.mean <-c()
se.ccali <-c()
sesgo.ccali <-c()
ic.t.ccaliinf <-c()
ic.t.ccalisup <-c()
ic.p.ccaliinf <-c()
ic.p.ccalisup <-c()
ic.bca.ccaliinf <-c()
ic.bca.ccalisup <-c()
for (j in 1:dim(Calphai)[2])
{
calphaiaux <- sapply(Calphaialm, function(x) x[i,j])
calc.ccali <-cal.ic(calphaiaux, liminf, limsup, Calphai[i,j], sapply(Calphaijackr, function(x) x[i,j]), niter)
ccali.mean <- c(ccali.mean, calc.ccali[1])
se.ccali <- c(se.ccali, calc.ccali[2])
sesgo.ccali <- c(sesgo.ccali,calc.ccali[3])
ic.t.ccaliinf <- c(ic.t.ccaliinf,calc.ccali[4])
ic.t.ccalisup <- c(ic.t.ccalisup,calc.ccali[5])
ic.p.ccaliinf <- c(ic.p.ccaliinf,calc.ccali[6])
ic.p.ccalisup <- c(ic.p.ccalisup,calc.ccali[7])
ic.bca.ccaliinf <- c(ic.bca.ccaliinf,calc.ccali[6])
ic.bca.ccalisup <- c(ic.bca.ccalisup,calc.ccali[7])
pdf(paste("Histogram of contributions to ", textlugares[i]," of axis ", j, ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(calphaiaux,main="Histogram", xlab=paste("Contribution to ", textlugares[i],"\n of axis ", j))
if(cpdfVal=="Color pdf")
{
abline(v=ccali.mean[j], lwd=2, col="blue")
abline(v=Calphai[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=ccali.mean[j], lwd=2)
abline(v=Calphai[i,j], lty =2, lwd=2)
}
qqnorm(calphaiaux)
dev.off()
postscript(paste("Histogram of contributions to ", textlugares[i]," of axis ", j, ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(calphaiaux,main="Histogram", xlab=paste("Contribution to ", textlugares[i],"\n of axis ", j))
if(cepsVal=="Color eps")
{
abline(v=ccali.mean[j], lwd=2, col="blue")
abline(v=Calphai[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=ccali.mean[j], lwd=2)
abline(v=Calphai[i,j], lty =2, lwd=2)
}
qqnorm(calphaiaux)
dev.off()
}#end for (j in 1:dimCalphai)[2])
calc.ccali <-array(cbind(unlist(Calphai[i,]), ccali.mean, se.ccali, sesgo.ccali, ic.t.ccaliinf, ic.t.ccalisup, ic.p.ccaliinf, ic.p.ccalisup, ic.bca.ccaliinf, ic.bca.ccalisup),
dim=c(nejes,10))
calc.ccali <- as.data.frame(calc.ccali)
colnames(calc.ccali) <- titulo
rownames(calc.ccali) <- ejes
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat(textlugares[i],"\n", file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.ccali, digits=2),file="temp.txt", sep="\t",dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end for(i in 1: dim(Calphai)[1])
}#end if (cCalphaiVal=="1")
### qalphaips
if (cqalphaipsVal=="1")
{
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Contributions of ", Namesit, " (PS):",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
for(i in 1: dim(qalphaips)[1])
{
calc.cqips <-c()
cqips.mean <-c()
se.cqips <-c()
sesgo.cqips <-c()
ic.t.cqipsinf <-c()
ic.t.cqipssup <-c()
ic.p.cqipsinf <-c()
ic.p.cqipssup <-c()
ic.bca.cqipsinf <-c()
ic.bca.cqipssup <-c()
for (j in 1:dim(qalphaips)[2])
{
qalphaipsaux <- sapply(qalphaipsalm, function(x) x[i,j])
calc.cqips <-cal.ic(qalphaipsaux, liminf, limsup, qalphaips[i,j], sapply(qalphaipsjackr, function(x) x[i,j]), niter)
cqips.mean <- c(cqips.mean, calc.cqips[1])
se.cqips <- c(se.cqips, calc.cqips[2])
sesgo.cqips <- c(sesgo.cqips,calc.cqips[3])
ic.t.cqipsinf <- c(ic.t.cqipsinf,calc.cqips[4])
ic.t.cqipssup <- c(ic.t.cqipssup,calc.cqips[5])
ic.p.cqipsinf <- c(ic.p.cqipsinf,calc.cqips[6])
ic.p.cqipssup <- c(ic.p.cqipssup,calc.cqips[7])
ic.bca.cqipsinf <- c(ic.bca.cqipsinf,calc.cqips[8])
ic.bca.cqipssup <- c(ic.bca.cqipssup,calc.cqips[9])
pdf(paste("Histogram of contribution of ", textlugares[i]," (PS)", ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(qalphaipsaux,main="Histogram", xlab=paste("Contribution of ", textlugares[i]," (PS)"))
if(cpdfVal=="Color pdf")
{
abline(v=cqips.mean[j], lwd=2, col="blue")
abline(v=qalphaips[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqips.mean[j], lwd=2)
abline(v=qalphaips[i,j], lty =2, lwd=2)
}
qqnorm(qalphaipsaux)
dev.off()
postscript(paste("Histogram of contribution of ", textlugares[i]," (PS)", ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(qalphaipsaux,main="Histogram", xlab=paste("Contribution of ", textlugares[i]," (PS)"))
if(cepsVal=="Color eps")
{
abline(v=cqips.mean[j], lwd=2, col="blue")
abline(v=qalphaips[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqips.mean[j], lwd=2)
abline(v=qalphaips[i,j], lty =2, lwd=2)
}
qqnorm(qalphaipsaux)
dev.off()
}#end for (j in 1:dim (qalphaips)[2])
calc.cqips <-array(cbind(unlist(qalphaips[i,]), cqips.mean, se.cqips, sesgo.cqips, ic.t.cqipsinf, ic.t.cqipssup, ic.p.cqipsinf, ic.p.cqipssup, ic.bca.cqipsinf, ic.bca.cqipssup),
dim=c(nejes,10))
calc.cqips <- as.data.frame(calc.cqips)
colnames(calc.cqips) <- titulo
rownames(calc.cqips) <- ejes
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat(textlugares[i],"\n", file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.cqips, digits=2),file="temp.txt", sep="\t",dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end for(i in 1: dim(qalphaips)[1])
}#end if (cqalphaipsVal=="1")
### dalphaios
if (cdalphaiosVal=="1")
{
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat("Contributions of ", Namesit, " (OS):",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
for(i in 1: dim(dalphaios)[1])
{
calc.cqios <-c()
cqios.mean <-c()
se.cqios <-c()
sesgo.cqios <-c()
ic.t.cqiosinf <-c()
ic.t.cqiossup <-c()
ic.p.cqiosinf <-c()
ic.p.cqiossup <-c()
ic.bca.cqiosinf <-c()
ic.bca.cqiossup <-c()
for (j in 1:dim(dalphaios)[2])
{
qalphaiosaux <- sapply(dalphaiosalm, function(x) x[i,j])
calc.cqios <-cal.ic(qalphaiosaux, liminf, limsup, dalphaios[i,j], sapply(dalphaiosjackr, function(x) x[i,j]), niter)
cqios.mean <- c(cqios.mean, calc.cqios[1])
se.cqios <- c(se.cqios, calc.cqios[2])
sesgo.cqios <- c(sesgo.cqios,calc.cqios[3])
ic.t.cqiosinf <- c(ic.t.cqiosinf,calc.cqios[4])
ic.t.cqiossup <- c(ic.t.cqiossup,calc.cqios[5])
ic.p.cqiosinf <- c(ic.p.cqiosinf,calc.cqios[6])
ic.p.cqiossup <- c(ic.p.cqiossup,calc.cqios[7])
ic.bca.cqiosinf <- c(ic.bca.cqiosinf,calc.cqios[8])
ic.bca.cqiossup <- c(ic.bca.cqiossup,calc.cqios[9])
pdf(paste("Histogram of contribution of ", textlugares[i]," (OS)", ".pdf", sep = ""), height = 7, width = 7, useDingbats=FALSE)
par(mfrow=c(1,2))
hist(qalphaiosaux,main="Histogram", xlab=paste("Contribution of ", textlugares[i]," (OS)"))
if(cpdfVal=="Color pdf")
{
abline(v=cqios.mean[j], lwd=2, col="blue")
abline(v=dalphaios[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqios.mean[j], lwd=2)
abline(v=dalphaios[i,j], lty =2, lwd=2)
}
qqnorm(qalphaiosaux)
dev.off()
postscript(paste("Histogram of contribution of ", textlugares[i]," (OS)", ".eps", sep = ""), height = 600, width = 1200, horizontal=FALSE)
par(mfrow=c(1,2))
hist(qalphaiosaux,main="Histogram", xlab=paste("Contribution of ", textlugares[i]," (OS)"))
if(cepsVal=="Color eps")
{
abline(v=cqios.mean[j], lwd=2, col="blue")
abline(v=dalphaios[i,j], lty =2, lwd=2, col="red")
}else{
abline(v=cqios.mean[j], lwd=2)
abline(v=dalphaios[i,j], lty =2, lwd=2)
}
qqnorm(qalphaiosaux)
dev.off()
}#end for (j in 1:dim (dalphaios)[2])
calc.cqios <-array(cbind(unlist(dalphaios[i,]), cqios.mean, se.cqios, sesgo.cqios, ic.t.cqiosinf, ic.t.cqiossup, ic.p.cqiosinf, ic.p.cqiossup, ic.bca.cqiosinf, ic.bca.cqiossup),
dim=c(nejes,10))
calc.cqios <- as.data.frame(calc.cqios)
colnames(calc.cqios) <- titulo
rownames(calc.cqios) <- ejes
cat("\n",file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
cat(textlugares[i],"\n", file="temp.txt")
file.append("Resultsbootstrap.txt","temp.txt")
write.table(round(calc.cqios, digits=2),file="temp.txt", sep="\t",dec=",")
file.append("Resultsbootstrap.txt","temp.txt")
}#end for(i in 1: dim(dalphaios)[1])
}#end if (cdalphaiosVal=="1")
file.show("Resultsbootstrap.txt")
file.remove("temp.txt")
}
OK.butboot <-tkbutton(framewigr,text=" OK ",command=OnOKboot, bg= "lightblue", width=20, foreground = "navyblue")
tkpack(OK.butboot, expand="TRUE", side= "left", fill ="both")
tkpack(framewi21,framewi22, expand = "TRUE",side="left", fill="x")
tkpack(framewi1,framewi2, expand = "TRUE",side="top", fill="both")
tkpack(framewi,framewigr, expand = "TRUE",side="top", fill="y")
}#end bootcnca
gcoia <-function(typeg)
{
if(typeg=="all")
{
winall<-tktoplevel()
tkwm.title(winall,"All Graphs")
plotall <- function()
{
#nomejes<-c()
#for (i in 1: nejes)
#{
# nomejes <<-c(nomejes, paste("Axis",i, sep=""))
#}#end for (i in 1:nejes)
layout(matrix(c(1, 1, 2, 1, 1, 3, 4, 5, 6), 3, 3))
par(mar=c(4,4,2,2))
##coinercia
datosaux<-rbind(colugaresz, colugaresy)
limixa <- round(c(min(datosaux[,dim1],0), max(datosaux[,dim1],0)), digits=2)
limiya <- round(c(min(datosaux[,dim2],0), max(datosaux[,dim2],0)), digits=2)
plot(datosaux[,c(dim1,dim2)], main=Namesit, type="n",xlab=paste(round(inerciatot[dim1]*100, digits=2),"%"),ylab=paste(round(inerciatot[dim2]*100,digits=2),"%"), asp=1/1, xlim = limixa * 1.01, ylim = limiya * 1.01)
arrows(colugaresz[,dim1],colugaresz[,dim2],colugaresy[,dim1],colugaresy[,dim2],col=collugares,lty=1, length=0.05)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
datost <<-colugaresy
for (d in 1:ejes)
{
dimension <- cbind(colugaresy[,d], colugaresz[,d])
datost[,d]<<-rowMeans(dimension)
}
for (i in 1: length(textlugares))
{
boxed.labels(datost[i,dim1],datost[i,dim2],labels=textlugares[i], col= collugares[i], cex= as.numeric(cexlugares[i]), border = collugares[i])
}
##especies
datosaux<-coespecies
limixa <- round(c(min(datosaux[,dim1],0), max(datosaux[,dim1],0)), digits=2)
limiya <- round(c(min(datosaux[,dim2],0), max(datosaux[,dim2],0)), digits=2)
plot(datosaux[,c(dim1,dim2)], main= Namespe, type="n",xlab=paste(round(inerciatot[dim1]*100, digits=2),"%"),ylab=paste(round(inerciatot[dim2]*100,digits=2),"%"), asp=1/1, xlim = limixa * 1.01, ylim = limiya * 1.01)
arrows(centro[1],centro[2],coespecies[,dim1],coespecies[,dim2],col=colespecies,lty=1, length=0.08)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
text(datosaux[,dim1],datosaux[,dim2],labels=textespecies, col= colespecies, cex= as.numeric(cexespecies))
##variables
datosaux<-covambien
limixa <- round(c(min(datosaux[,dim1],0), max(datosaux[,dim1],0)), digits=2)
limiya <- round(c(min(datosaux[,dim2],0), max(datosaux[,dim2],0)), digits=2)
plot(datosaux[,c(dim1,dim2)], main= Namevar, type="n",xlab=paste(round(inerciatot[dim1]*100, digits=2),"%"),ylab=paste(round(inerciatot[dim2]*100,digits=2),"%"), asp=1/1, xlim = limixa * 1.01, ylim = limiya * 1.01)
arrows(centro[1],centro[2],covambien[,dim1],covambien[,dim2],col=colvariables,lty=1, length=0.08)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
text(datosaux[,dim1],datosaux[,dim2],labels=textvariables, col= colvariables, cex= as.numeric(cexvariables))
##ejes especies
plot(0,0, type="n", xlim=c(-1,1), ylim=c(-1,1), asp=1/1, main=paste(Namespe, " axes"), xlab="", ylab="")
draw.circle(0,0,1, border="black", lty=1,lwd=1)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
arrows(centro[1],centro[2],Xaxes[,dim1],Xaxes[,dim2],lty=1, length=0.08)
text(Xaxes[,dim1],Xaxes[,dim2],labels=paste("Axis", 1:nejes))
##ejes variables
plot(0,0, type="n", xlim=c(-1,1), ylim=c(-1,1), asp=1/1, main=paste(Namevar, " axes"), xlab="", ylab="")
draw.circle(0,0,1, border="black", lty=1,lwd=1)
if (cbVal=="1"){
abline(h=centro[2],v=centro[1],lty="dotted")
}#end if (cbVal=="1")
arrows(centro[1],centro[2],Yaxes[,dim1],Yaxes[,dim2],lty=1, length=0.08)
text(Yaxes[,dim1],Yaxes[,dim2],labels=paste("Axis", 1:nejes))
#layout(matrix(c(1),1, 1))
}
imgall <- tkrplot(winall,fun=plotall,hscale=as.numeric(hescale),vscale=as.numeric(vescale))
tkpack(imgall, expand="TRUE", fill="both")
tkfocus(winall)
}else{
typecoia<<-typeg
if(typecoia=="sg")
{
datos <<-rbind(colugaresy, colugaresz)
textos <<-colugaresy
for (d in 1:ejes)
{
dimension <- cbind(colugaresy[,d], colugaresz[,d])
textos[,d]<<-rowMeans(dimension)
}
limix <<- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <<- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
tclvalue(Limix1) <<- limix[1]
tclvalue(Limix2) <<- limix[2]
tclvalue(Limiy1) <<- limiy[1]
tclvalue(Limiy2) <<- limiy[2]
}
if(typecoia=="eg")
{
datos<<-coespecies
textos<<-datos
limix <<- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <<- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
tclvalue(Limix1) <<- limix[1]
tclvalue(Limix2) <<- limix[2]
tclvalue(Limiy1) <<- limiy[1]
tclvalue(Limiy2) <<- limiy[2]
}
if(typecoia=="vg")
{
datos<<-covambien
textos<<-datos
limix <<- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <<- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
tclvalue(Limix1) <<- limix[1]
tclvalue(Limix2) <<- limix[2]
tclvalue(Limiy1) <<- limiy[1]
tclvalue(Limiy2) <<- limiy[2]
}
if(typecoia=="ef")
{
datos <<-Xaxes
textos <<-datos
limix <<- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <<- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
tclvalue(Limix1) <<- limix[1]
tclvalue(Limix2) <<- limix[2]
tclvalue(Limiy1) <<- limiy[1]
tclvalue(Limiy2) <<- limiy[2]
}
if(typecoia=="vf")
{
datos <<-Yaxes
textos <<-datos
limix <<- round(c(min(datos[,dim1],0), max(datos[,dim1],0)), digits=2)
limiy <<- round(c(min(datos[,dim2],0), max(datos[,dim2],0)), digits=2)
tclvalue(Limix1) <<- limix[1]
tclvalue(Limix2) <<- limix[2]
tclvalue(Limiy1) <<- limiy[1]
tclvalue(Limiy2) <<- limiy[2]
}
tkrreplot(img)
}
}#end gcoia
projections <- function(project)
{
proj<<-project
if(proj=="normal")
{
tkrreplot(img)
return()
}#end if(proj=="normal")
if(proj=="e" | (proj=="s" & cblugares=="1"))
{
wproj <- tktoplevel()
tkwm.title(wproj, paste("Select ",Namevar))
scrproj <- tkscrollbar(wproj, repeatinterval=5, command=function(...)tkyview(tlproj,...))
tlproj<-tklistbox(wproj,height=6,width=42,yscrollcommand=function(...)tkset(scrproj,...),background="white")
for (i in 1:Numbercuant)
{
tkinsert(tlproj,"end",textvariables[i])
}#end for (i in 1:Numbercuant)
tkselection.set(tlproj,0) # Indexing starts at zero.
OnOKproj <- function()
{
Choiceproj <<- as.numeric(tkcurselection(tlproj))+1
tkdestroy(wproj)
tkrreplot(img)
}#end OnOKproj <- function()
OK.butp <- tkbutton(wproj, text = " OK ", command = OnOKproj)
tkpack(tlproj,scrproj,expand = "TRUE", side="left", fill = "both")
tkpack.configure(scrproj,side="left")
tkpack(OK.butp,expand = "TRUE", side="left", fill = "both")
tkfocus(wproj)
tkwait.window(wproj)
}#end if
}#end projections <-function()
showaxes <- function()
{
if(cbVal=="1")
{
cbVal<<-"0"
tkrreplot(img)
}else{
cbVal<<-"1"
tkrreplot(img)
}#end if(cbVal=="1")
}#end showaxes
showsites <- function()
{
if(cblugares=="1")
{
cblugares<<-"0"
cblablugares<<-"0"
tkrreplot(img)
}else{
cblugares<<-"1"
tkrreplot(img)
}#end if(cblugares=="1")
}#end showsites
showlabsites <- function()
{
if(cblablugares=="1")
{
cblablugares<<-"0"
tkrreplot(img)
}else{
cblablugares<<-"1"
cblugares<<-"1"
indexLabeled <<- c(indexLabeled,
(length(textespecies)+length(textvariables)+1):(length(textespecies)+length(textvariables)+length(textlugares)))
tkrreplot(img)
}#end if(cblablugares=="1")
}#end showlabsites
changetit <- function()
{
ctwin<-tktoplevel()
tkwm.title(ctwin,"Change title")
OnOKchantit <- function()
{
tit_graph <<- tclvalue(tit_gr)
tkrreplot(img)
tkdestroy(ctwin)
}
OK.butchantit<-tkbutton(ctwin,text=" Change ", command=OnOKchantit, bg= "lightblue", width=20, foreground = "navyblue")
tkbind(OK.butchantit, "<Return>",OnOKchantit)
tit_gr<-tclVar(tit_graph)
entry.tit <-tkentry(ctwin, width="50",textvariable=tit_gr, bg="white")
tkbind(entry.tit, "<Return>",OnOKchantit)
tkpack(tklabel(ctwin,text="New title: "),entry.tit, expand = "TRUE", side="left", fill = "both")
tkpack(OK.butchantit)
tkfocus(ctwin)
}#end changetit
topMenugr <- tkmenu(wgr)
tkconfigure(wgr, menu = topMenugr)
menuFile <- tkmenu(topMenugr, tearoff = FALSE)
menuSaveAs <- tkmenu(topMenugr, tearoff = FALSE)
menu3d <- tkmenu(topMenugr, tearoff = FALSE)
menuproj <- tkmenu(topMenugr, tearoff = FALSE)
menuboot <- tkmenu(topMenugr, tearoff = FALSE)
menuopt <-tkmenu(topMenugr, tearoff = FALSE)
menucoia <-tkmenu(topMenugr, tearoff = FALSE)
tkadd(menuFile, "command", label = "Copy image", command = function() {tkrreplot(img)})
tkadd(menuFile, "cascade", label = "Save image", menu = menuSaveAs)
tkadd(menuSaveAs, "command", label = "Pdf file", command = function() {SaveFilePDF()})
tkadd(menuSaveAs, "command", label = "Eps file", command = function() {SaveFileeps()})
#tkadd(menuSaveAs, "command", label = "Bmp file", command = function() {SaveFileBmp()})
tkadd(menuSaveAs, "command", label = "Png file", command = function() {SaveFilePng()})
tkadd(menuSaveAs, "command", label = "Jpg/Jpeg file", command = function() {SaveFileJPG()})
tkadd(menuFile, "separator")
tkadd(menuFile, "command", label = "Exit", command = function() {tkdestroy(wgr)})
tkadd(menu3d, "command", label = "3D", command = function() {g3d()})
tkadd(menuboot, "command", label = "Bootstrap", command = function() {bootcnca()})
tkadd(menuopt, "command", label = "Change title", command = function() {changetit()})
tkadd(menuopt, "command", label = "Show/Hide axes", command = function() {showaxes()})
if (cccaVal!="COIA")
{
tkadd(menuopt, "command", label = paste("Show/Hide ", Namesit), command = function() {showsites()})
tkadd(menuopt, "command", label = paste("Show/Hide labels for", Namesit), command = function() {showlabsites()})
}
tkadd(topMenugr, "cascade", label ="File", menu = menuFile)
tkadd(menuFile, "separator")
tkadd(topMenugr, "cascade", label = "3D", menu = menu3d)
if (cccaVal!="COIA")
{
tkadd(menuproj, "command", label = Namespe, command = function() {projections(project="e")})
tkadd(menuproj, "command", label = Namesit, command = function() {projections(project="s")})
tkadd(menuproj, "command", label = "Back to original graph", command = function() {projections(project="normal")})
tkadd(topMenugr, "cascade", label = "Projections", menu = menuproj)
tkadd(topMenugr, "cascade", label = "Bootstrap", menu = menuboot)
}else{
tkadd(topMenugr, "cascade", label = "COIA", menu = menucoia)
tkadd(menucoia, "command", label = "Show all graphs", command = function() {gcoia(typeg="all")})
tkadd(menucoia, "command", label = paste(Namesit, " graph"), command = function() {gcoia(typeg="sg")})
tkadd(menucoia, "command", label = paste(Namespe, " graph"), command = function() {gcoia(typeg="eg")})
tkadd(menucoia, "command", label = paste(Namevar, " graph"), command = function() {gcoia(typeg="vg")})
tkadd(menucoia, "command", label = paste(Namespe, " axes"), command = function() {gcoia(typeg="ef")})
tkadd(menucoia, "command", label = paste(Namevar, " axes"), command = function() {gcoia(typeg="vf")})
}
tkadd(topMenugr, "cascade", label = "Options", menu = menuopt)
OnLeftClick.up <- function(x,y)
{
if(cccaVal!="COIA" | typecoia %in% c("all", "sg", "eg", "vg"))
{
msg <- ("-To change the label press Yes.\n-To remove it press No.\n-If you do not want to do anything press Cancel.")
mbval<- tkmessageBox(title="Change of label", message=msg,type="yesnocancel",icon="question")
if (tclvalue(mbval)=="yes"){
indexLabeled <<- c(indexLabeled,indexClosest)
}#end if (tclvalue(mbval)=="yes")
if(tclvalue(mbval)=="no"){
indexLabeledaux<<-c()
for (i in (1:length(indexLabeled)))
{
if (indexLabeled[i]!=indexClosest)
indexLabeledaux <<- c(indexLabeledaux,indexLabeled[i])
}#end for (i in (1:length(indexLabeled)))
indexLabeled<<-indexLabeledaux
}#end if(tclvalue(mbval)=="no")
if(tclvalue(mbval)=="cancel"){
if ((cblugares=="1")|(cblablugares=="1")|(cccaVal=="COIA")){
textos[indexClosest,dim1] <<- anteriorx
textos[indexClosest,dim2] <<- anteriory
}else{
textosr[indexClosest,dim1] <<- anteriorx
textosr[indexClosest,dim2] <<- anteriory
}#end if (cblugares=="1")
}#end if(tclvalue(mbval)=="cancel")
tkrreplot(img)
}
}#end OnLeftClick.up <- function(x,y)
OnLeftClick.move <- function(x,y)
{
if(cccaVal!="COIA" | typecoia %in% c("all", "sg", "eg", "vg"))
{
xClick <- x
yClick <- y
width = as.numeric(tclvalue(tkwinfo("reqwidth",img)))
height = as.numeric(tclvalue(tkwinfo("reqheight",img)))
xMin = parPlotSize[1] * width
xMax = parPlotSize[2] * width
yMin = parPlotSize[3] * height
yMax = parPlotSize[4] * height
rangeX = usrCoords[2] - usrCoords[1]
rangeY = usrCoords[4] - usrCoords[3]
imgXcoords = (xCoords-usrCoords[1])*(xMax-xMin)/rangeX + xMin
imgYcoords = (yCoords-usrCoords[3])*(yMax-yMin)/rangeY + yMin
xClick <- as.numeric(xClick)+0.5
yClick <- as.numeric(yClick)+0.5
yClick <- height - yClick
xPlotCoord = usrCoords[1]+(xClick-xMin)*rangeX/(xMax-xMin)
yPlotCoord = usrCoords[3]+(yClick-yMin)*rangeY/(yMax-yMin)
if ((cblugares=="1")|(cblablugares=="1")|(cccaVal=="COIA")){
textos[indexClosest,dim1]<<-xPlotCoord
textos[indexClosest,dim2]<<-yPlotCoord
}else{
textosr[indexClosest,dim1]<<-xPlotCoord
textosr[indexClosest,dim2]<<-yPlotCoord
}#end if (cblugares=="1")
tkrreplot(img)
}
}#end OnLeftClick.move <- function(x,y)
OnLeftClick.down <- function(x,y)
{
if(cccaVal!="COIA" | typecoia %in% c("all", "sg", "eg", "vg"))
{
anteriorx <- NULL
anteriory <- NULL
xClick <- x
yClick <- y
width <- as.numeric(tclvalue(tkwinfo("reqwidth",img)))
height <- as.numeric(tclvalue(tkwinfo("reqheight",img)))
xMin <- parPlotSize[1] * width
xMax <- parPlotSize[2] * width
yMin <- parPlotSize[3] * height
yMax <- parPlotSize[4] * height
rangeX <- usrCoords[2] - usrCoords[1]
rangeY <- usrCoords[4] - usrCoords[3]
imgXcoords <- (xCoords-usrCoords[1])*(xMax-xMin)/rangeX + xMin
imgYcoords <- (yCoords-usrCoords[3])*(yMax-yMin)/rangeY + yMin
xClick <- as.numeric(xClick)+0.5
yClick <- as.numeric(yClick)+0.5
yClick <- height - yClick
xPlotCoord <- usrCoords[1]+(xClick-xMin)*rangeX/(xMax-xMin)
yPlotCoord <- usrCoords[3]+(yClick-yMin)*rangeY/(yMax-yMin)
squared.Distance <- (xClick-imgXcoords)^2 + (yClick-imgYcoords)^2
indexClosest <<- which.min(squared.Distance)
if ((cblugares=="1")|(cblablugares=="1")|(cccaVal=="COIA")){
anteriorx <<- textos[indexClosest,dim1]
anteriory <<- textos[indexClosest,dim2]
}else{
anteriorx <<- textosr[indexClosest,dim1]
anteriory <<- textosr[indexClosest,dim2]
}#end if (cblugares=="1")
}
}#end OnLeftClick.down <- function(x,y)
OnRightClick <- function(x,y)
{
if(cccaVal!="COIA" | typecoia %in% c("all", "sg", "eg", "vg"))
{
xClick <- x
yClick <- y
width <- as.numeric(tclvalue(tkwinfo("reqwidth",img)))
height <- as.numeric(tclvalue(tkwinfo("reqheight",img)))
xMin <- parPlotSize[1] * width
xMax <- parPlotSize[2] * width
yMin <- parPlotSize[3] * height
yMax <- parPlotSize[4] * height
rangeX <- usrCoords[2] - usrCoords[1]
rangeY <- usrCoords[4] - usrCoords[3]
imgXcoords <- (xCoords-usrCoords[1])*(xMax-xMin)/rangeX + xMin
imgYcoords <- (yCoords-usrCoords[3])*(yMax-yMin)/rangeY + yMin
xClick <- as.numeric(xClick)+0.5
yClick <- as.numeric(yClick)+0.5
yClick <- height - yClick
xPlotCoord <- usrCoords[1]+(xClick-xMin)*rangeX/(xMax-xMin)
yPlotCoord <- usrCoords[3]+(yClick-yMin)*rangeY/(yMax-yMin)
labelClosestPointd(xClick,yClick,imgXcoords,imgYcoords)
}
}#end OnRightClick <- function(x,y)
tkbind(img, "<B1-Motion>",OnLeftClick.move)
tkbind(img, "<ButtonPress-1>",OnLeftClick.down)
tkbind(img, "<ButtonRelease-1>",OnLeftClick.up)
tkconfigure(img,cursor="pencil")
tkbind(img, "<Button-3>",OnRightClick)
tkconfigure(img,cursor="pencil")
}#end if (nejes > length(descom$d))
}#end Onaxis<-function()
numaxis <- tclVar( 1 )
enumaxis <-tkentry(barvp,width="50",textvariable=numaxis)
but.axis <-tkbutton(barvp,text="Choose",command=Onaxis, bg= "lightblue", width=10, foreground = "navyblue")
tkpack(imgbar, expand="TRUE", fill="both")
tkpack(tklabel(barvp,text="Select the number of axes:"),
enumaxis,but.axis,expand="FALSE", side= "left", fill ="both")
tkfocus(barvp)
}#end Graphics <- function()
graphic.button <-tkbutton(framegraphic,text="Graph",command=Graphics, bg= "lightblue", width=20, foreground = "navyblue")
tkpack(tlv,scrv,expand = "TRUE", side="left", fill = "both")
tkpack.configure(scrv,side="left")
tkpack(OK.butv,expand = "TRUE", side="left", fill = "both")
tkfocus(tt)
#######Color#######################################
indicev<-as.numeric(tkcurselection(tlv))+1
colorv <- colvariables[indicev[1]]
canvasv <- tkcanvas(framecol21,width="57",height="20",bg=colorv)
ChangeColorv <- function()
{
colorv <<- tclvalue(tcl("tk_chooseColor",initialcolor=colvariables[indicev[1]],title="Choose a color"))
if (nchar(colorv)>0)
{
tkconfigure(canvasv,bg=colorv)
colvariables[indicev]<<-colorv
}#end if (nchar(colorv)>0)
}#end ChangeColorv <- function()
ChangeColor.buttonv<- tkbutton(framecol22,text="Change Color",command=ChangeColorv,width=4)
tkpack(canvasv,expand = "TRUE", side="left", fill = "both")
tkpack(ChangeColor.buttonv,expand = "TRUE", side="left", fill = "both")
######Labels ###################################
Namev <- textvariables[indicev[1]]
entry.Namev <-tkentry(framename21,width="10",textvariable=Namev, bg="white")
OnOKlv <- function()
{
NameValv <<- tclvalue(Namev)
textvariables[indicev[1]] <<-NameValv
#####Values of listbox###############################
for (i in 1:dimvambien[2])
{
tkdelete(tlv,0)
}#end for (i in 1:dimvambien[2])
for (i in (1:(dimvambien[2])))
{
tkinsert(tlv,"end",textvariables[i])
}#end for (i in (1:(dimvambien[2])))
}#end OnOKlv <- function()
OK.butlv <-tkbutton(framename22,text="Change label",command=OnOKlv,width=4)
tkbind(entry.Namev, "<Return>",OnOKlv)
tkpack(entry.Namev,expand = "TRUE", side="left", fill = "both")
tkpack(OK.butlv,expand = "TRUE", side="left", fill = "both")
###### Sizes ###################################
Cexv <- cexvariables[indicev[1]]
entry.Cexv <-tkentry(framecex21,width="10",textvariable=Cexv, bg="white")
OnOKcv <- function()
{
NameCexv <<- tclvalue(Cexv)
cexvariables[indicev] <<-NameCexv
}#end OnOKcv <- function()
OK.butcv <-tkbutton(framecex22,text="Change size",command=OnOKcv,width=4)
tkbind(entry.Cexv, "<Return>",OnOKlv)
tkpack(entry.Cexv,expand = "TRUE", side="left", fill = "both")
tkpack(OK.butcv,expand = "TRUE", side="left", fill = "both")
######Symbols###################################
tkpack(tklabel(frames21,text=" ",width=27),expand = "TRUE", side="left", fill = "both")
##### List of sites ###########################
scrl <- tkscrollbar(framet3, repeatinterval=5, command=function(...)tkyview(tll,...))
tll<-tklistbox(framet3,height=6,width=42,selectmode="multiple",yscrollcommand=function(...)tkset(scrl,...),background="white")
tkpack(tklabel(frametext3,text=Namesit),side="left",expand = "TRUE",fill="both")
for (i in (1:(dimespec[1])))
{
tkinsert(tll,"end",textlugares[i])
}#end for (i in (1:(dimespec[1])))
tkselection.set(tll,0) # Indexing starts at zero.
OnOKl <- function()
{
Choicel <<- textespecies[as.numeric(tkcurselection(tll))+1]
##### Color of the selected variable #############
indicel<<-as.numeric(tkcurselection(tll))+1
colorl <- collugares[indicel[1]]
tkconfigure(canvasl,bg=colorl)
##### Text of the selected variable ###############
Namel <<- tclVar(textlugares[indicel[1]])
tkconfigure(entry.Namel,textvariable=Namel)
tkconfigure(comboBoxl,text=simlugares[indicel[1]])
##### Size of the selected variable ###############
Cexl <<- tclVar(cexlugares[indicel[1]])
tkconfigure(entry.Cexl,textvariable=Cexl)
tkconfigure(comboBoxl,text=simlugares[indicel[1]])
}#end OnOKl <- function()
OK.butl <-tkbutton(frameok3,text=" OK ",command=OnOKl)
tkpack(tll,scrl,expand = "TRUE", side="left", fill = "both")
tkpack.configure(scrl,side="left")
tkpack(OK.butl,expand = "TRUE", side="left", fill = "both")
tkfocus(tt)
#######Color#######################################
indicel<-as.numeric(tkcurselection(tll))+1
colorl <- collugares[indicel[1]]
canvasl <- tkcanvas(framecol31,width="57",height="20",bg=colorl)
ChangeColorl <- function()
{
colorl <<- tclvalue(tcl("tk_chooseColor",initialcolor=collugares[indicel[1]],title="Choose a color"))
if (nchar(colorl)>0)
{
tkconfigure(canvasl,bg=colorl)
collugares[indicel]<<-colorl
}#end if (nchar(colorl)>0)
}#end ChangeColorl <- function()
ChangeColor.buttonl<- tkbutton(framecol32,text="Change Color",command=ChangeColorl,width=4)
tkpack(canvasl,expand = "TRUE", side="left", fill = "both")
tkpack(ChangeColor.buttonl,expand = "TRUE", side="left", fill = "both")
######Labels ###################################
Namel <- textlugares[indicel[1]]
entry.Namel <-tkentry(framename31,width="10",textvariable=Namel, bg="white")
OnOKll <- function()
{
NameVall <<- tclvalue(Namel)
textlugares[indicel[1]] <-NameVall
#####Values of listbox###############################
for (i in 1:dimespec[1])
{
tkdelete(tll,0)
}#end for (i in 1:dimespec[1])
for (i in (1:(dimespec[1])))
{
tkinsert(tll,"end",textlugares[i])
}#end for (i in (1:(dimespec[1])))
}#end OnOKll <- function()
OK.butll <-tkbutton(framename32,text="Change label",command=OnOKll,width=4)
tkbind(entry.Namel, "<Return>",OnOKll)
tkpack(entry.Namel,expand = "TRUE", side="left", fill = "both")
tkpack(OK.butll,expand = "TRUE", side="left", fill = "both")
######Labels ###################################
Cexl <- cexlugares[indicel[1]]
entry.Cexl <-tkentry(framecex31,width="10",textvariable=Cexl, bg="white")
OnOKcl <- function()
{
NameCexl <<- tclvalue(Cexl)
cexlugares[indicel] <<-NameCexl
}#end OnOKcl <- function()
OK.butcl <-tkbutton(framecex32,text="Change size",command=OnOKcl,width=4)
tkbind(entry.Cexl, "<Return>",OnOKll)
tkpack(entry.Cexl,expand = "TRUE", side="left", fill = "both")
tkpack(OK.butcl,expand = "TRUE", side="left", fill = "both")
######Symbols###################################
comboBoxl <- tkwidget(frames31,"ComboBox",editable=FALSE,values=symbolos,width=7, background="white")
chang.syml <- function()
{
simChoicel <<-symbolos[as.numeric(tclvalue(tcl(comboBoxl,"getvalue")))+1]
simlugares[indicel] <<-simChoicel
}#end chang.syml <- function()
Change.symboll <-tkbutton(frames32,text="Change symbol",command=chang.syml,width=4)
tkpack(comboBoxl,side="left",expand="TRUE", fill="both")
tkpack(Change.symboll,side="left",expand="TRUE", fill="both")
tkpack(tklabel(frametext4,text=""),side="right",expand = "TRUE",fill="both")
tkpack(tklabel(framet4,text=""),side="right",expand = "TRUE",fill="both")
tkpack(tklabel(frameok4,text=""),side="right",expand = "TRUE",fill="both")
tkpack(tklabel(frames4,text=""),side="right",expand = "TRUE",fill="both")
tkpack(tklabel(framehvtitle,text="Graph size"),side="right",expand = "TRUE",fill="both")
tkpack(tklabel(framehnames,text="Horizontal"),side="right",expand = "TRUE",fill="both")
tkpack(tklabel(framevnames,text="Vertical"),side="right",expand = "TRUE",fill="both")
##### Textbox to change the size of the graph window #####
entryvalueh <- tclVar(hescale)
entryh <-tkentry(framehtext,width="10",textvariable=entryvalueh, bg="white")
tkbind(entryh, "<Return>",Graphics)
entryvaluev <- tclVar(vescale)
entryv <-tkentry(framevtext,width="10",textvariable=entryvaluev, bg="white")
tkbind(entryv, "<Return>",Graphics)
tkpack(entryh, entryv, expand = "TRUE",side="top", fill="both")
tkpack(tklabel(framecol41,text="Show axes"),expand = "TRUE", side="left", fill = "both")
tkpack(cb,expand = "TRUE", side="left",expand="TRUE", fill = "both")
tkpack(tklabel(framename41,text=paste("Show", Namesit)),expand = "TRUE", side="left", fill = "both")
tkpack(cbl,expand = "TRUE", side="left", fill = "both")
tkpack(tklabel(framecex41,text=paste("Show labels for", Namesit)),expand = "TRUE", side="left", fill = "both")
tkpack(cbll,expand = "TRUE", side="left", fill = "both")
tkpack(tklabel(frames41,text=" ",width=27),expand = "TRUE", side="left", fill = "both")
tkpack(framecol41,framecol42, side="left", expand = "TRUE", fill="both")
if(cccaVal!="COIA")
{
tkpack(framename41,framename42, side="left", expand = "TRUE", fill="both")
tkpack(framecex41,framecex42, side="left", expand = "TRUE", fill="both")
}
#tkpack(frames41, side="left", expand = "TRUE", fill="both")
tkpack(framecol11,framecol12, side="left", expand = "TRUE", fill="both")
tkpack(framename11,framename12, side="left", expand = "TRUE", fill="both")
tkpack(framecex11,framecex12, side="left", expand = "TRUE", fill="both")
tkpack(frames11,frames12, side="left", expand = "TRUE", fill="both")
tkpack(framecol21,framecol22, side="left", expand = "TRUE", fill="both")
tkpack(framename21,framename22, side="left", expand = "TRUE", fill="both")
tkpack(framecex21,framecex22, side="left", expand = "TRUE", fill="both")
tkpack(frames21, side="left", expand = "TRUE", fill="both")
tkpack(framecol31,framecol32, side="left", expand = "TRUE", fill="both")
tkpack(framename31,framename32, side="left", expand = "TRUE", fill="both")
tkpack(framecex31,framecex32, side="left", expand = "TRUE", fill="both")
tkpack(frames31,frames32, side="left", expand = "TRUE", fill="both")
tkpack(frametext1,framet1,frameok1,framecol1,framename1,framecex1,frames1,expand = "TRUE", fill="both")
tkpack(frametext2,framet2,frameok2,framecol2,framename2,framecex2,frames2,expand = "TRUE", fill="both")
tkpack(frametext3,framet3,frameok3,framecol3,framename3,framecex3,frames3,expand = "TRUE", fill="both")
tkpack(framecol4,framename4,framecex4,expand = "FALSE", fill="both")
tkpack(framehnames, framevnames, expand = "FALSE", fill="both")
tkpack(framehtext, framevtext, expand = "FALSE", fill="both")
tkpack(framehvnames, framehvtext,expand = "FALSE",side="left", fill="both")
tkpack(framehvtitle, framehv, expand = "FALSE", fill="both")
tkpack(frametext4,framet4,frameok4,frames4,framett4aux,framett4auxgs, expand = "FALSE", fill="both")
tkpack(graphic.button, expand="TRUE", side= "left", fill ="both")
tkpack(framett1,framett2,framett3, framett4,expand = "TRUE",side="left", fill="both")
tkpack(framett,framegraphic,expand = "TRUE",side="top", fill="y")
}#end OnOKnames<-function()
framenames<-tkframe(wnames, relief = "flat", borderwidth = 2, background = "white")
framee<-tkframe(framenames, relief = "flat", borderwidth = 2, background = "white")
framel<-tkframe(framenames, relief = "flat", borderwidth = 2, background = "white")
frameoknames<-tkframe(wnames, relief = "flat", borderwidth = 2, background = "white")
OK.butnames<-tkbutton(frameoknames,text=" OK ", command=OnOKnames, bg= "lightblue", width=20, foreground = "navyblue")
tkbind(OK.butnames, "<Return>",OnOKnames)
sitesname<-tclVar("Sites")
speciesname<-tclVar("Species")
variablesname<-tclVar("Environmental v")
# mixto<-tclVar("NO")
ncuant<-tclVar(dim(fvambientales)[2])
nmixto<-tclVar(0)
entry.Namesit <-tkentry(framee,width="50",textvariable=sitesname, bg="white")
tkbind(entry.Namesit, "<Return>",OnOKnames)
entry.Namespec <-tkentry(framee,width="50",textvariable=speciesname, bg="white")
tkbind(entry.Namespec, "<Return>",OnOKnames)
entry.Namev <-tkentry(framee,width="50",textvariable=variablesname, bg="white")
tkbind(entry.Namev, "<Return>",OnOKnames)
if (cccaVal!="COIA")
{
# entry.Namemix <-tkentry(framee,width="50",textvariable=mixto, bg="white")
# tkbind(entry.Namemix, "<Return>",OnOKnames)
#
entry.Namencuant <-tkentry(framee,width="50",textvariable=ncuant, bg="white")
tkbind(entry.Namencuant, "<Return>",OnOKnames)
entry.Namenmix <-tkentry(framee,width="50",textvariable=nmixto, bg="white")
tkbind(entry.Namenmix, "<Return>",OnOKnames)
tkpack(tklabel(framel,text="Names for sites:"),
tklabel(framel,text="Names for species:"),
tklabel(framel,text="Names for environmental v:"),
# tklabel(framel,text="Mixed environmental variables?:"),
tklabel(framel,text="Number of cuantitative variables:"),
tklabel(framel,text="Number of categorical variables:"), expand = "TRUE", side="top", fill = "both")
tkpack(OK.butnames)
tkpack(entry.Namesit, entry.Namespec, entry.Namev, #entry.Namemix,
entry.Namencuant, entry.Namenmix,
expand = "TRUE",side="top", fill="both")
}else{
tkpack(tklabel(framel,text="Names for sites:"),
tklabel(framel,text="Names for species:"),
tklabel(framel,text="Names for environmental v:"),
expand = "TRUE", side="top", fill = "both")
tkpack(OK.butnames)
tkpack(entry.Namesit, entry.Namespec, entry.Namev,
expand = "TRUE",side="top", fill="both")
}
tkpack(framel, framee, expand = "TRUE",side="left", fill="y")
tkpack(framenames, frameoknames, expand = "TRUE",side="top", fill="y")
tkfocus(wnames)
}#end OnOKinf <- function()
OK.butinf <-tkbutton(winfor,text=" OK ",command=OnOKinf, bg= "lightblue", width=20, foreground = "navyblue")
tkbind(OK.butinf, "<Return>",OnOKinf)
tkpack(OK.butinf)
tkfocus(winfor)
}#end function
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.