R/simprof-dendrogram.R

In fcorra/mod_clustsig: Modification of Significant Cluster Analysis

#' @include classes.R
NULL

#' Plot simplot objects
#'
#' Method to plot a simplot object. It calls \code{simprof.plot}
#'
#' @param x simplot. 
#' @param y missing.
#' @param ... other arguments for simprof.plot.
#'
#' @return
#' A dendrogram.
#' @seealso 
#' \code{\link{simprof.plot}}
#' @export
#' @examples
#' NULL
setMethod("plot", c(x = "simprof", y = "missing"),
          function(x, y, ...) simprof.plot(x, ...))

#' Similarity Profile Analysis Dendrogram Plotter
#'
#' Method to plot a simplot object.
#'
#' @name simprof.plot
#' 
#' @param results The object returned by \code{simprof}. It uses only the slots hclust and significantclusters.
#' @param leafcolors A vector of color names/identifiers (names or hex codes); it should be the same length as \code{"results$significantclusters"}. If this isn't supplied, the \code{\link{rainbow}} function will be used to generate enough colors(recommended). Because the colors are used in the order generated by \code{rainbow}, if there are a large number of significant clusters, they may appear to form a continuous color spectrum. If this is the case, the appropriate option is to manually supply a vector of colors to more clearly delineate different clusters.
#' @param plot A logical option indicating whether to plot the dendrogram or not.
#' @param fill A logical option indicating whether to color the entire subtree which comprises a signficant color (as opposed to just coloring the individual leaves).
#' @param leaflab The option from \code{dendrogram} indicating the label text orientation. Possible values are \code{"perpendicular"} (vertical), \code{"textlike"} (horizontal), or \code{"none"} (labels suppressed).
#' @param siglinetype A numeric option indicating the type of line to use for the significant clusters (the line type chosen applies to all significant clusters). The possible values are 0=blank, 1=solid (default), 2=dashed, 3=dotted, 4=dotdash, 5=longdash, 6=twodash, and \code{"different"}. This can be a vector of line-types to use; in the event that there are fewer available line-types than there are significant groups, some line-types will be repeated. The selection of \code{"different"} will use try to automatically use as many different line-types as necessary to have  a unique type for each significant group (the line-types will be used in the order of 6 through 1 so that solid is used last to increase clarity).
#' 
#' @return
#' A dendrogram is returned.
#' 
#' @seealso 
#' \code{\link{hclust}}, \code{\link{dendrogram}}
#' 
#' @author Douglas Whitaker and Mary Christman
#' 
#' @export
#'
#' @examples
#' NULL
simprof.plot <- function(results, leafcolors=NA, plot=TRUE, fill=TRUE, leaflab="perpendicular", siglinetype=1){
  firstfind <- rep(TRUE, results@numgroups)
  colour <- local({
    colorizer <- function(i, siggroups, leafcolors, fill, siglinetype){
      #
      # i = the current node (passed by dendrapply I assume)
      #
      # siggroups should be $significantclusters from the results of simprof
      # so siggroups is a list of vectors
      #
      # leafcolors should be a vector of colors equal in number to the number length of siggroups
      # leafcolors <- rainbow(length(siggroups)) basically
      #
      
      props <- attributes(i)
      if(is.leaf(i)){
        leafID <- props$label
        group <- findGroup(leafID, siggroups)
        color <- leafcolors[group]
        attr(i, "edgePar") <- c(props$edgePar, list(col=c(color, color), lty=siglinetype[group]))
      }
      if(!is.leaf(i) && fill){
        mems <- labels(i)
        unif <- pure(mems, siggroups)
        if (unif > 0){
          if (firstfind[unif]){
            firstfind[unif] <<- FALSE
          }
          else {
            color <- leafcolors[unif]
            attr(i, "edgePar") <- c(props$edgePar, list(col=c(color,color), lty=siglinetype[unif]))
          }
        }
      }
      i
    }
  })
  siggroups <- results@significantclusters
  if (typeof(siglinetype) == "character"){ # not && to get rid of warning
    if (siglinetype == "different"){
      siglinetype <- rev(c(1:6)) # make it so that "solid" is used last.
      if (length(siggroups) > length(siglinetype)){
        warning("More significant groups than there are valid line types. Some line types will be repeated.")
        while (length(siggroups) > length(siglinetype))
          siglinetype <- append(siglinetype, siglinetype) # just keep adding on until we are over how many we need
      }
    }
    else 
      siglinetype <- rep(1, length(siggroups)) # something went wrong
  }
  else if (length(siglinetype) == 1 && siglinetype[1] >= 1 && siglinetype[1] <= 6)
    siglinetype <- rep(siglinetype, length(siggroups))
  else if (length(siggroups) > length(siglinetype)){
    warning("Fewer line types supplied than there are significant groups.")
    if (length(siglinetype) < 6){
      siglinetype <- rev(c(1:6))
      if (length(siggroups) > length(siglinetype))
        while (length(siggroups) > length(siglinetype))
          siglinetype <- append(siglinetype, siglinetype) # just keep adding on until we are over how many we need
    }
  }
  
  if (is.na(leafcolors[1]))
    leafcolors <- rainbow(length(results@significantclusters))
  else if (length(leafcolors) == 1)
    leafcolors <- rep(leafcolors[1], length(siggroups))
  
  
  dend <- dendrapply(as.dendrogram(results@hclust), colour, siggroups=results@significantclusters, leafcolors=leafcolors, fill=fill, siglinetype=siglinetype)
  if(plot)
    plot(dend, leaflab=leaflab)
  return(dend)
}

findGroup <- function(leafID, siggroups){
  for (j in 1:length(siggroups)){
    if (length(which(siggroups[[j]] == leafID) != 0)){
      return(j) # this should be sufficient
    }
  }
}

pure <- function(mems, siggroups){
  for (j in 1:length(siggroups))
    if (all(!is.na(match(mems, siggroups[[j]]))))
      return(j) # return the group they all belong to
  return(-1)
}