绘制（ggplot？）两条曲线之间的平滑+颜色区域

Question

我有一个问题要问你：

我的数据：

    Nb_obs <- as.vector(c( 2,  0,  6,  2,  7,  1,  8,  0,  2,  1,  1,  3, 11,  5,  9,  6,  4,  0,  7,  9))
    Nb_obst <- as.vector(c(31, 35, 35, 35, 39, 39, 39, 39, 39, 41, 41, 42, 43, 43, 45, 45, 47, 48, 51, 51))
    inf20 <- as.vector(c(2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 3, 4, 4, 3, 5, 4))
    sup20 <- as.vector(c(3, 4, 4, 4, 5, 4, 4, 5, 4, 4, 5, 5, 5, 6, 5, 6, 6, 5, 7, 6))
    inf40 <- as.vector(c(1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 2, 3, 3, 3, 4, 3))
    sup40 <- as.vector(c(4, 5, 5, 5, 6, 5, 5, 6, 5, 5, 6, 6, 6, 7, 6, 7, 7, 7, 9, 7))
    inf60 <- as.vector(c(1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 2))
    sup60 <- as.vector(c(5, 6, 6,  6,  8,  7,  7,  7,  7,  7,  7,  7,  8,  9,  8,  9,  9,  9, 11,  9))
    inf90 <- as.vector(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1))
    sup90 <- as.vector(c(10, 11, 11, 11, 15, 13, 13, 14, 12, 13, 13, 13, 14, 17, 15, 17, 17, 16, 21, 18))

data <- cbind.data.frame(Nb_obs, Nb_obst, inf20, sup20, inf40, sup40, inf60 , sup60, inf90 , sup90)

我的情节：

plot(data$Nb_obst, data$Nb_obs, type = "n",  xlab = "Number obst", ylab = "number obs", ylim = c(0, 25))

lines(data$Nb_obst, data$inf20, col = "dark red")
lines(data$Nb_obst, data$sup20, col = "dark red")

lines(data$Nb_obst, data$inf40, col = "red")
lines(data$Nb_obst, data$sup40, col = "red")

lines(data$Nb_obst, data$inf60, col = "dark orange")
lines(data$Nb_obst, data$sup60, col = "dark orange")

lines(data$Nb_obst, data$inf90, col = "yellow")
lines(data$Nb_obst, data$sup90, col = "yellow")

我的问题：

我想做两件事（所以我认为可以通过 ggplot 完成）：

在顶部图表的概念中，“inf”和“sup”是我的模型在 IC 中的限制 20%，然后是 40%，然后是 60%，最后是 90%。我首先想平滑每条曲线，然后我想给同一IC的两条曲线之间的表面着色，例如“data$inf90”和“data$sup90”之间的表面是黄色的，“之间的区域” data$inf60" 和 "data$60" 是橙色的，等等。我想叠加这些彩色表面中的每一个 + 请放好图例。

感谢您的帮助！

Answer 1

很酷的问题，因为我不得不给自己上一个使用 LOESS 制作丝带的速成课程！

我要做的第一件事是将数据变成长形，因为这是ggplot 所期望的，并且因为您的数据具有一些隐藏在值中的特征。例如，如果您将gather 变成一个长形状，并且有一个列key，其值为“inf20”，另一个值为“sup20”，则这些信息包含的信息比您当前可以访问的信息多，即度量值类型为“inf”或“sup”，级别为 20。您可以从该列中提取该信息以获取度量类型（“inf”或“sup”）和级别（20、40、60、或 90)，然后将美学映射到这些变量上。

所以在这里我将数据变成一个长形，然后使用spread 制作inf 和sup 的列，因为这些将成为ymin 和ymax 用于功能区。我将level 设为一个因子并反转其水平，因为我想更改绘制丝带的顺序，使窄丝带最后出现并绘制在顶部。

library(tidyverse)

data_long <- data %>%
  as_tibble() %>%
  gather(key = key, value = value, -Nb_obs, -Nb_obst) %>%
  mutate(measure = str_extract(key, "\\D+")) %>%
  mutate(level = str_extract(key, "\\d+")) %>%
  select(-key) %>%
  group_by(level, measure) %>%
  mutate(row = row_number()) %>%
  spread(key = measure, value = value) %>%
  ungroup() %>%
  mutate(level = as.factor(level) %>% fct_rev())

head(data_long)
#> # A tibble: 6 x 6
#>   Nb_obs Nb_obst level   row   inf   sup
#>    <dbl>   <dbl> <fct> <int> <dbl> <dbl>
#> 1      0      35 20        2     2     4
#> 2      0      35 40        2     2     5
#> 3      0      35 60        2     1     6
#> 4      0      35 90        2     0    11
#> 5      0      39 20        8     3     5
#> 6      0      39 40        8     2     6

ggplot(data_long, aes(x = Nb_obst, ymin = inf, ymax = sup, fill = level)) +
  geom_ribbon(alpha = 0.6) +
  scale_fill_manual(values = c("20" = "darkred", "40" = "red", 
      "60" = "darkorange", "90" = "yellow")) +
  theme_light()

但它仍然存在锯齿状的问题，因此对于每个级别，我预测 inf 和 sup 与使用 loess 的 Nb_obst 的平滑值。 group_by 和 do 生成一个嵌套数据框，unnest 将其拉回一个可行的形式。随意调整span参数，以及其他我知之甚少的loess.control参数。

data_smooth <- data_long %>%
  group_by(level) %>%
  do(Nb_obst = .$Nb_obst,
     inf_smooth = predict(loess(.$inf ~ .$Nb_obst, span = 0.35), .$Nb_obst), 
     sup_smooth = predict(loess(.$sup ~ .$Nb_obst, span = 0.35), .$Nb_obst)) %>%
  unnest() 

head(data_smooth)
#> # A tibble: 6 x 4
#>   level Nb_obst inf_smooth sup_smooth
#>   <fct>   <dbl>      <dbl>      <dbl>
#> 1 90         35      0           11. 
#> 2 90         39      0           13.4
#> 3 90         48      0.526       16.7
#> 4 90         39      0           13.4
#> 5 90         41      0           13  
#> 6 90         41      0           13

ggplot(data_smooth, aes(x = Nb_obst, ymin = inf_smooth, ymax = sup_smooth, fill = level)) +
  geom_ribbon(alpha = 0.6) +
  scale_fill_manual(values = c("20" = "darkred", "40" = "red", 
      "60" = "darkorange", "90" = "yellow")) +
  theme_light()

由reprex package (v0.2.0) 于 2018 年 5 月 26 日创建。

Answer 2

这会使用基本 R 图形生成带有阴影区域的绘图。
诀窍是将x 值与y 值配对。

plot(data$Nb_obst, data$Nb_obs, type = "n",  xlab = "Number obst", ylab = "number obs", ylim = c(0, 25))

lines(data$Nb_obst, data$inf20, col = "dark red")
lines(data$Nb_obst, data$sup20, col = "dark red")

lines(data$Nb_obst, data$inf40, col = "red")
lines(data$Nb_obst, data$sup40, col = "red")

lines(data$Nb_obst, data$inf60, col = "dark orange")
lines(data$Nb_obst, data$sup60, col = "dark orange")

lines(data$Nb_obst, data$inf90, col = "yellow")
lines(data$Nb_obst, data$sup90, col = "yellow")

with(data, polygon(c(Nb_obst, rev(Nb_obst)), c(inf90, rev(sup90)), col = "yellow"))
with(data, polygon(c(Nb_obst, rev(Nb_obst)), c(inf60, rev(sup60)), col = "dark orange"))
with(data, polygon(c(Nb_obst, rev(Nb_obst)), c(inf40, rev(sup40)), col = "red"))
with(data, polygon(c(Nb_obst, rev(Nb_obst)), c(inf20, rev(sup20)), col = "dark red"))

ggplot 图表的代码有点长。有一个函数geom_ribbon 非常适合这个。

g <- ggplot(data)
g + geom_ribbon(aes(x = Nb_obst, ymin = sup60, ymax = sup90), fill = "yellow") + 
    geom_ribbon(aes(x = Nb_obst, ymin = sup40, ymax = sup60), fill = "dark orange") + 
    geom_ribbon(aes(x = Nb_obst, ymin = sup20, ymax = sup40), fill = "red") + 
    geom_ribbon(aes(x = Nb_obst, ymin = inf20, ymax = sup20), fill = "dark red") + 
    geom_ribbon(aes(x = Nb_obst, ymin = inf40, ymax = inf20), fill = "red") + 
    geom_ribbon(aes(x = Nb_obst, ymin = inf60, ymax = inf40), fill = "dark orange") + 
    geom_ribbon(aes(x = Nb_obst, ymin = inf90, ymax = inf60), fill = "yellow")

数据。

我将重做您的数据集，以简化其创建过程。你不需要as.vector，如果你正在创建一个data.frame，则不需要cbind的data.frame方法，data.frame(.)就足够了。

Nb_obs <- c( 2,  0,  6,  2,  7,  1,  8,  0,  2,  1,  1,  3, 11,  5,  9,  6,  4,  0,  7,  9)
Nb_obst <- c(31, 35, 35, 35, 39, 39, 39, 39, 39, 41, 41, 42, 43, 43, 45, 45, 47, 48, 51, 51)
inf20 <- c(2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 3, 4, 4, 3, 5, 4)
sup20 <- c(3, 4, 4, 4, 5, 4, 4, 5, 4, 4, 5, 5, 5, 6, 5, 6, 6, 5, 7, 6)
inf40 <- c(1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 2, 3, 3, 3, 4, 3)
sup40 <- c(4, 5, 5, 5, 6, 5, 5, 6, 5, 5, 6, 6, 6, 7, 6, 7, 7, 7, 9, 7)
inf60 <- c(1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 2)
sup60 <- c(5, 6, 6,  6,  8,  7,  7,  7,  7,  7,  7,  7,  8,  9,  8,  9,  9,  9, 11,  9)
inf90 <- c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1)
sup90 <- c(10, 11, 11, 11, 15, 13, 13, 14, 12, 13, 13, 13, 14, 17, 15, 17, 17, 16, 21, 18)

data <- data.frame(Nb_obs, Nb_obst, inf20, sup20, inf40, sup40, inf60 , sup60, inf90 , sup90)