#modified 6/6/20 to vectorize the labels and rectangles.
#modified 8/19/22 to make labels characters (which they are normally)
#modified 11/29/24 to put cluster labels in

"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),plot=TRUE,bottomup=TRUE,both=TRUE,pos=NULL,...) {

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

SMALL.size <- .6
                               
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) | is.null(dim(labels))) {
    	var.labels <- rownames(ic$loadings)} else { var.labels=labels[rownames(ic$loadings),]}  #fixed 6/16/25 to allow bigger dictionary
    if (short) {var.labels <- paste("V",1:num.var,sep="")} 
  if(is.null(var.labels)) {var.labels <- paste("V",1:num.var,sep="")} 
 	var.labels <- as.character(var.labels)  #added 8/19/22
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 *.25* 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)  #for long names and not many variables this is uglyu

if(nvar < 12) {limx <- c(-max.len*.08 * cex,nvar+2)} else {limx <- c(-length.labels,nvar+2)}  #for long names and not many variables this is ugly

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
if(plot) {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"))} else {new.max.len =10
     plot(0,type="n",frame.plot=FALSE,axes=FALSE,ylab="",xlab="")}
if (new.max.len > max.len) {limx <- c(-new.max.len/2,nvar+2)

if(plot) plot(0,type="n",xlim=limx,ylim=limy,frame.plot=FALSE,axes=FALSE,ylab="",xlab="",main=main)}
top <- num.var
done <- 0
rect.list <- list()
arrow.list <- list()
cluster.list <- list()

if (nc==1) {head <- num
           size <- num.var
           y.loc <- clusters[head,"size2"]
	  v.loc <-     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,
	   rect.list=rect.list,arrow.list=arrow.list,cluster.list=cluster.list,bottomup=bottomup,pos=pos,...)
	rect.list <- c(rect.list$rect.list,v.loc$rect.list) 
	cluster.list <- v.loc$cluster.list 
	 arrow.list <- v.loc$arrow.list   } 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])  #find top of cluster
	 

		cluster <- clusters[head,]
		 y.loc <- clusters[head,"size2"] + done
    v.loc <- 	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,rect.list=rect.list,arrow.list=arrow.list,cluster.list=cluster.list,bottomup=bottomup,pos=pos,...)
     rect.list <- v.loc$rect.list 
     cluster.list <- v.loc$cluster.list 
     arrow.list <- v.loc$arrow.list 
      }  else {v.name <- names(which(ic$clusters[,clust] ==1))  #the case of a non-clustered variable
   			 	v.loc  <-   dia.rect(0,done+.5,v.name,xlim=limx,ylim=limy,cex=cex,draw=FALSE,pos=pos,...)
    			rect.list <- c(rect.list,v.loc,v.name)
       			}
	done <- done + size 
} 
         
}


#we have gathered the variables, the clusters and the arrows, now show them


rect.mat <- matrix(unlist(rect.list),ncol=12,byrow=TRUE)
rect.df <- as.data.frame(rect.mat,stringsAsFactors=FALSE)

colnames(rect.df ) <- c("left","y","right","right.y","topx","topy", "xbott","botty","centerx","centery","radius","lab")

if(plot) {

text(as.numeric(rect.df$centerx),as.numeric(rect.df$centery),rect.df$lab,cex=cex)
rect(as.numeric(rect.df$left),as.numeric(rect.df$botty),as.numeric(rect.df$right),as.numeric(rect.df$topy))

cluster.mat <- matrix(unlist(cluster.list),ncol=15,byrow=TRUE)
cluster.df <- data.frame(cluster.mat,stringsAsFactors=FALSE)
cluster.df[c(1:12,14:15)] <- nchar2numeric(cluster.df[c(1:12,14:15)])
colnames(cluster.df ) <- c("left","yl","right","yr","topx","topy","xbott","botty","centerx","centery","link","radius","lab","alpha","beta")
rownames(cluster.df) <- cluster.names[cluster.df$lab]
dia.cluster1(cluster.df,cex=cex,e.size=e.size, digits=digits,both = both,...)


arrow.mat <- matrix(unlist(arrow.list),ncol=21,byrow=TRUE)
arrow.df <- data.frame(arrow.mat,stringsAsFactors=FALSE)
arrow.df[c(1:19,21)] <- nchar2numeric(arrow.df[c(1:19,21)])


tv <- arrow.df

text(tv[,1],tv[,2],tv[,3],cex=tv[,5])
      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])
}  #end of plot
sorted.order <-  dfOrder(data.frame(y=as.numeric(rect.df[,"y"]), lab= rect.df[,"lab"]),ascending=TRUE)[,"lab"]
invisible(sorted.order)
}   #end of iclust.diagram

 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=NA, digits=2,cex = cex,e.size=1.0,xlim=c(0,1),ylim=c(0,1),SMALL=FALSE,cluster.names,draw=FALSE,...) {
      x <- x +(1-SMALL)  #adjust bigger ones slightly 
	  if(draw) {
	  if(!SMALL){
	 text(x,y, (cluster.names[rownames(cluster)]),pos=1,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,draw=draw,... )} else {
	      text(x,y, (cluster.names[rownames(cluster)]),cex=cex)
	       xs <- dia.ellipse1(x,y,xlim=xlim,ylim=ylim,e.size=e.size *(1-.4*SMALL),...) }    
	      }
	      
	   #just save the information for later drawing
	   if (!draw) {
	     xs <- dia.ellipse1(x,y,xlim=xlim,ylim=ylim,e.size=e.size*(1-.4*SMALL),draw=FALSE,...)   ##
	   if(SMALL) {clust.info <- list(cluster= rownames(cluster),alpha=NA, beta = NA)}  else {
	    clust.info <- list(cluster= rownames(cluster),alpha=round(cluster[1,"alpha"],digits),
	     beta = round(cluster[1,"beta"],digits))
	     }
	    }
	
     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 , clust.info)
     }
  
  #June 27, 2020  revised to allow for faster drawing
  #this draws all the clusters at once 
  #still a little slow, but better than before
  # By putting NA at the end of every unit.circle, we can draw multiple circles rapidly
  #modified 8/21/22 to include "beta"
  #modified 6//15/24 to allow plotting both, alpha or beta 
 "dia.cluster1" <- 
 function(cluster.df,digits=2,cex = cex,e.size=.6,xlim=c(0,1),ylim=c(0,1),both=TRUE,...) {
 
 SMALL.size <- .6
 
 if(both==TRUE) {draw.alpha<- TRUE
          draw.beta <- TRUE} else {
          if(both == "alpha")  {draw.alpha <- TRUE
                               draw.beta <- FALSE}  else {
                               draw.alpha <- FALSE
                               draw.beta <- TRUE}
                               }
  ##

    big <- cluster.df[!is.na(cluster.df[,"alpha"]),]
  
    x.big <- big[,"centerx"]
    y.big <-  big[,"centery"]
    small <- cluster.df[is.na(cluster.df[,"alpha"]),]
   
    x <- cluster.df[,"centerx"]
    y <- cluster.df[,"centery"]
	 text(x.big,y.big, rownames(big),pos=3,cex=cex)  #all clusters have names
	
	 #these next two lines just report the first values
	 temp.alpha <- substitute(list(alpha) == "")
	 temp.beta <- substitute(list(beta) == "")
	 if(both==TRUE | both == "both") {   #draw them both
	       text(x.big,y.big,temp.alpha,cex=cex,adj=1)  #this shows the symbol alpha to the left
	                 text(x.big,y.big,round(big[,"alpha"],digits),offset=1,adj=0,cex=cex)
	       text(x.big,y.big,temp.beta, cex=cex,adj=c(1,1.5))  #below and to the left 
	                text(x.big,y.big,round(big[,"beta"],digits),cex=cex,adj=c(0,1.7))
	    } else {if(draw.alpha) {text(x.big,y.big,temp.alpha,cex=cex,adj=1)  #this shows the symbol alpha to the left
	                 text(x.big,y.big,round(big[,"alpha"],digits),offset=1,adj=0,cex=cex)
	                 } else {text(x.big,y.big,temp.beta, cex=cex,adj=1)  #below and to the left 
	                text(x.big,y.big,round(big[,"beta"],digits),cex=cex,offset=1,adj=0)}} 
	                 
	
	
	 #	 text(x.big,y.big,round(big[,"beta"],digits),cex=cex,pos=1)
     #text(x.big,y.big,round(big[,"beta"],digits),cex=cex,pos=1)
        
	 #text(x.big,y.big, substitute(list(alpha) == list(a),list(a=round(big[,"alpha"],digits))),cex=cex) 
	 #text(x.big,y.big, substitute(list(beta) == list(b), list(b=round(big[,"beta"],digits))),cex=cex,pos=1) 
	# temp.n <- NROW(big)
	# for(i in 1:temp.n) {text(x.big[i],y.big[i],substitute(list(alpha) == list(a),list(a=round(big[i,"alpha"],digits))),cex=cex)
	  #                  text(x.big[i],y.big[i],substitute(list(beta) == list(a),list(a=round(big[i,"beta"],digits))),cex=cex,pos=1) }
	 #do the geometric work just once
	 segments = 51
    angles <- c((0:segments) * 2 * pi/segments,NA)
    unit.circle <- cbind(cos(angles), sin(angles))
      #this will break 
    xrange = (xlim[2] - xlim[1])
    yrange = (ylim[2] - ylim[1])
    xs <- e.size * xrange
    
    #store the values for drawing 
     ellipsex <- rep(x.big,each=(segments + 2)) + unit.circle[,1] * xs
     ellipsey <- rep(y.big,each=(segments + 2))  + unit.circle[,2] *xs
    lines(ellipsex,ellipsey,...)
   if(NROW(small)>0) {
    x.small <- small[,"centerx"]
    y.small <- small[,"centery"]
     text(x.small,y.small, rownames(small),cex=cex) 
      nc <- NROW(small)
      ellipsex <- rep(x.small,each=(segments + 2)) + unit.circle[,1] *xs * (1- SMALL.size)      #the adjusts the size of the ellipses but not the location boundaries
     ellipsey <- rep(y.small,each=(segments + 2))  + unit.circle[,2] *xs * (1- SMALL.size)
     lines(ellipsex,ellipsey,...)
    }
	 }
  
  
     
  #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=e.size,color.lines=TRUE,colors=c("black","blue"),cluster.names,rect.list,arrow.list,cluster.list,bottomup,pos=NULL,...) {
        a.loc <- NULL
  SMALL.size <- .6
           shift <- 2
           size <- clusters[head,"size"]
		   cluster <- clusters[head,]
		   if(is.null(old.loc)) {link <- NA} 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 ,SMALL=FALSE,cluster.names=cluster.names,...)   ###
        			 cluster.list <- c(cluster.list,c.loc) } else {
        			            c.loc <- dia.cluster(head+2,y,cluster,link=link,digits=digits,cex=cex,e.size=e.size*SMALL.size,SMALL=TRUE,cluster.names=cluster.names,...) 
                                 cluster.list <- c(cluster.list,c.loc) }
               
           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) 
                                          			if(bottomup) {a.loc <- 	dia.arrow(c.loc,old.loc,labels=labels,cex=cex,col=colors[((sign.clust < 0)+1)],lty=(sign.clust < 0)+1,draw=FALSE)} else {
                                          			a.loc <- 	dia.arrow(old.loc,c.loc,labels=labels,cex=cex,col=colors[((sign.clust < 0)+1)],lty=(sign.clust < 0)+1,draw=FALSE)}} else {
                                        if(bottomup) { a.loc <-  dia.arrow(c.loc,old.loc,labels=labels,cex=cex,col=colors[((sign.clust <0)+1)],lty=((sign.clust)<0)+1,draw=FALSE)} else {
                                          a.loc <-  dia.arrow(old.loc,c.loc,labels=labels,cex=cex,col=colors[((sign.clust <0)+1)],lty=((sign.clust)<0)+1,draw=FALSE)}}} else {
          					if(bottomup){a.loc <-  dia.arrow(c.loc,old.loc,labels=labels,cex=cex,col=colors[((sign(labels)<0)+1)],lty=((sign(labels)<0)+1),draw=FALSE) } else {
          					 a.loc <-  dia.arrow(old.loc,c.loc,labels=labels,cex=cex,col=colors[((sign(labels)<0)+1)],lty=((sign(labels)<0)+1),draw=FALSE)}}}
                size1 <- clusters[head,"size1"]
                size2 <- clusters[head,"size2"]
                       arrow.list <- c(arrow.list,a.loc)                                         
               if(size1==1) {
             v.loc <-  dia.rect(0,y+.5,clusters[head,1],xlim=limx,ylim=limy,cex=cex,draw=FALSE,pos=pos,...)
               rect.list <- c(rect.list,v.loc,clusters[head,1])
               
                 #sign.clust <- sign.clust *sign(cluster["r1"])
                 sign.clust <-    sign(cluster["r1"]) 
              if(bottomup) {a.loc <-  dia.arrow(v.loc,c.loc,round(cluster["r1"],digits),cex=cex,col=colors[((sign.clust)<0) +1],lty=((sign.clust) <0)+ 1,draw=FALSE)} else {
                            a.loc <-  dia.arrow(c.loc,v.loc,round(cluster["r1"],digits),cex=cex,col=colors[((sign.clust)<0) +1],lty=((sign.clust) <0)+ 1,draw=FALSE) }
                 arrow.list <- c(arrow.list,a.loc)      } else {
                    
               		head1 <- which(rownames(clusters)== clusters[head,1]) 
               		cluster <- clusters[head1,]   #get ready to go down the tree

               		y.shift <- clusters[head1,"size2"]
              v.loc <- 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,rect.list=rect.list,arrow.list=arrow.list,cluster.list=cluster.list,bottomup=bottomup,...)
              rect.list <- v.loc$rect.list
              cluster.list <- v.loc$cluster.list
              arrow.list <- v.loc$arrow.list
              		} 
              		 
              		if(size2==1) {

              		  v.loc <- dia.rect(0,y-.5,clusters[head,2],xlim=limx,ylim=limy,cex=cex,draw=FALSE,pos=pos,...)
              			rect.list <- c(rect.list,v.loc,clusters[head,2])
              			sign.clust <-  sign(clusters[head,"r2"])
              			#sign.clust <- sign(clusters[head,"r2"])
                        if(bottomup) {a.loc <- dia.arrow(v.loc,c.loc,labels = round(clusters[head,"r2"],digits),cex=cex,col=colors[((sign.clust)<0) +1],lty=((sign.clust)<0) + 1, draw=FALSE,...) } else {
                                     a.loc  <- dia.arrow(c.loc,v.loc,labels = round(clusters[head,"r2"],digits),cex=cex,col=colors[((sign.clust)<0) +1],lty=((sign.clust)<0) + 1, draw=FALSE,...)}
                         arrow.list <- c(arrow.list,a.loc)    
              			 } else {
              			 old.head <- head
               			head <- which(rownames(clusters)== clusters[head,2]) 
               			cluster <- clusters[head,]
               			y.shift <- clusters[head,"size1"]
               			
               		 v.loc <- 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,rect.list=rect.list,arrow.list=arrow.list,cluster.list=cluster.list,bottomup=bottomup)
               		rect.list <- v.loc$rect.list
               		cluster.list <- v.loc$cluster.list
               		arrow.list <- v.loc$arrow.list
              					 } 
              					 
            invisible(list(rect.list=rect.list,arrow.list=arrow.list,cluster.list=cluster.list)) }
