This post was inspired by a figure I saw recently, meant to highlight the critical state of atmospheric CO2 and what kinds of predictions we can make from the historical data. The original article, from the National Observer, can be found here, but what struck me as interesting was this figure:

atm c02 trends

atm c02 trends

NOAA Mauna Loa C02 data

We can get the monthly mean data from:

ftp://aftp.cmdl.noaa.gov/products/trends/co2/co2_mm_mlo.txt

d <- read.table('ftp://aftp.cmdl.noaa.gov/products/trends/co2/co2_mm_mlo.txt',
                na.strings = -99.99)
names(d) <- c('year', 'month', 'decimalYear', 'average', 'interpolated', 'trend', 'ndays')
d$time <- with(d, as.Date(paste(year, sprintf('%02d', month), '01', sep='-'), format='%Y-%m-%d', tz='UTC'))
time <- d$time
co2 <- d$interpolated

We can smooth out the seasonal variations with a moving average (i.e. boxcar) filter:

library(zoo)

Attaching package: 㤼㸱zoo㤼㸲

The following objects are masked from 㤼㸱package:base㤼㸲:

    as.Date, as.Date.numeric
co2sm <- rollmean(co2, 12, NA)
plot(time, co2, type='l')
lines(time, co2sm, col=2)

Fits and predictions

Now lets go through the excercise shown from the above figure to produce a series of linear fits based on the decadal values.

starts <- as.Date(c('1960-01-01', '1970-01-01', '1980-01-01', '1990-01-01',
                    '2000-01-01', '2010-01-01'))
plot(time, co2sm, type='l', ylab='C02', xlab='', lwd=3,
     xlim=c(min(time), as.Date('2050-01-01')),
     ylim=c(min(co2), 500))
abline(h=450, lwd=2, col=2)
i <- 1
for (s in starts) {
  II <- s <= time & time <= (s + 10*365)
  m <- lm(c ~ t, data=list(c=co2sm[II], t=time[II]))
  tp <- as.Date(seq(s, as.numeric(as.Date('2050-01-01')), 365))
  lines(tp, predict(m, newdata=list(t=tp)), col=i)
  i <- i + 1
}
legend('topleft', legend=format(starts, '%Y'), lwd=1, col=seq_along(starts),
       title='Start of decade')

But wait – fitting a bunch of straight lines to a curve seems like an odd way of making predictions. Why don’t we try to fit the underlying functional form and use that to predict into the future.

The CO2 time series looks to be exponential in nature, e.g.

\[ CO_2 = a + b e^{t/\tau} \]

Let’s try to fit that form using nls(), and compare to the linear fit from data from 2010 to present:

t <- as.numeric(time)
nm <- nls(c ~ a + b*exp(t/tau), data=list(c=co2sm, t=as.numeric(time)),
            start=list(a=320, b=10, tau=8000))
plot(time, co2sm, type='l', ylab='C02', xlab='', lwd=4,
     xlim=c(min(time), as.Date('2050-01-01')),
     ylim=c(min(co2), 500))
abline(h=450, lwd=2, col=2)
tt <- seq(min(t), 30000, 365)
lines(tt, predict(nm, list(t=tt)), col=2, lwd=2)
abline(m)
expdate <- tt[which.min(abs(predict(nm, list(t=tt))-450))]
abline(v=expdate, col=2)
mtext(format(as.Date(expdate)), at=expdate, adj=1, col=2)
lindate <- tt[which.min(abs(predict(m, list(t=as.Date(tt)))-450))]
abline(v=lindate)
mtext(format(as.Date(lindate)), at=lindate, adj=0)

Looks like the 450 ppm mark will hit three years sooner than the current decadal trend predicts.

LS0tDQp0aXRsZTogIkNPMiBkYXRhIGFuZCB0cmVuZHMiDQphdXRob3I6IENsYXJrIFJpY2hhcmRzLCBjbGFyay5yaWNoYXJkcy5vcmcNCmRhdGU6IDIwMTctMDQtMjANCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNClRoaXMgcG9zdCB3YXMgaW5zcGlyZWQgYnkgYSBmaWd1cmUgSSBzYXcgcmVjZW50bHksIG1lYW50IHRvIGhpZ2hsaWdodCB0aGUgY3JpdGljYWwgc3RhdGUgb2YgYXRtb3NwaGVyaWMgQ08yIGFuZCB3aGF0IGtpbmRzIG9mIHByZWRpY3Rpb25zIHdlIGNhbiBtYWtlIGZyb20gdGhlIGhpc3RvcmljYWwgZGF0YS4gVGhlIG9yaWdpbmFsIGFydGljbGUsIGZyb20gdGhlIE5hdGlvbmFsIE9ic2VydmVyLCBjYW4gYmUgZm91bmQgW2hlcmVdKGh0dHA6Ly93d3cubmF0aW9uYWxvYnNlcnZlci5jb20vMjAxNy8wNC8xMC9vcGluaW9uL2F0bW9zcGhlcmljLWNvMi1sZXZlbHMtYWNjZWxlcmF0ZS11cHdhcmRzLXNtYXNoaW5nLXJlY29yZHMpLCBidXQgd2hhdCBzdHJ1Y2sgbWUgYXMgaW50ZXJlc3Rpbmcgd2FzIHRoaXMgZmlndXJlOg0KDQohW2F0bSBjMDIgdHJlbmRzXShodHRwOi8vd3d3Lm5hdGlvbmFsb2JzZXJ2ZXIuY29tL3NpdGVzL25hdGlvbmFsb2JzZXJ2ZXIuY29tL2ZpbGVzL3N0eWxlcy9ib2R5X2ltZy9wdWJsaWMvaW1nLzIwMTcvMDMvMzEvY28yLXBwbS10b3RhbC13aXRoLXRyZW5kcy5qcGc/aXRvaz14blJpeElpUCkNCg0KIyMgTk9BQSBNYXVuYSBMb2EgQzAyIGRhdGENCg0KV2UgY2FuIGdldCB0aGUgbW9udGhseSBtZWFuIGRhdGEgZnJvbToNCg0KZnRwOi8vYWZ0cC5jbWRsLm5vYWEuZ292L3Byb2R1Y3RzL3RyZW5kcy9jbzIvY28yX21tX21sby50eHQNCg0KYGBge3J9DQpkIDwtIHJlYWQudGFibGUoJ2Z0cDovL2FmdHAuY21kbC5ub2FhLmdvdi9wcm9kdWN0cy90cmVuZHMvY28yL2NvMl9tbV9tbG8udHh0JywNCiAgICAgICAgICAgICAgICBuYS5zdHJpbmdzID0gLTk5Ljk5KQ0KbmFtZXMoZCkgPC0gYygneWVhcicsICdtb250aCcsICdkZWNpbWFsWWVhcicsICdhdmVyYWdlJywgJ2ludGVycG9sYXRlZCcsICd0cmVuZCcsICduZGF5cycpDQpkJHRpbWUgPC0gd2l0aChkLCBhcy5EYXRlKHBhc3RlKHllYXIsIHNwcmludGYoJyUwMmQnLCBtb250aCksICcwMScsIHNlcD0nLScpLCBmb3JtYXQ9JyVZLSVtLSVkJywgdHo9J1VUQycpKQ0KdGltZSA8LSBkJHRpbWUNCmNvMiA8LSBkJGludGVycG9sYXRlZA0KYGBgDQoNCldlIGNhbiBzbW9vdGggb3V0IHRoZSBzZWFzb25hbCB2YXJpYXRpb25zIHdpdGggYSBtb3ZpbmcgYXZlcmFnZSAoaS5lLiBib3hjYXIpIGZpbHRlcjoNCmBgYHtyfQ0KbGlicmFyeSh6b28pDQpjbzJzbSA8LSByb2xsbWVhbihjbzIsIDEyLCBOQSkNCnBsb3QodGltZSwgY28yLCB0eXBlPSdsJykNCmxpbmVzKHRpbWUsIGNvMnNtLCBjb2w9MikNCmBgYA0KDQojIyBGaXRzIGFuZCBwcmVkaWN0aW9ucw0KDQpOb3cgbGV0cyBnbyB0aHJvdWdoIHRoZSBleGNlcmNpc2Ugc2hvd24gZnJvbSB0aGUgYWJvdmUgZmlndXJlIHRvIHByb2R1Y2UgYSBzZXJpZXMgb2YgbGluZWFyIGZpdHMgYmFzZWQgb24gdGhlIGRlY2FkYWwgdmFsdWVzLg0KDQpgYGB7cn0NCnN0YXJ0cyA8LSBhcy5EYXRlKGMoJzE5NjAtMDEtMDEnLCAnMTk3MC0wMS0wMScsICcxOTgwLTAxLTAxJywgJzE5OTAtMDEtMDEnLA0KICAgICAgICAgICAgICAgICAgICAnMjAwMC0wMS0wMScsICcyMDEwLTAxLTAxJykpDQoNCnBsb3QodGltZSwgY28yc20sIHR5cGU9J2wnLCB5bGFiPSdDMDInLCB4bGFiPScnLCBsd2Q9MywNCiAgICAgeGxpbT1jKG1pbih0aW1lKSwgYXMuRGF0ZSgnMjA1MC0wMS0wMScpKSwNCiAgICAgeWxpbT1jKG1pbihjbzIpLCA1MDApKQ0KYWJsaW5lKGg9NDUwLCBsd2Q9MiwgY29sPTIpDQppIDwtIDENCmZvciAocyBpbiBzdGFydHMpIHsNCiAgSUkgPC0gcyA8PSB0aW1lICYgdGltZSA8PSAocyArIDEwKjM2NSkNCiAgbSA8LSBsbShjIH4gdCwgZGF0YT1saXN0KGM9Y28yc21bSUldLCB0PXRpbWVbSUldKSkNCiAgdHAgPC0gYXMuRGF0ZShzZXEocywgYXMubnVtZXJpYyhhcy5EYXRlKCcyMDUwLTAxLTAxJykpLCAzNjUpKQ0KICBsaW5lcyh0cCwgcHJlZGljdChtLCBuZXdkYXRhPWxpc3QodD10cCkpLCBjb2w9aSkNCiAgaSA8LSBpICsgMQ0KfQ0KbGVnZW5kKCd0b3BsZWZ0JywgbGVnZW5kPWZvcm1hdChzdGFydHMsICclWScpLCBsd2Q9MSwgY29sPXNlcV9hbG9uZyhzdGFydHMpLA0KICAgICAgIHRpdGxlPSdTdGFydCBvZiBkZWNhZGUnKQ0KYGBgDQoNCkJ1dCB3YWl0IC0tIGZpdHRpbmcgYSBidW5jaCBvZiBzdHJhaWdodCBsaW5lcyB0byBhIGN1cnZlIHNlZW1zIGxpa2UgYW4gb2RkIHdheSBvZiBtYWtpbmcgcHJlZGljdGlvbnMuIFdoeSBkb24ndCB3ZSB0cnkgdG8gZml0IHRoZSB1bmRlcmx5aW5nIGZ1bmN0aW9uYWwgZm9ybSBhbmQgdXNlIHRoYXQgdG8gcHJlZGljdCBpbnRvIHRoZSBmdXR1cmUuDQoNClRoZSBDTzIgdGltZSBzZXJpZXMgbG9va3MgdG8gYmUgZXhwb25lbnRpYWwgaW4gbmF0dXJlLCBlLmcuDQoNCiQkIENPXzIgPSBhICsgYiBlXnt0L1x0YXV9ICQkDQoNCkxldCdzIHRyeSB0byBmaXQgdGhhdCBmb3JtIHVzaW5nIGBubHMoKWAsIGFuZCBjb21wYXJlIHRvIHRoZSBsaW5lYXIgZml0IGZyb20gZGF0YSBmcm9tIDIwMTAgdG8gcHJlc2VudDoNCmBgYHtyfQ0KdCA8LSBhcy5udW1lcmljKHRpbWUpDQpubSA8LSBubHMoYyB+IGEgKyBiKmV4cCh0L3RhdSksIGRhdGE9bGlzdChjPWNvMnNtLCB0PWFzLm51bWVyaWModGltZSkpLA0KICAgICAgICAgICAgc3RhcnQ9bGlzdChhPTMyMCwgYj0xMCwgdGF1PTgwMDApKQ0KcGxvdCh0aW1lLCBjbzJzbSwgdHlwZT0nbCcsIHlsYWI9J0MwMicsIHhsYWI9JycsIGx3ZD00LA0KICAgICB4bGltPWMobWluKHRpbWUpLCBhcy5EYXRlKCcyMDUwLTAxLTAxJykpLA0KICAgICB5bGltPWMobWluKGNvMiksIDUwMCkpDQphYmxpbmUoaD00NTAsIGx3ZD0yLCBjb2w9MikNCnR0IDwtIHNlcShtaW4odCksIDMwMDAwLCAzNjUpDQpsaW5lcyh0dCwgcHJlZGljdChubSwgbGlzdCh0PXR0KSksIGNvbD0yLCBsd2Q9MikNCmFibGluZShtKQ0KZXhwZGF0ZSA8LSB0dFt3aGljaC5taW4oYWJzKHByZWRpY3Qobm0sIGxpc3QodD10dCkpLTQ1MCkpXQ0KYWJsaW5lKHY9ZXhwZGF0ZSwgY29sPTIpDQptdGV4dChmb3JtYXQoYXMuRGF0ZShleHBkYXRlKSksIGF0PWV4cGRhdGUsIGFkaj0xLCBjb2w9MikNCmxpbmRhdGUgPC0gdHRbd2hpY2gubWluKGFicyhwcmVkaWN0KG0sIGxpc3QodD1hcy5EYXRlKHR0KSkpLTQ1MCkpXQ0KYWJsaW5lKHY9bGluZGF0ZSkNCm10ZXh0KGZvcm1hdChhcy5EYXRlKGxpbmRhdGUpKSwgYXQ9bGluZGF0ZSwgYWRqPTApDQpgYGANCkxvb2tzIGxpa2UgdGhlIDQ1MCBwcG0gbWFyayB3aWxsIGhpdCB0aHJlZSB5ZWFycyAqc29vbmVyKiB0aGFuIHRoZSBjdXJyZW50IGRlY2FkYWwgdHJlbmQgcHJlZGljdHMu