Metropolis Hastings Algorithm for an epidemic in R: Why is my code returning negative values of beta_store?

Question

I am trying to sample the parameter "beta" for a transmission dynamic model for COVID-19 (solved using ode in R), using the Metropolis Hastings Algorithm. I have first defined a function cBeta(x,a,b) to calculate the likelihood further in the metropolis hastings function (defined in the code below). My code is generating negative values of beta_store, and I am not sure why. Can someone please help? Thank you in advance.

library(deSolve)   # package with functions to solve the model
library(reshape2)  # package with functions to turn the model output into a long format
library(ggplot2)   # package for plotting
library(plyr)      # for rbind


#Initial number of people in each compartment of the model

initialvalues1<-  c (U  = 1 - (10^-5), # people uninfected or susceptible to COVID-19
                     E1 = 10^-5,       # current number of people exposed
                     E2 = 0,           # no one is recovered at the beginning of the simulation
                     A1 = 0,
                     A2 = 0,
                     P1 = 0,
                     P2 = 0,
                     S1 = 0,
                     S2 = 0,
                     R1 = 0,
                     R2 = 0,
                     J  = 0,
                     N  = 1) 

parameters1 <- c(beta1 = 0.265,  # transmission rate from symptomatic infection #0.268
                 beta2 = 0,
                 eeta = 0.275,   # amongst those exposed, rate of developing infectiousness
                 psym = 0.495,   # proportion developing symptoms
                 k = 0.83,       # relative infectiousness of asymptomatic vs symptomatic infection
                 r = 1,          # amongst those with pre-symptomatic infection, rate of developing symptoms
                 gamma = 0.2,    # recovery rate 
                 #w = 0,         # per-capita rate at which post infection immunity wanes
                 m = 1,          # connectivity matrix?
                 mu = 0.0029)    # average morality rate for severe case


times1 <- seq(from = 1, to = 395, by = 1) 

# Original Model 

COVID_model_revised <- function(time, state, parameters) {
  with(as.list(c(time,state,parameters)), 
       {
         
         N <- U + E1 + E2 + A1 + A2 + P1 + P2 + S1 + S2 + R1 + R2 
         
         lambda1 <-  m * (beta1* (S1 + (k* ( A1 + P1))))  
         
         lambda2 <-  m * (beta2* (S2 + (k* ( A2 + P2)))) 
         
         dU      <-  - (lambda1 + lambda2)*U
         
         dE1     <-  (lambda1*U)  - (eeta*E1)
         
         dE2     <-  (lambda2*U)  - (eeta*E2)
         
         dA1     <-  (eeta* (1-psym)*E1) - (gamma*A1)
         
         dA2     <-  (eeta*(1-psym)*E2)  - (gamma*A2)
         
         dP1     <-  (eeta*psym*E1) - (r*P1)
         
         dP2     <-  (eeta*psym*E2) - (r*P2)
         
         dS1     <-  (r*P1) -  ((gamma + mu)*S1)
         
         dS2     <-  (r*P2) -  ((gamma + mu)*S2)
         
         dR1     <-  ((A1 + S1)*gamma)
         
         dR2     <-  ((A2 + S2)*gamma)
         
         dJ      <-   (P1 + P2)*r
         
         dN      <-  - (S1 + S2)*mu
         
         return(list(c(dU, dE1, dE2, dA1, dA2, dP1, dP2, dS1,dS2, dR1, dR2, dJ,dN)))  # Return the number of people in each 
         # compartment at each timestep in the same
         # order as the input state variables.
       } )
}



output_covid_new<-as.data.frame(ode(y=initialvalues1,     # Solving the differential equations using 
                                    times = times1,          # the "ode" (Ordinary Differential Equations) algorithm.
                                    func = COVID_model_revised, 
                                    parms = parameters1))

# daily incidence

AI_new1 <- diff (output_covid_new[,13])  

AI_new1


output_covid_plot <- data.frame("time"=output_covid_new$time[1:394], "AI"= AI_new1)

plot(output_covid_plot$time,output_covid_plot$AI, xlab = "Days from introduction", ylab = "Daily Incidence per million of the population" )


# Metropolis Hastings

cBeta <- function(x,a,b)

{
  
  return ( ifelse(x < 0, value <- -Inf,  value <- lgamma(a + b) - lgamma(a) - lgamma(b) + 
                    
         ( (a-1)*lgamma(x) ) + ( (b-1)*lgamma(1-x) ) ) )
  
}

MH_first <- function (betasto0,t)     # t is the number of steps taken
  
{

  beta_store <- rep(0,t)
  betasto0   <- beta_store[1] 
  
  sp_store <- rep(0,t)
  
  
  for (i in 2:t)
  {
    
    beta_prop <- rnorm(1, mean = beta_store[i-1], sd = sqrt(0.01))

    parameters_MH <- c(beta1 = beta_prop,  # transmission rate from symptomatic infection #0.268
                       beta2 = 0,
                       eeta = 0.275,       # amongst those exposed, rate of developing infectiousness
                       psym = 0.495,      # proportion developing symptoms
                       k = 0.83,          # relative infectiousness of asymptomatic vs symptomatic infection
                       r = 1,             # amongst those with pre-symptomatic infection, rate of developing symptoms
                       gamma = 0.2,       # recovery rate
                       m = 1,             
                       mu = 0.0029)     # average morality rate for severe case

      times1 <- seq(from = 1, to = 395, by = 1)
      

      # To sovle the COVID-19 model using ode

      output_covid_MH <-as.data.frame(ode(y=initialvalues1,     
                                         times = times1,          
                                         func = COVID_model_revised,
                                         parms = parameters_MH))

      # date of the max. value of symptomatic infection (S1) => seroprevalence peak (R1)
      
      symp_peak <- which.max(output_covid_MH[,9]) 
      
      sp_prop <- (output_covid_MH[symp_peak,11])

      Y <- runif(1)
      
      r <- exp( cBeta(sp_prop,159,2116) - cBeta(sp_store[i-1],159,2116) )

     
     if (i == 2)
        
      { 
        sp_store[i] <- sp_prop
        
        beta_store[i] <- beta_prop
      
      }
      
      else 
        
      { 
  
        ifelse ( Y < r,  sp_store[i] <- sp_prop,  sp_store[i] <- sp_store[i - 1] )
        
        ifelse ( Y < r,  beta_store[i] <- beta_prop,  beta_store[i] <- beta_store[i - 1] )
        
      }
      
   
  }
  
  return(beta_store)
  
  }


# calling the function

model_plot <- MH_first(0.26,10000)

Answer 1

First, follow @GregorThomas's advice: don't use ifelse() , change the decisions to something like this:

  if( Y < r) {
     sp_store[i] <- sp_prop
     beta_store[i] <- beta_prop
  } else {
     sp_store[i] <- sp_store[i - 1]
     beta_store[i] <- beta_store[i - 1]
  }

Your Metropolis ratio doesn't look at beta , it looks at sp . You would reject any proposal that had a negative sp , but not a proposal that had a negative beta . So that explains why you are seeing negative values.

I don't know anything about your model, so I can't tell you if it is implemented correctly.