|
| 1 | + |
| 2 | +# This code for drawing dendrograms has been adapted from ggdendro package. |
| 3 | + |
| 4 | +dendro_data <- function(model, type=c("rectangle","triangle"), ...) { |
| 5 | + dhc <- as.dendrogram(model) |
| 6 | + hcdata <- dendrogram_data(dhc, type=type, ...) |
| 7 | + list( |
| 8 | + segments = hcdata$segments, |
| 9 | + labels = hcdata$labels, |
| 10 | + class="hclust" |
| 11 | + ) |
| 12 | +} |
| 13 | + |
| 14 | +dendrogram_data <- function (x, type = c("rectangle", "triangle"), ...){ |
| 15 | + |
| 16 | + # Initialise variables that used to be in parameter list |
| 17 | + leaflab <- "perpendicular" |
| 18 | + center <- FALSE |
| 19 | + xlab <- "" |
| 20 | + ylab <- "" |
| 21 | + horiz <- FALSE |
| 22 | + #frame.plot <- FALSE |
| 23 | + xaxt <- "n" |
| 24 | + yaxt <- "s" |
| 25 | + dLeaf <- NULL |
| 26 | + edge.root <- is.leaf(x) || !is.null(attr(x, "edgetext")) |
| 27 | + |
| 28 | + type <- match.arg(type) |
| 29 | + #leaflab <- match.arg(leaflab) |
| 30 | + hgt <- attr(x, "height") |
| 31 | + if (edge.root && is.logical(edge.root)) |
| 32 | + edge.root <- 0.0625 * if (is.leaf(x)) 1 else hgt |
| 33 | + mem.x <- .memberDend(x) |
| 34 | + yTop <- hgt + edge.root |
| 35 | + if (center) { |
| 36 | + x1 <- 0.5 |
| 37 | + x2 <- mem.x + 0.5 |
| 38 | + } |
| 39 | + else { |
| 40 | + x1 <- 1 |
| 41 | + x2 <- mem.x |
| 42 | + } |
| 43 | + xl. <- c(x1 - 1/2, x2 + 1/2) |
| 44 | + yl. <- c(0, yTop) |
| 45 | + if (edge.root) { |
| 46 | + if (!is.null(et <- attr(x, "edgetext"))) { |
| 47 | + my <- mean(hgt, yTop) |
| 48 | + } |
| 49 | + } |
| 50 | + |
| 51 | + gg.plotNode <- function (x1, x2, subtree, type, center, leaflab, dLeaf, horiz=FALSE, ddsegments=NULL, ddlabels=NULL) { |
| 52 | + inner <- !is.leaf(subtree) && x1 != x2 |
| 53 | + yTop <- attr(subtree, "height") |
| 54 | + bx <- plotNodeLimit(x1, x2, subtree, center) |
| 55 | + xTop <- bx$x |
| 56 | + hasP <- !is.null(nPar <- attr(subtree, "nodePar")) |
| 57 | + Xtract <- function(nam, L, default, indx) rep(if (nam %in% |
| 58 | + names(L)) L[[nam]] else default, length.out = indx)[indx] |
| 59 | + asTxt <- function(x){ |
| 60 | + if (is.character(x) || is.expression(x)) |
| 61 | + x else |
| 62 | + if (is.null(x)) "" else as.character(x) |
| 63 | + } |
| 64 | + i <- if (inner || hasP) |
| 65 | + 1 |
| 66 | + else 2 |
| 67 | + lab.cex <- 1 |
| 68 | + if (is.leaf(subtree)) { |
| 69 | + if (leaflab == "perpendicular") { |
| 70 | + Y <- yTop - dLeaf * lab.cex |
| 71 | + X <- xTop |
| 72 | + srt <- 90 |
| 73 | + adj <- 1 |
| 74 | + nodeText <- asTxt(attr(subtree, "label")) |
| 75 | + ddlabels <- rbind(ddlabels, data.frame(x=X, y=0, text=nodeText)) |
| 76 | + } |
| 77 | + } |
| 78 | + else if (inner) { |
| 79 | + segmentsHV <- function(x0, y0, x1, y1) { |
| 80 | + # ************************* |
| 81 | + data.frame(x0, y0, x1, y1) #AdV |
| 82 | + } |
| 83 | + for (k in seq_along(subtree)) { |
| 84 | + child <- subtree[[k]] |
| 85 | + yBot <- attr(child, "height") |
| 86 | + if (getOption("verbose")) |
| 87 | + cat("ch.", k, "@ h=", yBot, "; ") |
| 88 | + if (is.null(yBot)) |
| 89 | + yBot <- 0 |
| 90 | + xBot <- if (center) |
| 91 | + mean(bx$limit[k:(k + 1)]) |
| 92 | + else bx$limit[k] + .midDend(child) |
| 93 | + if (type == "triangle") { |
| 94 | + ddsegments <- rbind(ddsegments, segmentsHV(xTop, yTop, xBot, yBot)) |
| 95 | + } |
| 96 | + else { |
| 97 | + ddsegments <- rbind(ddsegments, segmentsHV(xTop, yTop, xBot, yTop)) |
| 98 | + ddsegments <- rbind(ddsegments, segmentsHV(xBot, yTop, xBot, yBot)) |
| 99 | + } |
| 100 | + vln <- NULL |
| 101 | + if (!is.null(attr(child, "edgetext"))) { |
| 102 | + edgeText <- asTxt(attr(child, "edgetext")) |
| 103 | + if (!is.null(vln)) { |
| 104 | + mx <- if (type == "triangle") |
| 105 | + (xTop + xBot + ((xTop - xBot)/(yTop - yBot)) * vln)/2 |
| 106 | + else xBot |
| 107 | + my <- (yTop + yBot + 2 * vln)/2 |
| 108 | + } |
| 109 | + else { |
| 110 | + mx <- if (type == "triangle") |
| 111 | + (xTop + xBot)/2 |
| 112 | + else xBot |
| 113 | + my <- (yTop + yBot)/2 |
| 114 | + } |
| 115 | + } |
| 116 | + plotNode_result <- gg.plotNode(bx$limit[k], bx$limit[k + 1], subtree = child, |
| 117 | + type, center, leaflab, dLeaf, horiz, ddsegments, ddlabels) |
| 118 | + ddsegments <- plotNode_result$segments |
| 119 | + ddlabels <- plotNode_result$labels |
| 120 | + } |
| 121 | + } |
| 122 | + return(list(segments=ddsegments, labels=ddlabels)) |
| 123 | + } |
| 124 | + |
| 125 | + ret <- gg.plotNode(x1, x2, x, type = type, center = center, leaflab = leaflab, |
| 126 | + dLeaf = dLeaf, horiz=FALSE, |
| 127 | + ddsegments=NULL, ddlabels=NULL) |
| 128 | + names(ret$segments) <- c("x", "y", "xend", "yend") |
| 129 | + names(ret$labels) <- c("x", "y", "label") |
| 130 | + ret |
| 131 | +} |
| 132 | + |
| 133 | + |
| 134 | + |
| 135 | +.memberDend <- function (x) |
| 136 | +{ |
| 137 | + r <- attr(x, "x.member") |
| 138 | + if (is.null(r)) { |
| 139 | + r <- attr(x, "members") |
| 140 | + if (is.null(r)) |
| 141 | + r <- 1L |
| 142 | + } |
| 143 | + r |
| 144 | +} |
| 145 | + |
| 146 | + |
| 147 | +plotNodeLimit <- function (x1, x2, subtree, center) |
| 148 | +{ |
| 149 | + inner <- !is.leaf(subtree) && x1 != x2 |
| 150 | + if (inner) { |
| 151 | + K <- length(subtree) |
| 152 | + mTop <- .memberDend(subtree) |
| 153 | + limit <- integer(K) |
| 154 | + xx1 <- x1 |
| 155 | + for (k in 1L:K) { |
| 156 | + m <- .memberDend(subtree[[k]]) |
| 157 | + xx1 <- xx1 + (if (center) |
| 158 | + (x2 - x1) * m/mTop |
| 159 | + else m) |
| 160 | + limit[k] <- xx1 |
| 161 | + } |
| 162 | + limit <- c(x1, limit) |
| 163 | + } |
| 164 | + else { |
| 165 | + limit <- c(x1, x2) |
| 166 | + } |
| 167 | + mid <- attr(subtree, "midpoint") |
| 168 | + center <- center || (inner && !is.numeric(mid)) |
| 169 | + x <- if (center) |
| 170 | + mean(c(x1, x2)) |
| 171 | + else x1 + (if (inner) |
| 172 | + mid |
| 173 | + else 0) |
| 174 | + list(x = x, limit = limit) |
| 175 | +} |
| 176 | + |
| 177 | + |
| 178 | +.midDend <- function (x) |
| 179 | + if (is.null(mp <- attr(x, "midpoint"))) 0 else mp |
| 180 | + |
| 181 | + |
| 182 | + |
0 commit comments