Затінення графіку щільності ядра між двома точками.


94

Я часто використовую графіки щільності ядра для ілюстрації розподілу. Їх легко і швидко створити в R так:

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

Що дає мені цей приємний маленький PDF:

введіть тут опис зображення

Я хотів би затінити область під PDF з 75-го до 95-го процентиля. Підрахувати бали легко за допомогою quantileфункції:

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

Але як мені затінити область між q75і q95?


Чи можете ви навести приклад затінення зовнішньої частини вашого діапазону проти внутрішньої частини діапазону? Дякую.
Milktrader

Відповіді:


75

Що стосується polygon()функції, перегляньте її довідкову сторінку, і я вважаю, що у нас також були подібні запитання.

Вам потрібно знайти індекс значень квантилів, щоб отримати фактичні (x,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"))

Вихідні дані (додано JDL)

введіть тут опис зображення


3
Я ніколи не дійшов би до того, щоб ви працювали, якби ви не надали структуру. Дякую!
JD Long

2
Це одна з тих речей ..., яка була demo(graphics)введена ще до світанку вчасно, тому кожен раз натрапляє.
Така

1
охххх. Я ЗНАЛ, що я це десь бачив, але не міг витягти зі свого розумового індексу те місце, де я його бачив. Я рада, що ваш ментальний показник кращий за мій.
JD Long

70

Інше рішення:

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)

Результат:

alt текст


21

Розширене рішення:

Якщо ви хочете затінити обидва хвости (скопіюйте та вставте код Дірка) і використовуйте відомі значення x:

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

Результат:

Двохвостий полі


Я маю файл png і розмістив його на freeimagehosting, і він може не завантажуватися, тому що ... Я не впевнений.
Milktrader

Дуже розмитий файл. Чи можете ви, будь ласка, відтворити його та завантажити сюди безпосередньо ТАК має власну службу серверів для цього?
Dirk Eddelbuettel

Вибачте, але я не бачу, як завантажити його безпосередньо в SO.
Milktrader

18

На це питання потрібна latticeвідповідь. Ось дуже базовий, просто адаптуючи метод, який застосовували Дірк та інші:

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

введіть тут опис зображення


3

Ось ще один ggplot2варіант, заснований на функції, яка апроксимує щільність ядра за вихідними значеннями даних:

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

Використання вихідних даних (а не створення нового кадру даних із оцінкою щільності x та y) дає перевагу також працювати на гранованих графіках, де значення квантилів залежать від змінної, за якою дані групуються:

Використовуваний код

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

Створено 13.07.2018 пакетом reprex (v0.2.0).

Використовуючи наш веб-сайт, ви визнаєте, що прочитали та зрозуміли наші Політику щодо файлів cookie та Політику конфіденційності.
Licensed under cc by-sa 3.0 with attribution required.