rggplot2factoextra

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