Область тени ggplot2 под кривой плотности по группам

Question

У меня есть этот фрейм данных:

set.seed(1)
x <- c(rnorm(50, mean = 1), rnorm(50, mean = 3))
y <- c(rep("site1", 50), rep("site2", 50))
xy <- data.frame(x, y)

И я сделал этот график плотности:

library(ggplot2)
ggplot(xy, aes(x, color = y)) + geom_density()

За site1 Мне нужно заштриховать область под кривой, которая> 1% данных. За site2 Мне нужно заштриховать область под кривой, которая < 75% данных.

Я ожидаю, что сюжет будет выглядеть примерно так (фотошоп). После переполнения стека я знаю, что другие спрашивали, как заштриховать часть области под кривой, но я не могу понять, как заштриховать область под кривой группой.

Answer 1

Вот один из способов (и, как говорит @joran, это расширение ответа здесь):

#  same data, just renaming columns for clarity later on
#  also, use data tables
library(data.table)
set.seed(1)
value <- c(rnorm(50, mean = 1), rnorm(50, mean = 3))
site  <- c(rep("site1", 50), rep("site2", 50))
dt    <- data.table(site,value)
#  generate kdf
gg <- dt[,list(x=density(value)$x, y=density(value)$y),by="site"]
#  calculate quantiles
q1 <- quantile(dt[site=="site1",value],0.01)
q2 <- quantile(dt[site=="site2",value],0.75)
# generate the plot
ggplot(dt) + stat_density(aes(x=value,color=site),geom="line",position="dodge")+
  geom_ribbon(data=subset(gg,site=="site1" & x>q1),
              aes(x=x,ymax=y),ymin=0,fill="red", alpha=0.5)+
  geom_ribbon(data=subset(gg,site=="site2" & x<q2),
              aes(x=x,ymax=y),ymin=0,fill="blue", alpha=0.5)

Производит это:

Answer 2

Проблема с решением @jlhoward заключается в том, что вам нужно вручную добавить goem_ribbonдля каждой вашей группы. Я написал свойggplotОбертка статистики после этой виньетки. Преимущество этого в том, что он автоматически работает сgroup_by а также facet и вам не нужно вручную добавлять геометрию для каждой группы.

StatAreaUnderDensity <- ggproto(
  "StatAreaUnderDensity", Stat,
  required_aes = "x",
  compute_group = function(data, scales, xlim = NULL, n = 50) {
    fun <- approxfun(density(data$x))
    StatFunction$compute_group(data, scales, fun = fun, xlim = xlim, n = n)
  }
)

stat_aud <- function(mapping = NULL, data = NULL, geom = "area",
                    position = "identity", na.rm = FALSE, show.legend = NA, 
                    inherit.aes = TRUE, n = 50, xlim=NULL,  
                    ...) {
  layer(
    stat = StatAreaUnderDensity, data = data, mapping = mapping, geom = geom, 
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(xlim = xlim, n = n, ...))
}

Теперь вы можете использовать stat_aud работают так же, как и другие геометрии ggplot.

set.seed(1)
x <- c(rnorm(500, mean = 1), rnorm(500, mean = 3))
y <- c(rep("group 1", 500), rep("group 2", 500))
t_critical = 1.5

tibble(x=x, y=y)%>%ggplot(aes(x=x,color=y))+
  geom_density()+
  geom_vline(xintercept = t_critical)+
  stat_aud(geom="area",
           aes(fill=y),
           xlim = c(0, t_critical), 
              alpha = .2)

tibble(x=x, y=y)%>%ggplot(aes(x=x))+
  geom_density()+
  geom_vline(xintercept = t_critical)+
  stat_aud(geom="area",
           fill = "orange",
           xlim = c(0, t_critical), 
              alpha = .2)+
  facet_grid(~y)

Answer 3

Вам нужно использовать заливку. Цвет управляет контуром графика плотности, который необходим, если вы хотите не черные контуры.

ggplot(xy, aes(x, color=y, fill = y, alpha=0.4)) + geom_density()

Чтобы получить что-то подобное. Затем вы можете удалить альфа-часть легенды, используя

ggplot(xy, aes(x, color = y, fill = y, alpha=0.4)) + geom_density()+ guides(alpha='none')