How to adjust rect_border to accept multiple colours like other colour palettes?
I am unable to pass other color schemes into rect_border but it somehow works when the colour palette lancet is specified. How can I adjust the second plot to work on the smooth_rainbow colours?
See reprex below:
library(factoextra)
library(ggplot2)
library(khroma)
df <- scale(mtcars) # Standardize the data
dist <- dist(df, method = "euclidean") # df = standardized data
hc <- hclust(dist, method = "ward.D2")
p <- fviz_dend(hc, k = 4, # Cut in four groups
cex = 0.6, # label size
k_colors = "lancet",
color_labels_by_k = TRUE, # color labels by groups
rect = TRUE, # Add rectangle around groups
rect_border = "lancet",
rect_fill = TRUE,
rotate = TRUE) +
theme_dark()
#> Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
#> "none")` instead.
p$layers[[1]]$data$col[p$layers[[1]]$data$col == "black"] <- "white"
p$layers[[2]]$data$angle <- 0
p
smooth_rainbow <- khroma::colour("smooth rainbow")
p2 <-
fviz_dend(hc, k = 4, # Cut in four groups
cex = 0.6, # label size
k_colors = smooth_rainbow(n = 4),
color_labels_by_k = TRUE, # color labels by groups
rect = TRUE, # Add rectangle around groups
rect_border = smooth_rainbow(n = 4),
rect_fill = TRUE,
rotate = TRUE) +
ggplot2::theme_dark()
#> Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
#> "none")` instead.
#> Error in if (color == "cluster") color <- "default": the condition has length > 1
p2
#> Error in eval(expr, envir, enclos): object 'p2' not found
Created on 2023-05-07 by the reprex package (v2.0.1)
> sessionInfo()
R version 4.2.3 (2023-03-15 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 19044)
Matrix products: default
locale:
[1] LC_COLLATE=English_South Africa.utf8 LC_CTYPE=English_South Africa.utf8
[3] LC_MONETARY=English_South Africa.utf8 LC_NUMERIC=C
[5] LC_TIME=English_South Africa.utf8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] khroma_1.10.0 cluster_2.1.4 MTGmeta_0.0.0.9000 factoextra_1.0.7
[5] magrittr_2.0.3 here_1.0.1 forcats_0.5.1 stringr_1.4.0
[9] dplyr_1.0.9 purrr_0.3.5 readr_2.1.2 tidyr_1.2.0
[13] tibble_3.1.8 ggplot2_3.3.6 tidyverse_1.3.2
Solution
This is a bug and it would be great if you could report it to the package maintainer. The error originates from a conditional statement in factoextra:::.rect_dendrogram, which tests if your color argument is color == "cluster". This only works if your color argument is a vector of length 1. (e.g., passing a palette name works, as you have demonstrated).
When passing a vector of colors, this naturally fails, as R doesn't like to compare vectors of length > 1 with a ==. If you replace the conditional statement, e.g. with all(color == "cluster"), it works.
NB I have copied the adjusted functions for your convenience - there are a few uncommented modifications, in particular adding required factoextra::: to some un-exported functions.
library(factoextra)
library(ggplot2)
library(khroma)
##adjusted functions
fviz_dend2 <-
function (x, k = NULL, h = NULL, k_colors = NULL, palette = NULL,
show_labels = TRUE, color_labels_by_k = TRUE, label_cols = NULL,
labels_track_height = NULL, repel = FALSE, lwd = 0.7, 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")) {
k <- length(unique(x$data.clust$clust))
x <- x$call$t$tree
}
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 <- ""
if (is.null(sub) & method != "")
sub = paste0("Method: ", method)
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 <- factoextra:::.get_k(dend, k, h)
if (!is.null(k)) {
if (ggpubr:::.is_col_palette(k_colors))
k_colors <- ggpubr:::.get_pal(k_colors, k = k)
else if (is.null(k_colors))
k_colors <- ggpubr:::.get_pal("default", k = k)
dend <- dendextend::set(dend, what = "branches_k_color",
k = k, value = k_colors)
if (color_labels_by_k)
dend <- dendextend::set(dend, "labels_col", k = k,
value = k_colors)
}
if (!is.null(label_cols)) {
dend <- dendextend::set(dend, "labels_col", label_cols)
}
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 <- factoextra:::.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_track_height = labels_track_height,
...)
if (!circular)
p <- p + labs(title = main, 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, ...)
}
if (circular | phylogenic | is.null(k))
rect <- FALSE
if (rect_fill & missing(rect_lty))
rect_lty = "blank"
if (missing(lower_rect))
lower_rect = -(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, size = lwd,
lower_rect = lower_rect)
}
attr(p, "dendrogram") <- dend
structure(p, class = c(class(p), "fviz_dend"))
return(p)
}
rect_dendrogram <- function(dend, k = NULL, h = NULL, k_colors = NULL, palette = NULL,
rect_fill = FALSE, rect_lty = 2, lower_rect = -1.5, ...) {
if (missing(k_colors) & !is.null(palette))
k_colors <- palette
prop_k_height <- 0.5
if (!dendextend::is.dendrogram(dend))
stop("x is not a dendrogram object.")
k <- factoextra:::.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")
if (k < 2) {
stop(gettextf("k must be between 2 and %d", length(tree_heights)),
domain = NA)
}
cluster <- dendextend::cutree(dend, k = k)
clustab <- table(cluster)[unique(cluster[tree_order])]
m <- c(0, cumsum(clustab))
which <- 1L:k
xleft <- ybottom <- xright <- ytop <- list()
for (n in seq_along(which)) {
next_k_height <- tree_heights[names(tree_heights) ==
k + 1]
if (length(next_k_height) == 0) {
next_k_height <- 0
prop_k_height <- 1
}
xleft[[n]] = m[which[n]] + 0.66
ybottom[[n]] = lower_rect
xright[[n]] = m[which[n] + 1] + 0.33
ytop[[n]] <- tree_heights[names(tree_heights) == k] *
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), stringsAsFactors = TRUE)
color <- k_colors
if (all(color == "cluster"))
color <- "default"
if (ggpubr:::.is_col_palette(color))
color <- ggpubr:::.get_pal(color, k = k)
else if (length(color) > 1 & length(color) < k) {
color <- rep(color, k)[1:k]
}
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, ...)
}
fviz_dend2(hc, k = 4, # Cut in four groups
cex = 0.6, # label size
k_colors = smooth_rainbow(4),
# color_labels_by_k = TRUE, # color labels by groups
rect = TRUE, # Add rectangle around groups
rect_border = smooth_rainbow(4),
rect_fill = TRUE,
rotate = TRUE) +
ggplot2::theme_dark()
#> Warning: The `<scale>` argument of `guides()` cannot be `FALSE`. Use "none" instead as
#> of ggplot2 3.3.4.
#> ℹ The deprecated feature was likely used in the factoextra package.
#> Please report the issue at <https://github.com/kassambara/factoextra/issues>.
Created on 2023-05-07 with reprex v2.0.2
- grid.arrange's relative height argument didn't works well in RMarkdown
- How apply a function to every element of a matrix?
- Polar plot in R using ggplot2
- Find total length of time in multiple values of a dataset that overlaps with a given period of time
- Faster than R's `simplify2array`?
- What is the most simple way to label a data.table frequency chart in R?
- How to show dates in a secondary x-axis while the primary x-axis is numerical?
- online compiler for r-markdown document
- Unecessarily large column widths in HTML tables published by R Quarto when the table header contains special characters
- Bootstrapping a vector of results, by group in R
- Speeding Up Monte Carlo Simulations for Weather-Dependent Claims
- Is there an R class which allows to list 2 elements but shows only the first of them by default when called?
- Convert day of week number to weekday name in R
- How do you use "<<-" (scoping assignment) in R?
- Using reactivePoll to monitor and process file changes
- How to find out which graph is most similar to another graph?
- ggplot2: rectangular background behind axis text in circular bar plot
- How to simulate button click using rvest
- CMIP6, automating by month
- Covert dummy variables to single categorical in R?
- Animated reducing bar chart with gganimate
- Create an object class matrix/array from data frame
- How to add a vector of names to `sort_by()` in base R
- Among many subfolders, find CSVs starting with a given string and within ZIPs or not, and merge them while adding their names in a new column with R
- How to add a greek letter to an axis label to a 3D plot in plotly?
- bigrquery + dplyr error when using functions and sourcing from separate R script
- Shiny App Error: /v1/applications/ 400 - Validation Error Execution halted
- Rupee Unicode replacement not working in R
- Mutate multiple variable to create multiple new variables
- How to use the Stata equivalent of a foreach loop in R with mutate()