Heatmap

draw_heatmap.R

# # MIT License
#
# Copyright (c) 2024 Mickaël Canouil
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

library(stats)
library(ggdendro)
library(ggplot2)
library(scales)
library(patchwork)
library(data.table)

data_matrix <- as.data.table(iris[, -5], keep.rownames = "Sample_ID")



dd_row <- as.dendrogram(
  hclust(
    d = dist(data_matrix[, -"Sample_ID"], method = "euclidean"), 
    method = "ward.D2"
  )
)
dd_col <- as.dendrogram(
  hclust(
    d = dist(transpose(data_matrix[, -"Sample_ID"]), method = "euclidean"), 
    method = "ward.D2"
  )
)
p_heatmap <- list(
  ggplot(
    data = melt(data_matrix, measure.vars = colnames(data_matrix[, -"Sample_ID"]))[, 
      (c("Sample_ID", "variable")) := 
        list(
          factor(Sample_ID, levels = data_matrix[order.dendrogram(dd_row), Sample_ID]),
          factor(variable, levels = colnames(data_matrix[, -"Sample_ID"])[order.dendrogram(dd_col)])
        )
    ],
    mapping = aes(x = variable, y = Sample_ID, fill = rescale(value, to = c(0, 1)))
  ) +
    geom_tile() +
    scale_x_discrete(position = "top", expand = c(0, 0)) +
    scale_y_discrete(position = "right", expand = c(0, 0)) +
    scale_fill_viridis_c(
      limits = c(0, 1), 
      labels = percent_format(accuracy = 1), 
      guide = guide_colourbar(
        title.position = "top", 
        title.hjust = 0.5,
        direction = "horizontal", 
        barwidth = unit(8, units = "lines"),
        raster = TRUE
      )
    ) +
    theme_minimal() +
    theme(
      axis.title = element_blank(),
      axis.text.y.right = element_text(),
      axis.ticks = element_line(colour = "black"),
      axis.ticks.length = unit(x = 0.1, units = "line")
    ),

  ggplot() +
    geom_segment(
      data = segment(dendro_data(dd_col, type = "rectangle")),
      mapping = aes(x = x, y = y, xend = xend, yend = yend),
      size = 0.5
    ) +
    theme_void() +
    scale_x_continuous(expand = expansion(add = c(0.5, 0.5))) +
    scale_y_continuous(expand = expansion(c(0, 0.1))),

  ggplot() +
    geom_segment(
      data = segment(dendro_data(dd_row, type = "rectangle")),
      mapping = aes(x = y, y = x, xend = yend, yend = xend),
      size = 0.5
    ) +
    theme_void() +
    scale_x_continuous(expand = expansion(mult = c(0, 0.1))) +
    scale_y_continuous(expand = expansion(add = c(0.5, 0.5))),

  guide_area()
)

wrap_plots(p_heatmap, design = "BD\nAC", guides = "collect", widths = c(2/3, 1/3), heights = c(1/3, 2/3))