Тепловая карта плотности линий в R - PullRequest
Новая
       23

Тепловая карта плотности линий в R

8 голосов
/ 17 марта 2020

Описание проблемы
У меня есть тысячи линий (~ 4000), которые я хочу построить. Однако невозможно построить все линии, используя geom_line(), и просто использовать, например, alpha=0.1, чтобы показать, где есть высокая плотность линий, а где нет. Я сталкивался с чем-то похожим в Python, особенно второй график ответов выглядит действительно хорошо, но я не знаю, можно ли добиться чего-то подобного в ggplot2. Примерно так теперь я только что сгенерировал случайные синусоидальные кривые: 

set.seed(1)
gen.dat <- function(key) {
    c <- sample(seq(0.1,1, by = 0.1), 1)
    time <- seq(c*pi,length.out=100)
    val <- sin(time)
    time = 1:100
    data.frame(time,val,key)
}
dat <- lapply(seq(1,10000), gen.dat) %>% bind_rows()

Пробная тепловая карта
Я попробовал тепловую карту , как ответил здесь , однако эта тепловая карта не будет рассматривать соединение точек по всей оси (как в линии), но скорее показывают «тепло» за момент времени.

Вопрос
Как мы можем в R, используя ggplot2 построить тепловую карту линий, аналогичную той, что показана на первом рисунке?

Ответы [ 3 ]

6 голосов
/ 19 марта 2020

Если присмотреться, можно увидеть, что график, на который вы ссылаетесь, состоит из многих, многих, многих точек, а не линий.

Пакет ggpointdensity выполняет аналогичную визуализацию. Обратите внимание, что при большом количестве точек данных возникают некоторые проблемы с производительностью. Я использую версию разработчика, потому что она содержит аргумент method, который позволяет использовать различные оценки сглаживания и, очевидно, помогает лучше справляться с большими числами. Также есть версия CRAN.

Вы можете настроить сглаживание с помощью аргумента adjust.

Я увеличил плотность интервалов х вашего кода, чтобы он выглядел больше как строки. Тем не менее, немного сократили количество «линий» на графике. 

library(tidyverse)
#devtools::install_github("LKremer/ggpointdensity")
library(ggpointdensity)

set.seed(1)
gen.dat <- function(key) {
  c <- sample(seq(0.1,1, by = 0.1), 1)
  time <- seq(c*pi,length.out=500)
  val <- sin(time)
  time = seq(0.02,100,0.1)
  data.frame(time,val,key)
}
dat <- lapply(seq(1, 1000), gen.dat) %>% bind_rows()

ggplot(dat, aes(time, val)) + 
  geom_pointdensity(size = 0.1, adjust = 10) 
#> geom_pointdensity using method='kde2d' due to large number of points (>20k)

Создано в 2020-03-19 пакетом представ. (v0.3.0)

обновление Спасибо пользователю Роберту Гертенбаху за создание более интересных примеров данных . Вот предлагаемое использование ggpointdensity для этих данных: 

library(tidyverse)
library(ggpointdensity)

gen.dat <- function(key) {
  has_offset <- runif(1) > 0.5
  time <- seq(1, 1000, length.out = 1000)
  val <- sin(time / 100 + rnorm(1, sd = 0.2) + (has_offset * 1.5)) * 
    rgamma(1, 20, 20)
  data.frame(time,val,key)
}

dat <- lapply(seq(1,1000), gen.dat) %>% bind_rows()
ggplot(dat, aes(time, val, group=key)) +stat_pointdensity(geom = "line", size = 0.05, adjust = 10) + scale_color_gradientn(colors = c("blue", "yellow", "red"))

Создано в 2020-03-24 пакетом Представить (v0 .3.0)

3 голосов
/ 25 марта 2020

Ваши данные приведут к довольно однородной плотности полкадо.

Я сгенерировал немного более интересные данные, подобные этим: 

gen.dat <- function(key) {
  has_offset <- runif(1) > 0.5
  time <- seq(1, 1000, length.out = 1000)
  val <- sin(time / 100 + rnorm(1, sd = 0.2) + (has_offset * 1.5)) * 
    rgamma(1, 20, 20)
  data.frame(time,val,key)
}
dat <- lapply(seq(1,1000), gen.dat) %>% bind_rows()

Затем мы получим 2-мерную оценку плотности. У kde2d нет функции predict, поэтому мы смоделировали ее с потерей 

dens <- MASS::kde2d(dat$time, dat$val, n = 400)
dens_df <- data.frame(with(dens, expand_grid( y, x)), z = as.vector(dens$z))
fit <- loess(z ~ y * x, data = dens_df, span = 0.02)
dat$z <- predict(fit, with(dat, data.frame(x=time, y=val)))

При ее построении получим следующий результат: 

ggplot(dat, aes(time, val, group = key, color = z)) +
  geom_line(size = 0.05) +
  theme_minimal() +
  scale_color_gradientn(colors = c("blue", "yellow", "red"))

enter image description here

Это все сильно зависит от:

  • Количество серий
  • Разрешение серии
  • Плотность kde2d
  • Пролет лесса

, поэтому ваш пробег может варьироваться

0 голосов
/ 19 марта 2020

Я пришел к следующему решению, используя geom_segment(), однако я не уверен, является ли geom_segment() подходом к go, поскольку он только проверяет, являются ли попарные значения точно то же самое, в то время как в тепловой карте (как в моем вопросе) значения рядом друг с другом также влияют на «тепло», а не точно так же. 

# Simple stats to get all possible line segments
vals <- unique(dat$time)
min.val = min(vals)
max.val = max(vals)

# Get all possible line segments
comb.df <- data.frame(
  time1 = min.val:(max.val - 1),
  time2 = (min.val + 1): max.val
)

# Join the original data to all possible line segments
comb.df <- comb.df %>% 
  left_join(dat %>% select(time1 = time, val1 = val, key )) %>%
  left_join(dat %>% select(time2 = time, val2 = val, key ))

# Count how often each line segment occurs in the data
comb.df <- comb.df %>% 
  group_by(time1, time2, val1, val2) %>%
  summarise(n = n_distinct(key))

# ggplot2 to plot segments
ggplot(comb.df %>% arrange(n)) +
  geom_segment(aes(x = time1, y = val1, xend = time2, yend = val2, color = n), alpha =0.9) +
  scale_colour_gradient( low = 'green', high = 'red')  +
  theme_bw()

enter image description here

...