An R package to resample or constrain large model ensemble to preserve physical aspects of the model simulations.
This example illustrates an ensemble resampling technique for bias correction of large initial condition ensembles and considers specifically heat-health indicators such as the wet bulb temperature or similar multivariate indices that combine temperature and relative humidity. Ensemble simulations from the HadRM3P are bias corrected, a regional variant of HadCM3, and computed through climateprediction.net/weatherathome. The focus here in on seasonal maximum heat stress as indicated e.g. through seasonal maxima of 3-day running averages of daily maximum wet bulb temperature (WBTX_3d), daily maximum Wet Bulb Globe Temperature (WBGTX_3d), or daily maximum temperature (TX_3d).
The present example is based on the following publication:
will follow soon…
library(ensbiascoR)
data(ensbiascoR.example2)
location = "DE_JEN" # Define current location
kernel.quantiles = seq(0, 1, 0.001)
obs.kernel = get.kernel.percentiles(data=ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax[which(ensbiascoR.example2$DE_JEN$obs.data$Year %in% 1985:2010)], kernel.quantiles = kernel.quantiles)
## KernSmooth 2.23 loaded
## Copyright M. P. Wand 1997-2009
mod.kernel = get.kernel.percentiles(data=ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax, kernel.quantiles = kernel.quantiles)
plot(ecdf(ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax[which(ensbiascoR.example2[[location]]$obs.data$Year %in% 1985:2010)]), bty='n',
xlab = "Observational metric", ylab="Cumulative Density Function", xlim=c(15,30),
main="", yaxt="n")
axis(side=2, las=1)
lines(x = obs.kernel, y=kernel.quantiles, col="blue", lwd=2)
lines(x = mod.kernel, y=kernel.quantiles, col="red", lwd = 2)
legend("topleft", location)
cur.transfer.function = get.percentile.transfer.function(obs.grid.cell = ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax[which(ensbiascoR.example2[[location]]$obs.data$Year %in% 1985:2010)],
mod.grid.cell = ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax)
plot(x = kernel.quantiles, y = cur.transfer.function(kernel.quantiles),
xlab="Observations - CDF", ylab="Model Ensemble - CDF", bty="n",
xlim = c(0,1), ylim=c(0, 1), type="n")
lines(x = kernel.quantiles, y = cur.transfer.function(kernel.quantiles), col="red")
lines(x=c(-10^6, 10^6), y=c(-10^6,10^6), col="darkgray", lwd = 2)
sapply(X= seq(0, 1, by=0.1), FUN=function(x) lines(x = c(x, x), y = c(0, cur.transfer.function(x)), lty=2, col="black"))
sapply(X= seq(0, 1, by=0.1), FUN=function(x) lines(x = c(0, x), y = c(cur.transfer.function(x), cur.transfer.function(x)), lty = 2, col="black"))
legend("topleft", c("Hermite Splines"), bty='n', lty=1, col="red")
i. with replacement:
resample.idx_replacement = resample.ensemble(mod.grid.cell = ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax, transfer.function= cur.transfer.function, replacement = T, sample.size=10000)
ii. without replacement:
resample.idx_no_replacement = resample.ensemble(mod.grid.cell = ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax, transfer.function= cur.transfer.function, replacement = F, sample.size=1000, search.radius = 0.5)
year.idx = which(ensbiascoR.example2[[location]]$obs.data$Year %in% 1985:2010)
plot(c(1,1), type='n', xlim=c(15, 35), ylim=c(15, 28), bty='n',
xlab = "21-day seas. max. temperature [°C]", ylab = "3-day seas. max. wet bulb temperature [°C]")
points(x= ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax, y= ensbiascoR.example2[[location]]$mod.data$WBT_3d_seasmax,
col="darkred", cex = 0.5, pch = 16)
points(x= ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax[resample.idx_replacement], y= ensbiascoR.example2[[location]]$mod.data$WBT_3d_seasmax[resample.idx_replacement], col="darkblue", cex = 0.5, pch = 16)
points(x= ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax, ensbiascoR.example2[[location]]$obs.data$WBT_3d_seasmax, col="black", pch=16)
points(x= ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax[year.idx], ensbiascoR.example2[[location]]$obs.data$WBT_3d_seasmax[year.idx], col="pink", pch=16)
legend("bottomright", c("ECA&D, 1901-2014", "ECA&D, 1985-2010", "HadRM3P, 1985-2010, original", "HadRM3P, 1985-2010, resampled"),
col = c("black", "pink", "darkred", "darkblue"), bty='n', pch=16)
legend("topleft", location)
plot(c(1,1), type='n', xlim=c(15, 35), ylim=c(20, 40), bty='n',
xlab = "21-day seas. max. temperature [°C]", ylab = "3-day seas. max. temperature [°C]")
points(x= ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax, y= ensbiascoR.example2[[location]]$mod.data$Tair_3d_seasmax,
col="darkred", cex = 0.5, pch = 16)
points(x= ensbiascoR.example2[[location]]$mod.data$Tair_21d_seasmax[resample.idx_replacement], y= ensbiascoR.example2[[location]]$mod.data$Tair_3d_seasmax[resample.idx_replacement], col="darkblue", cex = 0.5, pch = 16)
points(x= ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax, ensbiascoR.example2[[location]]$obs.data$Tair_3d_seasmax, col="black", pch=16)
points(x= ensbiascoR.example2[[location]]$obs.data$Tair_21d_seasmax[year.idx], ensbiascoR.example2[[location]]$obs.data$Tair_3d_seasmax[year.idx], col="pink", pch=16)
legend("bottomright", c("ECA&D, 1901-2014", "ECA&D, 1985-2010", "HadRM3P, 1985-2010, original", "HadRM3P, 1985-2010, resampled"),
col = c("black", "pink", "darkred", "darkblue"), bty='n', pch=16)
legend("topleft", location)