Mapa de calor de densidad de línea en R

Descripción del problema
Tengo miles de líneas (~ 4000) que quiero trazar. Sin embargo, no es factible trazar todas las líneas usando geom_line()y solo usar, por ejemplo, alpha=0.1para ilustrar dónde hay una alta densidad de líneas y dónde no. Encontré algo similar en Python , especialmente la segunda trama de las respuestas se ve muy bien, pero ahora no sé si se puede lograr algo similar ggplot2. Entonces algo como esto:

Un conjunto de datos de ejemplo
Tendría mucho más sentido demostrar esto con un conjunto que muestra un patrón, pero por ahora solo generé curvas sinusales aleatorias:

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

Probé un mapa de calor Probé
un mapa de calor como el que he respondido aquí , sin embargo, este mapa de calor no considerará la conexión de puntos sobre el eje completo (como en una línea), sino que mostrará el "calor" por punto de tiempo.

Pregunta
¿Cómo podemos en R, usando ggplot2trazar un mapa de calor de líneas similares al que se muestra en la primera figura?

Sus datos darán como resultado una densidad de polkadot bastante uniforme.

Generé algunos datos un poco más interesantes 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()

Luego obtenemos una estimación de densidad 2D. kde2d no tiene una predictfunción, por lo que lo modelamos con 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)))

Al trazarlo se obtiene 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"))

Todo esto depende en gran medida de:

• El número de series
• La resolución de series
• La densidad de kde2d
• El lapso de loess

Así que su millaje puede variar

Mirando de cerca, uno puede ver que el gráfico al que está vinculando consiste en muchos, muchos, muchos puntos en lugar de líneas.

El ggpointdensitypaquete hace una visualización similar. Tenga en cuenta que con tantos puntos de datos, hay bastantes problemas de rendimiento. Estoy usando la versión de desarrollador, porque contiene el methodargumento que permite usar diferentes estimadores de suavizado y aparentemente ayuda a lidiar mejor con números más grandes. También hay una versión CRAN.

Puede ajustar el suavizado con el adjustargumento.

He aumentado la densidad del intervalo x de su código, para que se vea más como líneas. Sin embargo, he reducido ligeramente el número de 'líneas' en la 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)

^{Creado en 2020-03-19 por el paquete reprex (v0.3.0)}

actualización Gracias al usuario Robert Gertenbach por crear algunos datos de muestra más interesantes . Aquí el uso sugerido de ggpointdensity en estos datos:

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

^{Creado en 2020-03-24 por el paquete reprex (v0.3.0)}

Se me ocurrió la siguiente solución, usando geom_segment(), sin embargo, no estoy seguro de si geom_segment()es el camino a seguir, ya que solo comprueba si los valores por pares son exactamente iguales, mientras que en un mapa de calor (como en mi pregunta) los valores cercanos también afectan el "calor" en lugar de ser exactamente lo mismo.

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