1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
# 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))
}
}
else if (inner) {
segmentsHV <- function(x0, y0, x1, y1) {
data.frame(x0, y0, x1, y1)
}
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())
}
|
