Diagonal Heat map using R-CodePudding

I am trying to draw heatmap using R as exact as given here in image, kindly help here is example code

df <- data.frame(
  x1 = c("A","A","A","A","A","B","B","B","B","C","C","C","D","D","E"),
  x2 = c("B","C","D","E","F","C","D","E","F","D","E","F","E","F","F"),
  relation = c(76.90,75.26,74.82,74.61,71.78,75.49,75.56,75.41,72.16,74.68,74.28,71.71,
               73.87,72.34,72.14)
)

CodePudding user response：

Hope this help you. PD the dendogram is based on an order i can guess for sure.

library(ggplot2)
library(dplyr)
library(tidyr)

df <- data.frame(
  x1 = c("A","A","A","A","A","B","B","B","B","C","C","C","D","D","E"),
  x2 = c("B","C","D","E","F","C","D","E","F","D","E","F","E","F","F"),
  relation = c(76.90,75.26,74.82,74.61,71.78,75.49,75.56,75.41,72.16,74.68,74.28,71.71,
               73.87,72.34,72.14))


dend_order = rev(LETTERS[1:6])# dendogram order

arg = 3*pi/4
offs = 3
rot.matrix <- matrix(c(
  cos(arg), sin(arg), 
  -sin(arg), cos(arg)), 2,2) 

df <- df %>% rowwise() %>% 
  mutate(coord = list(tibble(
    x =  (match(x1, LETTERS)   c(0,1,1,0) - offs),
    y =  (match(x2, LETTERS) - c(0,0,1,1) - offs)))) %>% 
  unnest(coord) 

#rotate the figure
df[,c("x","y")] <- as.matrix(df[,c("x","y")]) %*% rot.matrix   offs

# position of the letters
ypos <- seq(max(df$y),min(df$y), len=6)

#dendogram

dgram_y <-  
  rev(Reduce(\(x,y) mean(c(x,y)), 
          rev(ypos[(match(dend_order, LETTERS))]), accumulate = T))

ggplot(df)   
  geom_polygon(aes(
    x=x, y=y, group = interaction(x1,x2), fill = relation) , color="black")  
  geom_text(aes(x,y,label=label), size = 6, data = data.frame(
    x=2, y=ypos, label = LETTERS[1:6])) 
  geom_text(aes(x,y,label=label), size = 4, data = df %>% 
              group_by(x1,x2) %>% 
              summarise(x=mean(x),y=mean(y), label = relation[1])) 
  geom_segment(aes(x,y,xend=xend,yend=yend), data = data.frame(
    x = 0 - match(dend_order, LETTERS) * 0.1, 
    xend=1,
    y = ypos[match(dend_order, LETTERS)],
    yend = ypos[match(dend_order, LETTERS)]))  
  geom_segment(aes(x,y,xend=xend,yend=yend), data = data.frame(
    y = tail(dgram_y, -1), 
    yend = head(ypos[match(dend_order, LETTERS)],-1),
    x = head(0 - match(dend_order, LETTERS) * 0.1, -1),
    xend = head(0 - match(dend_order, LETTERS) * 0.1,-1)))   
  geom_segment(aes(x,y,xend=xend,yend=yend), data = data.frame(
    y = tail(dgram_y, -1), 
    yend = tail(dgram_y, -1), 
    x = tail(0 - match(dend_order, LETTERS) * 0.1, -1),
    xend = head(0 - match(dend_order, LETTERS) * 0.1,-1)))   
  scale_fill_gradientn(colours = c("blue","green","yellow","orange","red"),
                       limits = range(50,100)) 
  theme(axis.ticks = element_blank(), 
        axis.text = element_blank(), 
        axis.title = element_blank(),
        panel.grid = element_blank(), 
        panel.background =element_blank())
#> `summarise()` has grouped output by 'x1'. You can override using the `.groups`
#> argument.