Shading below line graph in R

Question

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)))

Answer 1

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.)

Edit: I assumed making the polygon start at the bottom of the plot, as defined by miny <- min(dat$y). As a cue from AllanCameron's excellent answer, if you set miny <- 0 instead, you get this:

Answer 2

My guess is you are looking for something like this. Create two new series in your data frame - one that is 0 if the y value is negative, and another that is 0 if your y value is positive. Bookend both these series with 0 values. You can then use these two series as the outlines of your polygons:

Thanks ro r2evans for the dataset, which I have modified somewhat to make it more in keeping with the ranges of the OP's data.

set.seed(2022)
dat <- data.frame(x = 1:123, y = cumsum(runif(123, -1.5, 1.5)))

dat$y_up <- ifelse(dat$y > 0, dat$y, 0)
dat$y_dn <- ifelse(dat$y < 0, dat$y, 0)

plot(dat$x, dat$y, type = "l", ann = FALSE, xaxt = "n", yaxt = "n")
title(xlab = "Years", ylab = "NAO SLP Index")
abline(h = 0)
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)) 
polygon(c(dat$x[1], dat$x, tail(dat$x, 1)), c(0, dat$y_up, 0), col = "red")
polygon(c(dat$x[1], dat$x, tail(dat$x, 1)), c(0, dat$y_dn, 0), col = "blue")

^{Created on 2022-12-23 with reprex v2.0.2}

Answer 3

Here's an alternative approach. Instead of dividing the time series into many polygons I decided to draw everything at once (well, twice actually) and limit the plotting region instead.

Generating data and initial plotting:

# random data
set.seed(1)
ts.NAO <- list(NAO_index=rnorm(123, sd=2))
running_mean <- stats::filter(ts.NAO$NAO_index, rep(1, 7)/7)

plot(ts.NAO$NAO_index, type='n', ann=F, xaxt='n', yaxt='n', xlim=c(0, 123))
title(xlab="Years", ylab="NAO SLP Index")
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

# save for later use
par0 <- par(c('usr', 'mar'))
# vertical value of dividing point between red and blue
split.at <- 0
# normalized device coordinates of plotting region x and y limits and 
#   the split point
coords <- list(x=grconvertX(par0$usr[1:2], to='ndc'),
               y=grconvertY(c(par0$usr[3:4], split.at), to='ndc'))

Here's a function that creates the lower or upper subfigure and draws the polygon. I didn't want to repeat some parts of code twice, hence the function (although it would be shorter without it).

sub_fig <- function(upper=T, color='red') {
  
  if (upper) {
    
    y.fig <- coords$y[3:2]             # subfigure bottom and top
    y.usr <- c(split.at, par0$usr[4])  # plot y limits
    
  } else {
    
    y.fig <- coords$y[c(1, 3)]          
    y.usr <- c(par0$usr[3], split.at)
  }
  
  par(fig=c(coords$x, y.fig), mar=rep(0, 4), new=T)
  frame()
  plot.window(par0$usr[1:2], y.usr, xaxs='i', yaxs='i')
  polygon(c(1, seq_along(ts.NAO$NAO_index), length(ts.NAO$NAO_index)),
          c(split.at, ts.NAO$NAO_index, split.at), 
          col=color)
}
# upper
sub_fig()
# lower
sub_fig(F, 'blue')

# restore initial plot coordinates
par(fig=c(0, 1, 0, 1), mar=par0$mar, new=T)
frame()
plot.window(par0$usr[1:2], par0$usr[3:4], xaxs='i', yaxs='i')
abline(h=0, col="blue")
lines(running_mean, col=gray(.7), lty=2, lwd=2)

Answer 4

plot(ts.NAO$Year, ts.NAO$NAO_index, type="l", xaxt="n", yaxt="n", xlim=c(1900,2020))
par(new=TRUE)
plot(ts.NAO$Year, running_mean, type="l", lty=2, lwd=2, col="red", xaxt="n", yaxt="n")
title(xlab="Years", ylab="NAO SLP Index")
abline(h=0, col="blue")
axis(side=1, at=seq(1900,2020,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$NAO_index)) {
  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$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="blue", border=NA)

  }#you can choose to remove the polygon borders which is standard 
    #practice for presentation purposes where I work, certainly not 
    #the best way by any means
}

Answer 5

An alternative approach using bars.

set.seed(2022)
dat <- data.frame(x = seq(1900, 2022, 1), y = cumsum(runif(123, -1.5, 1.5)))
dat$col <- ifelse(dat$y < 0, "blue3", "red3")

bp <- barplot(dat$y, border=F, col=dat$col, space=0, xlab="Year", ylab="Index")
lines(bp, dat$y, col="gray45")
lines(bp, rnorm(nrow(dat), 1.5, 0.3), lt=2, col="red2")
abline(h=0, col="blue")
axis(1, bp[c(T, rep(F, 9))], labels=dat$x[c(T,rep(F, 9))])
box()