R/cluster.plot.R

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

#revised Sept 16, 2013 to give control over the positon (pos) and size (cex) of the labels
#revised June 21, 2016 to allow naming of the points
 "cluster.plot" <- 
function(ic.results,cluster=NULL,cut = 0.0,labels=NULL, title="Cluster plot",pch=18,pos,show.points=TRUE,choose=NULL,...) {
 if (!is.matrix(ic.results) ) {if (!is.null(class(ic.results)) )   {
  if(inherits(ic.results[1],"kmeans")) { load <- t(ic.results$centers) }  else {
      load <-ic.results$loadings} }} else {load <- ic.results}
      if(!is.null(choose)) load <- load[,choose,drop=FALSE]
nc <- dim(load)[2]
nvar <- dim(load)[1]

#defined locally, so as to be able to pass a parameter to it
  "panel.points" <- 
function (x, y,  pch = par("pch"), ...) 
{   ymin <- min(y)
    ymax <- max(y)
    xmin <- min(x)
    xmax <- max(x)
    ylim <- c(min(ymin,xmin),max(ymax,xmax))
    xlim <- ylim
   if(show.points) points(x, y, pch = pch,ylim = ylim, xlim= xlim,...)
    text(x,y,vnames,...)
}


if(missing(pos)) pos <- rep(1,nvar)   #this allows more control over plotting
ch.col=c("black","blue","red","gray","black","blue","red","gray")
if (is.null(cluster)) {
cluster <- rep(nc+1,nvar)
cluster <- apply( abs(load)  ,1,which.max)
cluster[(apply(abs(load),1,max) < cut)] <- nc+1
}
if (nc > 2 ) {
vnames <- labels  #global variable
 pairs(load,pch = cluster+pch,col=ch.col[cluster],bg=ch.col[cluster],main=title,lower.panel=panel.points,upper.panel=panel.points,...) }
 else {
if(show.points) { plot(load,pch = cluster+pch,col=ch.col[cluster],bg=ch.col[cluster],main=title,...) } else {
  plot(load,pch = cluster+pch,col=ch.col[cluster],bg=ch.col[cluster],main=title,type="n",...)
  pos=NULL}
 abline(h=0)
 abline(v=0)}
 if(is.null(labels)) labels <- paste(1:nvar)
 if(nc < 3) text(load,labels,pos=pos,...)
 }
 
 


 
  "factor.plot" <-  
function(ic.results,cluster=NULL,cut = 0.0,labels=NULL, title,jiggle=FALSE,amount=.02,pch=18,pos,show.points=TRUE,...) { #deprecated
fa.plot(ic.results,cluster=cluster,cut=cut,labels=labels,title=title,jiggle=jiggle,amount=amount,pch=pch,pos=pos,show.points=show.points,...)
}


 "fa.plot" <- 
function(ic.results,cluster=NULL,cut = 0.0,labels=NULL, title,jiggle=FALSE,amount=.02,pch=18,pos,show.points=TRUE,choose=NULL,main=NULL,...) {
if(missing(title) ) { title="Plot"
              if (length(class(ic.results)) >1 )  {if (inherits(ic.results, "fa")) {title = "Factor Analysis"} else {
                     if (inherits(ic.results,"principal")) {title = "Principal Component Analysis"} 
                     } }
                     }
 if(missing(main)) {main<- title} else {title <- main}  #getting rid of confusion from years ago
 if (!is.matrix(ic.results)) {
        if (!is.null(class(ic.results))) {
       if(inherits(ic.results, "kmeans")) { load <- t(ic.results$centers) }  else {
      load <-ic.results$loadings} }} else {load <- ic.results}
      
      
   if(is.null(colnames(load))) colnames(load) <- paste("F",1:ncol(load),sep="")
if(!is.null(choose)) load <- load[,choose,drop=FALSE]
nc <- dim(load)[2]
nvar <- dim(load)[1]
if(missing(pos)) pos <- rep(1,nvar)   #this allows more control over plotting
ch.col=c("black","blue","red","gray","black","blue","red","gray")
if (is.null(cluster)) {
cluster <- rep(nc+1,nvar)
cluster <- apply( abs(load)  ,1,which.max)
cluster[(apply(abs(load),1,max) < cut)] <- nc+1
}
#define this function inside the bigger function so that vnames is globabl to it
 "panel.points" <- 
function (x, y,  pch = par("pch"), ...) 
{   ymin <- min(y)
    ymax <- max(y)
    xmin <- min(x)
    xmax <- max(x)
    ylim <- c(min(ymin,xmin),max(ymax,xmax))
    xlim <- ylim
   if(show.points) points(x, y, pch = pch,ylim = ylim, xlim= xlim,...)

    text(x,y,vnames,...)
}
if(jiggle) load <- jitter(load,amount=amount)
if (nc > 2 ) {
vnames <- labels  #
 pairs(load,pch = cluster+pch,col=ch.col[cluster],bg=ch.col[cluster],lower.panel=panel.points,upper.panel = panel.points,main=title,...) }
 else {
if(show.points) { plot(load,pch = cluster+pch,col=ch.col[cluster],bg=ch.col[cluster],main=title,...) } else {
 
     plot(load,pch = cluster+pch,col=ch.col[cluster],bg=ch.col[cluster],main=title,type="n",...)
     pos=NULL}
 abline(h=0)
 abline(v=0)
 if(is.null(labels)) labels <- paste(1:nvar)
  text(load,labels,pos=pos,...)}
 }