Liniendichte-Heatmap in R.

Problembeschreibung
Ich habe Tausende von Linien (~ 4000), die ich zeichnen möchte. Es ist jedoch nicht möglich, alle Linien mit zu zeichnen geom_line()und nur alpha=0.1zu veranschaulichen, wo es eine hohe Liniendichte gibt und wo nicht. Ich bin in Python auf etwas Ähnliches gestoßen , besonders die zweite Handlung der Antworten sieht wirklich gut aus, aber ich weiß jetzt nicht, ob etwas Ähnliches in erreicht werden kann ggplot2. Also so etwas wie das:

Ein Beispieldatensatz
Es wäre viel sinnvoller, dies mit einem Satz zu demonstrieren, der ein Muster zeigt, aber im Moment habe ich nur zufällige Sinuskurven generiert:

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

Versuchte Heatmap
Ich habe eine Heatmap ausprobiert wie hier beantwortet Diese Heatmap berücksichtigt jedoch nicht die Verbindung von Punkten über die gesamte Achse (wie in einer Linie), sondern zeigt die "Wärme" pro Zeitpunkt.

Frage
Wie können wir in R mitggplot2 eine Heatmap von Linien zeichnen, die der in der ersten Abbildung gezeigten ähnlich sind?

Ihre Daten führen zu einer recht gleichmäßigen Polkadot-Dichte.

Ich habe einige etwas interessantere Daten wie diese generiert:

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

Wir erhalten dann eine 2D-Dichteschätzung. kde2d hat keinepredict Funktion, daher modellieren wir sie mit einem 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)))

Wenn Sie es zeichnen, erhalten Sie folgendes Ergebnis:

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

Dies alles hängt in hohem Maße ab von:

• Die Anzahl der Serien
• Die Auflösung von Serien
• Die Dichte von kde2d
• Die Spanne von Löss

Ihr Kilometerstand kann also variieren

Bei genauerem Hinsehen kann man erkennen, dass das Diagramm, mit dem Sie verknüpfen, aus vielen, vielen, vielen besteht Punkten und nicht aus Linien besteht.

Das ggpointdensityPaket macht eine ähnliche Visualisierung. Beachten Sie, dass bei so vielen Datenpunkten einige Leistungsprobleme auftreten. Ich benutze die Entwicklerversion, weil sie die enthältmethod Argument die Verwendung verschiedener Glättungsschätzer ermöglicht und anscheinend dazu beiträgt, mit größeren Zahlen besser umzugehen. Es gibt auch eine CRAN-Version.

Sie können die Glättung mit dem adjustArgument anpassen .

Ich habe die x-Intervalldichte Ihres Codes erhöht, damit er eher wie Linien aussieht. Habe die Anzahl der 'Linien' im Plot leicht reduziert.

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)

^{Erstellt am 2020-03-19 durch das reprex-Paket (v0.3.0)}

update Vielen Dank an Benutzer Robert Gertenbach für die Erstellung weiterer interessanter Beispieldaten . Hier die vorgeschlagene Verwendung von ggpointdensity für diese Daten:

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

^{Erstellt am 24.03.2018 durch das reprex-Paket (v0.3.0)}

Ich habe die folgende Lösung gefunden, wobei geom_segment()ich jedoch nicht sicher bin, ob dies geom_segment()der richtige Weg ist, da nur geprüft wird, ob paarweise Werte genau gleich sind, während in einer Heatmap (wie in meiner Frage) auch Werte in der Nähe voneinander betroffen sind die "Hitze", anstatt genau gleich zu sein.

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