#modified 6/6/20 to vectorize the labels and rectangles. #modified 8/19/22 to make labels characters (which they are normally) "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) { 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="")} 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* .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) #for long names and not many variables this is ugly 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} 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) 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]) 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) 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) 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.df$lab dia.cluster1(cluster.df,cex=cex,e.size=e.size, digits=digits) 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 <- psychTools::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=.6,xlim=c(0,1),ylim=c(0,1),small=FALSE,cluster.names,draw=FALSE) { if(draw) { if(!small){ 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,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 *.75) } } #just save the information for later drawing if (!draw) { xs <- dia.ellipse1(x,y,xlim=xlim,ylim=ylim,e.size=e.size,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" "dia.cluster1" <- function(cluster.df,digits=2,cex = cex,e.size=.6,xlim=c(0,1),ylim=c(0,1)) { 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) == "") text(x.big,y.big,temp.alpha,cex=cex,adj=1) #this shows the symbol alpha to the left 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[,"alpha"],digits),offset=1,adj=0,cex=cex) # 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,round(big[,"beta"],digits),cex=cex,adj=c(0,1.7)) #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 * .75 ellipsey <- rep(y.small,each=(segments + 2)) + unit.circle[,2] *xs * .75 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=.6,color.lines=TRUE,colors=c("black","blue"),cluster.names,rect.list,arrow.list,cluster.list,bottomup) { a.loc <- NULL 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,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*.6,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) 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) 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)) }