使用 R 中的 ggplot 分别为相交曲线上方和下方着色？

Question

其他类似的问题也被问过here，但它们比我的问题稍微简单一些。

我正在使用 R 中的 ggplot2 绘制两条曲线

geom_line

。我们将曲线 1 称为“基线”。曲线 2 与曲线 1 在多个点相交，并且可以在许多点高于基线或低于基线。我正在尝试计算曲线之间的面积，然后绘制它们！

我正在计算：

1：基线和曲线 2 之间的总面积

2：曲线 2 与基线之间高于基线的面积

3：曲线 2 与基线之间低于基线的面积。

我有一些工作代码（可能正确也可能不正确！）来计算面积，但是 现在我想绘制曲线和曲线 2 高于基线的区域，我想将其涂成蓝色。当曲线 2 低于基线时，我希望它呈红色。希望我下面的例子能够阐明我想要实现的目标。

第一个示例是我的方法有效的简单示例：

library(dplyr)
library(ggplot2)

df <- data.frame(time = c(0,1,2,3),
                 percent = c(50, 50, 10, 10),
                 preds = c(40,50,50,10))

calculate_area_between_curves <- function(df, x_col, y1_col, y2_col) {
  df <- df %>% arrange(!!sym(x_col))
  
  x <- df[[x_col]]
  y1 <- df[[y1_col]]
  y2 <- df[[y2_col]]
  
  dx <- diff(x)
  
  # Calculate areas
  total_area <- sum(abs((y1[-1] + y1[-length(y1)])/2 - (y2[-1] + y2[-length(y2)])/2) * dx)
  blue_area <- sum(pmax((y1[-1] + y1[-length(y1)])/2 - (y2[-1] + y2[-length(y2)])/2, 0) * dx)
  red_area <- sum(pmax((y2[-1] + y2[-length(y2)])/2 - (y1[-1] + y1[-length(y1)])/2, 0) * dx)
  
  return(list(total = total_area, blue = blue_area, red = red_area))
}

# Calculate areas
areas <- calculate_area_between_curves(df, "time", "percent", "preds")
> areas
$total
[1] 45

$blue
[1] 5

$red
[1] 40

# Plot 
ggplot(df, aes(time)) +
  geom_ribbon(aes(ymin = pmin(baseline, curve2), ymax = baseline), fill = "blue", alpha = 0.3) +
  geom_ribbon(aes(ymin = baseline, ymax = pmax(baseline, curve2)), fill = "red", alpha = 0.3) +
  geom_line(aes(y = baseline), col = 'red') +
  geom_line(aes(y = curve2), col = 'blue') + 
  theme_bw()

看来我的面积函数已经正确计算了面积，并且能够正确地为图中的区域着色。但是，如果我将数据框更改为稍微复杂一些：

df <- data.frame(time = c(0, 120, 300, 600, 900),
                 baseline = c(100, 62.3, 56.7, 47.9, 44.7),
                 curve2 = c(92.2, 58.7, 58.2, 52.4, 51.1))

并运行相同的代码，我现在得到这些区域和这个图：

> areas
$total
[1] 3408

$blue
[1] 873

$red
[1] 2535

问题是，我不知道这些区域对于更复杂的数据是否正确，正如您所看到的，彩色区域在交点处溢出到其线之外。对于我的数据中的其他一些图，曲线 2 多次与基线相交。

关于如何解决这个问题有什么建议吗？

Answer 1

第二个示例中的问题是两条线相交的位置不是数据框中的点之一，就像第一个示例中那样。

一种解决方案是将线相交的所有点添加到数据框中。像这样的东西：

intersections <- sapply(1:(nrow(df)-1), function(i) {
  x <- df$time[(i:(i+1))]
  y1 <- df$baseline[(i:(i+1))]
  y2 <- df$curve2[(i:(i+1))]
  
  # calculate the intersection point (xp, yp)
  xp <- (y1[1]-y2[1])*(x[2]-x[1])/((y2[2]-y2[1])-(y1[2]-y1[1]))+x[1]
  yp <- y1[1]+(y1[2]-y1[1])/(x[2]-x[1])*(xp-x[1])
  
  # flag non-intersecting line segments by setting time = NA
  row <- c(
    time = ifelse((xp>x[1])*(xp<x[2]),xp,NA), 
    baseline = yp, 
    curve2 = yp
  )
  
  return(row)
}) %>% t %>% as.data.frame
# insert intersection points
df <- rbind(df, intersections) %>% 
  .[!is.na(.$time),] %>%
  arrange(., time)

这会给你带来稍微不同的区域。它们比以前更高，而不是更低，因为之前，它在某种意义上计算了交叉点处的一些负区域。

> areas
$total
[1] 3487.412

$blue
[1] 912.7059

$red
[1] 2574.706

还有图表：