This vignette illustrates the package EGOcalibrationFSPM
that is an implementation of the Bayesian calibration method for
functional structural plant modeling that is described in Blanc et al.
Efficient Bayesian automatic calibration of a functional-structural
wheat model using an adaptive design and a metamodeling
approach.
Dependencies:
suppressPackageStartupMessages(library(EGOcalibrationFSPM))
suppressPackageStartupMessages(library(MCMCpack))
suppressPackageStartupMessages(library(DiceDesign))
suppressPackageStartupMessages(library(DiceKriging))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(cowplot))
suppressPackageStartupMessages(library(ggmcmc))
A toy model is provided, that simulates biomass along time. It is
implemented in the function fbiomass
which takes three
arguments: a sowing density, daily meteorological data and a vector of
parameters. It returns a vector of cumulative biomass values over
time.
The toy model is based on an example from wheat, with sowing in October and harvest in July. The three parameters define, in a very simplistic way, the dynamics of the leaf area index (LAI). The first parameter corresponds to the date at which the LAI increases rapidly (e.g., 850 growing degree days), the second to the date at which the LAI reaches its maximum value (e.g., 1600 growing degree days), and the third to the maximum LAI value (e.g., 3).
Typical meteorological data are provided for several seasons. These monitoring data came from the INRAE CLIMATIK platform managed by the AgroClim laboratory of Avignon, France.
set.seed(12345)
# sowing density (nb of plants per m2)
x <- 200
# chosen values for the parameters of the FSPM
theta <- c(850, 1600, 3)
ltheta <- length(theta)
# bounds for calibrating theta
Boundstheta = matrix(c( 600, 1000,
1300, 1800,
1, 6),
nrow=3, ncol=2, byrow=TRUE)
# observational noise
sigma <- .02
# times of observation
nobs <- 5
times <- round(seq(160, 305, length=nobs))
# considered seasons
seasons <- list("2019-2020","2018-2019","2017-2018","2016-2017","2015-2016")
These parameters are the settings for the MCMC exploration that performs Bayesian calibration and the EGO algorithm that will add points sequentially to the design of numerical experiments:
# cov matrix of the random walk
V = diag(ltheta) * 1e-4
nburnin = 1000
nMCMC = 5e3
npointsEGO = 1000
nsimEGO = 1000
We consider as the available field data a noisy version of outputs of the toy model. A Gaussian white noise is added on the logarithm of the biomass in order to have a noise whose standard deviation is proportional to the outputs.
resSimu = lapply(seasons, function(season)
{
datameteo = BuildMeteodat(season)
ybiom = fbiomass(x, datameteo, theta)
logybiom = log(ybiom) + rnorm(length(ybiom), 0, sigma)
logybiom[is.infinite(logybiom)] = -10
return(list(datmeteo=datameteo, logy=logybiom))
})
listdatmeteo = lapply(resSimu, function(res){res$datmeteo})
listlogy = lapply(resSimu, function(res){res$logy[times]})
One can plot the data for a given season:
str(listdatmeteo[[1]])
#> 'data.frame': 305 obs. of 2 variables:
#> $ PAR : num 0.9 1.42 1.49 2.45 2.3 1.83 3.04 2.54 2.76 0.79 ...
#> $ cumdegree: num 13.2 25.5 36.2 46.3 55 64.1 71.9 77.5 82.5 88.1 ...
summary(listdatmeteo[[1]])
#> PAR cumdegree
#> Min. : 0.310 Min. : 13.2
#> 1st Qu.: 1.990 1st Qu.: 528.5
#> Median : 5.330 Median :1066.7
#> Mean : 5.935 Mean :1392.1
#> 3rd Qu.: 9.280 3rd Qu.:2175.0
#> Max. :13.650 Max. :3680.6
summary(exp(listlogy[[1]]))
#> Min. 1st Qu. Median Mean 3rd Qu. Max.
#> 2.476 6.002 8.842 7.042 8.860 9.032
plot(listdatmeteo[[1]]$cumdegree[times], exp(listlogy[[1]]),
las=1, type="b", lty=3,
main="Simulated data", xlab="cumulative growing degree-days",
ylab="biomass (in g)")
It assumes many calls to the FSPM (only possible when the FSPM is fast). In this situation, fitting metamodels is not necessary and the calibration boils down to step 5 (see Figure 1 of Blanc et al.) where the true FSPM can be used in lieu of metamodels.
We denote by \(y_{m,t}\) the log of the biomass for meteorological condition corresponding to index \(m\) and for time \(t\).
We assume the following model that links the \(y_{m,t}\) to the toy model for calibrating the FSPM: for all \(m,t\)
\[y_{m,t} = \log f(m,t,x) +
\epsilon_{m,t}\] where \(\epsilon_{m,t}\overset{iid}{\sim}\mathcal{N}(0,\sigma^2)\)
where \(\sigma^2\) is considered as
known fixed to 4^{-4}. From this model, we derive the likelihood and
apply a Bayesian calibration. The prior on the parameters is given as
independent uniform distribution between fixed lower and upper bounds
given in Boundstheta
.
system.time(
res1 <- MCMCmetrop1R(exactlogpostMulti, theta.init=rep(.5,ltheta),
burnin=nburnin, mcmc=nMCMC, logfun=TRUE, V=V,
listlogy=listlogy, x=x, listdatmeteo=listdatmeteo, times=times,
sigma2=sigma^2, Bounds=Boundstheta)
)
#>
#>
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> The Metropolis acceptance rate was 0.32467
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> utilisateur système écoulé
#> 1.326 0.008 1.336
# reput theta in the correct scale
resUN1 = unNormalise(res1, Boundstheta)
par(mfrow=c(1,3))
for (i in 1:ltheta)
{hist(resUN1[,i], main=paste0("theta[",i,"]"), xlab="", las=1)
abline(v=theta[i],col=2,lwd=4)}
In addition to checking the acceptance rate in the MCMC outputted above. Another chain can be run.
res1b = MCMCmetrop1R(exactlogpostMulti, theta.init=rep(.5,ltheta),
burnin=nburnin, mcmc=nMCMC, logfun=TRUE, V=V,
listlogy=listlogy, x=x, listdatmeteo=listdatmeteo, times=times,
sigma2=sigma^2, Bounds=Boundstheta,seed=1)
#>
#>
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> The Metropolis acceptance rate was 0.33917
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Then, the Brooks-Gelman-Rubin statistic is computed in order to check convergence (Brooks, S. P., and Gelman, A., 1998). The convergence of the MCMC algorithm is reached provided that the statistic reaches the neighborhood of 1.
S = ggs(as.mcmc.list(list(res1,res1b)))
ggs_grb(S)
We assume here that our computational budget is limited to a given number of runs of the FSPM (which is not the case in this vignette since the FSPM is a toy model…). In this situation, all the 6 steps described in Figure 1 of Blanc et al. can be run. These steps will be referred to in the following as Step \(n\) with \(n\) varying between \(1\) and \(6\).
A first exploratory design of numerical experiments is built over the domain of calibration parameters (Step 1).
# Exploratory design of experiments
nkrig = 15
# Design of experiments maximin LHS over the dimension of theta
D = lhsDesign(nkrig, ltheta)$design
Dopt = maximinSA_LHS(D, T0=10, c=0.99, it=2000)$design
# unnormalize
Dun = unNormalise(Dopt, Boundstheta)
Then, this design of numerical experiments is combined with the available input configurations and the true FSPM is run (Step 2):
## Running the FSPM only for nkrig runs
YDun = lapply(seasons, function(season)
{
datameteo = BuildMeteodat(season)
y = t(sapply(1:nrow(Dun), function(i) fbiomass(x,datameteo,Dun[i,])[times]))
y = log(y)
if (any(is.infinite(y))) print("0 value for y")
y[is.infinite(y)] = -10
y
})
For each experimental condition (here meteorological condition) and each output of interest (here given times of observation), a metamodel is fitted (Step 3).
## Fitting kriging metamodels for each time of observation and each meteorological conditions
# setting the nugget
fixedNugget = sigma^2/10
krig = lapply(YDun, function(y)
{
res=lapply(1:ncol(y), function(k){
m <- km(design=Dopt, response=y[,k],nugget = fixedNugget,control=list(trace=FALSE))
return(m)
})
res
}
)
In Step 3, the quality of the metamodels may be tested as below.
X = krig[[1]][[1]]@X
ResListCrossValidationAllmeteo = lapply(krig,function(krigm){
ResListCrossValidation = lapply(krigm,function(krigmt) {
Y = krigmt@y
resloo = sapply(1:nrow(X),function(i){
Xloo = X[-i,]
Yloo = Y[-i]
m <- km(design=Xloo, response=Yloo,nugget = fixedNugget,control=list(trace=FALSE))
new = (matrix(X[i,],nrow=1))
colnames(new)= colnames(X)
pred = predict(m,newdata=new,type="UK")
return(c(pred$mean,pred$sd,pred$mean-Y[i],(pred$mean-Y[i])/pred$sd))
})
resloo
})
ResListCrossValidation
})
dfCV = data.frame(meteo = rep(paste0("m",1:length(listdatmeteo)),each=nrow(X)*nobs),
time = rep(rep(1:nobs,each=nrow(X)),length(listdatmeteo)),
Error = numeric(nrow(X)*nobs*length(listdatmeteo)),
NormError = numeric(nrow(X)*nobs*length(listdatmeteo)))
cpt=0
for (i in 1:length(listdatmeteo))
{
for (j in 1:nobs)
{
dfCV[cpt+1:nrow(X),3:4] = t(ResListCrossValidationAllmeteo[[i]][[j]][3:4,])
cpt = cpt + nrow(X)
}
}
ggplot(dfCV,aes(x=time,y=Error,col=meteo)) +geom_point() +geom_jitter() + ggtitle("Leave-one-out errors")
ggplot(dfCV,aes(x=time,y=NormError,col=meteo)) +geom_point() +geom_jitter() + ggtitle("Leave-one-out normalized errors")
One may run the Bayesian calibration with the fitted metamodels (Step 5) without augmenting the design of numerical experiments. This is a valid strategy but the quality of the calibration may suffer from the discrepancies between the true FSPM and the metamodels. At this stage, no more calls to the FSPM are made. The following Bayesian calibration takes into account both the measurement error and the uncertainty related to the metamodel approximation.
system.time(
res2 <- MCMCmetrop1R(approxlogpostMulti, theta.init=rep(.5, ltheta),
burnin=nburnin, mcmc=nMCMC, logfun=TRUE, V=V,
listlogy=listlogy, krig=krig, sigma2=sigma^2)
)
#>
#>
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> The Metropolis acceptance rate was 0.48950
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> utilisateur système écoulé
#> 64.777 0.000 64.778
resUN2 = unNormalise(res2, Boundstheta)
par(mfrow=c(1,3))
for (i in 1:ltheta)
{hist(resUN2[,i], main=paste0("theta[",i,"]"), xlab="", las=1)
abline(v=theta[i],col=2,lwd=4)}
In this section, we use Step 4 where we aim to enhance the Kriging metamodels with few more calls to the FSPM.
The code below iterates nEI
times the loop between Steps
4, 2 and 3.
nEI = 5
system.time(
updatedKrig <- runEGO(krig, listlogy, sigma^2, x, seasons, Boundstheta,
times, nEI=nEI, npoints=npointsEGO, nsim=nsimEGO)
)
#> $thetanew
#> [1] 0.6222867 0.6206012 0.4104828
#>
#> $critEI
#> [1] 4.586477
#>
#> [1] 9.035403
#> $thetanew
#> [1] 0.6134735 0.5735964 0.3843848
#>
#> $critEI
#> [1] 6.117854
#>
#> [1] 2.838142
#> $thetanew
#> [1] 0.6613330 0.6542889 0.3852466
#>
#> $critEI
#> [1] 1.296589
#>
#> [1] 1.503335
#> $thetanew
#> [1] 0.6417581 0.6261051 0.4325599
#>
#> $critEI
#> [1] 0.7627752
#>
#> [1] 0.7639365
#> $thetanew
#> [1] 0.6298471 0.5868092 0.4095330
#>
#> $critEI
#> [1] 0.2395619
#>
#> [1] 0.5237504
#> utilisateur système écoulé
#> 683.388 12.342 70.982
We can plot the new points:
upkrig = updatedKrig$krig
thetaNN = Normalise(theta, Boundstheta)
X = upkrig[[1]][[1]]@X
plot(X[,1:2],col=c(rep(1,nrow(X)-nEI),rep(2,nEI)))
points(x=thetaNN[1],y=thetaNN[2],col=3,pch=20)
plot(X[,c(1,3)],col=c(rep(1,nrow(X)-nEI),rep(2,nEI)))
points(x=thetaNN[1],y=thetaNN[3],col=3,pch=20)
Then we can redo the Bayesian calibration with these updated metamodels (Step5):
system.time(
res3 <- MCMCmetrop1R(approxlogpostMulti, theta.init=rep(.5, ltheta),
burnin=nburnin, mcmc=nMCMC, logfun=TRUE, V=V,
listlogy=listlogy, krig=upkrig, sigma2=sigma^2)
)
#>
#>
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> The Metropolis acceptance rate was 0.32483
#> @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
#> utilisateur système écoulé
#> 62.453 0.000 62.457
resUN3 = unNormalise(res3, Boundstheta)
par(mfrow=c(1,3))
for (i in 1:ltheta)
{hist(resUN3[,i], main=paste0("theta[",i,"]"), xlab="", las=1)
abline(v=theta[i],col=2,lwd=4)}
We group the plots of the posterior distributions in order to compare the three calibrations.
lims = matrix(NA, ltheta, 2)
lims[,1] = apply(resUN2, 2, min) - .5
lims[,2] = apply(resUN2, 2, max) + .5
resUN1df = as.data.frame(resUN1)
names(resUN1df) = paste0("theta",1:3)
title <- "True FSPM"
p1 = ggplot(resUN1df,aes(x=theta1))+geom_histogram()+theme_bw() +
xlim(lims[1,])+ geom_vline(xintercept=theta[1],color=2,size=2) +
labs(title=title)
#> Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
#> ℹ Please use `linewidth` instead.
#> This warning is displayed once every 8 hours.
#> Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
#> generated.
p2 = ggplot(resUN1df,aes(x=theta2))+geom_histogram()+theme_bw() +
xlim(lims[2,])+ geom_vline(xintercept=theta[2],color=2,size=2) +
labs(title=title)
p3 = ggplot(resUN1df,aes(x=theta3))+geom_histogram()+theme_bw() +
xlim(lims[3,])+ geom_vline(xintercept=theta[3],color=2,size=2) +
labs(title=title)
resUN2df = as.data.frame(resUN2)
names(resUN2df) = paste0("theta",1:3)
title <- "Kriging metamodel"
p4 = ggplot(resUN2df,aes(x=theta1))+geom_histogram()+theme_bw() +
xlim(lims[1,])+ geom_vline(xintercept=theta[1],color=2,size=2) +
labs(title=title)
p5 = ggplot(resUN2df,aes(x=theta2))+geom_histogram()+theme_bw() +
xlim(lims[2,])+ geom_vline(xintercept=theta[2],color=2,size=2) +
labs(title=title)
p6 = ggplot(resUN2df,aes(x=theta3))+geom_histogram()+theme_bw() +
xlim(lims[3,])+ geom_vline(xintercept=theta[3],color=2,size=2) +
labs(title=title)
resUN3df = as.data.frame(resUN3)
names(resUN3df) = paste0("theta",1:3)
title <- "EGO-enhanced metamodel"
p7 = ggplot(resUN3df,aes(x=theta1))+geom_histogram()+theme_bw() +
xlim(lims[1,])+ geom_vline(xintercept=theta[1],color=2,size=2) +
labs(title=title)
p8 = ggplot(resUN3df,aes(x=theta2))+geom_histogram()+theme_bw() +
xlim(lims[2,])+ geom_vline(xintercept=theta[2],color=2,size=2) +
labs(title=title)
p9 = ggplot(resUN3df,aes(x=theta3))+geom_histogram()+theme_bw() +
xlim(lims[3,])+ geom_vline(xintercept=theta[3],color=2,size=2) +
labs(title=title)
# enforce the same y-axes
A = ggplot_build(p1)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
B = ggplot_build(p4)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
C = ggplot_build(p7)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
ymax = max(A$layout$panel_scales_y[[1]]$range$range[2],B$layout$panel_scales_y[[1]]$range$range[2],C$layout$panel_scales_y[[1]]$range$range[2])
p1 = p1 + ylim(c(0,ymax))
p4 = p4 + ylim(c(0,ymax))
p7 = p7 + ylim(c(0,ymax))
A = ggplot_build(p2)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
B = ggplot_build(p5)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
C = ggplot_build(p8)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 18 rows containing non-finite values (`stat_bin()`).
ymax = max(A$layout$panel_scales_y[[1]]$range$range[2],B$layout$panel_scales_y[[1]]$range$range[2],C$layout$panel_scales_y[[1]]$range$range[2])
p2 = p2 + ylim(c(0,ymax))
p5 = p5 + ylim(c(0,ymax))
p8 = p8 + ylim(c(0,ymax))
A = ggplot_build(p3)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
B = ggplot_build(p6)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
C = ggplot_build(p9)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
ymax = max(A$layout$panel_scales_y[[1]]$range$range[2],B$layout$panel_scales_y[[1]]$range$range[2],C$layout$panel_scales_y[[1]]$range$range[2])
p3 = p3 + ylim(c(0,ymax))
p6 = p6 + ylim(c(0,ymax))
p9 = p9 + ylim(c(0,ymax))
plot_grid(p1,p2,p3,p4,p5,p6,p7,p8,p9,nrow=3,ncol=3)
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 18 rows containing non-finite values (`stat_bin()`).
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
#> `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
#> Warning: Removed 2 rows containing missing values (`geom_bar()`).
Step 6 can be impleted on new data in order to check the accuracy of the calibrated FSPM. It may be either the true FSPM (in the case it is fast) or the calibrated FSPM that is approximated by metamodels. We then predict the biomass for a dataset that was not used as field data in the calibration procedure. We will not consider observational variance on the following plots.
# true biomass
season = "2011-2012"
datameteo1112 = BuildMeteodat(season)
ybiom1112 = fbiomass(x,datameteo1112,theta)
Predbiomass = predictExact(x, datameteo1112, res1, Boundstheta)
meanBiom = apply(Predbiomass, 2, mean)
q5 = apply(Predbiomass,2,quantile,.05) ; q95 = apply(Predbiomass,2,quantile,.95)
preddf = data.frame(meanBiomass = meanBiom,
cumdegree = datameteo1112$cumdegree,
quantile05 = q5, quantile95 = q95)
ggplot(preddf,aes(x=cumdegree,y=meanBiom)) +
labs(x="cumulative growing degree-days", y="biomass (in g)") +
geom_line() + ylim(c(0,10)) + theme_bw() +
geom_ribbon(aes(ymin=quantile05, ymax=quantile95), alpha=.2)
# Kriging for the season
y = t(sapply(1:nrow(Dun), function(i) fbiomass(x,datameteo1112,Dun[i,])[times]))
y = log(y)
krig1112=lapply(1:ncol(y), function(k){
m <- km(design=Dopt, response=y[,k], nugget=fixedNugget,
control=list(trace=FALSE))
return(m)
})
# posterior predictions
PredA = predictApprox(krig1112,res2)
meanPred = predictmultdim(apply(res2,2,mean),krig1112)
Simus = sapply(1:ncol(PredA$Mpred),function(k){
Sim = PredA$Mpred[,k] + rnorm(1000,0,PredA$Spred[,k])})
q5 = apply(Simus,2,quantile,.05) ; q95 = apply(Simus,2,quantile,.95)
predKdf = data.frame(meanBiom = exp(meanPred[1,]),
cumdegree = datameteo1112$cumdegree[times],
quantile05 = exp(q5), quantile95 = exp(q95))
ggplot(predKdf, aes(cumdegree, meanBiom)) +
labs(x="cumulative growing degree-days", y="biomass (in g)") +
geom_point() + geom_line() + ylim(c(0,10)) +
geom_ribbon(aes(ymin=quantile05, ymax=quantile95), alpha=.2) +
geom_errorbar(aes(ymin = exp(meanPred[1,] - 1.64*meanPred[2,]),
ymax = exp(meanPred[1,] + 1.64*meanPred[2,]))) +
geom_line(data=preddf, aes(x=cumdegree,y=meanBiom), color="blue") +
theme_bw()