tests/testthat/test-addDeath.R

In PatientProfiles: Identify Characteristics of Patients in the OMOP Common Data Model

test_that("addDeathDate", {
  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    seed = 11,
    numberIndividuals = 10
  )
  cdm$cohort1 <- addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c(0, Inf),
    deathDateName = "ddate"
  )
  expect_true("ddate" %in% colnames(cdm$cohort1))

  cdm$cohort1 <- addDeathDays(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c(0, Inf),
    deathDaysName = "ddays"
  )
  expect_true("ddays" %in% colnames(cdm$cohort1))

  cdm$cohort1 <- addDeathFlag(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = list(c(0, Inf)), # can also provide window as a list
    deathFlagName = "dflag"
  )
  expect_true("dflag" %in% colnames(cdm$cohort1))


  # warning if variable already exists
  expect_warning(cdm$cohort1 |>
    addDeathFlag(deathFlagName = "dflag2") |>
    addDeathFlag(deathFlagName = "dflag2"))

  # expected errors
  expect_error(addDeathDate(
    x = "not a table",
    indexDate = "cohort_start_date",
    window = c(0, Inf),
    deathDateName = "ddate"
  ))
  expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "not_a_variable",
    window = c(0, Inf),
    deathDateName = "ddate"
  ))
  expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "not_a_variable",
    window = c(0, 1, 2),
    deathDateName = "ddate"
  ))
  expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c("not a number", Inf),
    deathDateName = "ddate"
  ))
  expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c(10, 2),
    deathDateName = "ddate"
  ))
  expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c(-Inf, -Inf),
    deathDateName = "ddate"
  ))
  expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c(Inf, Inf),
    deathDateName = "ddate"
  ))
  expect_warning(expect_error(addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = list(c(0, Inf), c(1, Inf)),
    deathDateName = "ddate"
  )))
  expect_warning(addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_start_date",
    window = c(0, Inf),
    deathDateName = "NotSnakeCase"
  ))

  # no death table in cdm reference
  cdm$death <- NULL
  expect_error(addDeathDate(x = cdm$cohort1))
  expect_error(addDeathDays(x = cdm$cohort1))
  expect_error(addDeathFlag(x = cdm$cohort1))

  mockDisconnect(cdm = cdm)
})

test_that("check alternative index date", {
  skip_on_cran()
  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    seed = 11,
    numberIndividuals = 10
  )

  # test simple working example
  deathTable <- cdm$cohort1 |>
    dplyr::collect() |>
    dplyr::select(
      "person_id" = "subject_id",
      "death_date" = "cohort_end_date"
    ) |>
    dplyr::filter(person_id == 1L)
  cdm <- omopgenerics::insertTable(cdm = cdm, name = "death", table = deathTable)

  cdm$cohort1 <- addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(0, Inf),
    deathDateName = "ddate"
  )
  # should be the same date as cohort end date
  local_df <- cdm$cohort1 |>
    dplyr::collect() |>
    dplyr::filter(!is.na(ddate))
  expect_true(all(local_df$cohort_end_date == local_df$ddate))

  cdm$cohort1 <- addDeathDays(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(0, Inf),
    deathDaysName = "ddays"
  )
  local_df <- cdm$cohort1 |>
    dplyr::collect() |>
    dplyr::filter(!is.na(ddays))
  expect_true(all(local_df$ddays == 0))

  mockDisconnect(cdm = cdm)
})

test_that("check window logic", {
  skip_on_cran()
  cohort1 <- dplyr::tibble(
    cohort_definition_id = as.integer(c(1, 2, 1, 2, 1)),
    subject_id = as.integer(c(1, 1, 1, 1, 1)),
    cohort_start_date = as.Date(c("2020-01-01", "2020-01-01", "2021-07-01", "2021-07-01", "2022-01-01")),
    cohort_end_date = as.Date(c("2020-01-01", "2020-01-01", "2021-07-01", "2021-07-01", "2022-06-30"))
  )
  observation_period <- dplyr::tibble(
    observation_period_id = as.integer(c(1, 2, 3)),
    person_id = as.integer(c(1, 1, 1)),
    observation_period_start_date = as.Date(c("2015-06-30", "2019-06-30", "2021-06-30")),
    observation_period_end_date = as.Date(c("2018-06-30", "2020-06-30", "2022-06-30")),
    period_type_concept_id = 0L
  )
  deathTable <- dplyr::tibble(
    person_id = 1L,
    death_date = as.Date("2022-06-30")
  )
  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    cohort1 = cohort1,
    observation_period = observation_period,
    cohort2 = cohort1,
    death = deathTable
  )

  # with window of zero days around cohort end, we should only have death days for last cohort entry
  cdm$cohort1 <- cdm$cohort1 |>
    addDeathDays(
      indexDate = "cohort_end_date",
      window = c(0, 0),
      deathDaysName = "ddays"
    )
  expect_true(cdm$cohort1 |>
    dplyr::filter(!is.na(ddays) & ddays == 0) |>
    dplyr::tally() |>
    dplyr::pull("n") == 1)

  # with window of 1 days to inf for cohort end, we should death days for all but the last cohort entry
  cdm$cohort1 <- addDeathDays(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(1, Inf),
    deathDaysName = "ddays2"
  )
  # only 2 are observed as only events in observation period are considered
  # otherwise 4 would be observed
  expect_true(cdm$cohort1 |>
    dplyr::filter(!is.na(ddays2)) |>
    dplyr::tally() |>
    dplyr::pull("n") == 2)

  # with window of -inf days to inf for cohort end, we should death days for all
  cdm$cohort1 <- addDeathDays(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(-Inf, Inf),
    deathDaysName = "ddays3"
  )
  # only 3 are observed as only events in observation period are considered
  # otherwise 5 would be observed
  expect_true(cdm$cohort1 |>
    dplyr::filter(!is.na(ddays3)) |>
    dplyr::tally() |>
    dplyr::pull("n") == 3)


  # with window of -inf days to -1 for cohort end, we should have no death days for anyone
  cdm$cohort1 <- addDeathDays(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(-Inf, -1),
    deathDaysName = "ddays4"
  )

  expect_true(cdm$cohort1 |>
    dplyr::filter(!is.na(ddays4)) |>
    dplyr::tally() |>
    dplyr::pull("n") == 0)

  # with window of -inf days to 0 for cohort end, we should have death days for last cohort entry
  cdm$cohort1 <- addDeathDays(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(-Inf, 0),
    deathDaysName = "ddays5"
  )

  expect_true(cdm$cohort1 |>
    dplyr::filter(!is.na(ddays5)) |>
    dplyr::tally() |>
    dplyr::pull("n") == 1)

  mockDisconnect(cdm = cdm)
})

test_that("check with omop table", {
  skip_on_cran()
  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    seed = 11,
    numberIndividuals = 10
  )

  cdm$condition_occurrence <- addDeathDate(
    x = cdm$condition_occurrence,
    indexDate = "condition_start_date",
    window = c(0, Inf),
    deathDateName = "ddate"
  )
  expect_true("ddate" %in% colnames(cdm$condition_occurrence))

  cdm$condition_occurrence <- addDeathDays(
    x = cdm$condition_occurrence,
    indexDate = "condition_start_date",
    window = c(0, Inf),
    deathDaysName = "ddays"
  )
  expect_true("ddays" %in% colnames(cdm$condition_occurrence))

  cdm$condition_occurrence <- addDeathFlag(
    x = cdm$condition_occurrence,
    indexDate = "condition_start_date",
    window = list(c(0, Inf)),
    deathFlagName = "dflag"
  )
  expect_true("dflag" %in% colnames(cdm$condition_occurrence))

  # default index date is cohort start so should error if not changed
  expect_error(addDeathDate(
    x = cdm$condition_occurrence,
    window = c(0, Inf),
    deathDateName = "ddate"
  ))

  mockDisconnect(cdm = cdm)
})

test_that("check functionality in presence of multiple death records", {
  skip_on_cran()
  cohort1 <- dplyr::tibble(
    cohort_definition_id = as.integer(c(1, 2, 1, 2, 1, 1)),
    subject_id = as.integer(c(1, 1, 1, 1, 1, 2)),
    cohort_start_date = as.Date(c(
      "2020-01-01", "2020-01-01", "2021-07-01", "2021-07-01", "2022-01-01",
      "2020-01-01"
    )),
    cohort_end_date = as.Date(c(
      "2020-01-01", "2020-01-01", "2021-07-01", "2021-07-01", "2022-06-30",
      "2020-01-01"
    ))
  )
  observation_period <- dplyr::tibble(
    observation_period_id = as.integer(c(1, 2, 3, 4)),
    person_id = as.integer(c(1, 1, 1, 2)),
    observation_period_start_date = as.Date(c(
      "2015-06-30", "2019-06-30", "2021-06-30",
      "2020-01-01"
    )),
    observation_period_end_date = as.Date(c(
      "2018-06-30", "2020-06-30", "2022-06-30",
      "2020-01-01"
    )),
    period_type_concept_id = 0L
  )
  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    cohort1 = cohort1,
    observation_period = observation_period,
    cohort2 = cohort1
  )
  deathTable <- dplyr::tibble(
    person_id = as.integer(c(1, 1, 2)),
    death_date = c(as.Date("2022-06-30"), as.Date("2022-07-30"), as.Date("2020-01-01"))
  )
  cdm <- omopgenerics::insertTable(cdm = cdm, name = "death", table = deathTable)

  nrow_start <- cdm$cohort1 |>
    dplyr::tally() |>
    dplyr::pull("n")

  cdm$cohort1 <- addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(0, Inf),
    deathDateName = "death_date"
  )
  nrow_end <- cdm$cohort1 |>
    dplyr::tally() |>
    dplyr::pull("n")
  expect_true(nrow_start == nrow_end)

  # all are the first death date for subject 1
  expect_true(all(
    cdm$cohort1 |>
      dplyr::filter(subject_id == 1) |>
      dplyr::select("death_date") |>
      dplyr::distinct() |>
      dplyr::pull() %in%
      as.Date(c("2022-06-30", NA))
  ))

  # now in the last case, starting window from 1 will result in last record having second death date
  cdm$cohort1 <- addDeathDate(
    x = cdm$cohort1,
    indexDate = "cohort_end_date",
    window = c(1, Inf),
    deathDateName = "death_date_2"
  )
  expect_equal(length(cdm$cohort1 |>
    dplyr::filter(subject_id == 1) |>
    dplyr::select("death_date_2") |>
    dplyr::distinct() |>
    dplyr::pull()), 2)

  mockDisconnect(cdm = cdm)
})