基于值填充曲线下的区域

Question

我们正在尝试使用ggplot2制作一个区域图，其中x轴上方的正面积分为一种颜色，负面积分为另一种颜色。

鉴于这个数据集，我想要一个区域图，在轴的每侧都有不同的颜色。

我可以看到一种将数据集分成两个子集的方法：一个是所有负值为零的正数，另一个是所有正值为零的负数，然后在同一轴上分别绘制这些子集，但似乎有更多适用于ggplot的方法。

在此问题中发布的解决方案没有给出准确的结果（如下所示）。

以下是正确显示为条形图的示例数据。 代码:

# create some fake data with zero-crossings
yvals=c(2,2,-1,2,2,2,0,-1,-2,2,-2)
test = data.frame(x=seq(1,length(yvals)),y=yvals)

# generate the bar plot
ggplot(data=test,aes(x=x,y=y)) 
    + geom_bar(data=test[test$y>0,],aes(y=y), fill="blue",stat="identity", width=.5) 
    + geom_bar(data=test[test$y<0,],aes(y=y), fill="red",stat="identity", width=.5)

RLE算法不是通用的

在其他问题上提出的RLE算法，在应用到我们的数据集时会产生与零点相关的伪像：

以下是生成该图的代码（请勿使用）：

# set up grouping function
rle.grp <- function(x) {
   xx <- rle(x)
   xx$values = seq_along(xx$values)
   inverse.rle(xx) }

# generate ribbon plot
ggplot(test, aes(x=x,y=y,group = factor(rle.grp(sign(y))))) + 
    geom_ribbon(aes(ymax = pmax(0,y),ymin = pmin(0,y),
   fill = factor(sign(y), levels = c(-1,0,1), labels = c('-','0','+')))) 
   + scale_fill_brewer(name = 'sign', palette = 'RdBu')

请看下文中由@baptiste和Kohske建议的终极答案。

- beroe

---

请参考https://dev59.com/JmLVa4cB1Zd3GeqPuTlD#9974544。 - baptiste

以及相关代码 https://dev59.com/SI7ea4cB1Zd3GeqPCo6a#32284831 - baptiste

Answer 1

根据@baptiste（已删除评论）的评论，我认为这是最好的答案。它基于Kohske的这篇文章。它在零交叉点处向数据集添加新的x-y对，并生成下面的图表。

# create some fake data with zero-crossings
yvals = c(2,2,-1,2,2,2,0,-1,-2,2,-2)
d = data.frame(x=seq(1,length(yvals)),y=yvals)

rx <- do.call("rbind",
   sapply(1:(nrow(d)-1), function(i){
   f <- lm(x~y, d[i:(i+1),])
   if (f$qr$rank < 2) return(NULL)
   r <- predict(f, newdata=data.frame(y=0))
   if(d[i,]$x < r & r < d[i+1,]$x)
      return(data.frame(x=r,y=0))
    else return(NULL)
 }))
 d2 <- rbind(d,rx)
 ggplot(d2,aes(x,y)) + geom_area(data=subset(d2, y<=0), fill="pink") 
     + geom_area(data=subset(d2, y>=0), fill="lightblue") + geom_point()

生成以下输出：

- beroe

Answer 2

我希望在此添加更新，首先提供一个更简单的方法使用dplyr，其次是让@beroe的答案更易读。

一个新答案

你可以通过代数方式解决x的问题。该方程来自于重新排列一条直线的方程（y = mx + b），以解决给定两个其他点和y = 0时的x值。

library(dplyr)
library(magrittr)
library(ggplot2)

df <- data.frame(x = 1:10, y = runif(10, -1, 1))

df_inbetween <- df %>% 
  mutate(
    # Solve for x given two points and y = 0
    xzero = -((y * (lead(x) - x)) / (lead(y) - y)) + x,
    xzero_valid = xzero > x & xzero < lead(x),
    xzero = replace(xzero, !xzero_valid, NA),
    yzero = 0,
    yzero = replace(yzero, !xzero_valid, NA)
  ) %>% 
  select(x = xzero, y = yzero) %>% 
  filter(!is.na(x))

df <- rbind(df, df_inbetween)

ggplot(data = df, aes(x = x, y = y)) + 
  geom_area(data = filter(df, y >= 0), fill = 'pink') +
  geom_area(data = filter(df, y <= 0), fill = 'light blue') +
  geom_point()

重新编辑beroe的答案

这个回答不太简洁，原始答案很难阅读。此外，最好使用lapply，因为sapply在这里不会简化列表。

library(ggplot2)
d <- data.frame(x = 1:10, y = runif(10, -1, 1))

find_root <- function(i){
  f <- lm(x~y, d[c(i, i+1),])
  
  # If the model is invalid, NULL
  if (f$qr$rank < 2) return(NULL)
  
  r <- predict(f, newdata=data.frame(y=0))
  
  # Check if that point falls between the two other x-values
  if(d[i,]$x < r & r < d[i+1,]$x)
    return(data.frame(x=r,y=0))
  
  else return(NULL)
}

# Make dataset containing root points
rx <- do.call('rbind', 
  lapply(1:(nrow(d) - 1), find_root)
)

# Append and plot
d2 <- rbind(d,rx)

ggplot(d2,aes(x, y)) + 
  geom_area(data=subset(d2, y<=0), fill="pink") + 
  geom_area(data=subset(d2, y>=0), fill="lightblue") + 
  geom_point()

注意：对于这两种解决方案，如果您的数据集除了 x 和 y 之外还有其他变量，则最终的 rbind 调用将失败。在 dplyr 解决方案中，您可以根据需要更改 select 调用。

- Charlie Gallagher

---

谢谢Charlie。我很感激你的努力，我会研究这些解决方案。 - beroe

Answer 3

我使用以下易于理解的逻辑做了一个相似的图表。我为正值和负值创建了以下两个对象。请注意，其中有一个“非常小的数字”，以避免从一个点跳到另一个点而不经过零点。

pos <- mutate(df, y = ifelse(ROI >= 0, y, 0.0001))
neg <- mutate(df, y = ifelse(ROI < 0, y, -0.0001))

然后，只需将 geom_area 添加到您的 ggplot 对象中：

ggplot(..., aes(y = y)) + 
  geom_area(data = pos, fill = "#3DA4AB") +
  geom_area(data = neg, fill = "tomato")

希望它对您有用！;)

- Bernardo