R/bassAckward.diagram.r

In psych: Procedures for Psychological, Psychometric, and Personality Research

#modified 6/620  to increase drastically increase speed by taking the drawing out of a loop
#fixed a problem of plotting in wrong order   8/20/20
#perhaps finally fixed the variables to appear in the right order for both lr and vertical mode  09/12/20
bassAckward.diagram <- function(x,digits=2,cut = .3,labels=NULL,marg=c(1.5,.5,1.0,.5),
main="BassAckward",items=TRUE,sort=TRUE,lr=TRUE,curves=FALSE,organize=TRUE,values=FALSE,...) {
 old.par<- par(mar=marg)  #give the window some narrower margins
    on.exit(par(old.par))  #set them back

if(x$fm == "pca") {pca <-TRUE} else {pca <- FALSE}  #added 19/08/21 to draw boxes for components
if(organize) x <- ba.organize(x)    
nf = length(x$bass.ack) #this counts how many results are there
if(!items) nf <- nf-1
if(sort){ x$bass.ack[[nf]] <- fa.sort(x$bass.ack[[nf]])
       x$labels[[nf]] <- rownames(x$bass.ack[[nf]]) }
       
if(lr) {ylim <- c(0,NROW(x$bass.ack[[nf]]))   #this is the number of variables 
	    xlim <- c(-1.1,(nf-1.9)) } else {xlim <- c(.9,NROW(x$bass.ack[[nf]]))
        ylim <- c(-1.1,(nf-1.9))}
lower <- list()
upper <- list()
if(is.null(labels)) labels <- x$labels
if(values) labels<- add.values(labels,x$fa.vac , lr = lr)
if(items) labels[[nf]] <- x$labels[[nf]]  #this puts in the bottom row/left hand side (the items) 
plot(0,type="n",xlim=xlim,ylim=ylim,frame.plot=FALSE,axes=FALSE,ylab="",xlab="",main=main)
#first draw the bottom row
nvar <- NROW(x$bass.ack[[nf]])
max.var <- nvar
rname <- labels[[nf]] 


if(lr) {
	all.rects.x <- rep(-1,nvar)
	
	all.rects.y <- seq(nvar,1, -1 ) #top to bottom numbering
	all.rects.rname <- rname[1:nvar] 
	} else {
 	all.rects.y <- rep(-1,nvar)
	all.rects.x <- seq(1:nvar) 
	#all.rects.rname <- rname[seq(nvar,1,-1)] }
	all.rects.rname <- rname[seq(1, nvar, 1)] }


#first define the various locations but don't draw them
 for(j in 1:nvar) {
   if(lr) {lower [[j]] <- dia.rect(-1, nvar - j + 1, rname[ j],draw=FALSE,...) } else {lower [[j]] <- dia.rect(j,-1, rname[j],draw=FALSE,...)}
  #  if(lr) {lower [[j]] <- dia.rect(-1,j , rname[j],draw=FALSE,...) } else {lower [[j]] <- dia.rect(j,-1, rname[j],draw=FALSE,...)}  #12/07/20
 
 
 } 
 #if either the bottom (item) row or pca draw rectangles. otherwise ellipses
if(pca | items) {dia.rect(all.rects.x,all.rects.y,all.rects.rname) } else {
 dia.multi.ellipse(all.rects.x,all.rects.y,all.rects.rname) }


#now draw the next row and then repeat until the top 

for(j in (nf):2) {
	if((j < nf)  & organize) x <- ba.organize(x,j)
	nvar <- NCOL(x$bass.ack[[j]]) 
	scale <- max.var/(nvar+1)

#store the locations
if(lr) {
	all.rects.x <- rep(nf-j,nvar)
	all.rects.y <- seq(nvar,1,-1) * scale
	all.rects.rname <- labels[[j-1]]
	} else {

 	all.rects.y <- rep(nf-j,nvar)
	all.rects.x <- seq(1:nvar) *scale
	all.rects.rname <- labels[[j-1]] }



for(i in 1:nvar) {  #which is actually the number of lower level variables or factors
  cname <- labels[[j-1]]
  
#  if(lr) {upper[[i]] <-  dia.rect(nf-j,(nvar-i + 1) *scale, labels= cname[i],draw=FALSE,...)} else {  upper[[i]] <-  dia.rect(i*scale,nf-j, labels= cname[i],draw=FALSE,...) }
    if(lr) {upper[[i]] <-  dia.ellipse(nf-j,(nvar-i + 1) *scale, labels= cname[i],draw=FALSE,e.size=1,...)} else {  upper[[i]] <-  dia.ellipse(i*scale,nf-j, labels= cname[i],draw=FALSE,e.size=1,...) }
    
    }
    
if(pca) {dia.rect(all.rects.x,all.rects.y,all.rects.rname) } else {    #this makes all the ellipses the same size, but we need to adjust the limits to match the ellipses
 dia.multi.ellipse(all.rects.x,all.rects.y,all.rects.rname) }
  #connect them and then put  in the correlation values

text.values <- list()     #save the text values from the arrows
ki <- 1   #set the counter to 1
for(i in 1:nvar) {#do it for every top factor
if(length(x$Phi)>0) {Phi <- x$Phi[[j-1]]} else {Phi <- NULL}
nfact  <- NROW(x$bass.ack[[j]])

 if(!is.null(Phi) && (ncol(Phi) >1) && curves) {

   if(i < nvar) {for(k in ((i+1):(nvar))) {
     if(abs(Phi[i,k]) > cut) {
		 if(lr){dia.curve(from=upper[[i]]$right,to=upper[[k]]$right,labels=round(Phi[i,k],digits),scale = .2 , ...) } else {dia.curve(from=upper[[i]]$top,to=upper[[k]]$top,labels=round(Phi[i,k],digits),scale = .2 , ...)}
              }
              }}
              }


for(k in 1:nfact) {
if(abs(x$bass.ack[[j]][k,i]) >  cut ) { #just draw the large loadings
   value <- x$bass.ack[[j]][k,i]
   
   if(lr) { text.values[[ki]] <- dia.arrow(upper[[i ]]$left,lower[[k]]$right,adj=((i-k) %% 3)   ,labels = round(value,digits),
                                 col=(sign(value <0) +1),lty=(sign(value<0)+1),draw=FALSE,...)
   												
   } else {
     text.values[[ki]] <-  dia.arrow(upper[[i]]$bottom,lower[[k]]$top,adj=((i-k) %% 3)   ,labels = round(value,digits),
                              col=(sign(value <0) +1),lty=(sign(value<0)+1),draw=FALSE,...)}
   ki <- ki +1 
} 
   
}


}

tv <- matrix(unlist(text.values),byrow=TRUE,ncol=21)



text(tv[,1],tv[,2],tv[,3]) # ,tv[,5])    #don't use the adj parameter
      arrows(x0=tv[,6],y0=tv[,7],x1=tv[,8],y1=tv[,9],length=tv[1,10],angle=tv[1,11],code=1,col=tv[,20],lty=tv[,21])
        arrows(x0=tv[,13],y0=tv[,14],x1=tv[,15],y1=tv[,16],length=tv[1,17],angle=tv[1,18],code=2,col=tv[,20],lty=tv[,21])


lower <- upper #go on to the next level
upper <- list()  #zeros it out 


}
invisible(x)
}

#organize the lowest two levels to get somewhat cleaner structures

ba.organize <- function(x,level=NULL){
if(is.null(level)) {nf = length(x$bass.ack) #this counts how many results are there
level0 <- fa.sort(x$bass.ack[[nf]])
x$labels[[nf]] <- rownames(level0) 
fa <- x$fa$loadings[[nf-1] ]   #added as fa$loadings to match change in bassAckward
fa <- fa[x$labels[[nf]],]
x$fa[[nf-1] ] <- fa

level1 <- fa.sort(x$bass.ack[[nf-1]]) 
ord1 <- rownames(level1)
level0 <- level0[,ord1,drop=FALSE]
colnames(level0) <- paste0("F",1:NCOL(level0))
x$bass.ack[[nf]] <- level0
x$bass.ack[[nf-1]] <- level1 } else {nf <- level  #just organize the factors, not the items



}
return(x)
}


add.values <- function(labels=NULL,values=NULL,lr=FALSE) {
nlab <- length(labels)
if(length(values) < nlab) nlab=length(values)
for (i in 1:nlab) {
 attributes(values[[i]]) <- NULL
 if(lr) {labels[[i]] <- paste(labels[[i]]," ",round(values[[i]],2))} else {labels[[i]] <- paste(labels[[i]],"\n",round(values[[i]],2))}
  }
return(labels)
}