Nothing
R/fviz_dend.R
In factoextra: Extract and Visualize the Results of Multivariate Data Analyses
Defines functions
.coord_color_order
.get_k
.get_label_params
.phylogenic_tree
fviz_dend
Documented in
fviz_dend
#' Enhanced Visualization of Dendrogram
#'
#' @description Draws easily beautiful dendrograms using either R base plot or
#' ggplot2. It also provides options for circular dendrograms and
#' phylogenetic-style trees.
#'
#' Read more: \href{https://www.datanovia.com/learn/machine-learning/clustering/visualizing-dendrograms}{Visualizing Dendrograms in R: Color, Zoom & Customize};
#' to compare two trees see \href{https://www.datanovia.com/learn/machine-learning/clustering/comparing-dendrograms}{Comparing Dendrograms in R: Tanglegrams & Correlation}.
#'
#' @param x an object of class dendrogram, hclust, agnes, diana, hcut,
#' hkmeans or HCPC (FactoMineR).
#' @param k the number of groups for cutting the tree.
#' @param h a numeric value. Cut the dendrogram by cutting at height h. (k
#' overrides h)
#' @param k_colors,palette a vector containing colors to be used for the groups.
#' It should contain \code{k} colors. Allowed values also include "grey"
#' for grey color palettes; brewer palettes e.g. "RdBu", "Blues", ...; and
#' scientific journal palettes from ggsci R package, e.g.: "npg", "aaas",
#' "lancet", "jco", "ucscgb", "uchicago", "simpsons" and "rickandmorty".
#' @param show_labels a logical value. If TRUE, leaf labels are shown. Default
#' value is TRUE.
#' @param color_labels_by_k logical value. If TRUE, labels are colored
#' automatically by group when k != NULL.
#' @param match_coord_colors logical value. Default is FALSE, where dendrogram
#' colors follow the left-to-right leaf order. If TRUE, cluster colors are
#' remapped to cluster-label order so they match \code{\link{fviz_cluster}()}
#' and \code{\link{fviz_silhouette}()} for the same clustering.
#' @param label_cols a vector containing the colors for labels.
#' @param labels_font font face for the leaf labels of "rectangle"/"circular"
#' dendrograms. One of "plain" (default), "bold", "italic" or "bold.italic".
#' Default "plain" leaves labels unchanged.
#' @param labels_track_height a positive numeric value for adjusting the room for the
#' labels. Used only when type = "rectangle".
#' @param repel logical value. Use repel = TRUE to avoid label overplotting when
#' \code{type = "phylogenic"}. The literal \code{"phylogenic"} value is a
#' historical API token retained for compatibility.
#' @param lwd a numeric value specifying dendrogram branch and rectangle line
#' width.
#' @param highlight an optional character vector of leaf labels; the branches
#' leading to those leaves are emphasized (thicker, and coloured
#' \code{highlight.col}) while every other branch keeps its colour and width.
#' \code{NULL} (default) highlights nothing. Has no effect for
#' \code{type = "phylogenic"} (that layout does not colour branch segments).
#' @param highlight.col colour (name or hex) for the highlighted branches.
#' @param highlight.lwd line width for the highlighted branches. \code{NULL}
#' (default) uses \code{2 * lwd} so the emphasis stands out by thickness
#' regardless of colour; set \code{highlight.lwd = lwd} for colour-only emphasis.
#' @param type type of plot. Allowed values are \code{"rectangle"},
#' \code{"circular"}, and the historical compatibility token
#' \code{"phylogenic"} for a phylogenetic-style tree.
#' @param phylo_layout the layout used for phylogenetic-style trees. Default value
#' is "layout.auto", which is kept as a compatibility alias for
#' \code{"layout_nicely"}. Allowed values include:
#' \code{\link[igraph]{layout.auto}}, \code{\link[igraph]{layout_nicely}},
#' \code{\link[igraph]{layout_with_drl}}, \code{\link[igraph]{layout_as_tree}},
#' \code{\link[igraph]{layout.gem}}, \code{\link[igraph]{layout_with_gem}},
#' \code{\link[igraph]{layout.mds}}, \code{\link[igraph]{layout_with_mds}} and
#' \code{\link[igraph]{layout_with_lgl}}.
#' @param rect logical value specifying whether to add a rectangle around
#' groups. Used only when k != NULL.
#' @param rect_border,rect_lty border color and line type for rectangles.
#' @param rect_fill a logical value. If TRUE, fill the rectangle.
#' @param lower_rect a value of how low should the lower part of the rectangle
#' around clusters. Ignored when rect = FALSE.
#' @param horiz a logical value. If TRUE, a horizontal dendrogram is drawn.
#' @param cex size of labels
#' @param main,xlab,ylab main and axis titles
#' @param sub Plot subtitle. Default is NULL (no subtitle). Set to a character
#' string to display a subtitle below the title, e.g.
#' \code{sub = paste0("Method: ", "ward.D2")}.
#' @param ggtheme function, ggplot2 theme name. Default value is
#' theme_classic(). Allowed values include ggplot2 official themes:
#' theme_gray(), theme_bw(), theme_minimal(), theme_classic(), theme_void(),
#' ....
#' @param ... other arguments to be passed to the function plot.dendrogram()
#' @return an object of class fviz_dend which is a ggplot with the attributes
#' "dendrogram" accessible using attr(x, "dendrogram"), where x is the result
#' of fviz_dend().
#' @details For branch styling beyond \code{highlight} - for example dashed
#' branches or per-branch colours - pre-style a \code{dendextend} dendrogram and
#' pass it to \code{fviz_dend()}, which honours its \code{set()} aesthetics:
#' \preformatted{
#' library(dendextend)
#' dend <- as.dendrogram(hclust(dist(scale(USArrests))))
#' dend <- set(dend, "branches_lty", 2) # dashed branches
#' fviz_dend(dend)
#' }
#'
#' \strong{Comparing two dendrograms.} To compare two hierarchical clusterings of
#' the same observations (e.g. different linkages), draw a \emph{tanglegram} with
#' \code{dendextend} (already a dependency): the two trees face each other, matched
#' leaves are connected, and \code{entanglement()} measures agreement (0 = perfect,
#' 1 = worst). This uses base graphics.
#' \preformatted{
#' library(dendextend)
#' d1 <- as.dendrogram(hclust(dist(scale(USArrests)), "complete"))
#' d2 <- as.dendrogram(hclust(dist(scale(USArrests)), "average"))
#' dl <- dendlist(d1, d2)
#' dl <- untangle(dl, method = "step2side") # reduce crossings
#' tanglegram(dl, common_subtrees_color_branches = TRUE)
#' entanglement(dl) # agreement, in [0, 1]
#' }
#' Both dendrograms must share the same leaf labels.
#' @seealso \code{\link[dendextend]{tanglegram}}, \code{\link[dendextend]{entanglement}}
#' for comparing two dendrograms (see \strong{Details}).
#' Online tutorials: \href{https://www.datanovia.com/learn/machine-learning/clustering/visualizing-dendrograms}{Visualizing Dendrograms in R: Color, Zoom & Customize}
#' and \href{https://www.datanovia.com/learn/machine-learning/clustering/comparing-dendrograms}{Comparing Dendrograms in R: Tanglegrams & Correlation}.
#' @examples
#' \donttest{
#' # Load and scale the data
#' data(USArrests)
#' df <- scale(USArrests)
#'
#' # Hierarchical clustering
#' res.hc <- hclust(dist(df))
#'
#' # Default plot
#' fviz_dend(res.hc)
#'
#' # Increase branch and rectangle line widths
#' fviz_dend(res.hc, lwd = 2)
#'
#' # Cut the tree
#' fviz_dend(res.hc, cex = 0.5, k = 4, color_labels_by_k = TRUE)
#'
#' # Don't color labels, add rectangles
#' fviz_dend(res.hc, cex = 0.5, k = 4,
#' color_labels_by_k = FALSE, rect = TRUE)
#'
#' # Change the color of tree using black color for all groups
#' # Change rectangle border colors
#' fviz_dend(res.hc, rect = TRUE, k_colors ="black",
#' rect_border = 2:5, rect_lty = 1)
#'
#' # Customized color for groups
#' fviz_dend(res.hc, k = 4,
#' k_colors = c("#1B9E77", "#D95F02", "#7570B3", "#E7298A"))
#'
#'
#' # Color labels using k-means clusters
#' km.clust <- kmeans(df, 4)$cluster
#' fviz_dend(res.hc, k = 4,
#' k_colors = c("blue", "green3", "red", "black"),
#' label_cols = km.clust[res.hc$order], cex = 0.6)
#'
#' # Phylogenetic-style tree layouts support both compatibility aliases and
#' # current igraph layout names
#' if (requireNamespace("igraph", quietly = TRUE)) {
#' fviz_dend(res.hc, type = "phylogenic", phylo_layout = "layout_nicely",
#' show_labels = FALSE)
#' }
#'
#' }
#' @export
fviz_dend <- function(x, k = NULL, h = NULL, k_colors = NULL, palette = NULL, show_labels = TRUE, color_labels_by_k = TRUE,
match_coord_colors = FALSE,
label_cols = NULL, labels_font = "plain", labels_track_height = NULL, repel = FALSE, lwd = 0.7,
highlight = NULL, highlight.col = "red", highlight.lwd = NULL,
type = c("rectangle", "circular", "phylogenic"),
phylo_layout = "layout.auto",
rect = FALSE, rect_border = "gray", rect_lty = 2, rect_fill = FALSE, lower_rect,
horiz = FALSE, cex = 0.8, main = "Cluster Dendrogram", xlab = "", ylab = "Height",
sub = NULL, ggtheme = theme_classic(), ...)
{
if(missing(k_colors) && !is.null(palette)) {
k_colors <- palette
palette <- NULL
}
if(!color_labels_by_k && is.null(label_cols)) label_cols <- "black"
type <- match.arg(type)
circular <- type == "circular"
phylogenic <- type == "phylogenic"
rectangle <- type == "rectangle"
if(inherits(x, "HCPC")){
# Honor an explicit k; default to the number of HCPC clusters when k is
# NULL. The previous code always overwrote k, so a user-supplied k (e.g.
# fviz_dend(hcpc, k = 5)) was silently ignored and colored at the HCPC
# cluster count instead. (#81)
if(is.null(k)) k <- length(unique(x$data.clust$clust))
x <- x$call$t$tree #hclust
}
if(inherits(x, "hcut")){
k <- x$nbclust
dend <- as.dendrogram(x)
method <- x$method
}
else if(inherits(x, "hkmeans")){
k <- length(unique(x$cluster))
dend <- as.dendrogram(x$hclust)
method <- x$hclust$method
}
else if(inherits(x, c("hclust", "agnes", "diana"))) {
dend <- as.dendrogram(x)
method <- x$method
}
else if(inherits(x, "dendrogram")) {
dend <- x
method <- ""
}
else stop("Can't handle an object of class ", paste(class(x), collapse =", ") )
if(is.null(method)) method <- ""
else if(is.na(method)) method <- ""
# `sub` defaults to NULL (no subtitle), preserving the previous appearance.
# When set, it is rendered via labs(subtitle=) below (#54).
if(!is.null(dendextend::labels_cex(dend))) cex <- dendextend::labels_cex(dend)
dend <- dendextend::set(dend, "labels_cex", cex)
dend <- dendextend::set(dend, "branches_lwd", lwd)
k <- .get_k(dend, k, h)
if(!is.null(k)) {
if(.is_color_palette(k_colors)) k_colors <- ggpubr::get_palette(k_colors, k = k)
else if(is.null(k_colors)) k_colors <- ggpubr::get_palette("default", k = k)
# By default colours follow the left-to-right leaf order (dendextend). With
# match_coord_colors = TRUE, remap them to cluster-label order so they match
# fviz_cluster()/fviz_silhouette() for the same clustering (#103).
branch_colors <- k_colors
if(match_coord_colors){
ord <- .coord_color_order(dend, k)
if(!is.null(ord)) branch_colors <- k_colors[ord]
}
dend <- dendextend::set(dend, what = "branches_k_color", k = k, value = branch_colors)
if(color_labels_by_k) dend <- dendextend::set(dend, "labels_col", k = k, value = branch_colors)
}
if(!is.null(label_cols)){
dend <- dendextend::set(dend, "labels_col", label_cols)
}
# Emphasize the branches leading to specific leaves. Applied AFTER the k /
# label colouring so it layers on top: highlighted branches take
# `highlight.col` (and optionally `highlight.lwd`), every other branch keeps
# its existing colour/width (the Inf sentinel). highlight = NULL (default)
# leaves the dendrogram untouched, so existing plots are unchanged. (#P2.3)
if(!is.null(highlight)){
bad <- setdiff(highlight, labels(dend))
if(length(bad))
stop("`highlight` contains labels not in the dendrogram: ",
paste(bad, collapse = ", "), ".", call. = FALSE)
if(phylogenic)
warning("`highlight` has no effect for type = \"phylogenic\": that layout ",
"does not colour branch segments.", call. = FALSE)
dend <- dendextend::set(dend, "by_labels_branches_col", value = highlight,
TF_values = c(highlight.col, Inf))
# Emphasize by THICKNESS by default (2x lwd): thickness always stands out,
# even when highlight.col happens to match a nearby cluster colour. Pass
# highlight.lwd = lwd for colour-only emphasis.
h_lwd <- if(is.null(highlight.lwd)) 2 * lwd else highlight.lwd
dend <- dendextend::set(dend, "by_labels_branches_lwd", value = highlight,
TF_values = c(h_lwd, Inf))
}
leaflab <- ifelse(show_labels, "perpendicular", "none")
if(xlab =="") xlab <- NULL
if(ylab=="") ylab <- NULL
max_height <- max(dendextend::get_branches_heights(dend))
if(missing(labels_track_height))
labels_track_height <- max_height/8
if(max_height < 1) offset_labels <- -max_height/100
else offset_labels <- -0.1
if(rectangle || circular){
p <- .ggplot_dend(dend, type = "rectangle", offset_labels = offset_labels, nodes = FALSE,
ggtheme = ggtheme, horiz = horiz, circular = circular, palette = palette,
labels = show_labels, label_cols = label_cols, labels_font = labels_font,
labels_track_height = labels_track_height, ...)
if(!circular) p <- p + labs(title = main, subtitle = sub, x = xlab, y = ylab)
}
else if(phylogenic){
p <- .phylogenic_tree(dend, labels = show_labels, label_cols = label_cols,
palette = palette, repel = repel,
ggtheme = ggtheme, phylo_layout = phylo_layout, ...)
}
# Add rectangle around clusters
if(circular || phylogenic || is.null(k)) rect <- FALSE
if(rect_fill && missing(rect_lty)) rect_lty = "blank"
if(missing(lower_rect)) {
# The absolute -0.5 offset overwhelms short trees (e.g. correlation/gower
# distances with max height < 1), pushing the rectangles far below the
# labels. For those, scale the offset to the tree height instead; taller
# trees (>= 1) keep the previous default unchanged (#55).
lower_rect <- if(max_height < 1) -(labels_track_height + max_height/8)
else -(labels_track_height + 0.5)
}
if(rect){
p <- p + .rect_dendrogram(dend, k = k, palette = rect_border, rect_fill = rect_fill,
rect_lty = rect_lty, linewidth = lwd,
lower_rect = lower_rect, match_coord_colors = match_coord_colors)
}
# Keep the leaf-label text layer out of the legend (no stray "a" glyph),
# mirroring the scatter-plot cleanup in .fviz_finish() (#14).
p <- .hide_text_legend(p)
attr(p, "dendrogram") <- dend
structure(p, class = c(class(p), "fviz_dend"))
return(p)
}
# require igraph
.phylogenic_tree <- function(dend, labels = TRUE, label_cols = NULL,
palette = NULL, repel = FALSE,
ggtheme = theme_classic(),
phylo_layout = "layout.auto", ...){
if (!requireNamespace("igraph", quietly = TRUE)) {
stop("The igraph package is required for a phylogenetic-style tree. ",
"Install it with install.packages('igraph').")
}
allowed_layouts <- c("layout.auto", "layout_nicely", "layout_with_drl", "layout_as_tree",
"layout.gem", "layout_with_gem", "layout.mds", "layout_with_mds", "layout_with_lgl")
if(!(phylo_layout %in% allowed_layouts)) stop(phylo_layout, " is not a supported layout. ",
"Allowed phylogenetic-style layouts are: ",
paste( allowed_layouts, collapse = ", "))
layout_func <- switch(phylo_layout,
layout.auto = igraph::layout_nicely,
layout_nicely = igraph::layout_nicely,
layout_with_drl = igraph::layout_with_drl,
layout_as_tree = igraph::layout_as_tree,
layout.gem = igraph::layout_with_gem,
layout_with_gem = igraph::layout_with_gem,
layout.mds = igraph::layout_with_mds,
layout_with_mds = igraph::layout_with_mds,
layout_with_lgl = igraph::layout_with_lgl
)
# Convert to 'phylo' object
hc <- stats::as.hclust(dend)
phylo_tree <- .as.phylo(hc)
graph_edges <- phylo_tree$edge
# get graph from edge list
graph_net <- igraph::graph_from_edgelist(graph_edges)
# extract layout (x-y coords)
graph_layout <- .with_preserved_seed(123, layout_func(graph_net))
# number of observations
nobs <- length(hc$labels)
# draw tree branches
data.segments <- data.frame(
x = graph_layout[graph_edges[,1],1],
y = graph_layout[graph_edges[,1],2],
xend = graph_layout[graph_edges[,2],1],
yend = graph_layout[graph_edges[,2],2]
)
data.labels <- data.frame(
x = graph_layout[1:nobs,1],
y = graph_layout[1:nobs,2],
label = phylo_tree$tip.label
)
data.labels <- data.labels[order(as.vector(data.labels$label)), ]
# Support for dendextend
gdend <- dendextend::as.ggdend(dend)
gdat <- dendextend::prepare.ggdend(gdend)
gdat$labels <- gdat$labels[order(as.vector(gdat$labels$label)), ]
data.labels <- cbind(data.labels, gdat$labels[, c("col", "cex")])
if(!is.null(dendextend::labels_cex(dend))) font.label <- round(dendextend::labels_cex(dend)[1]*12)
else font.label <- 12
# FIX: ggplot2 3.0.0+ deprecation - aes_string() replaced with aes() + .data pronoun
# See: https://github.com/kassambara/factoextra/issues/190
p <- ggplot() + geom_segment(data = data.segments,
aes(x = .data[["x"]], y = .data[["y"]], xend = .data[["xend"]], yend = .data[["yend"]]),
lineend = "square")
if(is.null(label_cols)) label_cols <- "col"
if(!labels) labels <- NULL
else labels <- "label"
p <- ggpubr::ggscatter(data.labels, "x", "y", label = labels,
color = label_cols,
ggp = p, repel = repel, font.label = font.label, ...)
if(is.null(palette)) p <- p + scale_colour_identity()
p <- ggpubr::ggpar(p, ggtheme = ggtheme, palette = palette, ...)
p <- p + theme(axis.title.x = element_blank(), axis.title.y = element_blank(),
axis.text= element_blank(),
axis.line = element_blank(), axis.ticks = element_blank(),
legend.position = "none")
p
}
# Helper functions
#%%%%%%%%%%%%%%%%%%%%
# Plot dendrogram using ggplot
# .ggplot_dend derrived from dendextend::ggplot.ggdend
# data: a ggdend class object.
.ggplot_dend <- function (dend, segments = TRUE, labels = TRUE, nodes = TRUE,
horiz = FALSE, ggtheme = theme_classic(),
offset_labels = 0, circular = FALSE, type = "rectangle",
palette = NULL, label_cols = NULL, labels_font = "plain", labels_track_height = 1,
...) {
gdend <- dendextend::as.ggdend(dend, type = type)
#angle <- ifelse(horiz, 0, 90)
#hjust <- ifelse(horiz, 0, 1)
gdend$labels$angle <- ifelse(horiz, 0, 90)
gdend$labels$hjust <- ifelse(horiz, 0, 1)
gdend$labels$vjust <- 0.5
if(circular){
# If circular, change the angle and hjust so that the labels rotate
if(circular) {
pms <- .get_label_params(gdend$labels)
gdend$labels$angle <- pms$angle
gdend$labels$hjust <- pms$hjust
}
}
data <- dendextend::prepare.ggdend(gdend)
# To avoid overlaping of labels at coord_polar start
if(circular) {
n_rows <- nrow(data$labels)
data$labels$x[1] <- 0.7
data$labels$vjust[1] <- 1.7
}
p <- ggplot()
if (segments) {
# FIX: ggplot2 3.0.0+ deprecation - aes_string() replaced with aes() + .data pronoun
# FIX: ggplot2 3.4.0+ deprecation - size replaced with linewidth for line geoms
# See: https://github.com/kassambara/factoextra/issues/190, #191
p <- p + geom_segment(data = data$segments,
aes(x = .data[["x"]], y = .data[["y"]], xend = .data[["xend"]], yend = .data[["yend"]],
colour = .data[["col"]], linetype = .data[["lty"]], linewidth = .data[["lwd"]]), lineend = "square") +
# FIX: ggplot2 3.3.4+ deprecation - use "none" instead of FALSE for guides()
# See: https://github.com/kassambara/factoextra/issues/179
guides(linetype = "none", col = "none", linewidth = "none") + #scale_colour_identity() +
scale_linewidth_identity() + scale_linetype_identity()
if(is.null(palette)) p <- p + scale_colour_identity()
}
if (nodes) {
# FIX: ggplot2 3.0.0+ deprecation - aes_string() replaced with aes() + .data pronoun
# See: https://github.com/kassambara/factoextra/issues/190
p <- p + geom_point(data = data$nodes,
aes(x = .data[["x"]], y = .data[["y"]], colour = .data[["col"]], shape = .data[["pch"]], size = .data[["cex"]])) +
# FIX: ggplot2 3.3.4+ deprecation - use "none" instead of FALSE for guides()
# See: https://github.com/kassambara/factoextra/issues/179
guides(shape = "none", col = "none", size = "none") +
scale_shape_identity()
}
if (labels) {
data$labels$cex <- 5 * data$labels$cex
data$labels$y <- data$labels$y + offset_labels
if(is.null(label_cols)) label_cols <- "col"
p <- p + ggpubr::geom_exec(geom_text, data = data$labels,
x = "x", y = "y", label = "label", color = label_cols, size = "cex",
angle = "angle", hjust = "hjust", vjust = "vjust")
# Map the label size through an identity scale so `cex` (stored per leaf in
# data$labels$cex) sets the text size directly. Without this, ggplot2's
# default continuous size scale rescales a single per-plot cex value to a
# fixed midpoint, so `cex` had no visible effect on the leaf labels (#281).
p <- p + scale_size_identity()
# Apply a single font face to all leaf labels (e.g. "italic") as a fixed
# layer parameter. Only when non-default, so the "plain" path is untouched (#121).
if(!identical(labels_font, "plain"))
p$layers[[length(p$layers)]]$aes_params$fontface <- labels_font
}
p <- ggpubr::ggpar(p, ggtheme = ggtheme, palette = palette, ...) + theme(axis.line = element_blank())
if (horiz && !circular) {
p <- p + coord_flip() + scale_y_reverse()+
theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(),
axis.text.x = element_text())
}
else p <- p + theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
if(circular){
p <- p + theme(plot.margin = margin(0, 0, 0, 0),
axis.title.x = element_blank(), axis.title.y = element_blank(),
axis.text= element_blank(),
axis.line = element_blank(), axis.ticks = element_blank())+
ylim(max(dendextend::get_branches_heights(dend)), -1)+
coord_polar(theta = 'x', direction = 1)
}
else{
p <- p + expand_limits(y=-labels_track_height)
}
p
}
# Function used for circular dendrogram
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Create the angle and hjust vectors so that the labels
# rotation switches from 6 o'clock to 12 o'clock to improve readability.
.get_label_params <- function(labeldf) {
nn <- length(labeldf$y)
halfn <- floor(nn/2)
firsthalf <- rev(90 + seq(0,360, length.out = nn))
secondhalf <- rev(-90 + seq(0,360, length.out = nn))
angle <- numeric(nn)
angle[1:halfn] <- firsthalf[1:halfn]
angle[(halfn+1):nn] <- secondhalf[(halfn+1):nn]
hjust <- numeric(nn)
hjust[1:halfn] <- 0
hjust[(halfn+1):nn] <- 1
return(list(angle = angle, hjust = hjust))
}
# Convert 'hclust' to 'phylo' object
# used for phylogenic tree
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# from ape::as.phylo.hclust
# x hclust
.as.phylo <- function (x, ...)
{
N <- dim(x$merge)[1]
edge <- matrix(0L, 2 * N, 2)
edge.length <- numeric(2 * N)
node <- integer(N)
node[N] <- N + 2L
cur.nod <- N + 3L
j <- 1L
for (i in N:1) {
edge[j:(j + 1), 1] <- node[i]
for (l in 1:2) {
k <- j + l - 1L
y <- x$merge[i, l]
if (y > 0) {
edge[k, 2] <- node[y] <- cur.nod
cur.nod <- cur.nod + 1L
edge.length[k] <- x$height[i] - x$height[y]
}
else {
edge[k, 2] <- -y
edge.length[k] <- x$height[i]
}
}
j <- j + 2L
}
if (is.null(x$labels))
x$labels <- as.character(1:(N + 1))
obj <- list(edge = edge, edge.length = edge.length/2, tip.label = x$labels,
Nnode = N)
class(obj) <- "phylo"
obj
#ape::reorder.phylo(obj)
}
# Get k value if h specified
# Make also some checking
# dend a dendrogram object
# h: tree height
.get_k <- function(dend, k = NULL, h = NULL){
if (!dendextend::is.dendrogram(dend)) stop("x is not a dendrogram object.")
if (length(h) > 1L || length(k) > 1L)
stop("'k' and 'h' must be a scalar(i.e.: of length 1)")
if(!is.null(k)){
n_leaves <- length(stats::order.dendrogram(dend))
k <- .coerce_integerish(
k, "k", lower = 1L, upper = n_leaves,
value_label = "single integer value"
)
}
tree_heights <- dendextend::heights_per_k.dendrogram(dend)[-1]
tree_order <- stats::order.dendrogram(dend)
if (!is.null(h)) {
if (!is.null(k))
stop("specify exactly one of 'k' and 'h'")
if (!is.numeric(h) || length(h) != 1L || is.na(h) || !is.finite(h))
stop("'h' must be a single finite numeric value", call. = FALSE)
candidate_k <- as.numeric(names(tree_heights))[tree_heights < h]
if (!length(candidate_k))
stop("'h' is at or below the lowest merge height; increase 'h'",
call. = FALSE)
k <- min(candidate_k)
k <- max(k, 2)
}
k
}
# Left-to-right cluster-label order of a dendrogram cut into k groups.
# dendextend colours branches in leaf (left-to-right) order, whereas
# fviz_cluster()/fviz_silhouette() colour by cluster label. Remapping a length-k
# colour vector by this order makes the colours match across the three plots
# (#103). Returns NULL when the cut is not a clean permutation of seq_len(k).
.coord_color_order <- function(dend, k){
# dendextend colours the g-th cluster in LEAF (left-to-right) order with
# value[g]. fviz_cluster()/fviz_silhouette() colour by the DATA-order cluster
# label (cutree's labelling). So value[g] should be k_colors[ data-label of the
# g-th leaf cluster ]. That permutation is the data-order labels read in leaf
# order: unique(cutree(.., as_data = TRUE)[order.dendrogram(dend)]).
cl <- tryCatch(dendextend::cutree(dend, k = k, order_clusters_as_data = TRUE),
error = function(e) NULL)
ord <- tryCatch(stats::order.dendrogram(dend), error = function(e) NULL)
if(is.null(cl) || is.null(ord) || length(cl) != length(ord)) return(NULL)
lr <- unique(cl[ord])
lr <- lr[!is.na(lr)]
if(length(lr) == k && setequal(lr, seq_len(k))) as.integer(lr) else NULL
}
# Add rectangle to a dendrogram
# lower_rect: a (scalar) value of how low should the lower part of the rect be.
.rect_dendrogram <- function (dend, k = NULL, h = NULL,
k_colors = NULL, palette = NULL, rect_fill = FALSE, rect_lty = 2,
lower_rect=-1.5, match_coord_colors = FALSE,
...)
{
if(missing(k_colors) && !is.null(palette)) k_colors <- palette
# value (should be between 0 to 1): proportion of the height
# our rect will be between the height needed for k and k+1 clustering.
prop_k_height <- 0.5
if (!dendextend::is.dendrogram(dend))
stop("x is not a dendrogram object.")
k <- .get_k(dend, k, h)
tree_heights <- dendextend::heights_per_k.dendrogram(dend)[-1]
tree_order <- stats::order.dendrogram(dend)
if (is.null(k)) stop("specify k")
k <- .coerce_integerish(
k, "k", lower = 2L, upper = length(tree_order),
value_label = "single integer value"
)
cluster <- dendextend::cutree(dend, k = k)
clustab <- table(cluster)[unique(cluster[tree_order])]
m <- c(0, cumsum(clustab))
which <- 1L:k
# Collapse height lookups to a single value: tied merge heights can make
# `names(tree_heights) == k` match more than one entry, which would make
# ytop (and thus the rectangle data frame) longer than k rows and break the
# geom_rect aesthetics. Well-behaved dendrograms match exactly one (#154, #168).
k_height <- tree_heights[names(tree_heights) == k]
k_height <- if (length(k_height) == 0) 0 else max(k_height)
next_k_height <- tree_heights[names(tree_heights) == k + 1]
if (length(next_k_height) == 0) {
next_k_height <- 0
prop_k_height <- 1
} else next_k_height <- max(next_k_height)
xleft <- ybottom <- xright <- ytop <- list()
for (n in seq_along(which)) {
xleft[[n]] = m[which[n]] + 0.66
ybottom[[n]] = lower_rect
xright[[n]] = m[which[n] + 1] + 0.33
ytop[[n]] <- k_height * prop_k_height + next_k_height * (1 - prop_k_height)
}
df <- data.frame(xmin = unlist(xleft), ymin = unlist(ybottom), xmax = unlist(xright), ymax = unlist(ytop))
color <- k_colors
# FIX: R 4.2.0+ deprecation - condition has length > 1 warning
# Use length() == 1 check before scalar comparison
# See: https://github.com/kassambara/factoextra/issues/163, #180
if(length(color) == 1 && color == "cluster") color <- "default"
if(.is_color_palette(color)) color <- ggpubr::get_palette(color, k = k)
else if(length(color) > 1 && length(color) != k){
# recycle/trim a multi-colour vector to exactly k (one per rectangle)
color <- rep_len(color, k)
}
# Align rectangle colours to cluster-label order (matches branch/label colours
# and fviz_cluster()/fviz_silhouette()) when requested (#103).
if(match_coord_colors && length(color) == k){
ord <- .coord_color_order(dend, k)
if(!is.null(ord)) color <- color[ord]
}
if(rect_fill){
fill <- color
alpha <- 0.2
}
else {
fill <- "transparent"
alpha <- 0
}
df$color <- color
df$cluster <- as.factor(paste0("c", 1:k))
ggpubr::geom_exec(geom_rect, data = df,
xmin = "xmin", ymin = "ymin", xmax = "xmax", ymax = "ymax",
fill = fill, color = color, linetype = rect_lty, alpha = alpha, ...)
}
Try the factoextra package in your browser
Any scripts or data that you put into this service are public.
factoextra documentation built on July 24, 2026, 9:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .coord_color_order .get_k .get_label_params .phylogenic_tree fviz_dend
Documented in fviz_dend
#' Enhanced Visualization of Dendrogram
#'
#' @description Draws easily beautiful dendrograms using either R base plot or
#' ggplot2. It also provides options for circular dendrograms and
#' phylogenetic-style trees.
#'
#' Read more: \href{https://www.datanovia.com/learn/machine-learning/clustering/visualizing-dendrograms}{Visualizing Dendrograms in R: Color, Zoom & Customize};
#' to compare two trees see \href{https://www.datanovia.com/learn/machine-learning/clustering/comparing-dendrograms}{Comparing Dendrograms in R: Tanglegrams & Correlation}.
#'
#' @param x an object of class dendrogram, hclust, agnes, diana, hcut,
#' hkmeans or HCPC (FactoMineR).
#' @param k the number of groups for cutting the tree.
#' @param h a numeric value. Cut the dendrogram by cutting at height h. (k
#' overrides h)
#' @param k_colors,palette a vector containing colors to be used for the groups.
#' It should contain \code{k} colors. Allowed values also include "grey"
#' for grey color palettes; brewer palettes e.g. "RdBu", "Blues", ...; and
#' scientific journal palettes from ggsci R package, e.g.: "npg", "aaas",
#' "lancet", "jco", "ucscgb", "uchicago", "simpsons" and "rickandmorty".
#' @param show_labels a logical value. If TRUE, leaf labels are shown. Default
#' value is TRUE.
#' @param color_labels_by_k logical value. If TRUE, labels are colored
#' automatically by group when k != NULL.
#' @param match_coord_colors logical value. Default is FALSE, where dendrogram
#' colors follow the left-to-right leaf order. If TRUE, cluster colors are
#' remapped to cluster-label order so they match \code{\link{fviz_cluster}()}
#' and \code{\link{fviz_silhouette}()} for the same clustering.
#' @param label_cols a vector containing the colors for labels.
#' @param labels_font font face for the leaf labels of "rectangle"/"circular"
#' dendrograms. One of "plain" (default), "bold", "italic" or "bold.italic".
#' Default "plain" leaves labels unchanged.
#' @param labels_track_height a positive numeric value for adjusting the room for the
#' labels. Used only when type = "rectangle".
#' @param repel logical value. Use repel = TRUE to avoid label overplotting when
#' \code{type = "phylogenic"}. The literal \code{"phylogenic"} value is a
#' historical API token retained for compatibility.
#' @param lwd a numeric value specifying dendrogram branch and rectangle line
#' width.
#' @param highlight an optional character vector of leaf labels; the branches
#' leading to those leaves are emphasized (thicker, and coloured
#' \code{highlight.col}) while every other branch keeps its colour and width.
#' \code{NULL} (default) highlights nothing. Has no effect for
#' \code{type = "phylogenic"} (that layout does not colour branch segments).
#' @param highlight.col colour (name or hex) for the highlighted branches.
#' @param highlight.lwd line width for the highlighted branches. \code{NULL}
#' (default) uses \code{2 * lwd} so the emphasis stands out by thickness
#' regardless of colour; set \code{highlight.lwd = lwd} for colour-only emphasis.
#' @param type type of plot. Allowed values are \code{"rectangle"},
#' \code{"circular"}, and the historical compatibility token
#' \code{"phylogenic"} for a phylogenetic-style tree.
#' @param phylo_layout the layout used for phylogenetic-style trees. Default value
#' is "layout.auto", which is kept as a compatibility alias for
#' \code{"layout_nicely"}. Allowed values include:
#' \code{\link[igraph]{layout.auto}}, \code{\link[igraph]{layout_nicely}},
#' \code{\link[igraph]{layout_with_drl}}, \code{\link[igraph]{layout_as_tree}},
#' \code{\link[igraph]{layout.gem}}, \code{\link[igraph]{layout_with_gem}},
#' \code{\link[igraph]{layout.mds}}, \code{\link[igraph]{layout_with_mds}} and
#' \code{\link[igraph]{layout_with_lgl}}.
#' @param rect logical value specifying whether to add a rectangle around
#' groups. Used only when k != NULL.
#' @param rect_border,rect_lty border color and line type for rectangles.
#' @param rect_fill a logical value. If TRUE, fill the rectangle.
#' @param lower_rect a value of how low should the lower part of the rectangle
#' around clusters. Ignored when rect = FALSE.
#' @param horiz a logical value. If TRUE, a horizontal dendrogram is drawn.
#' @param cex size of labels
#' @param main,xlab,ylab main and axis titles
#' @param sub Plot subtitle. Default is NULL (no subtitle). Set to a character
#' string to display a subtitle below the title, e.g.
#' \code{sub = paste0("Method: ", "ward.D2")}.
#' @param ggtheme function, ggplot2 theme name. Default value is
#' theme_classic(). Allowed values include ggplot2 official themes:
#' theme_gray(), theme_bw(), theme_minimal(), theme_classic(), theme_void(),
#' ....
#' @param ... other arguments to be passed to the function plot.dendrogram()
#' @return an object of class fviz_dend which is a ggplot with the attributes
#' "dendrogram" accessible using attr(x, "dendrogram"), where x is the result
#' of fviz_dend().
#' @details For branch styling beyond \code{highlight} - for example dashed
#' branches or per-branch colours - pre-style a \code{dendextend} dendrogram and
#' pass it to \code{fviz_dend()}, which honours its \code{set()} aesthetics:
#' \preformatted{
#' library(dendextend)
#' dend <- as.dendrogram(hclust(dist(scale(USArrests))))
#' dend <- set(dend, "branches_lty", 2) # dashed branches
#' fviz_dend(dend)
#' }
#'
#' \strong{Comparing two dendrograms.} To compare two hierarchical clusterings of
#' the same observations (e.g. different linkages), draw a \emph{tanglegram} with
#' \code{dendextend} (already a dependency): the two trees face each other, matched
#' leaves are connected, and \code{entanglement()} measures agreement (0 = perfect,
#' 1 = worst). This uses base graphics.
#' \preformatted{
#' library(dendextend)
#' d1 <- as.dendrogram(hclust(dist(scale(USArrests)), "complete"))
#' d2 <- as.dendrogram(hclust(dist(scale(USArrests)), "average"))
#' dl <- dendlist(d1, d2)
#' dl <- untangle(dl, method = "step2side") # reduce crossings
#' tanglegram(dl, common_subtrees_color_branches = TRUE)
#' entanglement(dl) # agreement, in [0, 1]
#' }
#' Both dendrograms must share the same leaf labels.
#' @seealso \code{\link[dendextend]{tanglegram}}, \code{\link[dendextend]{entanglement}}
#' for comparing two dendrograms (see \strong{Details}).
#' Online tutorials: \href{https://www.datanovia.com/learn/machine-learning/clustering/visualizing-dendrograms}{Visualizing Dendrograms in R: Color, Zoom & Customize}
#' and \href{https://www.datanovia.com/learn/machine-learning/clustering/comparing-dendrograms}{Comparing Dendrograms in R: Tanglegrams & Correlation}.
#' @examples
#' \donttest{
#' # Load and scale the data
#' data(USArrests)
#' df <- scale(USArrests)
#'
#' # Hierarchical clustering
#' res.hc <- hclust(dist(df))
#'
#' # Default plot
#' fviz_dend(res.hc)
#'
#' # Increase branch and rectangle line widths
#' fviz_dend(res.hc, lwd = 2)
#'
#' # Cut the tree
#' fviz_dend(res.hc, cex = 0.5, k = 4, color_labels_by_k = TRUE)
#'
#' # Don't color labels, add rectangles
#' fviz_dend(res.hc, cex = 0.5, k = 4,
#' color_labels_by_k = FALSE, rect = TRUE)
#'
#' # Change the color of tree using black color for all groups
#' # Change rectangle border colors
#' fviz_dend(res.hc, rect = TRUE, k_colors ="black",
#' rect_border = 2:5, rect_lty = 1)
#'
#' # Customized color for groups
#' fviz_dend(res.hc, k = 4,
#' k_colors = c("#1B9E77", "#D95F02", "#7570B3", "#E7298A"))
#'
#'
#' # Color labels using k-means clusters
#' km.clust <- kmeans(df, 4)$cluster
#' fviz_dend(res.hc, k = 4,
#' k_colors = c("blue", "green3", "red", "black"),
#' label_cols = km.clust[res.hc$order], cex = 0.6)
#'
#' # Phylogenetic-style tree layouts support both compatibility aliases and
#' # current igraph layout names
#' if (requireNamespace("igraph", quietly = TRUE)) {
#' fviz_dend(res.hc, type = "phylogenic", phylo_layout = "layout_nicely",
#' show_labels = FALSE)
#' }
#'
#' }
#' @export
fviz_dend <- function(x, k = NULL, h = NULL, k_colors = NULL, palette = NULL, show_labels = TRUE, color_labels_by_k = TRUE,
match_coord_colors = FALSE,
label_cols = NULL, labels_font = "plain", labels_track_height = NULL, repel = FALSE, lwd = 0.7,
highlight = NULL, highlight.col = "red", highlight.lwd = NULL,
type = c("rectangle", "circular", "phylogenic"),
phylo_layout = "layout.auto",
rect = FALSE, rect_border = "gray", rect_lty = 2, rect_fill = FALSE, lower_rect,
horiz = FALSE, cex = 0.8, main = "Cluster Dendrogram", xlab = "", ylab = "Height",
sub = NULL, ggtheme = theme_classic(), ...)
{
if(missing(k_colors) && !is.null(palette)) {
k_colors <- palette
palette <- NULL
}
if(!color_labels_by_k && is.null(label_cols)) label_cols <- "black"
type <- match.arg(type)
circular <- type == "circular"
phylogenic <- type == "phylogenic"
rectangle <- type == "rectangle"
if(inherits(x, "HCPC")){
# Honor an explicit k; default to the number of HCPC clusters when k is
# NULL. The previous code always overwrote k, so a user-supplied k (e.g.
# fviz_dend(hcpc, k = 5)) was silently ignored and colored at the HCPC
# cluster count instead. (#81)
if(is.null(k)) k <- length(unique(x$data.clust$clust))
x <- x$call$t$tree #hclust
}
if(inherits(x, "hcut")){
k <- x$nbclust
dend <- as.dendrogram(x)
method <- x$method
}
else if(inherits(x, "hkmeans")){
k <- length(unique(x$cluster))
dend <- as.dendrogram(x$hclust)
method <- x$hclust$method
}
else if(inherits(x, c("hclust", "agnes", "diana"))) {
dend <- as.dendrogram(x)
method <- x$method
}
else if(inherits(x, "dendrogram")) {
dend <- x
method <- ""
}
else stop("Can't handle an object of class ", paste(class(x), collapse =", ") )
if(is.null(method)) method <- ""
else if(is.na(method)) method <- ""
# `sub` defaults to NULL (no subtitle), preserving the previous appearance.
# When set, it is rendered via labs(subtitle=) below (#54).
if(!is.null(dendextend::labels_cex(dend))) cex <- dendextend::labels_cex(dend)
dend <- dendextend::set(dend, "labels_cex", cex)
dend <- dendextend::set(dend, "branches_lwd", lwd)
k <- .get_k(dend, k, h)
if(!is.null(k)) {
if(.is_color_palette(k_colors)) k_colors <- ggpubr::get_palette(k_colors, k = k)
else if(is.null(k_colors)) k_colors <- ggpubr::get_palette("default", k = k)
# By default colours follow the left-to-right leaf order (dendextend). With
# match_coord_colors = TRUE, remap them to cluster-label order so they match
# fviz_cluster()/fviz_silhouette() for the same clustering (#103).
branch_colors <- k_colors
if(match_coord_colors){
ord <- .coord_color_order(dend, k)
if(!is.null(ord)) branch_colors <- k_colors[ord]
}
dend <- dendextend::set(dend, what = "branches_k_color", k = k, value = branch_colors)
if(color_labels_by_k) dend <- dendextend::set(dend, "labels_col", k = k, value = branch_colors)
}
if(!is.null(label_cols)){
dend <- dendextend::set(dend, "labels_col", label_cols)
}
# Emphasize the branches leading to specific leaves. Applied AFTER the k /
# label colouring so it layers on top: highlighted branches take
# `highlight.col` (and optionally `highlight.lwd`), every other branch keeps
# its existing colour/width (the Inf sentinel). highlight = NULL (default)
# leaves the dendrogram untouched, so existing plots are unchanged. (#P2.3)
if(!is.null(highlight)){
bad <- setdiff(highlight, labels(dend))
if(length(bad))
stop("`highlight` contains labels not in the dendrogram: ",
paste(bad, collapse = ", "), ".", call. = FALSE)
if(phylogenic)
warning("`highlight` has no effect for type = \"phylogenic\": that layout ",
"does not colour branch segments.", call. = FALSE)
dend <- dendextend::set(dend, "by_labels_branches_col", value = highlight,
TF_values = c(highlight.col, Inf))
# Emphasize by THICKNESS by default (2x lwd): thickness always stands out,
# even when highlight.col happens to match a nearby cluster colour. Pass
# highlight.lwd = lwd for colour-only emphasis.
h_lwd <- if(is.null(highlight.lwd)) 2 * lwd else highlight.lwd
dend <- dendextend::set(dend, "by_labels_branches_lwd", value = highlight,
TF_values = c(h_lwd, Inf))
}
leaflab <- ifelse(show_labels, "perpendicular", "none")
if(xlab =="") xlab <- NULL
if(ylab=="") ylab <- NULL
max_height <- max(dendextend::get_branches_heights(dend))
if(missing(labels_track_height))
labels_track_height <- max_height/8
if(max_height < 1) offset_labels <- -max_height/100
else offset_labels <- -0.1
if(rectangle || circular){
p <- .ggplot_dend(dend, type = "rectangle", offset_labels = offset_labels, nodes = FALSE,
ggtheme = ggtheme, horiz = horiz, circular = circular, palette = palette,
labels = show_labels, label_cols = label_cols, labels_font = labels_font,
labels_track_height = labels_track_height, ...)
if(!circular) p <- p + labs(title = main, subtitle = sub, x = xlab, y = ylab)
}
else if(phylogenic){
p <- .phylogenic_tree(dend, labels = show_labels, label_cols = label_cols,
palette = palette, repel = repel,
ggtheme = ggtheme, phylo_layout = phylo_layout, ...)
}
# Add rectangle around clusters
if(circular || phylogenic || is.null(k)) rect <- FALSE
if(rect_fill && missing(rect_lty)) rect_lty = "blank"
if(missing(lower_rect)) {
# The absolute -0.5 offset overwhelms short trees (e.g. correlation/gower
# distances with max height < 1), pushing the rectangles far below the
# labels. For those, scale the offset to the tree height instead; taller
# trees (>= 1) keep the previous default unchanged (#55).
lower_rect <- if(max_height < 1) -(labels_track_height + max_height/8)
else -(labels_track_height + 0.5)
}
if(rect){
p <- p + .rect_dendrogram(dend, k = k, palette = rect_border, rect_fill = rect_fill,
rect_lty = rect_lty, linewidth = lwd,
lower_rect = lower_rect, match_coord_colors = match_coord_colors)
}
# Keep the leaf-label text layer out of the legend (no stray "a" glyph),
# mirroring the scatter-plot cleanup in .fviz_finish() (#14).
p <- .hide_text_legend(p)
attr(p, "dendrogram") <- dend
structure(p, class = c(class(p), "fviz_dend"))
return(p)
}
# require igraph
.phylogenic_tree <- function(dend, labels = TRUE, label_cols = NULL,
palette = NULL, repel = FALSE,
ggtheme = theme_classic(),
phylo_layout = "layout.auto", ...){
if (!requireNamespace("igraph", quietly = TRUE)) {
stop("The igraph package is required for a phylogenetic-style tree. ",
"Install it with install.packages('igraph').")
}
allowed_layouts <- c("layout.auto", "layout_nicely", "layout_with_drl", "layout_as_tree",
"layout.gem", "layout_with_gem", "layout.mds", "layout_with_mds", "layout_with_lgl")
if(!(phylo_layout %in% allowed_layouts)) stop(phylo_layout, " is not a supported layout. ",
"Allowed phylogenetic-style layouts are: ",
paste( allowed_layouts, collapse = ", "))
layout_func <- switch(phylo_layout,
layout.auto = igraph::layout_nicely,
layout_nicely = igraph::layout_nicely,
layout_with_drl = igraph::layout_with_drl,
layout_as_tree = igraph::layout_as_tree,
layout.gem = igraph::layout_with_gem,
layout_with_gem = igraph::layout_with_gem,
layout.mds = igraph::layout_with_mds,
layout_with_mds = igraph::layout_with_mds,
layout_with_lgl = igraph::layout_with_lgl
)
# Convert to 'phylo' object
hc <- stats::as.hclust(dend)
phylo_tree <- .as.phylo(hc)
graph_edges <- phylo_tree$edge
# get graph from edge list
graph_net <- igraph::graph_from_edgelist(graph_edges)
# extract layout (x-y coords)
graph_layout <- .with_preserved_seed(123, layout_func(graph_net))
# number of observations
nobs <- length(hc$labels)
# draw tree branches
data.segments <- data.frame(
x = graph_layout[graph_edges[,1],1],
y = graph_layout[graph_edges[,1],2],
xend = graph_layout[graph_edges[,2],1],
yend = graph_layout[graph_edges[,2],2]
)
data.labels <- data.frame(
x = graph_layout[1:nobs,1],
y = graph_layout[1:nobs,2],
label = phylo_tree$tip.label
)
data.labels <- data.labels[order(as.vector(data.labels$label)), ]
# Support for dendextend
gdend <- dendextend::as.ggdend(dend)
gdat <- dendextend::prepare.ggdend(gdend)
gdat$labels <- gdat$labels[order(as.vector(gdat$labels$label)), ]
data.labels <- cbind(data.labels, gdat$labels[, c("col", "cex")])
if(!is.null(dendextend::labels_cex(dend))) font.label <- round(dendextend::labels_cex(dend)[1]*12)
else font.label <- 12
# FIX: ggplot2 3.0.0+ deprecation - aes_string() replaced with aes() + .data pronoun
# See: https://github.com/kassambara/factoextra/issues/190
p <- ggplot() + geom_segment(data = data.segments,
aes(x = .data[["x"]], y = .data[["y"]], xend = .data[["xend"]], yend = .data[["yend"]]),
lineend = "square")
if(is.null(label_cols)) label_cols <- "col"
if(!labels) labels <- NULL
else labels <- "label"
p <- ggpubr::ggscatter(data.labels, "x", "y", label = labels,
color = label_cols,
ggp = p, repel = repel, font.label = font.label, ...)
if(is.null(palette)) p <- p + scale_colour_identity()
p <- ggpubr::ggpar(p, ggtheme = ggtheme, palette = palette, ...)
p <- p + theme(axis.title.x = element_blank(), axis.title.y = element_blank(),
axis.text= element_blank(),
axis.line = element_blank(), axis.ticks = element_blank(),
legend.position = "none")
p
}
# Helper functions
#%%%%%%%%%%%%%%%%%%%%
# Plot dendrogram using ggplot
# .ggplot_dend derrived from dendextend::ggplot.ggdend
# data: a ggdend class object.
.ggplot_dend <- function (dend, segments = TRUE, labels = TRUE, nodes = TRUE,
horiz = FALSE, ggtheme = theme_classic(),
offset_labels = 0, circular = FALSE, type = "rectangle",
palette = NULL, label_cols = NULL, labels_font = "plain", labels_track_height = 1,
...) {
gdend <- dendextend::as.ggdend(dend, type = type)
#angle <- ifelse(horiz, 0, 90)
#hjust <- ifelse(horiz, 0, 1)
gdend$labels$angle <- ifelse(horiz, 0, 90)
gdend$labels$hjust <- ifelse(horiz, 0, 1)
gdend$labels$vjust <- 0.5
if(circular){
# If circular, change the angle and hjust so that the labels rotate
if(circular) {
pms <- .get_label_params(gdend$labels)
gdend$labels$angle <- pms$angle
gdend$labels$hjust <- pms$hjust
}
}
data <- dendextend::prepare.ggdend(gdend)
# To avoid overlaping of labels at coord_polar start
if(circular) {
n_rows <- nrow(data$labels)
data$labels$x[1] <- 0.7
data$labels$vjust[1] <- 1.7
}
p <- ggplot()
if (segments) {
# FIX: ggplot2 3.0.0+ deprecation - aes_string() replaced with aes() + .data pronoun
# FIX: ggplot2 3.4.0+ deprecation - size replaced with linewidth for line geoms
# See: https://github.com/kassambara/factoextra/issues/190, #191
p <- p + geom_segment(data = data$segments,
aes(x = .data[["x"]], y = .data[["y"]], xend = .data[["xend"]], yend = .data[["yend"]],
colour = .data[["col"]], linetype = .data[["lty"]], linewidth = .data[["lwd"]]), lineend = "square") +
# FIX: ggplot2 3.3.4+ deprecation - use "none" instead of FALSE for guides()
# See: https://github.com/kassambara/factoextra/issues/179
guides(linetype = "none", col = "none", linewidth = "none") + #scale_colour_identity() +
scale_linewidth_identity() + scale_linetype_identity()
if(is.null(palette)) p <- p + scale_colour_identity()
}
if (nodes) {
# FIX: ggplot2 3.0.0+ deprecation - aes_string() replaced with aes() + .data pronoun
# See: https://github.com/kassambara/factoextra/issues/190
p <- p + geom_point(data = data$nodes,
aes(x = .data[["x"]], y = .data[["y"]], colour = .data[["col"]], shape = .data[["pch"]], size = .data[["cex"]])) +
# FIX: ggplot2 3.3.4+ deprecation - use "none" instead of FALSE for guides()
# See: https://github.com/kassambara/factoextra/issues/179
guides(shape = "none", col = "none", size = "none") +
scale_shape_identity()
}
if (labels) {
data$labels$cex <- 5 * data$labels$cex
data$labels$y <- data$labels$y + offset_labels
if(is.null(label_cols)) label_cols <- "col"
p <- p + ggpubr::geom_exec(geom_text, data = data$labels,
x = "x", y = "y", label = "label", color = label_cols, size = "cex",
angle = "angle", hjust = "hjust", vjust = "vjust")
# Map the label size through an identity scale so `cex` (stored per leaf in
# data$labels$cex) sets the text size directly. Without this, ggplot2's
# default continuous size scale rescales a single per-plot cex value to a
# fixed midpoint, so `cex` had no visible effect on the leaf labels (#281).
p <- p + scale_size_identity()
# Apply a single font face to all leaf labels (e.g. "italic") as a fixed
# layer parameter. Only when non-default, so the "plain" path is untouched (#121).
if(!identical(labels_font, "plain"))
p$layers[[length(p$layers)]]$aes_params$fontface <- labels_font
}
p <- ggpubr::ggpar(p, ggtheme = ggtheme, palette = palette, ...) + theme(axis.line = element_blank())
if (horiz && !circular) {
p <- p + coord_flip() + scale_y_reverse()+
theme(axis.text.y = element_blank(), axis.ticks.y = element_blank(),
axis.text.x = element_text())
}
else p <- p + theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
if(circular){
p <- p + theme(plot.margin = margin(0, 0, 0, 0),
axis.title.x = element_blank(), axis.title.y = element_blank(),
axis.text= element_blank(),
axis.line = element_blank(), axis.ticks = element_blank())+
ylim(max(dendextend::get_branches_heights(dend)), -1)+
coord_polar(theta = 'x', direction = 1)
}
else{
p <- p + expand_limits(y=-labels_track_height)
}
p
}
# Function used for circular dendrogram
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Create the angle and hjust vectors so that the labels
# rotation switches from 6 o'clock to 12 o'clock to improve readability.
.get_label_params <- function(labeldf) {
nn <- length(labeldf$y)
halfn <- floor(nn/2)
firsthalf <- rev(90 + seq(0,360, length.out = nn))
secondhalf <- rev(-90 + seq(0,360, length.out = nn))
angle <- numeric(nn)
angle[1:halfn] <- firsthalf[1:halfn]
angle[(halfn+1):nn] <- secondhalf[(halfn+1):nn]
hjust <- numeric(nn)
hjust[1:halfn] <- 0
hjust[(halfn+1):nn] <- 1
return(list(angle = angle, hjust = hjust))
}
# Convert 'hclust' to 'phylo' object
# used for phylogenic tree
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# from ape::as.phylo.hclust
# x hclust
.as.phylo <- function (x, ...)
{
N <- dim(x$merge)[1]
edge <- matrix(0L, 2 * N, 2)
edge.length <- numeric(2 * N)
node <- integer(N)
node[N] <- N + 2L
cur.nod <- N + 3L
j <- 1L
for (i in N:1) {
edge[j:(j + 1), 1] <- node[i]
for (l in 1:2) {
k <- j + l - 1L
y <- x$merge[i, l]
if (y > 0) {
edge[k, 2] <- node[y] <- cur.nod
cur.nod <- cur.nod + 1L
edge.length[k] <- x$height[i] - x$height[y]
}
else {
edge[k, 2] <- -y
edge.length[k] <- x$height[i]
}
}
j <- j + 2L
}
if (is.null(x$labels))
x$labels <- as.character(1:(N + 1))
obj <- list(edge = edge, edge.length = edge.length/2, tip.label = x$labels,
Nnode = N)
class(obj) <- "phylo"
obj
#ape::reorder.phylo(obj)
}
# Get k value if h specified
# Make also some checking
# dend a dendrogram object
# h: tree height
.get_k <- function(dend, k = NULL, h = NULL){
if (!dendextend::is.dendrogram(dend)) stop("x is not a dendrogram object.")
if (length(h) > 1L || length(k) > 1L)
stop("'k' and 'h' must be a scalar(i.e.: of length 1)")
if(!is.null(k)){
n_leaves <- length(stats::order.dendrogram(dend))
k <- .coerce_integerish(
k, "k", lower = 1L, upper = n_leaves,
value_label = "single integer value"
)
}
tree_heights <- dendextend::heights_per_k.dendrogram(dend)[-1]
tree_order <- stats::order.dendrogram(dend)
if (!is.null(h)) {
if (!is.null(k))
stop("specify exactly one of 'k' and 'h'")
if (!is.numeric(h) || length(h) != 1L || is.na(h) || !is.finite(h))
stop("'h' must be a single finite numeric value", call. = FALSE)
candidate_k <- as.numeric(names(tree_heights))[tree_heights < h]
if (!length(candidate_k))
stop("'h' is at or below the lowest merge height; increase 'h'",
call. = FALSE)
k <- min(candidate_k)
k <- max(k, 2)
}
k
}
# Left-to-right cluster-label order of a dendrogram cut into k groups.
# dendextend colours branches in leaf (left-to-right) order, whereas
# fviz_cluster()/fviz_silhouette() colour by cluster label. Remapping a length-k
# colour vector by this order makes the colours match across the three plots
# (#103). Returns NULL when the cut is not a clean permutation of seq_len(k).
.coord_color_order <- function(dend, k){
# dendextend colours the g-th cluster in LEAF (left-to-right) order with
# value[g]. fviz_cluster()/fviz_silhouette() colour by the DATA-order cluster
# label (cutree's labelling). So value[g] should be k_colors[ data-label of the
# g-th leaf cluster ]. That permutation is the data-order labels read in leaf
# order: unique(cutree(.., as_data = TRUE)[order.dendrogram(dend)]).
cl <- tryCatch(dendextend::cutree(dend, k = k, order_clusters_as_data = TRUE),
error = function(e) NULL)
ord <- tryCatch(stats::order.dendrogram(dend), error = function(e) NULL)
if(is.null(cl) || is.null(ord) || length(cl) != length(ord)) return(NULL)
lr <- unique(cl[ord])
lr <- lr[!is.na(lr)]
if(length(lr) == k && setequal(lr, seq_len(k))) as.integer(lr) else NULL
}
# Add rectangle to a dendrogram
# lower_rect: a (scalar) value of how low should the lower part of the rect be.
.rect_dendrogram <- function (dend, k = NULL, h = NULL,
k_colors = NULL, palette = NULL, rect_fill = FALSE, rect_lty = 2,
lower_rect=-1.5, match_coord_colors = FALSE,
...)
{
if(missing(k_colors) && !is.null(palette)) k_colors <- palette
# value (should be between 0 to 1): proportion of the height
# our rect will be between the height needed for k and k+1 clustering.
prop_k_height <- 0.5
if (!dendextend::is.dendrogram(dend))
stop("x is not a dendrogram object.")
k <- .get_k(dend, k, h)
tree_heights <- dendextend::heights_per_k.dendrogram(dend)[-1]
tree_order <- stats::order.dendrogram(dend)
if (is.null(k)) stop("specify k")
k <- .coerce_integerish(
k, "k", lower = 2L, upper = length(tree_order),
value_label = "single integer value"
)
cluster <- dendextend::cutree(dend, k = k)
clustab <- table(cluster)[unique(cluster[tree_order])]
m <- c(0, cumsum(clustab))
which <- 1L:k
# Collapse height lookups to a single value: tied merge heights can make
# `names(tree_heights) == k` match more than one entry, which would make
# ytop (and thus the rectangle data frame) longer than k rows and break the
# geom_rect aesthetics. Well-behaved dendrograms match exactly one (#154, #168).
k_height <- tree_heights[names(tree_heights) == k]
k_height <- if (length(k_height) == 0) 0 else max(k_height)
next_k_height <- tree_heights[names(tree_heights) == k + 1]
if (length(next_k_height) == 0) {
next_k_height <- 0
prop_k_height <- 1
} else next_k_height <- max(next_k_height)
xleft <- ybottom <- xright <- ytop <- list()
for (n in seq_along(which)) {
xleft[[n]] = m[which[n]] + 0.66
ybottom[[n]] = lower_rect
xright[[n]] = m[which[n] + 1] + 0.33
ytop[[n]] <- k_height * prop_k_height + next_k_height * (1 - prop_k_height)
}
df <- data.frame(xmin = unlist(xleft), ymin = unlist(ybottom), xmax = unlist(xright), ymax = unlist(ytop))
color <- k_colors
# FIX: R 4.2.0+ deprecation - condition has length > 1 warning
# Use length() == 1 check before scalar comparison
# See: https://github.com/kassambara/factoextra/issues/163, #180
if(length(color) == 1 && color == "cluster") color <- "default"
if(.is_color_palette(color)) color <- ggpubr::get_palette(color, k = k)
else if(length(color) > 1 && length(color) != k){
# recycle/trim a multi-colour vector to exactly k (one per rectangle)
color <- rep_len(color, k)
}
# Align rectangle colours to cluster-label order (matches branch/label colours
# and fviz_cluster()/fviz_silhouette()) when requested (#103).
if(match_coord_colors && length(color) == k){
ord <- .coord_color_order(dend, k)
if(!is.null(ord)) color <- color[ord]
}
if(rect_fill){
fill <- color
alpha <- 0.2
}
else {
fill <- "transparent"
alpha <- 0
}
df$color <- color
df$cluster <- as.factor(paste0("c", 1:k))
ggpubr::geom_exec(geom_rect, data = df,
xmin = "xmin", ymin = "ymin", xmax = "xmax", ymax = "ymax",
fill = fill, color = color, linetype = rect_lty, alpha = alpha, ...)
}
Try the factoextra package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.