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
|
#######################################################################
# dbscan - Density Based Clustering of Applications with Noise
# and Related Algorithms
# Copyright (C) 2015 Michael Hahsler, Matt Piekenbrock
# This program 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
# any later version.
#
# This program 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.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
#' Coersions to Dendrogram
#'
#' Provides a new generic function to coerce objects to dendrograms with
#' [stats::as.dendrogram()] as the default. Additional methods for
#' [hclust], [hdbscan] and [reachability] objects are provided.
#'
#' Coersion methods for
#' [hclust], [hdbscan] and [reachability] objects to [dendrogram] are provided.
#'
#' The coercion from `hclust` is a faster C++ reimplementation of the coercion in
#' package `stats`. The original implementation can be called
#' using [stats::as.dendrogram()].
#'
#' The coersion from [hdbscan] builds the non-simplified HDBSCAN hierarchy as a
#' dendrogram object.
#'
#' @name dendrogram
#' @aliases dendrogram
#'
#' @param object the object
#' @param ... further arguments
NULL
#' @rdname dendrogram
#' @export
as.dendrogram <- function (object, ...) {
UseMethod("as.dendrogram", object)
}
#' @rdname dendrogram
#' @export
as.dendrogram.default <- function (object, ...)
stats::as.dendrogram(object, ...)
## this is a replacement for stats::as.dendrogram for hclust
#' @rdname dendrogram
#' @export
as.dendrogram.hclust <- function(object, ...) {
return(buildDendrogram(object))
}
#' @rdname dendrogram
#' @export
as.dendrogram.hdbscan <- function(object, ...) {
return(buildDendrogram(object$hc))
}
#' @rdname dendrogram
#' @export
as.dendrogram.reachability <- function(object, ...) {
if (sum(is.infinite(object$reachdist)) > 1)
stop(
"Multiple Infinite reachability distances found. Reachability plots can only be converted if they contain enough information to fully represent the dendrogram structure. If using OPTICS, a larger eps value (such as Inf) may be needed in the parameterization."
)
#dup_x <- object
c_order <- order(object$reachdist) - 1
# dup_x$order <- dup_x$order - 1
#q_order <- sapply(c_order, function(i) which(dup_x$order == i))
res <- reach_to_dendrogram(object, c_order)
# res <- dendrapply(res, function(leaf) { new_leaf <- leaf[[1]]; attributes(new_leaf) <- attributes(leaf); new_leaf })
# add mid points for plotting
res <- .midcache.dendrogram(res)
res
}
# calculate midpoints for dendrogram
# from stats, but not exported
# see stats:::midcache.dendrogram
.midcache.dendrogram <- function(x, type = "hclust", quiet = FALSE) {
type <- match.arg(type)
stopifnot(inherits(x, "dendrogram"))
verbose <- getOption("verbose", 0) >= 2
setmid <- function(d, type) {
depth <- 0L
kk <- integer()
jj <- integer()
dd <- list()
repeat {
if (!is.leaf(d)) {
k <- length(d)
if (k < 1)
stop("dendrogram node with non-positive #{branches}")
depth <- depth + 1L
if (verbose)
cat(sprintf(" depth(+)=%4d, k=%d\n", depth,
k))
kk[depth] <- k
if (storage.mode(jj) != storage.mode(kk))
storage.mode(jj) <- storage.mode(kk)
dd[[depth]] <- d
d <- d[[jj[depth] <- 1L]]
next
}
while (depth) {
k <- kk[depth]
j <- jj[depth]
r <- dd[[depth]]
r[[j]] <- unclass(d)
if (j < k)
break
depth <- depth - 1L
if (verbose)
cat(sprintf(" depth(-)=%4d, k=%d\n", depth,
k))
midS <- sum(vapply(r, .midDend, 0))
if (!quiet && type == "hclust" && k != 2)
warning("midcache() of non-binary dendrograms only partly implemented")
attr(r, "midpoint") <- (.memberDend(r[[1L]]) +
midS) / 2
d <- r
}
if (!depth)
break
dd[[depth]] <- r
d <- r[[jj[depth] <- j + 1L]]
}
d
}
setmid(x, type = type)
}
.midDend <- function(x) {
attr(x, "midpoint") %||% 0
}
.memberDend <- function(x) {
attr(x, "x.member") %||% attr(x, "members") %||% 1
}
|
