apply fullrange option on multiple loess smooth lines when subsetting the data - r

Question

How could I draw different smooth lines on my plot for data included in separate time periods, but draw them both on the full range of the plot?
In my working example below, even when setting the fullrange argument to TRUE, the smooth lines limit themselves, and I get the missing values warnings (which does make sense as we are setting a new data range locally in each one of the geom_smooth() functions).
# convert time series to data.frame, conserving date info
sb <- data.frame(Seatbelts, date = time(Seatbelts))
# convert from ts to date
library(lubridate)
sb$date <- as_date(date_decimal(as.numeric(sb$date)))
# store seatbelt law date
law <- ymd(19830131)
# plot
library(ggplot2)
ggplot(sb) + aes(x = date, y = front) +
geom_line() +
geom_vline(xintercept = law, colour = "red") +
geom_smooth(data = sb[sb$date < law,],
fullrange = TRUE) +
geom_smooth(data = sb[sb$date > law,],
fullrange = TRUE)
Warning messages:
Warning messages:
1: Removed 10 rows containing missing values (geom_smooth).
2: Removed 71 rows containing missing values (geom_smooth).
(currently using ggplot2 3.1.0 and R 3.5.2)
Edit:
As I thought the issue was the preliminary subsetting of the data, I also tried this cleaner version, to no avail:
# add before/after
sb$relative <- ifelse(sb$date < law, "before", "after")
# plot v.2
ggplot(sb) + aes(x = date, y = front) +
geom_line() +
geom_vline(xintercept = law, colour = "red") +
geom_smooth(aes(colour = relative),
fullrange = TRUE)

Answer 1

The explanation for the behaviour you're seeing has to do with the way the LOESS fit is performed; by default
dates <- seq(as.Date("1960-01-01"), law, by = "1 day")
head(setNames(predict(
loess(front ~ as.numeric(date), data = sb[sb$date < law, ]),
data.frame(date = as.numeric(dates))), dates))
1960-01-01 1960-01-02 1960-01-03 1960-01-04 1960-01-05 1960-01-06
NA NA NA NA NA NA
the behaviour of which is explained in ?predict.loess (bold-face mine)
When the fit was made using ‘surface = "interpolate"’ (the
default), ‘predict.loess’ will not extrapolate - so points outside
an axis-aligned hypercube enclosing the original data will have
missing (‘NA’) predictions and standard errors.
In order to extrapolate to points outside of the range of points used for the LOESS model we can use control = loess.control(surface = "direct") inside loess.
Unfortunately this means that we need to manually perform the two LOESS fits, predict values for two ranges of interest, and plot everything.
Here is what I would do:
Define a convenience function extrapolate.loess that predicts values for dates with a lower/upper confidence interval (based on an alpha level)
library(tidyverse)
library(broom)
extrapolate.loess <- function(data, dates, alpha = 0.95) {
loess(
front ~ as.numeric(date), data = data,
control = loess.control(surface = "direct")) %>%
augment(newdata = data.frame(date = as.numeric(dates))) %>%
transmute(
date = dates,
front = .fitted,
front.l = front - qnorm((1 - alpha) / 2) * .se.fit,
front.h = front + qnorm((1 - alpha) / 2) * .se.fit)
}
We now store LOESS estimates with CI's for the two ranges in a data.frame
dates.left <- seq(as.Date("1960-01-01"), law, by = "1 day")
df.left <- extrapolate.loess(sb[sb$date < law, ], dates.left)
dates.right <- seq(law, as.Date("1990-01-01"), by = "1 day")
df.right <- extrapolate.loess(sb[sb$date > law, ], dates.right)
Now we can plot
ggplot(sb) + aes(x = date, y = front) +
geom_line() +
geom_vline(xintercept = law, colour = "red") +
geom_line(data = df.left, colour = "blue", size = 1) +
geom_ribbon(data = df.left, aes(x = date, ymin = front.l, ymax = front.h), alpha = 0.2) +
geom_line(data = df.right, colour = "blue", size = 1) +
geom_ribbon(data = df.right, aes(x = date, ymin = front.l, ymax = front.h), alpha = 0.2) +
coord_cartesian(ylim = c(400, 1300))
I will not/cannot comment on how useful/meaningful these LOESS extrapolations are.