Simulate the final size with heterogeneity in social contact and infection susceptibility

Author

Andree Valle-Campos

Published

June 26, 2025

What do we have?

  • Heterogeneous social contact
  • Different susceptibility to the infection:
    • Between individuals of different age groups from 20% (infants) to 100% (65+), and
    • Within individuals of the same age group due the immunization effect of 25%.
  • The immunization uptake rate is also different for each of the age groups: immunization increases with age from 20% (infants) to 90% (65+)

Steps in code

# Simulate final size with heterogeneity in social contact and infection susceptibility

library(finalsize)
library(socialmixr)
library(tidyverse)

# get UK polymod data
polymod <- socialmixr::polymod
contact_data <- socialmixr::contact_matrix(
  polymod,
  countries = "United Kingdom",
  age.limits = c(0, 5, 18, 40, 65),
  symmetric = TRUE
)

# get the contact matrix and demography data
contact_matrix <- t(contact_data$matrix)

# scale the contact matrix so the largest eigenvalue is 1.0
# this is to ensure that the overall epidemic dynamics correctly reflect
# the assumed value of R0
contact_matrix_scaled <- contact_matrix / max(Re(eigen(contact_matrix)$values))

# Define population in each age group
demography_vector <- contact_data$demography$population
demography_groups <- contact_data$demography$age.group

demography_vector
#> [1]  3453670  9761554 18110368 19288101  9673058
demography_groups
#> [1] "[0,5)"   "[5,18)"  "[18,40)" "[40,65)" "65+"

# divide each row of the contact matrix by the corresponding demography
# this reflects the assumption that each individual in group {j} make contacts
# at random with individuals in group {i}
contact_matrix_random <- contact_matrix_scaled / demography_vector


# Set and immunization effect
immunization_effect <- 0.25

# susceptibility matrix
susceptibility <- tibble(
  age_group = demography_groups,
  unimmunised = c(0.2, 0.5, 0.6, 0.9, 1.0)
) %>%
  mutate(immunised = unimmunised * (1 - immunization_effect)) %>%
  column_to_rownames(var = "age_group") %>%
  as.matrix()

susceptibility
#>         unimmunised immunised
#> [0,5)           0.2     0.150
#> [5,18)          0.5     0.375
#> [18,40)         0.6     0.450
#> [40,65)         0.9     0.675
#> 65+             1.0     0.750

# demography-in-susceptibility matrix
p_susceptibility <- tibble(
  age_group = demography_groups,
  immunised = c(0.2, 0.4, 0.6, 0.7, 0.9)
) %>%
  mutate(unimmunised = 1 - immunised) %>%
  column_to_rownames(var = "age_group") %>%
  as.matrix()

p_susceptibility
#>         immunised unimmunised
#> [0,5)         0.2         0.8
#> [5,18)        0.4         0.6
#> [18,40)       0.6         0.4
#> [40,65)       0.7         0.3
#> 65+           0.9         0.1

# R0 of the disease
r0 <- 2 # assumed for pandemic influenza

# Calculate the proportion of individuals infected in each age group
final_size(
  r0 = r0,
  contact_matrix = contact_matrix_random,
  demography_vector = demography_vector,
  susceptibility = susceptibility,
  p_susceptibility = p_susceptibility
)
#>    demo_grp    susc_grp susceptibility p_infected
#> 1     [0,5) unimmunised          0.200 0.05131913
#> 2    [5,18) unimmunised          0.500 0.25099668
#> 3   [18,40) unimmunised          0.600 0.23551194
#> 4   [40,65) unimmunised          0.900 0.30101687
#> 5       65+ unimmunised          1.000 0.22067782
#> 6     [0,5)   immunised          0.150 0.03874169
#> 7    [5,18)   immunised          0.375 0.19487594
#> 8   [18,40)   immunised          0.450 0.18242420
#> 9   [40,65)   immunised          0.675 0.23554836
#> 10      65+   immunised          0.750 0.17055465

Steps in detail

  • (pending)