R/ICLUST.diagram.R

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

"iclust.diagram" <- 
function(ic,labels=NULL,short=FALSE,digits=2,cex=NULL,min.size=NULL,e.size=1,colors=c("black","blue"), main="ICLUST diagram",cluster.names = NULL,marg=c(.5,.5,1.5,.5)) {

  old.par<- par(mar=marg)  #give the window some narrower margins
  on.exit(par(old.par))  #set them back

clusters <- ic$results  #the main table from ICLUST 
num <- nrow(clusters)
num.var <- num+1
if(is.null(cex)) cex <- min(16/num.var,1)


    if (is.null(labels)) {
    	var.labels <- rownames(ic$loadings)} else {var.labels=labels}
    if (short) {var.labels <- paste("V",1:num.var,sep="")} 
  if(is.null(var.labels)) {var.labels <- paste("V",1:num.var,sep="")} 

fixed <- fix.names(ic,var.labels)
clusters <- fixed$ic$results
max.len <- max(nchar((var.labels)))

if(is.null(cluster.names)) cluster.names <- rownames(clusters)  #added Sept 2, 2012
names(cluster.names) <- rownames(clusters) 

length.labels <- max(max.len* .15 * cex,.25*cex)
##

nc <- length(ic$size)
nvar <- sum(ic$size)
last <- dim(clusters)[1]
max.size <- max(ic$size)

limx <- c(-length.labels,nvar+2)
limy <-  c(0,nvar+1)
if(nvar < 12) e.size <- e.size * .7   #this is a kludge to make small problems look better


if(is.null(min.size)) min.size <- .1 * nvar
plot(0,type="n",xlim=limx,ylim=limy,frame.plot=FALSE,axes=FALSE,ylab="",xlab="",main=main)
new.max.len <- max(strwidth(var.labels,units="user"))
if (new.max.len > max.len) {limx <- c(-new.max.len/2,nvar+2)
plot(0,type="n",xlim=limx,ylim=limy,frame.plot=FALSE,axes=FALSE,ylab="",xlab="",main=main)}
top <- num.var
done <- 0
if (nc==1) {head <- num
           size <- num.var
           y.loc <- clusters[head,"size2"]
	       down(clusters,head,size,y.loc,old.head= NULL,old.loc=NULL,min.size=min.size,e.size=e.size,digits=digits,cex=cex,limx=limx,limy=limy,colors=colors,cluster.names=cluster.names)
	       } else {
#the multiple cluster case           
for(clust in 1:nc) {
   #size <- ic$size[clust]
   size <-  sum(abs(ic$clusters[,clust]))
	
	if (substr(colnames(ic$clusters)[clust],1,1)=="C") {
	
	#head <- which(rownames(clusters)==names(ic$size[clust]))
	 head <- which(rownames(clusters)==colnames(ic$clusters)[clust])
	
		cluster <- clusters[head,]
		 y.loc <- clusters[head,"size2"] + done
    	down(clusters,head,size,y.loc,old.head= NULL,old.loc=NULL,min.size=min.size,e.size=e.size,digits=digits,cex=cex,limx=limx,limy=limy,colors=colors,cluster.names = cluster.names)
      }  else {v.name <-names(which(ic$clusters[,clust] ==1))
      dia.rect(0,done+.5,v.name,xlim=limx,ylim=limy,cex=cex)
    
       #done <- done + 1
       }
	done <- done + size 
} 
         
}}

 fix.names <- function(ic,var.labels) {
 	var.names <- ic$results[,c(1:2)]
	max.len <- 0
	vn <- dim(var.names)[1]
	for(i in 1:vn) {
   		vname <- sub("V","",var.names[i,1])
 		suppressWarnings(vname <- as.numeric(vname) )
 		if(!is.na(vname) & (vname < 1)) vname <- NA
  		if(!is.na(vname)) {var.names[i,1] <- var.labels[vname] 
  		if(max.len < nchar(var.labels[vname])) max.len <- nchar(var.labels[vname]) }
   		vname <- sub("V","",var.names[i,2])
  		suppressWarnings(vname <- as.numeric(vname) )
  		if(!is.na(vname) & (vname < 1)) vname <- NA
 		 if(!is.na(vname)) {var.names[i,2] <- var.labels[vname] 
  		if(max.len < nchar(var.labels[vname])) max.len <- nchar(var.labels[vname]) }
  					}
  	ic$results[,c(1:2)] <- var.names
  return(list(ic=ic,max.len=max.len))
  }


    
 "dia.cluster" <- 
 function(x, y = NULL, cluster, link=NULL, digits=2,cex = cex,e.size=.6,xlim=c(0,1),ylim=c(0,1),small=FALSE,cluster.names) {
  
	if(!small) {
	 #text(x,y, rownames(cluster),pos=3,cex=cex)
	 text(x,y, (cluster.names[rownames(cluster)]),pos=3,cex=cex)
	 text(x,y, substitute(list(alpha) == list(a),list(a=round(cluster[1,"alpha"],digits))),cex=cex) 
	text(x,y, substitute(list(beta) == list(b), list(b=round(cluster[1,"beta"],digits))),cex=cex,pos=1) 
	 xs <- dia.ellipse1(x,y,xlim=xlim,ylim=ylim,e.size=e.size )} else { text(x,y, (cluster.names[rownames(cluster)]),cex=cex)
	      xs <- dia.ellipse1(x,y,xlim=xlim,ylim=ylim,e.size=e.size *.75) }
     vert <- cex*.3
     
     left <- c(x-xs,y)
     right <- c(x+xs,y)
     top <- c(x,y+xs)
     bottom <- c(x,y-xs)
     center <- c(x,y)
    dia.cluster <- list(left=left,right=right,top=top,bottom=bottom,center=center,link=link,radius=xs)
     }
  
     
  #down is a recursive function that draws the complete cluster structure
  
   "down" <- 
   function(clusters,head,x,y,sign.clust=1,old.head = NULL,old.loc=NULL,digits,cex,limx,limy,min.size=1,e.size=.6,color.lines=TRUE,colors=c("black","blue"),cluster.names ) {
   
  
           shift <-2
           size <- clusters[head,"size"]
		   cluster <- clusters[head,]
		   if(is.null(old.loc)) {link <- NULL} else {link <- old.head}   #remember the cluster that spawned this cluster
           if(size > min.size) {c.loc <- dia.cluster(head+shift,y,cluster,link=link,digits=digits,cex=cex,e.size=e.size,cluster.names=cluster.names) } else {c.loc <- dia.cluster(head+2,y,cluster,link=link,digits=digits,cex=cex,e.size=e.size*.6,small=TRUE,cluster.names=cluster.names)}

           if(!is.null(old.loc)) { 
           						if(old.loc$top[2] < c.loc$top[2]) {labels <- round(clusters[c.loc$link,"r1"],digits) } else { labels <- round(clusters[c.loc$link,"r2"],digits)}
        						sign.clust <-  sign(labels)
        						if(old.loc$left[1] < c.loc$right[1]) {
        											if(old.loc$left[2] < c.loc$right[2]) { 
        											   
        											    sign.clust <-   sign(labels) 
                                          				dia.arrow(old.loc,c.loc,labels=labels,cex=cex,col=colors[((sign.clust < 0)+1)],lty=(sign.clust < 0)+1)} else {
                                          dia.arrow(old.loc,c.loc,labels=labels,cex=cex,col=colors[((sign.clust <0)+1)],lty=((sign.clust)<0)+1)}} else {
          					 dia.arrow(old.loc,c.loc,labels=labels,cex=cex,col=colors[((sign(labels)<0)+1)],lty=((sign(labels)<0)+1))}}
                size1 <- clusters[head,"size1"]
                size2 <- clusters[head,"size2"]
                                                                
               if(size1==1) {
                v.loc <-  dia.rect(0,y+.5,clusters[head,1],xlim=limx,ylim=limy,cex=cex)
                 #sign.clust <- sign.clust *sign(cluster["r1"])
                 sign.clust <-    sign(cluster["r1"]) 
                dia.arrow(c.loc,v.loc$right,round(cluster["r1"],digits),cex=cex,col=colors[((sign.clust)<0) +1],lty=((sign.clust) <0)+ 1)
                  } else {
                    
               		head1 <- which(rownames(clusters)== clusters[head,1]) 
               		cluster <- clusters[head1,]   #get ready to go down the tree

               		y.shift <- clusters[head1,"size2"]
              		down(clusters,head1,x,y+y.shift,sign.clust,old.head=head,old.loc = c.loc,min.size=min.size,e.size=e.size,digits=digits,cex=cex,limx=limx,limy=limy,colors=colors,cluster.names=cluster.names) 
              		} 
              		 
              		if(size2==1) {

              			v.loc <- dia.rect(0,y-.5,clusters[head,2],xlim=limx,ylim=limy,cex=cex)
              			sign.clust <-  sign(clusters[head,"r2"])
              			#sign.clust <- sign(clusters[head,"r2"])
                        dia.arrow(c.loc,v.loc$right,labels = round(clusters[head,"r2"],digits),cex=cex,col=colors[((sign.clust)<0) +1],lty=((sign.clust)<0) + 1)

              			 } else {
              			 old.head <- head
               			head <- which(rownames(clusters)== clusters[head,2]) 
               			cluster <- clusters[head,]
               			y.shift <- clusters[head,"size1"]
               			down(clusters,head,x,y-y.shift,sign.clust,old.head=old.head,old.loc = c.loc,min.size=min.size,e.size=e.size,digits=digits,cex=cex,limx=limx,limy=limy,colors=colors,cluster.names=cluster.names)
               			
              					 } 
             }