Fix for issue with missing.contact.age "sample" and age.limits > 0

R/contact_matrix.R

@@ -195,31 +195,33 @@ contact_matrix <- function(survey, countries = NULL, survey.pop, age.limits, fil
     # note: do nothing when "missing" is specified
   }
 
+  # remove contact ages below the age limit, before dealing with missing contact ages
+  survey$contacts <- survey$contacts[is.na(cnt_age) |
+    cnt_age >= min(age.limits), ]
+
   if (missing.contact.age == "remove" &&
-    nrow(survey$contacts[is.na(cnt_age) |
-      cnt_age < min(age.limits)]) > 0) {
+    nrow(survey$contacts[is.na(cnt_age)]) > 0) {
     if (!missing.contact.age.set) {
       message(
         "Removing participants that have contacts without age information. ",
         "To change this behaviour, set the 'missing.contact.age' option"
       )
     }
     missing.age.id <- survey$contacts[
-      is.na(cnt_age) | cnt_age < min(age.limits), part_id
+      is.na(cnt_age), part_id
     ]
     survey$participants <- survey$participants[!(part_id %in% missing.age.id)]
   }
 
   if (missing.contact.age == "ignore" &&
-    nrow(survey$contacts[is.na(cnt_age) | cnt_age < min(age.limits)]) > 0) {
+    nrow(survey$contacts[is.na(cnt_age)]) > 0) {
     if (!missing.contact.age.set) {
       message(
         "Ignore contacts without age information. ",
         "To change this behaviour, set the 'missing.contact.age' option"
       )
     }
-    survey$contacts <- survey$contacts[!is.na(cnt_age) &
-      cnt_age >= min(age.limits), ]
+    survey$contacts <- survey$contacts[!is.na(cnt_age), ]
   }
 
   ## check if any filters have been requested
@@ -513,7 +515,7 @@ contact_matrix <- function(survey, countries = NULL, survey.pop, age.limits, fil
               replace = TRUE
             )
         ]
-      } else {
+      } else if (nrow(survey$contacts[!is.na(cnt_age), ]) > 0) {
         ## no contacts in the age group have an age, sample uniformly between limits
         min.contact.age <-
           survey$contacts[, min(cnt_age, na.rm = TRUE)]
@@ -530,6 +532,7 @@ contact_matrix <- function(survey, countries = NULL, survey.pop, age.limits, fil
         ]
       }
     }
+    survey$contacts <- survey$contacts[!is.na(cnt_age), ] # make sure the final set does not contain NA's anymore
   }
 
   ## set contact age groups

tests/testthat/test-matrix.r

@@ -555,3 +555,10 @@ test_that("Contact matrices per capita are also generated when bootstrapping", {
 test_that("Symmetric contact matrices with large normalisation weights throw a warning", {
   expect_warning(contact_matrix(survey = polymod, age.limits = c(0, 90), symmetric = TRUE), "artefacts after making the matrix symmetric")
 })
+
+test_that("Contacts with an age below the age limits are excluded regardless of the missing.contact.age setting", {
+  expect_identical(ncol(contact_matrix(polymod, age.limits = c(10, 50), missing.contact.age = "remove")$matrix), 2L)
+  expect_identical(ncol(contact_matrix(polymod, age.limits = c(10, 50), missing.contact.age = "sample")$matrix), 2L)
+  expect_identical(ncol(contact_matrix(polymod, age.limits = c(10, 50), missing.contact.age = "keep")$matrix), 3L) # extra column for ages outside age limits (= NA)
+  expect_identical(ncol(contact_matrix(polymod, age.limits = c(10, 50), missing.contact.age = "ignore")$matrix), 2L)
+})