├── .gitignore ├── LICENSE ├── PMCMC-tutorial.Rproj ├── R ├── ReedFrost.R └── Volatility_SIS.R ├── README.md ├── assets ├── andre_estimates_21_02.txt └── references.bib ├── dureauLibbi.Rmd ├── dureauLibbi.html ├── pmcmcTutorial.Rmd ├── pmcmcTutorial.html ├── rwmodel.Rmd └── rwmodel.html /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 akira-endo 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /PMCMC-tutorial.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /R/ReedFrost.R: -------------------------------------------------------------------------------- 1 | #' A function to simulate epidemics using the Reed-Frost model 2 | #' 3 | #' This function allows you to simulate epidemics. 4 | #' @param Nsim. 5 | #' @keywords Reed-Frost 6 | #' @export 7 | #' @examples 8 | #' simulateReedFrost() 9 | 10 | simulateReedFrost <- function(Nsim=100000, Npop=10000, p=0.00015, I0=1, Nit=50, fig=T) 11 | { 12 | S0=Npop-I0 13 | I=t(matrix(rep(c(I0,rep(0,Nit-1)),Nsim),ncol = Nsim)) 14 | S=t(matrix(rep(c(S0,rep(0,Nit-1)),Nsim),ncol = Nsim)) 15 | for(t in 2:Nit) 16 | { 17 | I[,t]=rbinom(Nsim,size=S[,t-1],1-(1-p)^I[,t-1]) 18 | S[,t]=S[,t-1]-I[,t] 19 | } 20 | 21 | if(fig) 22 | hist(apply(I,1,max),breaks = 100, freq = T) 23 | 24 | return(list(S=S,I=I)) 25 | } 26 | 27 | RF_with_obs<-function(Npop=10000, p=0.00015, Np = 1, p_obs = 0.05, size = 2) 28 | { 29 | initial_pop= Npop -rpois(n= Np, lambda = 5)#Npop-rpois(n = 1, lambda = 20) 30 | initial_I=Npop- initial_pop #rpois(n=1, lambda = 5) 31 | simu_epi=simulateReedFrost(Nsim=1,Npop=initial_pop, p=p, I0=initial_I, fig=F) 32 | X<-cbind(simu_epi$S[1,],simu_epi$I[1,]) #the "hidden" Markov chain 33 | Y<-rnbinom(n=length(X[,1]),mu=p_obs*X[,2], size=size) #the observered process 34 | 35 | return(list(X=X,Y=Y)) 36 | } 37 | 38 | RF_SIR <- function(Y, Np=1000, Npop=10000, p=0.00015, p_obs = 0.05, size = 2) 39 | { 40 | N=length(Y) 41 | 42 | #Sequential important sampling 43 | Xp<-array(rep(0,2*N*Np),dim=c(Np,N,2)) #particles 44 | gammap<-matrix(rep(0,N*Np),ncol=N) #partial likelihood 45 | wp<-matrix(rep(0,N*Np),ncol=N) #unormalised importance weights 46 | Wp<-matrix(rep(0,N*Np),ncol=N) #normalised importance weights 47 | #Xrp<-matrix(rep(0,N*Np),ncol=N) #resampled particles 48 | A<-matrix(rep(0,N*Np),ncol=N) #Ancestry of particle 49 | 50 | #Initialisation of the algorithm 51 | Xp[,1,1]<-Npop -rpois(n= Np, lambda = 5)#-rpois(n = Np, lambda = 20) #initialisation of the size of susceptible population for each particle 52 | Xp[,1,2]<-Npop- Xp[,1,1] # rpois(n= Np, lambda = 5) #initialisation of the size of the infectious population for each particle 53 | gammap[,1]<-dpois(Npop-Xp[,1,1], lambda = 20)*dpois(Xp[,1,2],lambda=5)*dnbinom(Y[1],mu=p_obs*Xp[,1,2],size=size) 54 | 55 | wp[,1]<-gammap[,1]/(dpois(Npop-Xp[,1,1], lambda = 20)*dpois(Xp[,1,2],lambda=5)) 56 | Wp[,1]<-wp[,1]/sum(wp[,1]) 57 | 58 | #Sequential calculation of particles and importance weights 59 | for(i in 2:N) 60 | { 61 | #Resampling step -using systematic resampling 62 | U1<-runif(1,min = 0,max = 1/Np) 63 | cumWj<-0 64 | lU<-U1 65 | index<-1 66 | for(j in 1:Np) 67 | { 68 | cumWjminus<-cumWj 69 | cumWj<-cumWj+Wp[j,i-1] 70 | if(lU% 70 | rowSums() 71 | y <- data.frame(value = v) %>% 72 | mutate(time = seq(7, by = 7, length.out = n())) %>% 73 | dplyr::select(time, value) 74 | ncores <- 8 75 | minParticles <- max(ncores, 16) 76 | ``` 77 | 78 | ```{r model, echo = T} 79 | model_str <- " 80 | model dureau { 81 | obs y 82 | 83 | state S 84 | state E 85 | state I 86 | state R 87 | state x 88 | 89 | state Z 90 | 91 | input N 92 | param k 93 | param gamma 94 | param sigma // Noise driver 95 | param E0 96 | param I0 97 | param R0 98 | param x0 99 | param tau 100 | 101 | sub parameter { 102 | k ~ truncated_gaussian(1.59, 0.02, lower = 0) // k is the period here, not the rate, i.e. 1/k is the rate 103 | gamma ~ truncated_gaussian(1.08, 0.075, lower = 0) // gamma is the period, not the rate 104 | sigma ~ uniform(0,1) 105 | x0 ~ uniform(-5,2) 106 | I0 ~ uniform(-16, -9) 107 | E0 ~ uniform(-16, -9) 108 | R0 ~ truncated_gaussian(0.15, 0.15, lower = 0, upper = 1) 109 | tau ~ uniform(0, 1) 110 | } 111 | 112 | sub initial { 113 | S <- N 114 | R <- R0*S 115 | S <- S - R 116 | 117 | E <- exp(E0 + log(S)) 118 | S <- S - E 119 | I <- exp(I0 + log(S)) 120 | S <- S - I 121 | x <- x0 122 | Z <- 0 123 | } 124 | 125 | sub transition(delta = 1) { 126 | Z <- ((t_now) % 7 == 0 ? 0 : Z) 127 | noise e 128 | e ~ wiener() 129 | ode(alg = 'RK4(3)', h = 1.0, atoler = 1.0e-3, rtoler = 1.0e-8) { 130 | dx/dt = sigma*e 131 | dS/dt = -exp(x)*S*I/N 132 | dE/dt = exp(x)*S*I/N - E/k 133 | dI/dt = E/k-I/gamma 134 | dR/dt = I/gamma 135 | dZ/dt = E/k 136 | } 137 | } 138 | 139 | sub observation { 140 | y ~ log_normal(log(max(Z/10.0, 0)), tau) 141 | } 142 | 143 | sub proposal_parameter { 144 | k ~ gaussian(k, 0.005) 145 | sigma ~ gaussian(sigma, 0.01) 146 | gamma ~ gaussian(gamma, 0.01) 147 | x0 ~ gaussian(x0, 0.05) 148 | E0 ~ gaussian(E0, 0.05) 149 | I0 ~ gaussian(I0, 0.05) 150 | R0 ~ gaussian(R0, 0.05) 151 | tau ~ gaussian(tau, 0.05) 152 | } 153 | }" 154 | ``` 155 | 156 | # Results 157 | 158 | Run the inference (note this can take some time): 159 | 160 | ```{r, echo = T} 161 | model <- bi_model(lines = stringi::stri_split_lines(model_str)[[1]]) 162 | bi_model <- libbi(model) 163 | input_lst <- list(N = 52196381) 164 | end_time <- max(y$time) 165 | obs_lst <- list(y = y %>% dplyr::filter(time <= end_time)) 166 | 167 | bi <- sample(bi_model, end_time = end_time, input = input_lst, obs = obs_lst, nsamples = 1000, nparticles = minParticles, nthreads = ncores, proposal = 'prior') %>% 168 | adapt_particles(min = minParticles, max = minParticles*200) %>% 169 | adapt_proposal(min = 0.05, max = 0.4) %>% 170 | sample(nsamples = 5000, thin = 5) %>% # burn in 171 | sample(nsamples = 5000, thin = 5) 172 | 173 | bi_lst <- bi_read(bi %>% sample_obs) 174 | ``` 175 | 176 | ```{r figDatafit, dependson = c("load_results"), fig.cap="Model inference results. Top panel shows the GP consultation results, with the points showing the actual data points. The ribbons represent the 95%% and 50%% confidence interval in incidence and the black line shows the median. The middle panel shows the transmissibiltiy over time and the bottom panel the change in transmissibility relative to the starting transmissibility.", echo = F, fig.height = 8} 177 | fitY <- bi_lst$y %>% 178 | group_by(time) %>% 179 | mutate( 180 | q025 = quantile(value, 0.025), 181 | q25 = quantile(value, 0.25), 182 | q50 = quantile(value, 0.5), 183 | q75 = quantile(value, 0.75), 184 | q975 = quantile(value, 0.975) 185 | ) %>% ungroup() %>% 186 | left_join(y %>% rename(Y = value)) 187 | 188 | g1 <- ggplot(data = fitY) + 189 | geom_ribbon(aes(x = time, ymin = q25, ymax = q75), alpha = 0.3) + 190 | geom_ribbon(aes(x = time, ymin = q025, ymax = q975), alpha = 0.3) + 191 | geom_line(aes(x = time, y = q50)) + 192 | geom_point(aes(x = time, y = Y), colour = "Red") + 193 | ylab("Incidence") + 194 | xlab("Time") 195 | 196 | plot_df <- bi_lst$x %>% mutate(value = exp(value)) %>% 197 | group_by(time) %>% 198 | mutate( 199 | q025 = quantile(value, 0.025), 200 | q25 = quantile(value, 0.25), 201 | q50 = quantile(value, 0.5), 202 | q75 = quantile(value, 0.75), 203 | q975 = quantile(value, 0.975) 204 | ) %>% ungroup() 205 | 206 | g2 <- ggplot(data = plot_df) + 207 | geom_ribbon(aes(x = time, ymin = q25, ymax = q75), alpha = 0.3) + 208 | geom_ribbon(aes(x = time, ymin = q025, ymax = q975), alpha = 0.3) + 209 | geom_line(aes(x = time, y = q50)) + 210 | ylab(TeX("Transmissibility ($\\beta(t)$)")) + 211 | xlab("Time") 212 | 213 | plot_df <- bi_lst$x %>% mutate(value = exp(value)) %>% 214 | group_by(np) %>% mutate(value = value - value[1]) %>% 215 | group_by(time) %>% 216 | mutate( 217 | q025 = quantile(value, 0.025), 218 | q25 = quantile(value, 0.25), 219 | q50 = quantile(value, 0.5), 220 | q75 = quantile(value, 0.75), 221 | q975 = quantile(value, 0.975) 222 | ) %>% ungroup() 223 | 224 | g3 <- ggplot(data = plot_df) + 225 | geom_ribbon(aes(x = time, ymin = q25, ymax = q75), alpha = 0.3) + 226 | geom_ribbon(aes(x = time, ymin = q025, ymax = q975), alpha = 0.3) + 227 | geom_line(aes(x = time, y = q50)) + 228 | ylab(TeX("Relative trans. ($\\beta(t)-\\beta(0)$)")) + 229 | xlab("Time") 230 | 231 | 232 | ggarrange(g1, g2, g3, ncol = 1, nrow = 3, align = "v") 233 | ``` 234 | 235 | Figure \@ref(fig:figDatafit) shows the results of the data fitting. The top panel shows the incidence data (red dots), with the two distinct epidemiological waves and the model predict. As shown the model is able to reproduce both waves. The middle panel shows transmissibility over time, with an apparent dip between day 50 and 100. This dip can be confirmed by comparing the transmissibility to the transmissibility at time 0 (bottom panel), which shows that between day 50 and 100 the transmissibility is below the starting transmissibility in all cases. The dip in transmissibility coincides with the time period that the first epidemiological wave started to slow down. 236 | 237 | # References 238 | -------------------------------------------------------------------------------- /pmcmcTutorial.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "A PMCMC Tutorial for infectious disease modellers" 3 | author: "Marc Baguelin" 4 | output: 5 | html_document: default 6 | html_notebook: default 7 | pdf_document: 8 | toc: yes 9 | always_allow_html: yes 10 | --- 11 | 12 | ```{r} 13 | #Files with the code of the functions used in the tutorial 14 | source(file = "R/Volatility_SIS.R") 15 | source(file = "R/ReedFrost.R") 16 | ``` 17 | 18 | #Introduction 19 | This is a tutorial on PMCMC with a special attention to transmission disease modellers. 20 | 21 | This tutorial will guide you through the basic concepts necessary to understand particle Markov chain Monte Carlo (PMCMC) and will let you build an algorithm to perform pMcMC on the Reed-Frost model, one of the simplest of the stochastic epidemic models. 22 | 23 | This tutorial has been built by taking material from different references 24 | Andrieu et al. 25 | Chopin & Papaspiliopoulos 26 | Robert & Casela 27 | 28 | #Background concepts 29 | 30 | pMcMC is built out of several key concepts from statistics. One of the problems for mathematical modellers to get into Particle MCMC, is in my opinion, that we might not be familiar with some of these (elementary) statistical concepts. It is important to understand well each of these elementary concepts. 31 | 32 | Another difficulty arises as many of these key concepts have connectiongs in different disciplines and sometimes have been developed concurrently under different names. 33 | 34 | ```{r, echo=F} 35 | DiagrammeR::grViz(" 36 | digraph rmarkdown{ 37 | 'Monte Carlo' -> 'Importance Sampling' -> 'Sequential IS' -> 'SMC'; 38 | 'Monte Carlo' -> 'MCMC'; 39 | {'MCMC' 'SMC'} -> 'Particle MCMC' 40 | }", height=300) 41 | ``` 42 | 43 | ##Monte Carlo approximation 44 | 45 | Monte Carlo methods have originated in the 1940's during the effort by allied physicist to develop a nuclear bomb in Los Alamos. One of most common problem in statistical inference is to compute integrals. Monte Carlo is a numerical method which allows to calculate easily (or at least relatively easily compared with other methods) integrals. The method use the definition of expectation as an integral over a probability measure. 46 | $$\mathbb{E}_{f} [h(X) ] = \int_{\mathcal{X}} h(x)f(x)dx$$ 47 | 48 | $$\frac{1}{N} \sum \limits^{N}_{n=1}h(X^{n}), \space X^{n} \sim f,$$ 49 | 50 | ##Bayesian inference 51 | 52 | Very often, we want to relate a model of a phenomenon with some observations of this phenomenon. Most of the time the model is defined as equations describing the mechanisms of the phenomenon (mechanistic model). We thus usually have and idea on . The fundamental idea behind Bayesian inference is to use Bayes' theorem to derive the probability of 53 | 54 | ##Importance sampling 55 | 56 | The idea behind importance sampling is simple. Monte Carlo approximation relies on the ability to draw from a certain distribution (q). In many cases, this might be complicated or inefficient. The idea is to sample from a simpler distribution and then calculate "weights" associated with these samples in order be able to derive a Monte Carlo approximation with these samples. 57 | 58 | ###Basic algorithm 59 | 60 | Importance sampling is based on the simple identity 61 | $$\mathbb{E}_{f} [h(X) ] = \int_{\mathcal{X}} h(x)\frac{f(x)}{g(x)}g(x)dx=\mathbb{E}_{g}\left [\frac{h(X)f(X)}{g(X)} \right ].$$ 62 | And thus $\mathbb{E}_{f} [h(X) ]$ can be estimated as 63 | $$\frac{1}{n} \sum\limits_{j=1}^{n}\frac{f(X_{j})}{g(X_{j})}h(X_j)\rightarrow\mathbb{E}_{f} [h(X) ]$$ 64 | with $X_{j}$ drawn from $g$. $g$ can be chosen arbitrary as soon as supp($g$) $\supset$ supp($h \times f$) with supp$(f)=\{x \in X | f(x) \neq 0 \}$ for $f: X \rightarrow \mathbb{R}$. 65 | 66 | ###Example. Estimating the tail of a normal distribution 67 | 68 | Let's assume that we are interested in computing $P(Z>4.5)$ for $Z \sim \mathcal{N}(0,1)$ 69 | 70 | ```{r} 71 | pnorm(-4.5) 72 | ``` 73 | 74 | So to compute $P(Z>4.5)$ using a naive Monte Carlo estimate is very unefficient as a hit is produced on average every 3 millions or so draws. To get a stable estimate we would need a huge number of simulations. 75 | Using importance sampling, we can chose another distribution, valued on $[ 4.5 , +\infty[$ to calculate $P(Z>4.5)$. A natural choice is 76 | $$g(y)=\frac{e^{-y}}{\int_{4.5}^{\infty}e^{-x}dx }=e^{-(y-4.5)}$$ 77 | which leads to the following importance sampling estimator 78 | $$\frac{1}{n} \sum\limits_{i=1}^{n} \frac{f(Y^i)}{g(Y^i)}=\frac{1}{n}\sum\limits_{i=1}^{n} \frac{e^{-Y^2/2+Y_i-4.5}}{\sqrt{2 \pi}}$$ 79 | 80 | ```{r} 81 | #Number of Monte Carlo samples 82 | Nsim=10^3 83 | 84 | #Draw samples from the truncated exponential 85 | y=rexp(Nsim)+4.5 86 | 87 | #Calculation of the importance weights 88 | weit=dnorm(y)/dexp(y-4.5) 89 | 90 | #Plot the the Monte-Carlo estimator and in red the true value 91 | plot(cumsum(weit)/1:Nsim,type="l") 92 | abline(a=pnorm(-4.5),b=0,col="red") 93 | ``` 94 | 95 | ###Importance sampling resampling 96 | 97 | ##State space models 98 | 99 | ###Example 1. Volatility model 100 | 101 | $$\begin{array}{rcl} 102 | X_{n} & = & \alpha X_{n-1} + \sigma V_{n}\\ 103 | Y_{n} & = & \beta \exp \left ( \frac{X_{n}}{2}\right) W_{n} 104 | \end{array}$$ 105 | 106 | ```{r} 107 | simu<-SV_simulate(N=500,alpha=0.91,sigma=1,beta=0.5) #changed .5 for orginal 0.91 108 | 109 | plot(simu$X,type="l",col="blue",ylim=c(-10,10),xlab="Time") 110 | points(simu$Y,pch="*",col="red") 111 | 112 | ``` 113 | 114 | ###Example 2. Reed-Frost model with Negative Binomial observation 115 | 116 | The Reed-Frost model is a dicrete-time stochastic model, with each time step representing a new generation of infectious agents. During the period of time between two timesteps, each of the susceptible individuals has a probability $p$ of getting infected by any infectious individual. The probability of escaping infection from all the infectious individuals is $(1-p)^{I_{n-1}}$ and thus the number of infectious individuals at the next time step (i.e. the ones who did not escape infection) can be drawn from a binomial distribution with probability $1-(1-p)^{I_{n-1}}$. On top of this we assume that we can only detect a fraction of the cases. 117 | 118 | $$\begin{array}{rcl} 119 | I_{n} & \sim & Bin \left (S_{n-1}, 1-(1-p)^{I_{n-1}} \right )\\ 120 | S_{n} & = & S_{n-1} - I_{n} 121 | \end{array}$$ 122 | 123 | The Reed-Frost model can be made into a state space model by using $(S_{n},I_{n})$ as the state space and writing an observation function. For example if we assume, that on average only a proportion $p_{obs}$ of the infected individuals are observed and that the observed cases are distributed following a neg-binomial of size $s$. 124 | 125 | $$\begin{array}{rcl} 126 | X_{n}&=&(S_{n},I_{n})\\ 127 | Y_{n} &\sim& NegBin(\mu=p_{obs}*I_{n}, size=s) 128 | \end{array}$$ 129 | 130 | ```{r} 131 | #Simulate a Reed-Frost model with negative binomial observation 132 | simuRF<-RF_with_obs() 133 | 134 | #Plot of the observation 135 | plot(simuRF$Y, pch=18, col="red", xlab="Number of generations", ylab="Number of cases") 136 | 137 | #Blue line representing the actual underlying epidemics scaled by the proportion detected 138 | lines(simuRF$X[,2]*.05,col="#0000ff77", lwd=4) 139 | ``` 140 | 141 | ##Filtering and inference 142 | 143 | When confronting a SSM with data, two common problems pop up. We might want to know what is the actual hidden trajectory of the system, this is particularly important in situations where you want to do some sort of control/reactive intervention. This type of question is called "Filtering" i.e. recovering the actual state of the system through the noise and distortion created by the observation process. The filtering problem assumes that the parameter $\theta$ of the models are fully known, all the uncertainty in the status coming from the stochasticity of the processes and the noise 144 | 145 | $$p_{\theta}(X_{1:T}|Y_{1:T})$$ 146 | 147 | Another problem is to estimate which likely parameter distribution given the observation. In the case of SSM, it means infer jointly 148 | 149 | $$p(\theta,x_{1:T}|Y_{1:T}) \propto p_{\theta}(X_{1:T},Y_{1:T})p(\theta)$$ 150 | 151 | #Sequential Monte Carlo 152 | 153 | Sequential Monte Carlo (SMC) is a methodology which trying to exploit the sequential time structure of the model to calculate efficiently some quantities. In particular it is particularly useful to infer the hidden states of the model (filtering) but also to calculate the overall (i.e. marginalising over the possible hidden states) probability of the model to generate the data (the marginal likelihood). This is this property which allows to integrate SMC with other algorithms from computational statistics (such as MCMC) to perform jointly inference of hidden states and model parameters. 154 | 155 | ##Sequential importance sampling 156 | 157 | 158 | 159 | ##Sequential sampling resampling 160 | 161 | ###Example 1 Volatility 162 | 163 | ```{r} 164 | #Plot the hidden state of the trajectory 165 | plot(simu$X,type="l",col="blue") 166 | 167 | #Run the particle filter 168 | filterParticles<-SV_SIR(simu$Y) 169 | 170 | #Calculate the mean path at each time point 171 | mu_Xp<-computeMeanPath(filterParticles) 172 | 173 | #Plot the filtered hidden states 174 | points(mu_Xp,pch=19,col="#00aa0066") 175 | ``` 176 | 177 | ###Example 2 Reed-Frost epidemic model 178 | 179 | 180 | 181 | ```{r} 182 | #SMC on the observed epidemic 183 | filter_particlesRF <- RF_SIR(simuRF$Y) 184 | summary_PF_RF <- computeMeanPathRF(filter_particlesRF) 185 | plot(NULL,xlim=c(0,50),ylim=c(0,max(summary_PF_RF$mu_Xp[,3],simuRF$Y/0.05)) ,col="white",xlab="Time",ylab="Number of cases") 186 | 187 | #95% confidence interval 188 | polygon(c(1:50,50:1),c(summary_PF_RF$mu_Xp[,2],summary_PF_RF$mu_Xp[50:1,3]),col="#00bb0033",border=NA) 189 | 190 | #Hidden Markov model 191 | lines(simuRF$X[,2],col="blue",lwd=2) 192 | 193 | #Mean of particles 194 | lines(summary_PF_RF$mu_Xp[,1],col="#00bb0066",lwd=2) 195 | 196 | #Observations 197 | points(simuRF$Y/0.05, pch=18, col="red") 198 | legend("topright", legend = c("Scaled observations","95% CI of particles","Mean particles","Hidden states"), bty="n", col=c("red","#00bb0033","#00bb0066","blue"), pch=c(18,15,NA,NA), pt.cex=c(1,2,1,1),lty=c(0,0,1,1), lwd=2) 199 | 200 | ``` 201 | 202 | We will use in this last section the Particle marginal Metropolis–Hastings sampler from Andrieu et al. 203 | 204 | ```{r} 205 | Na<-50 206 | Np<-5000 207 | p_estimate <- seq(from=0.00014,to=0.00017,length.out = Na) 208 | marginal_likelihood <- rep(0,Na) 209 | 210 | for(i in 1:Na) 211 | { 212 | filterParticles<-RF_SIR(simuRF$Y, Np=Np, p=p_estimate[i]) 213 | 214 | marginal_likelihood[i]<-prod(colSums(filterParticles$wp)/Np) 215 | } 216 | 217 | plot(p_estimate, log(marginal_likelihood), xlab="probability of transmission", ylab="Marginal log-likelihood") 218 | abline(v=0.00015, col="red") 219 | ``` 220 | 221 | #Particle MCMC 222 | 223 | ```{r} 224 | #Run a particle Marginal Metropolis Hastings algorithm 225 | inference_results<-RF_PMMH(simuRF$Y, PBar=F, p0=0.0001) 226 | ``` 227 | 228 | 229 | ```{r} 230 | plot(inference_results$p, ylim=c(0,0.00020), ylab = "Probability of transmission") 231 | abline(h=0.00015,col="red") 232 | ``` 233 | 234 | 235 | -------------------------------------------------------------------------------- /rwmodel.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Random-walk model" 3 | author: "Akira Endo" 4 | date: "12 December 2018" 5 | output: 6 | html_document: default 7 | pdf_document: default 8 | --- 9 | 10 | ```{r setup, include=FALSE} 11 | knitr::opts_chunk$set(echo = TRUE) 12 | ``` 13 | 14 | ## Random-walk model 15 | This is a simple toy model (random-walk model) used as an example to in the main text. We assume that \(x_t\) evolves following a simple Gaussian kernel \(x_t\sim \mathcal N(x_{t-1},\sigma)\) with an initial state \(x_1=0\). The data is assumed to be obtained as a rounded integer with a Gaussian measurement error \(y_t=round(\mathcal N(x_{t-1},0.1))\). Consider that a five-step observation (\(T=5\)) with \(\sigma=0.5\) yielded \(y_{1:5}=(0,1,1,1,2)\). Without any observations, the possible trajectories of \(x_{1:5}\) are very diverse (Figure 1, Left panel). Trajectories \(x_{1:5}\) consistent with the observation are only a fractions of those (Figure 1, Right panel), and they need to be efficiently sampled to compute the marginal likelihood \(p(y_{1:T}|\sigma)\). 16 | 17 | ```{r prep} 18 | ## Preparation 19 | yt<-c(0,1,1,1,2) #observed data 20 | 21 | set.seed(122018) 22 | 23 | #SMC by the bootstrap filter 24 | BF_sim<-function(yt,sig,merror,size){ 25 | tlen<-length(yt) 26 | xt<-matrix(0,tlen,size) 27 | xt_prop<-matrix(0,tlen,size) 28 | avg_wt<-numeric(tlen) 29 | avg_wt[1]=1 30 | for(t in 2:tlen){ 31 | xt_prop[t,]<-rnorm(size,xt[t-1,],sig) #proposal particles 32 | weights=pnorm(yt[t]+0.5,xt_prop[t,],merror)-pnorm(yt[t]-0.5,xt_prop[t,],merror) #weighted by p(yt|xt_prop) 33 | avg_wt[t]=sum(weights)/size 34 | if(sum(weights)==0)weights=weights+1 #marginal likelihood 0: avoid error in sample() below due to weights=0 35 | ind<-sample(size,size,replace=T,prob=weights) #resample 36 | xt[1:t,]=rbind(xt[1:(t-1),ind],xt_prop[t,ind]) 37 | 38 | } 39 | return(list(xt=xt,xt_prop=xt_prop,avg_wt=avg_wt)) 40 | } 41 | 42 | sig=0.5 43 | merror=0.1 44 | xt_prior<-apply(rbind(0,matrix(rnorm(10000,0,sig),4)),2,cumsum) #prior samples of xt 45 | xt_BF<-BF_sim(yt,sig,merror,10000) 46 | xt_posterior<-xt_BF$xt#posterior samples of x_t 47 | xt_prop<-xt_BF$xt_prop 48 | ``` 49 | 50 | ```{r plot-traj, fig.width=8,fig.height=4} 51 | ## Figure 1. Trajectories of x_t 52 | par(mfrow=c(1,2)) 53 | matplot(xt_prior,type="l",lty=1,ylim=c(-3,3),ylab="hidden state",xlab="time") 54 | matplot(xt_posterior[,1:500],type="l",lty=1,ylim=c(-3,3),main="",ylab="hidden state",xlab="time") 55 | ``` 56 | ```{r plot-pos, fig.width=12,fig.height=3} 57 | ## Figure 2. Posterior distribution p(x|y) 58 | par(mfrow=c(1,4),cex=1) 59 | for(i in 2:5){ 60 | hist(xt_posterior[i,],xlab=paste0("x",i),main="",breaks=15,col="gray",freq=F,ylim=c(0,2)) 61 | abline(v=c(0,1,1,1,2)[i],col="red") 62 | } 63 | 64 | 65 | ``` 66 | 67 | ## SMC 68 | The bootstrap filter is one of the most popular algorithms for sequantial Monte Carlo (SMC). At each time step, candidate particles are generated from the time-evolution process \(f_\theta(x_t|x_{t-1})\). Particles are then filetered by the importance sampling resampling (ISR) based on \(g_\theta(y_t|x_t)\) to yield samples from the target distribution \(p_\theta(x_t|y_{1:t})\propto g_\theta(y_t|x_t)f_\theta(x_t|x_{t-1},y_{1:t-1})\). 69 | 70 | ```{r smc} 71 | set.seed(122018) 72 | xt_BF<-BF_sim(yt,sig,merror=0.1,200) #SMC 73 | xt_posterior<-xt_BF$xt #posterior samples of xt 74 | xt_prop<-xt_BF$xt_prop #proposed particles at each time step 75 | ``` 76 | ```{r plot-smc, fig.width=12, fig.height=6} 77 | ## Figure 3. Sequential sampling of trajectories x 78 | par(mfrow=c(2,4)) 79 | for(t in 2:5){ #plot trajectories 80 | matplot(rbind(xt_posterior[1:(t-1),],xt_prop[t,],matrix(NA,5-t,ncol(xt_posterior))),type="l",lty=1,ylim=c(-1,3),ylab="hidden state",xlab="time") 81 | matplot(rbind(xt_posterior[1:t,],matrix(NA,5-t,ncol(xt_posterior))),type="l",lty=1,ylim=c(-1,3),ylab="hidden state",xlab="time") 82 | } 83 | 84 | ``` 85 | 86 | ##PMCMC 87 | Particle Markov-chain Monte Carlo is a method to estimate parameter \(\theta\) of a hidden-Markov process by efficiently sampling the hidden variable \(x\) with SMC. SMC is used as a sub-algorithm that returns the approximated marginal likelihood \(\hat p(y_{1:T}|\theta)\). Here, the parameter in the Gaussian kernel \(\sigma\) is estimated with an improper prior over the positive real line \(p(\sigma)=\mathcal U(0,\infty)\). 88 | 89 | ```{r pmcmc} 90 | set.seed(122018) 91 | tlen<-5 # total time steps 92 | mcmclen<-5000 # Iterations in MCMC 93 | nparticle<-200 # Particles used in SMC 94 | merror=0.1 #measurement error 95 | 96 | # Initialise MCMC 97 | sig_mcmc<-numeric(mcmclen) #sigma 98 | sig_mcmc[1]=1 99 | ll<-numeric(mcmclen) #log-likelihood 100 | ll[1]=-Inf 101 | x_mcmc<-matrix(0,mcmclen,tlen) #x_t 102 | prop_sd<-0.5 #sd of proposal distribution 103 | 104 | # PMCMC 105 | for(n in 2:mcmclen){ 106 | sig_prop<-sig_mcmc[n-1]+rnorm(1,0,prop_sd) 107 | sig_prop=abs(sig_prop) 108 | BF<-BF_sim(yt,sig_prop,merror,nparticle) 109 | ll_prop<-sum(log(BF$avg_wt)) 110 | prob_update<-min(1,exp(ll_prop-ll[n-1])) 111 | if(runif(1)