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
|
#' @describeIn tbl_graph Method for dendrogram objects
#' @importFrom dplyr bind_rows
#' @export
as_tbl_graph.dendrogram <- function(x, directed = TRUE, mode = 'out', ...) {
x <- identify_nodes(x)
nodes <- get_nodes(x)
extraPar <- bind_rows(lapply(nodes$nodePar, as.data.frame, stringsAsFactors = FALSE))
nodes$nodePar <- NULL
nodes <- cbind(nodes, extraPar)
nodes <- nodes[order(nodes$.tidygraph_id), ]
nodes$.tidygraph_id <- NULL
if (all(nodes$label == '')) nodes$label <- NULL
edges <- get_edges(x)
extraPar <- bind_rows(lapply(edges$edgePar, as.data.frame, stringsAsFactors = FALSE))
edges$edgePar <- NULL
edges <- cbind(edges, extraPar)
if (all(edges$label == '')) edges$label <- NULL
if (directed && mode == 'in') {
edges[, c('from', 'to')] <- edges[, c('to', 'from')]
}
as_tbl_graph(list(nodes = nodes, edges = edges), directed = directed)
}
#' @importFrom stats is.leaf
identify_nodes <- function(den, start = 1) {
if (is.leaf(den)) {
attr(den, '.tidygraph_id') <- start
} else {
den[[1]] <- identify_nodes(den[[1]], start)
den[[2]] <- identify_nodes(den[[2]], attr(den[[1]], '.tidygraph_id') + 1)
attr(den, '.tidygraph_id') <- attr(den[[2]], '.tidygraph_id') + 1
}
den
}
#' @importFrom stats is.leaf
get_nodes <- function(den) {
id <- attr(den, '.tidygraph_id')
label <- attr(den, 'label')
if (is.null(label)) label <- ''
members <- attr(den, 'members')
nodePar <- attr(den, 'nodePar')
if (is.null(nodePar)) nodePar <- data.frame(row.names = 1)
if (is.leaf(den)) {
list(
height = attr(den, 'height'),
.tidygraph_id = id,
leaf = TRUE,
label = label,
members = members,
nodePar = list(nodePar)
)
} else {
coord1 <- get_nodes(den[[1]])
coord2 <- get_nodes(den[[2]])
list(
height = c(coord1$height, coord2$height, attr(den, 'height')),
.tidygraph_id = c(coord1$.tidygraph_id, coord2$.tidygraph_id, id),
leaf = c(coord1$leaf, coord2$leaf, FALSE),
label = c(coord1$label, coord2$label, label),
members = c(coord1$members, coord2$members, members),
nodePar = c(coord1$nodePar, coord2$nodePar, list(nodePar))
)
}
}
#' @importFrom stats is.leaf
get_edges <- function(den) {
id <- attr(den, '.tidygraph_id')
if (is.leaf(den)) {
data.frame(row.names = 1)
} else {
conn1 <- get_edges(den[[1]])
conn2 <- get_edges(den[[2]])
list(
from = c(conn1$from, conn2$from, rep(id, 2)),
to = c(conn1$to, conn2$to, unlist(lapply(den, attr, which = '.tidygraph_id'))),
label = c(conn1$label, conn2$label, unlist(lapply(den, function(subden) {
lab <- attr(subden, 'edgetext')
if (is.null(lab)) '' else lab
}))),
edgePar = c(conn1$edgePar, conn2$edgePar, lapply(den, function(subden) {
par <- attr(subden, 'edgePar')
if (is.null(par)) data.frame(row.names = 1) else par
}))
)
}
}
|
