Sơ đồ nhiệt mật độ dòng trong R

Mô tả vấn đề
Tôi có hàng ngàn dòng (~ 4000) mà tôi muốn vẽ. Tuy nhiên, không thể vẽ sơ đồ tất cả các dòng bằng cách sử dụng geom_line()và chỉ sử dụng ví dụ alpha=0.1để minh họa nơi có mật độ dòng cao và nơi không. Tôi đã bắt gặp một cái gì đó tương tự trong Python , đặc biệt là cốt truyện thứ hai của các câu trả lời trông rất hay, nhưng bây giờ tôi không biết nếu có thể đạt được điều tương tự ggplot2. Vì vậy, một cái gì đó như thế này:

Một tập dữ liệu mẫu
sẽ có ý nghĩa hơn nhiều khi chứng minh điều này với một bộ hiển thị một mẫu, nhưng bây giờ tôi chỉ tạo các đường cong xoang ngẫu nhiên:

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

Đã thử bản đồ nhiệt
Tôi đã thử một bản đồ nhiệt như đã trả lời ở đây , tuy nhiên bản đồ nhiệt này sẽ không xem xét kết nối các điểm trên trục hoàn chỉnh (như trong một dòng) mà chỉ hiển thị "nhiệt" cho mỗi điểm thời gian.

Câu hỏi
Làm thế nào chúng ta có thể trong R, sử dụng ggplot2sơ đồ một sơ đồ nhiệt của các dòng tương tự như trong hình đầu tiên?

Dữ liệu của bạn sẽ dẫn đến mật độ polkadot khá đồng đều.

Tôi đã tạo ra một số dữ liệu thú vị hơn một chút như thế này:

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

Sau đó chúng tôi có được một ước tính mật độ 2d. kde2d không có predictchức năng nên chúng tôi mô hình hóa nó với 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)))

Vẽ nó sau đó nhận được kết quả này:

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

Đây là tất cả phụ thuộc rất cao vào:

• Số lượng loạt
• Độ phân giải của loạt
• Mật độ của kde2d
• Khoảng hoàng thổ

vì vậy số dặm của bạn có thể thay đổi

Nhìn kỹ, người ta có thể thấy rằng biểu đồ mà bạn đang liên kết bao gồm nhiều, rất nhiều, nhiều điểm hơn là các đường.

Các ggpointdensitygói làm một hình ảnh tương tự. Lưu ý với rất nhiều điểm dữ liệu, có khá nhiều vấn đề về hiệu suất. Tôi đang sử dụng phiên bản dành cho nhà phát triển, vì nó chứa methodđối số cho phép sử dụng các công cụ ước tính làm mịn khác nhau và rõ ràng giúp giải quyết tốt hơn với số lượng lớn hơn. Có một phiên bản CRAN quá.

Bạn có thể điều chỉnh làm mịn với adjustđối số.

Tôi đã tăng mật độ x khoảng mã của bạn, để làm cho nó trông giống các dòng hơn. Đã giảm một chút số lượng 'dòng' trong cốt truyện.

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)

^{Được tạo vào ngày 2020-03-19 bởi gói reprex (v0.3.0)}

cập nhật Cảm ơn người dùng Robert Gertenbach đã tạo ra một số dữ liệu mẫu thú vị hơn . Ở đây đề xuất sử dụng ggpointd mật độ trên dữ liệu này:

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

^{Được tạo vào ngày 2020-03-24 bởi gói reprex (v0.3.0)}

Tôi đã đưa ra các giải pháp sau đây, sử dụng geom_segment(), tuy nhiên tôi không chắc chắn nếu geom_segment()là con đường để đi vì nó sau đó chỉ kiểm tra xem giá trị cặp là chính xác như nhau trong khi ở một Heatmap (như trong câu hỏi của tôi) giá trị gần nhau cũng ảnh hưởng đến "nhiệt" hơn là giống hệt nhau.

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