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

1 Simulation of data

1.1 Toy model

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.

1.2 Configuration and settings

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

1.3 Simulation

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

2 First calibration on the true FSPM

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)

3 Second calibration of the FSPM via a kriging metamodel

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

3.1 Building the kriging metamodel

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

3.2 Checking the quality of the metamodels

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

3.3 Running the calibration on the kriging metamodel

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

4 Third calibration using the EGO

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

5 Comparison of the three calibrations

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

6 Prediction for other data

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)

6.1 With the true FSPM

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)

6.2 Using kriging

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