Mapa de calor de densidade de linha em R

Descrição do problema
Tenho milhares de linhas (~ 4000) que quero plotar. No entanto, é inviável plotar todas as linhas usando geom_line()e apenas usando, por exemplo, alpha=0.1para ilustrar onde há uma alta densidade de linhas e onde não. Me deparei com algo semelhante em Python , especialmente o segundo gráfico das respostas parece muito bom, mas não o faço agora se algo semelhante puder ser alcançado ggplot2. Assim, algo como isto:

Um exemplo de conjunto de dados
Seria muito mais sensato demonstrar isso com um conjunto que mostra um padrão, mas, por enquanto, eu apenas gerava curvas sinusais aleatórias:

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()

Tentei um mapa de calor
Tentei um mapa de calor como o respondido aqui , no entanto, este mapa de calor não considerará a conexão de pontos sobre o eixo completo (como em uma linha), mas mostrará o "calor" por ponto de tempo.

Pergunta
Como podemos em R, usando o ggplot2gráfico de um mapa de calor de linhas semelhante ao mostrado na primeira figura?

Seus dados resultarão em uma densidade polkadot bastante uniforme.

Eu gerei alguns dados um pouco mais interessantes como este:

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()

Em seguida, obtemos uma estimativa de densidade 2d. O kde2d não possui uma predictfunção, então nós o modelamos com um LOESS

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)))

Ao plotá-lo, obtém-se este resultado:

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

Tudo isso é altamente dependente de:

• O número de séries
• A resolução de séries
• A densidade do kde2d
• O período de loess

então sua milhagem pode variar

Observando atentamente, pode-se ver que o gráfico ao qual você está vinculando consiste em muitos, muitos, muitos pontos em vez de linhas.

O ggpointdensitypacote faz uma visualização semelhante. Observe que, com tantos pontos de dados, existem alguns problemas de desempenho. Estou usando a versão do desenvolvedor, porque contém o methodargumento que permite usar diferentes estimadores de suavização e aparentemente ajuda a lidar melhor com números maiores. Também existe uma versão CRAN.

Você pode ajustar a suavização com o adjustargumento

Aumentei a densidade do intervalo x do seu código, para torná-lo mais parecido com linhas. No entanto, reduzimos ligeiramente o número de 'linhas' na trama.

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)

^{Criado em 2020-03-19 pelo pacote reprex (v0.3.0)}

update Agradecemos ao usuário Robert Gertenbach por criar alguns dados de amostra mais interessantes . Aqui, o uso sugerido de ggpointdensity nesses dados:

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"))

^{Criado em 2020-03-24 pelo pacote reprex (v0.3.0)}

Eu vim com a seguinte solução, usando geom_segment(), no entanto, não tenho certeza se geom_segment()é o caminho a seguir, pois apenas verifica se os valores em pares são exatamente os mesmos, enquanto em um mapa de calor (como na minha pergunta) os valores próximos um do outro também afetam o 'calor' ao invés de ser exatamente o mesmo.

# 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()