tests/testthat/test-compute-matrix.R

In socialmixr: Social Mixing Matrices for Infectious Disease Modelling

polymod_uk_grouped <- polymod |>
  (\(s) s[country == "United Kingdom"])() |>
  assign_age_groups(age_limits = c(0, 5, 15))

test_that("compute_matrix() produces a basic contact matrix", {
  result <- compute_matrix(polymod_uk_grouped)
  expect_true("matrix" %in% names(result))
  expect_true("participants" %in% names(result))
  expect_true(is.matrix(result$matrix) || is.array(result$matrix))
  expect_identical(nrow(result$matrix), 3L)
  expect_identical(ncol(result$matrix), 3L)
})

test_that("compute_matrix() counts works", {
  result <- compute_matrix(polymod_uk_grouped, counts = TRUE)
  result_mean <- compute_matrix(polymod_uk_grouped, counts = FALSE)
  expect_true(all(
    result$matrix >= result_mean$matrix,
    na.rm = TRUE
  ))
})

test_that("compute_matrix() errors when age.group missing", {
  survey <- copy(polymod)
  survey <- survey[country == "United Kingdom"]
  expect_error(
    compute_matrix(survey),
    "assign_age_groups"
  )
})

test_that("compute_matrix() warns for multiple observations per participant", {
  survey <- polymod_uk_grouped
  # Duplicate participants to simulate longitudinal data
  survey$participants <- rbind(survey$participants, survey$participants)
  expect_warning(
    compute_matrix(survey),
    "multiple observations"
  )
})

test_that("compute_matrix() warning mentions observation_key when present", {
  survey <- polymod_uk_grouped
  survey$participants <- rbind(survey$participants, survey$participants)
  survey$observation_key <- "wave"
  expect_warning(
    compute_matrix(survey),
    "wave"
  )
})

test_that("pipeline matches contact_matrix() without weighting", {
  result_pipe <- polymod |>
    (\(s) s[country == "United Kingdom"])() |>
    assign_age_groups(age_limits = c(0, 5, 15)) |>
    compute_matrix()

  result_legacy <- contact_matrix(
    polymod,
    countries = "United Kingdom",
    age_limits = c(0, 5, 15),
    symmetric = FALSE
  )

  expect_identical(result_pipe$matrix, result_legacy$matrix)
})

test_that("pipeline with dayofweek weighting is close to contact_matrix()", {
  result_pipe <- polymod |>
    (\(s) s[country == "United Kingdom"])() |>
    assign_age_groups(age_limits = c(0, 5, 15)) |>
    weigh("dayofweek", target = c(5, 2), groups = list(1:5, c(0, 6))) |>
    compute_matrix()

  result_legacy <- contact_matrix(
    polymod,
    countries = "United Kingdom",
    age_limits = c(0, 5, 15),
    weigh_dayofweek = TRUE,
    symmetric = FALSE
  )

  ## Small difference remains because legacy lumps NA dayofweek with weekends,

  ## while weigh() assigns them a neutral average weight.
  expect_equal(
    result_pipe$matrix,
    result_legacy$matrix,
    tolerance = 0.03
  )
})