Я не знаю, открыты ли вы для решений, не основанных на heatmap.2
. По моему мнению, ggplot
предлагает большую гибкость, и с небольшой настройкой вы можете воспроизвести тепловую карту, аналогичную той, которую вы показываете довольно комфортно, при этом максимально увеличивая заговор "недвижимости" и избегая чрезмерных пробелов.
Я рад удалить это сообщение, если вы ищете только heatmap.2
решения.
Кроме того, решение ggplot2
может выглядеть так:
Во-первых, давайте сгенерируем пример данных
set.seed(2018)
df <- as_tibble(matrix(runif(7*10), ncol = 10), .name_repair = ~seq(1:10))
Перед построением графика нам нужно изменить df
с широкого на длинный
library(tidyverse)
df <- df %>%
rowid_to_column("row") %>%
gather(col, Correlation, -row) %>%
mutate(col = as.integer(col))
Затем на сюжет
ggplot(df, aes(row, col, fill = Correlation)) +
geom_tile() +
scale_fill_gradientn(colours = my_palette) + # Use your custom colour palette
theme_void() + # Minimal theme
labs(title = "Main title") +
geom_text(aes(label = sprintf("%2.1f", Correlation)), size = 2) +
theme(
plot.title = element_text(hjust = 1), # Right-aligned text
legend.position="bottom") + # Legend at the bottom
guides(fill = guide_colourbar(
title.position = "bottom", # Legend title below bar
barwidth = 25, # Extend bar length
title.hjust = 0.5))
Пример с несколькими тепловыми картами в сетке с помощью facet_wrap
Прежде всего, давайте сгенерируем более сложные данные.
set.seed(2018)
df <- replicate(
4,
as_tibble(matrix(runif(7*10), ncol = 10), .name_repair = ~seq(1:10)), simplify = F) %>%
setNames(., paste("data", 1:4, sep = "")) %>%
map(~ .x %>% rowid_to_column("row") %>%
gather(col, Correlation, -row) %>%
mutate(col = as.integer(col))) %>%
bind_rows(.id = "data")
Тогда график идентичен тому, что мы делали раньше, плюс дополнительный оператор facet_wrap(~data, ncol = 2)
ggplot(df, aes(row, col, fill = Correlation)) +
geom_tile() +
scale_fill_gradientn(colours = my_palette) + # Use your custom colour palette
theme_void() + # Minimal theme
labs(title = "Main title") +
geom_text(aes(label = sprintf("%2.1f", Correlation)), size = 2) +
facet_wrap(~ data, ncol = 2) +
theme(
plot.title = element_text(hjust = 1), # Right-aligned text
legend.position="bottom") + # Legend at the bottom
guides(fill = guide_colourbar(
title.position = "bottom", # Legend title below bar
barwidth = 25, # Extend bar length
title.hjust = 0.5))
Одно окончательное обновление
Я подумал, что было бы весело / интересно посмотреть, как далеко мы сможем добраться до сложной тепловой карты, аналогичной той, на которую вы ссылаетесь из статьи .
Пример данных включается в конце, так как это занимает немного места.
Сначала мы строим три различных ggplot2
объекта графика, которые показывают основную тепловую карту (gg3
), дополнительную меньшую тепловую карту с отсутствующими значениями (gg2
) и столбец, обозначающий групповые метки для каждой строки (gg1
).
gg3 <- ggplot(df.cor, aes(col, row, fill = Correlation)) +
geom_tile() +
scale_fill_distiller(palette = "RdYlBu") +
theme_void() +
labs(title = "Main title") +
geom_text(aes(label = sprintf("%2.1f", Correlation)), size = 2) +
scale_y_discrete(position = "right") +
theme(
plot.title = element_text(hjust = 1),
legend.position="bottom",
axis.text.y = element_text(color = "black", size = 10)) +
guides(fill = guide_colourbar(
title.position = "bottom",
barwidth = 10,
title.hjust = 0.5))
gg2 <- ggplot(df.flag, aes(col, row, fill = Correlation)) +
geom_tile(colour = "grey") +
scale_fill_distiller(palette = "RdYlBu", guide = F, na.value = "white") +
theme_void() +
scale_x_discrete(position = "top") +
theme(
axis.text.x = element_text(color = "black", size = 10, angle = 90, hjust = 1, vjust = 0.5))
gg1 <- ggplot(df.bar, aes(1, row, fill = grp)) +
geom_tile() +
scale_fill_manual(values = c("grp1" = "orange", "grp2" = "green")) +
theme_void() +
theme(legend.position = "left")
Теперь мы можем использовать egg::ggarrange
, чтобы расположить все три графика так, чтобы диапазоны оси y были выровнены.
library(egg)
ggarrange(gg1, gg2, gg3, ncol = 3, widths = c(0.1, 1, 3))
Пример данных
library(tidyverse)
set.seed(2018)
nrow <- 7
ncol <- 20
df.cor <- matrix(runif(nrow * ncol, min = -1, max = 1), nrow = nrow) %>%
as_tibble(.name_repair = ~seq(1:ncol)) %>%
rowid_to_column("row") %>%
gather(col, Correlation, -row) %>%
mutate(
row = factor(
paste("row", row, sep = ""),
levels = paste("row", 1:nrow, sep = "")),
col = factor(
paste("col", col, sep = ""),
levels = paste("col", 1:ncol, sep = "")))
nrow <- 7
ncol <- 10
df.flag <- matrix(runif(nrow * ncol, min = -1, max = 1), nrow = nrow) %>%
as_tibble(.name_repair = ~seq(1:ncol)) %>%
rowid_to_column("row") %>%
gather(col, Correlation, -row) %>%
mutate(
row = factor(
paste("row", row, sep = ""),
levels = paste("row", 1:nrow, sep = "")),
col = factor(
paste("col", col, sep = ""),
levels = paste("col", 1:ncol, sep = ""))) %>%
mutate(Correlation = ifelse(abs(Correlation) < 0.5, NA, Correlation))
df.bar <- data.frame(
row = 1:nrow,
grp = paste("grp", c(rep(1, nrow - 3), rep(2, 3)), sep = "")) %>%
mutate(
row = factor(
paste("row", row, sep = ""),
levels = paste("row", 1:nrow, sep = "")))