Shading below line graph in R-CodePudding

I have a line graph time series and I wanna make a filling color red for positive y values and blue for negative y values. How can i do it using polygon function because iam not using ggplot? Thank you!

plot(ts.NAO$NAO_index, type="l",ann=FALSE, xaxt="n", yaxt="n",xlim=c(0,123))
par(new=TRUE)
plot(running_mean, type="l", 
     lty=2, lwd=2, col="red", ann=FALSE, xaxt="n", yaxt="n")
title(xlab="Years", ylab="NAO SLP Index")
abline(h=0, col="blue")
axis(side=1, at=seq(1,123,10), labels=seq(1900,2020,10), las=1) # customizing the x axis
axis(side=2, at=seq(-6,6,0.5), labels=seq(-6,6,0.5)) # customizing the y axis
polygon(c(ts.NAO$Year,rev(ts.NAO$Year),
          c(ts.NAO$NAO_index,rev(ts.NAO$NAO_index),
            col = "darkgreen",border=NA)))

enter code here

CodePudding user response：

plot(ts.NAO$NAO_index, type="l",ann=FALSE, xaxt="n", yaxt="n",xlim=c(0,123))
par(new=TRUE)
plot(running_mean, type="l", lty=2, lwd=2, col="red", ann=FALSE, xaxt="n", yaxt="n")
title(xlab="Years", ylab="NAO SLP Index")
abline(h=0, col="blue")
axis(side=1, at=seq(1,123,10), labels=seq(1900,2020,10), las=1)
axis(side=2, at=seq(-6,6,0.5), labels=seq(-6,6,0.5))

for (i in 1:length(ts.NAO$Year)) {
  if (ts.NAO$NAO_index[i] > 0) {
    polygon(c(ts.NAO$Year[i], ts.NAO$Year[i 1], ts.NAO$Year[i 1], ts.NAO$Year[i]),
            c(0, 0, ts.NAO$NAO_index[i], ts.NAO$NAO_index[i]),
            col="red", border=NA)
  } else {
    polygon(c(ts.NAO$Year[i], ts.NAO$

CodePudding user response：

Sample data,

set.seed(2022)
dat <- data.frame(x=1:100, y=cumsum(runif(100, -10, 10)))
head(dat)
#   x         y
# 1 1  8.296121
# 2 2 17.037629
# 3 3 12.760420
# 4 4 19.369372
# 5 5 22.204283
# 6 6 22.586202

First cut: we'll split the sequence into blocks of neg/pos, then plot each polygon. (data.table::rleid works well, if you must use something else we can contrive a naive version that does the same thing.

my_rleid <- function(z) {
  r <- rle(z)
  rep.int(seq_along(r$lengths), times = r$lengths)
} # or you can use data.table::rleid
spl <- split(dat, my_rleid(dat$y < 0))
lapply(spl[1:2], head)
# $`1`
#   x        y
# 1 1 6.319553
# 2 2 9.264740
# 3 3 1.671311
# 4 4 2.547314
# $`2`
#     x          y
# 5   5  -3.758086
# 6   6  -1.042269
# 7   7  -9.556289
# 8   8 -18.716770
# 9   9 -21.310428
# 10 10 -16.165370

miny <- min(dat$y)
plot(y ~ x, data = dat, type = "l")
abline(h = 0, lty = 2)
for (Z in spl) {
  polygon(Z$x[c(1, 1:nrow(Z), nrow(Z))], c(miny, Z$y, miny),
          col = if (Z$y[1] < 0) "red" else "blue")
}

As you can see, we need to extend each element of spl to extend to the next block (since the x values will show a gap). There are many options for this depending on your preferences: carry-forward (add a row to the bottom of each), push-backward (add a row to the top of each from the preceding block), or interpolate between the first row in one with the bottom row in the preceding. I think the first two are fairly simple, I'll opt for the more-difficult (but visually more consistent) one of interpolation.

for (ind in 2:length(spl)) {
  x1 <- spl[[ind-1]]
  x2 <- spl[[ind]]
  newdat <- do.call(approx, c(setNames(rbind(x1[nrow(x1),], x2[1,]), c("y", "x")), list(xout = 0)))
  names(newdat) <- c("y", "x")
  newdat <- data.frame(newdat)[,2:1]
  spl[[ind-1]] <- rbind(spl[[ind-1]], newdat)
  spl[[ind]] <- rbind(newdat, spl[[ind]])
}

plot(y ~ x, data = dat, type = "l")
abline(h = 0, lty = 2)
for (Z in spl) {
  polygon(Z$x[c(1, 1:nrow(Z), nrow(Z))], c(miny, Z$y, miny),
          col = if (mean(Z$y) < 0) "red" else "blue")
}

(Note that the col= conditional changed, since we know that the first value should "always" be 0.)