Schattieren eines Kernel-Dichtediagramms zwischen zwei Punkten.

Ich verwende häufig Kernel-Dichtediagramme, um Verteilungen zu veranschaulichen. Diese sind einfach und schnell in R zu erstellen:

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

Welches gibt mir dieses schöne kleine PDF:

Ich möchte den Bereich unter dem PDF vom 75. bis zum 95. Perzentil schattieren. Es ist einfach, die Punkte mit der quantileFunktion zu berechnen :

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

Aber wie schattiere ich den Bereich zwischen q75und q95?

Informationen zur polygon()Funktion finden Sie auf der Hilfeseite. Ich glaube, wir hatten auch hier ähnliche Fragen.

Sie müssen den Index der Quantilwerte finden, um die tatsächlichen (x,y)Paare zu erhalten.

Edit: Los geht's:

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

Ausgabe (von JDL hinzugefügt)

Eine andere Lösung:

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)

Ergebnis:

Eine erweiterte Lösung:

Wenn Sie beide Schwänze schattieren möchten (Dirk-Code kopieren und einfügen) und bekannte x-Werte verwenden möchten:

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

Ergebnis:

Diese Frage braucht eine latticeAntwort. Hier ist eine sehr grundlegende, die einfach die von Dirk und anderen angewandte Methode anpasst:

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

Hier ist eine weitere ggplot2Variante, die auf einer Funktion basiert, die die Kerneldichte bei den ursprünglichen Datenwerten approximiert:

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

Die Verwendung der Originaldaten (anstatt einen neuen Datenrahmen mit den x- und y-Werten der Dichteschätzung zu erstellen) hat den Vorteil, dass auch in facettierten Diagrammen gearbeitet wird, bei denen die Quantilwerte von der Variablen abhängen, nach der die Daten gruppiert werden:

Code verwendet

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

Erstellt am 2018-07-13 vom reprex-Paket (v0.2.0).