如何在 R 和 ggplot2 中绘制等高线，显示 95% 的值落在何处

Question

假设我们有：

x <- rnorm(1000)
y <- rnorm(1000)

如何使用 ggplot2 生成包含以下两个几何图形的绘图：

1. 两个系列值的二元期望
2. 等高线显示 95% 的估计值在哪里？

我知道第一部分该怎么做：

 df <- data.frame(x=x, y=y)
 p <- ggplot(df, aes(x=x, y=y))
 p <- p + xlim(-10, 10) + ylim(-10, 10) # say
 p <- p + geom_point(x=mean(x), y=mean(y))

我还知道 ggplot2 中的 stat_contour() 和 stat_density2d() 函数。

而且我也知道 stat_contour 中有“bins”选项。

但是，我想我需要的是类似于 quantile 中的 probs 参数，但在二维而不是一维上。

我还看到了图形包中的解决方案。但是，我想在 ggplot 中执行此操作。

非常感谢您的帮助，

乔恩

Answer 1

不幸的是，目前接受的答案在ggplot2 2.1.0 上以Error: Unknown parameters: breaks 失败。我根据this answer 中的代码拼凑了一种替代方法，它使用ks 包来计算内核密度估计：

library(ggplot2)

set.seed(1001)
d <- data.frame(x=rnorm(1000),y=rnorm(1000))

kd <- ks::kde(d, compute.cont=TRUE)
contour_95 <- with(kd, contourLines(x=eval.points[[1]], y=eval.points[[2]],
                                    z=estimate, levels=cont["5%"])[[1]])
contour_95 <- data.frame(contour_95)

ggplot(data=d, aes(x, y)) +
  geom_point() +
  geom_path(aes(x, y), data=contour_95) +
  theme_bw()

结果如下：

提示：ks 包依赖于rgl 包，手动编译可能会很痛苦。即使您在 Linux 上，获得预编译版本也容易得多，例如sudo apt install r-cran-rgl 在 Ubuntu 上，如果您设置了适当的 CRAN 存储库。

Answer 2

这可行，但效率很低，因为您实际上必须计算 3 次核密度估计值。

set.seed(1001)
d <- data.frame(x=rnorm(1000),y=rnorm(1000))
getLevel <- function(x,y,prob=0.95) {
    kk <- MASS::kde2d(x,y)
    dx <- diff(kk$x[1:2])
    dy <- diff(kk$y[1:2])
    sz <- sort(kk$z)
    c1 <- cumsum(sz) * dx * dy
    approx(c1, sz, xout = 1 - prob)$y
}
L95 <- getLevel(d$x,d$y)
library(ggplot2); theme_set(theme_bw())
ggplot(d,aes(x,y)) +
   stat_density2d(geom="tile", aes(fill = ..density..),
                  contour = FALSE)+
   stat_density2d(colour="red",breaks=L95)

（在http://comments.gmane.org/gmane.comp.lang.r.ggplot2/303的帮助下）

更新：使用最新版本的ggplot2 (2.1.0) 似乎无法将breaks 传递给stat_density2d（或者至少我不知道如何)，但下面使用geom_contour 的方法似乎仍然有效...

您可以通过计算内核密度估计一次并从同一网格绘制图块和轮廓来使事情变得更高效：

kk <- with(dd,MASS::kde2d(x,y))
library(reshape2)
dimnames(kk$z) <- list(kk$x,kk$y)
dc <- melt(kk$z)
ggplot(dc,aes(x=Var1,y=Var2))+
   geom_tile(aes(fill=value))+
   geom_contour(aes(z=value),breaks=L95,colour="red")

• 从kk 网格进行 95% 级别的计算（将内核计算的数量减少到 1）留作练习
• 我不确定为什么 stat_density2d(geom="tile") 和 geom_tile 给出的结果略有不同（前者被平滑）
• 我没有添加二元均值，但是像 annotate("point",x=mean(d$x),y=mean(d$y),colour="red") 这样的东西应该可以工作。

Answer 3

借鉴 Ben Bolker 的答案，一个可以处理多个级别并与 ggplot 2.2.1 配合使用的解决方案：

library(ggplot2)
library(MASS)
library(reshape2)
# create data:
set.seed(8675309)
Sigma <- matrix(c(0.1,0.3,0.3,4),2,2)
mv <- data.frame(mvrnorm(4000,c(1.5,16),Sigma))

# get the kde2d information: 
mv.kde <- kde2d(mv[,1], mv[,2], n = 400)
dx <- diff(mv.kde$x[1:2])  # lifted from emdbook::HPDregionplot()
dy <- diff(mv.kde$y[1:2])
sz <- sort(mv.kde$z)
c1 <- cumsum(sz) * dx * dy

# specify desired contour levels:
prob <- c(0.95,0.90,0.5)

# plot:
dimnames(mv.kde$z) <- list(mv.kde$x,mv.kde$y)
dc <- melt(mv.kde$z)
dc$prob <- approx(sz,1-c1,dc$value)$y
p <- ggplot(dc,aes(x=Var1,y=Var2))+
  geom_contour(aes(z=prob,color=..level..),breaks=prob)+
  geom_point(aes(x=X1,y=X2),data=mv,alpha=0.1,size=1)
print(p)

结果：

Answer 4

我有一个示例，其中MASS::kde2d() 带宽规范不够灵活，因此我最终使用了ks 包和ks::kde() 函数，例如，ks::Hscv() 函数来估计灵活带宽更好地捕捉平滑度。这种计算可能有点慢，但在某些情况下它的性能要好得多。这是该示例的上述代码的一个版本：

set.seed(1001)
d <- data.frame(x=rnorm(1000),y=rnorm(1000))
getLevel <- function(x,y,prob=0.95) {
    kk <- MASS::kde2d(x,y)
    dx <- diff(kk$x[1:2])
    dy <- diff(kk$y[1:2])
    sz <- sort(kk$z)
    c1 <- cumsum(sz) * dx * dy
    approx(c1, sz, xout = 1 - prob)$y
}
L95 <- getLevel(d$x,d$y)
library(ggplot2); theme_set(theme_bw())
ggplot(d,aes(x,y)) +
    stat_density2d(geom="tile", aes(fill = ..density..),
                   contour = FALSE)+
    stat_density2d(colour="red",breaks=L95)

## using ks::kde
hscv1 <- Hscv(d)
fhat <- ks::kde(d, H=hscv1, compute.cont=TRUE)

dimnames(fhat[['estimate']]) <- list(fhat[["eval.points"]][[1]], 
                                     fhat[["eval.points"]][[2]])
library(reshape2)
aa <- melt(fhat[['estimate']])

ggplot(aa, aes(x=Var1, y=Var2)) +
    geom_tile(aes(fill=value)) +
    geom_contour(aes(z=value), breaks=fhat[["cont"]]["50%"], color="red") +
    geom_contour(aes(z=value), breaks=fhat[["cont"]]["5%"], color="purple") 

对于此特定示例，差异很小，但在带宽规范需要更大灵活性的示例中，此修改可能很重要。请注意，95% 等高线是使用breaks=fhat[["cont"]]["5%"] 指定的，我觉得这有点违反直觉，因为它在这里被称为“5% 等高线”。

Answer 5

只需混合上面的答案，以更友好的tidyverse 方式放置它们，并允许多个轮廓级别。我在这里使用geom_path(group=probs)，手动添加它们geom_text。另一种方法是使用geom_path(colour=probs)，它会自动将轮廓标记为图例。

library(ks)
library(tidyverse)

set.seed(1001)

## data
d <- MASS::mvrnorm(1000, c(0, 0.2), matrix(c(1, 0.4, 1, 0.4), ncol=2)) %>% 
  magrittr::set_colnames(c("x", "y")) %>% 
  as_tibble() 

## density function
kd <- ks::kde(d, compute.cont=TRUE, h=0.2)

## extract results
get_contour <- function(kd_out=kd, prob="5%") {
  contour_95 <- with(kd_out, contourLines(x=eval.points[[1]], y=eval.points[[2]],
                                      z=estimate, levels=cont[prob])[[1]])
  as_tibble(contour_95) %>% 
    mutate(prob = prob)
}

dat_out <- map_dfr(c("10%", "20%","80%", "90%"), ~get_contour(kd, .)) %>% 
  group_by(prob) %>% 
  mutate(n_val = 1:n()) %>% 
  ungroup()

## clean kde output
kd_df <- expand_grid(x=kd$eval.points[[1]], y=kd$eval.points[[2]]) %>% 
  mutate(z = c(kd$estimate %>% t))

ggplot(data=kd_df, aes(x, y)) +
  geom_tile(aes(fill=z)) +
  geom_point(data = d, alpha = I(0.4), size = I(0.4), colour = I("yellow")) +
  geom_path(aes(x, y, group = prob), 
            data=filter(dat_out, !n_val %in% 1:3), colour = I("white")) +
  geom_text(aes(label = prob), data = 
              filter(dat_out, (prob%in% c("10%", "20%","80%") & n_val==1) | (prob%in% c("90%") & n_val==20)),
            colour = I("black"), size =I(3))+
  scale_fill_viridis_c()+
  theme_bw() +
  theme(legend.position = "none")

^{由reprex package (v0.3.0) 于 2019 年 6 月 25 日创建}