R/ggdendro.R

In dendextend: Extending 'dendrogram' Functionality in R

# Copyright (C) Tal Galili
#
# This file is part of dendextend.
#
# dendextend is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# dendextend is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/
#

# Run first so that it would have access to all of these functions from stats.
# source("R\\stats_imports.R")

# This is a copy (import) of the function dendrogram_data, from Andrie de Vries's ggdendro package (which is a modified \link{plot.dendrogram}).
# https://cran.r-project.org/package=ggdendro
# This function is the basis for the as.ggdend function.
dendrogram_data <- function(x, type = c("rectangle", "triangle"), ...) {
  #    dev.new()
  #    plot(x) # we must add a new plot of the dend in order to extract features from it!

  # without the following line, we will get:
  #    Error in plot.xy(xy.coords(x, y), type = type, ...) :
  #       plot.new has not been called yet
  # unless a regular plot device was first initiated.
  # this is resolved by clearing the nodes from attributes!
  x <- x %>%
    remove_branches_edgePar() %>%
    remove_nodes_nodePar()
  #    x %>% remove_branches_edgePar %>% remove_nodes_nodePar %>% unclass

  leaflab <- "perpendicular"
  center <- FALSE
  xlab <- ""
  ylab <- ""
  horiz <- FALSE
  xaxt <- "n"
  yaxt <- "s"
  nodePar <- NULL
  edgePar <- list()
  dLeaf <- NULL
  edge.root <- is.leaf(x) || !is.null(attr(x, "edgetext"))
  type <- match.arg(type)
  hgt <- attr(x, "height")
  if (edge.root && is.logical(edge.root)) {
    edge.root <- 0.0625 * if (is.leaf(x)) {
      1
    } else {
      hgt
    }
  }
  mem.x <- .memberDend(x)
  yTop <- hgt + edge.root
  if (center) {
    x1 <- 0.5
    x2 <- mem.x + 0.5
  }
  else {
    x1 <- 1
    x2 <- mem.x
  }
  xl. <- c(x1 - 1 / 2, x2 + 1 / 2)
  yl. <- c(0, yTop)
  if (edge.root) {
    if (!is.null(et <- attr(x, "edgetext"))) {
      my <- mean(hgt, yTop)
    }
  }
  gg.plotNode <- function(x1, x2, subtree, type, center, leaflab,
                            dLeaf, nodePar, edgePar, horiz = FALSE, ddsegments = NULL,
                            ddlabels = NULL) {
    inner <- !is.leaf(subtree) && x1 != x2
    yTop <- attr(subtree, "height")
    bx <- plotNodeLimit(x1, x2, subtree, center)
    xTop <- bx$x
    hasP <- !is.null(nPar <- attr(subtree, "nodePar"))
    if (!hasP) {
      nPar <- nodePar
    }
    Xtract <- function(nam, L, default, indx) rep(if (nam %in%
        names(L)) {
        L[[nam]]
      } else {
        default
      }, length.out = indx)[indx]
    asTxt <- function(x) {
      if (is.character(x) || is.expression(x)) {
        x
      } else if (is.null(x)) {
        ""
      } else {
        as.character(x)
      }
    }
    i <- if (inner || hasP) {
      1
    } else {
      2
    }
    if (!is.null(nPar)) {
      pch <- Xtract("pch", nPar, default = 1L:2, i)
      cex <- Xtract("cex", nPar, default = c(1, 1), i)
      col <- Xtract("col", nPar,
        default = par("col"),
        i
      )
      bg <- Xtract("bg", nPar, default = par("bg"), i)
      points(if (horiz) {
        cbind(yTop, xTop)
      } else {
        cbind(xTop, yTop)
      },
      pch = pch, bg = bg, col = col,
      cex = cex
      )
    }
    lab.cex <- 1
    if (is.leaf(subtree)) {
      if (leaflab == "perpendicular") {
        Y <- yTop - dLeaf * lab.cex
        X <- xTop
        srt <- 90
        adj <- 1
        nodeText <- asTxt(attr(subtree, "label"))
        ddlabels <- rbind(ddlabels, data.frame(
          x = X,
          y = 0, text = nodeText, stringsAsFactors = TRUE
        ))
      }
    }
    else if (inner) {
      segmentsHV <- function(x0, y0, x1, y1) {
        data.frame(x0, y0, x1, y1, stringsAsFactors = TRUE)
      }
      for (k in seq_along(subtree)) {
        child <- subtree[[k]]
        yBot <- attr(child, "height")
        if (getOption("verbose")) {
          cat("ch.", k, "@ h=", yBot, "; ")
        }
        if (is.null(yBot)) {
          yBot <- 0
        }
        xBot <- if (center) {
          mean(bx$limit[k:(k + 1)])
        } else {
          bx$limit[k] + .midDend(child)
        }
        if (type == "triangle") {
          ddsegments <- rbind(ddsegments, segmentsHV(
            xTop,
            yTop, xBot, yBot
          ))
        }
        else {
          ddsegments <- rbind(ddsegments, segmentsHV(
            xTop,
            yTop, xBot, yTop
          ))
          ddsegments <- rbind(ddsegments, segmentsHV(
            xBot,
            yTop, xBot, yBot
          ))
        }
        vln <- NULL
        if (!is.null(attr(child, "edgetext"))) {
          edgeText <- asTxt(attr(child, "edgetext"))
          if (!is.null(vln)) {
            mx <- if (type == "triangle") {
              (xTop + xBot + ((xTop - xBot) / (yTop - yBot)) *
                vln) / 2
            } else {
              xBot
            }
            my <- (yTop + yBot + 2 * vln) / 2
          }
          else {
            mx <- if (type == "triangle") {
              (xTop + xBot) / 2
            } else {
              xBot
            }
            my <- (yTop + yBot) / 2
          }
        }
        plotNode_result <- gg.plotNode(bx$limit[k], bx$limit[k +
          1],
        subtree = child, type, center, leaflab,
        dLeaf, nodePar, edgePar, horiz, ddsegments,
        ddlabels
        )
        ddsegments <- plotNode_result$segments
        ddlabels <- plotNode_result$labels
      }
    }
    return(list(segments = ddsegments, labels = ddlabels))
  }
  ret <- gg.plotNode(x1, x2, x,
    type = type, center = center,
    leaflab = leaflab, dLeaf = dLeaf, nodePar = nodePar,
    edgePar = edgePar, horiz = FALSE, ddsegments = NULL,
    ddlabels = NULL
  )
  names(ret$segments) <- c("x", "y", "xend", "yend")
  names(ret$labels) <- c("x", "y", "label")



  #    dev.off() # Turn off device!

  ret
}






#' @title Creates completely blank theme in ggplot
#' @export
#' @description
#' Sets most of the ggplot options to blank, by returning blank theme elements for the panel grid, panel background, axis title, axis text, axis line and axis ticks.
#' @author Andrie de Vries
#' @seealso \link{ggdend}
#' @source
#'
#' This function is from Andrie de Vries's ggdendro package.
#'
#' The motivation for this fork is the need to add more graphical parameters to the plotted tree.
#' This required a strong mixter of functions from ggdendro and dendextend (to the point that
#' it seemed better to just fork the code into its current form)
#'
theme_dendro <- function() {
  # library(ggplot2)
  element_blank <- ggplot2::element_blank
  element_text <- ggplot2::element_text
  theme <- ggplot2::theme

  theme(
    panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
    panel.background = element_blank(), axis.title.x = element_text(colour = NA),
    axis.title.y = element_blank(), axis.text.x = element_blank(),
    axis.text.y = element_blank(), axis.line = element_blank(),
    axis.ticks = element_blank()
  )
}