Tô bóng một biểu đồ mật độ hạt nhân giữa hai điểm.

Tôi thường sử dụng biểu đồ mật độ hạt nhân để minh họa các phân phối. Chúng dễ dàng và nhanh chóng để tạo trong R như vậy:

set.seed(1)
draws <- rnorm(100)^2
dens <- density(draws)
plot(dens)
#or in one line like this: plot(density(rnorm(100)^2))

Cái nào mang lại cho tôi bản PDF nhỏ xinh này:

Tôi muốn tô bóng vùng dưới PDF từ phân vị thứ 75 đến 95. Thật dễ dàng để tính điểm bằng cách sử dụng quantilehàm:

q75 <- quantile(draws, .75)
q95 <- quantile(draws, .95)

Nhưng làm cách nào để tô bóng khu vực giữa q75và q95?

Với polygon()chức năng, hãy xem trang trợ giúp của nó và tôi tin rằng chúng tôi cũng đã có những câu hỏi tương tự ở đây.

Bạn cần tìm chỉ số của các giá trị lượng tử để có được các (x,y)cặp thực tế .

Chỉnh sửa: Của bạn đây:

x1 <- min(which(dens$x >= q75))  
x2 <- max(which(dens$x <  q95))
with(dens, polygon(x=c(x[c(x1,x1:x2,x2)]), y= c(0, y[x1:x2], 0), col="gray"))

Đầu ra (do JDL thêm vào)

Giải pháp khác:

dd <- with(dens,data.frame(x,y))

library(ggplot2)

qplot(x,y,data=dd,geom="line")+
  geom_ribbon(data=subset(dd,x>q75 & x<q95),aes(ymax=y),ymin=0,
              fill="red",colour=NA,alpha=0.5)

Kết quả:

Một giải pháp mở rộng:

Nếu bạn muốn tô bóng cả hai đuôi (sao chép và dán mã của Dirk) và sử dụng các giá trị x đã biết:

set.seed(1)
draws <- rnorm(100)^2
dens <- density(draws)
plot(dens)

q2     <- 2
q65    <- 6.5
qn08   <- -0.8
qn02   <- -0.2

x1 <- min(which(dens$x >= q2))  
x2 <- max(which(dens$x <  q65))
x3 <- min(which(dens$x >= qn08))  
x4 <- max(which(dens$x <  qn02))

with(dens, polygon(x=c(x[c(x1,x1:x2,x2)]), y= c(0, y[x1:x2], 0), col="gray"))
with(dens, polygon(x=c(x[c(x3,x3:x4,x4)]), y= c(0, y[x3:x4], 0), col="gray"))

Kết quả:

Câu hỏi này cần một latticecâu trả lời. Đây là một cách rất cơ bản, chỉ đơn giản là điều chỉnh phương pháp được sử dụng bởi Dirk và những người khác:

#Set up the data
set.seed(1)
draws <- rnorm(100)^2
dens <- density(draws)

#Put in a simple data frame   
d <- data.frame(x = dens$x, y = dens$y)

#Define a custom panel function;
# Options like color don't need to be hard coded    
shadePanel <- function(x,y,shadeLims){
    panel.lines(x,y)
    m1 <- min(which(x >= shadeLims[1]))
    m2 <- max(which(x <= shadeLims[2]))
    tmp <- data.frame(x1 = x[c(m1,m1:m2,m2)], y1 = c(0,y[m1:m2],0))
    panel.polygon(tmp$x1,tmp$y1,col = "blue")
}

#Plot
xyplot(y~x,data = d, panel = shadePanel, shadeLims = c(1,3))

Đây là một ggplot2biến thể khác dựa trên một hàm xấp xỉ mật độ hạt nhân ở các giá trị dữ liệu gốc:

approxdens <- function(x) {
    dens <- density(x)
    f <- with(dens, approxfun(x, y))
    f(x)
}

Việc sử dụng dữ liệu gốc (thay vì tạo ra khung dữ liệu mới với các giá trị x và y của ước tính mật độ) có lợi ích là cũng làm việc trong các biểu đồ khía cạnh nơi các giá trị lượng tử phụ thuộc vào biến mà dữ liệu đang được nhóm:

Mã đã được sử dụng

library(tidyverse)
library(RColorBrewer)

# dummy data
set.seed(1)
n <- 1e2
dt <- tibble(value = rnorm(n)^2)

# function that approximates the density at the provided values
approxdens <- function(x) {
    dens <- density(x)
    f <- with(dens, approxfun(x, y))
    f(x)
}

probs <- c(0.75, 0.95)

dt <- dt %>%
    mutate(dy = approxdens(value),                         # calculate density
           p = percent_rank(value),                        # percentile rank 
           pcat = as.factor(cut(p, breaks = probs,         # percentile category based on probs
                                include.lowest = TRUE)))

ggplot(dt, aes(value, dy)) +
    geom_ribbon(aes(ymin = 0, ymax = dy, fill = pcat)) +
    geom_line() +
    scale_fill_brewer(guide = "none") +
    theme_bw()



# dummy data with 2 groups
dt2 <- tibble(category = c(rep("A", n), rep("B", n)),
              value = c(rnorm(n)^2, rnorm(n, mean = 2)))

dt2 <- dt2 %>%
    group_by(category) %>% 
    mutate(dy = approxdens(value),    
           p = percent_rank(value),
           pcat = as.factor(cut(p, breaks = probs,
                                include.lowest = TRUE)))

# faceted plot
ggplot(dt2, aes(value, dy)) +
    geom_ribbon(aes(ymin = 0, ymax = dy, fill = pcat)) +
    geom_line() +
    facet_wrap(~ category, nrow = 2, scales = "fixed") +
    scale_fill_brewer(guide = "none") +
    theme_bw()

Được tạo vào 2018-07-13 bởi gói reprex (v0.2.0).