tests/testthat/test-indication.R

In DrugUtilisation: Summarise Patient-Level Drug Utilisation in Data Mapped to the OMOP Common Data Model

test_that("test case single indication", {
  skip_on_cran()
  targetCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 1, 2),
    subject_id = c(1, 1, 2, 3),
    cohort_start_date = as.Date(c(
      "2020-01-01", "2020-06-01", "2020-01-02", "2020-01-01"
    )),
    cohort_end_date = as.Date(c(
      "2020-04-01", "2020-08-01", "2020-02-02", "2020-03-01"
    ))
  )
  indicationCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 2, 1),
    subject_id = c(1, 3, 1, 1),
    cohort_start_date = as.Date(
      c(
        "2019-12-30",
        "2020-01-01",
        "2020-05-25",
        "2020-05-25"
      )
    ),
    cohort_end_date = as.Date(
      c(
        "2019-12-30",
        "2020-01-01",
        "2020-05-25",
        "2020-05-25"
      )
    )
  )
  attr(indicationCohortName, "cohort_set") <- dplyr::tibble(
    cohort_definition_id = c(1, 2),
    cohort_name = c("asthma", "covid")
  )
  observationPeriod <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 2, 3),
    observation_period_start_date = as.Date(c(
      "2015-01-01", "2016-05-15", "2012-12-30"
    )),
    observation_period_end_date = as.Date("2024-01-01"),
    period_type_concept_id = 44814724
  )
  condition_occurrence <- dplyr::tibble(
    condition_occurrence_id = 1,
    condition_concept_id = 0,
    condition_type_concept_id = 0,
    person_id = 1,
    condition_start_date = as.Date("2020-05-31"),
    condition_end_date = as.Date("2020-05-31")
  )

  cdm <- mockDrugUtilisation(
    con = connection(),
    writeSchema = schema(),
    cohort1 = targetCohortName,
    cohort2 = indicationCohortName,
    condition_occurrence = condition_occurrence,
    observation_period = observationPeriod
  )
  # check it works without cdm object specified

  expect_no_error(cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(0, 0)),
      unknownIndicationTable = NULL
    ))

  # check overwrites existing variable with warning
  expect_warning(cdm$new <- cdm[["cohort1"]] |>
    dplyr::mutate(a = 1) |>
    addIndication(
      indicationCohortName = "cohort2",
      indicationWindow = list(
        c(0, 0),
        c(-Inf, 0)
      ),
      indexDate = "cohort_end_date",
      unknownIndicationTable = NULL
    ) |>
    addIndication(
      indicationCohortName = "cohort2",
      indicationWindow = list(
        c(0, 0),
        c(-Inf, 0)
      ),
      indexDate = "cohort_end_date",
      unknownIndicationTable = NULL
    ))
  expect_true("a" %in% colnames(cdm$new))

  # check for indication 0
  res0 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(0, 0)),
      unknownIndicationTable = NULL
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(res0), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_0_to_0") %in%
      setdiff(colnames(res0), colnames(cdm[["cohort1"]]))
  ))

  expect_true(
    res0 |>
      dplyr::filter(.data$subject_id == 3) |>
      dplyr::pull("indication_0_to_0") == "asthma"
  )
  expect_true(
    all(res0 |>
      dplyr::filter(.data$subject_id != 3) |>
      dplyr::pull("indication_0_to_0") == "none")
  )

  # check for indication 1
  res1 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(-1, 0)),
      unknownIndicationTable = NULL
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(res1), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_m1_to_0") %in%
      setdiff(colnames(res1), colnames(cdm[["cohort1"]]))
  ))

  expect_true(
    res1 |>
      dplyr::filter(.data$subject_id == 3) |>
      dplyr::pull("indication_m1_to_0") == "asthma"
  )
  expect_true(
    all(res1 |>
      dplyr::filter(.data$subject_id != 3) |>
      dplyr::pull("indication_m1_to_0") == "none")
  )

  # check for indication 2
  res2 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(-2, 0)),
      unknownIndicationTable = NULL
    ) |>
    dplyr::collect()

  expect_true(length(setdiff(colnames(res2), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_m2_to_0") %in%
      setdiff(colnames(res2), colnames(cdm[["cohort1"]]))
  ))

  expect_true(all(
    res2 |>
      dplyr::arrange(
        .data$subject_id,
        .data$cohort_start_date,
        .data$cohort_definition_id,
        .data$cohort_end_date
      ) |>
      dplyr::pull("indication_m2_to_0") ==
      c("asthma", "none", "none", "asthma")
  ))

  # check for all indication Gap
  resinf <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(-Inf, 0)),
      unknownIndicationTable = NULL
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(resinf), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_minf_to_0") %in%
      setdiff(colnames(resinf), colnames(cdm[["cohort1"]]))
  ))


  expect_true(any(
    identical(
      resinf |>
        dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
        dplyr::pull("indication_minf_to_0"),
      c("asthma", "asthma and covid", "none", "asthma")
    ),
    identical(
      resinf |>
        dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
        dplyr::pull("indication_minf_to_0"),
      c("asthma", "asthma and covid", "none", "asthma")
    )
  ))

  mockDisconnect(cdm = cdm)
})

test_that("test case single indication with unknown indication table", {
  skip_on_cran()
  targetCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 1, 2),
    subject_id = c(1, 1, 2, 3),
    cohort_start_date = as.Date(c(
      "2020-01-01", "2020-06-01", "2020-01-02", "2020-01-01"
    )),
    cohort_end_date = as.Date(c(
      "2020-04-01", "2020-08-01", "2020-02-02", "2020-03-01"
    ))
  )
  indicationCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 2, 1),
    subject_id = c(1, 3, 1, 1),
    cohort_start_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    )),
    cohort_end_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    ))
  )
  condition_occurrence <- dplyr::tibble(
    person_id = 1,
    condition_start_date = as.Date("2020-05-31"),
    condition_end_date = as.Date("2020-05-31"),
    condition_occurrence_id = 1,
    condition_concept_id = 0,
    condition_type_concept_id = 0
  )
  attr(indicationCohortName, "cohort_set") <- dplyr::tibble(
    cohort_definition_id = c(1, 2),
    cohort_name = c("asthma", "covid")
  )
  observationPeriod <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 2, 3),
    observation_period_start_date = as.Date(c(
      "2015-01-01", "2016-05-15", "2012-12-30"
    )),
    observation_period_end_date = as.Date("2024-01-01"),
    period_type_concept_id = 44814724
  )
  cdm <- mockDrugUtilisation(
    con = connection(),
    writeSchema = schema(),
    cohort1 = targetCohortName,
    cohort2 = indicationCohortName, condition_occurrence = condition_occurrence,
    observation_period = observationPeriod
  )

  # check for indication 0
  res0 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(0, 0)),
      unknownIndicationTable = "condition_occurrence"
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(res0), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_0_to_0") %in%
      setdiff(colnames(res0), colnames(cdm[["cohort1"]]))
  ))

  expect_true(identical(
    res0 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_0_to_0"),
    c("none", "none", "none", "asthma")
  ))

  # check for indication 1
  res1 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(-1, 0)),
      unknownIndicationTable = "condition_occurrence"
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(res1), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_m1_to_0") %in%
      setdiff(colnames(res1), colnames(cdm[["cohort1"]]))
  ))

  expect_true(identical(
    res1 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m1_to_0"),
    c("none", "unknown", "none", "asthma")
  ))

  # check for indication 6
  res6 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(-6, 0)),
      unknownIndicationTable = "condition_occurrence"
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(res6), colnames(cdm[["cohort1"]]))) == 1)
  expect_true(all(
    c("indication_m6_to_0") %in%
      setdiff(colnames(res6), colnames(cdm[["cohort1"]]))
  ))

  expect_true(identical(
    res6 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m6_to_0"),
    c("asthma", "unknown", "none", "asthma")
  ))

  # check all gaps simultaniously
  res016 <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2", indicationWindow = list(c(0, 0), c(-1, 0), c(-6, 0)),
      unknownIndicationTable = "condition_occurrence"
    ) |>
    dplyr::collect()
  expect_true(length(setdiff(colnames(res016), colnames(cdm[["cohort1"]]))) == 3)
  expect_true(all(
    c(
      "indication_0_to_0", "indication_m1_to_0",
      "indication_m6_to_0"
    ) %in%
      setdiff(colnames(res016), colnames(cdm[["cohort1"]]))
  ))

  expect_true(identical(
    res016 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_0_to_0"),
    res0 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_0_to_0")
  ))
  expect_true(identical(
    res016 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m1_to_0"),
    res1 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m1_to_0")
  ))
  expect_true(identical(
    res016 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m6_to_0"),
    res6 |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m6_to_0")
  ))

  # expect no error
  expect_no_error(
    resres <- cdm[["cohort1"]] |>
      addIndication(
        indicationCohortName = "cohort2", indicationWindow = list(c(0, 0), c(-1, 0), c(-6, 0)),
        unknownIndicationTable = c("condition_occurrence", "drug_exposure", "observation")
      ) |>
      dplyr::collect()
  )

  mockDisconnect(cdm = cdm)
})

test_that("test indicationDate", {
  skip_on_cran()
  targetCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 1, 2),
    subject_id = c(1, 1, 2, 3),
    cohort_start_date = as.Date(c(
      "2020-01-01", "2020-06-01", "2020-01-02", "2020-01-01"
    )),
    cohort_end_date = as.Date(c(
      "2020-04-01", "2020-08-01", "2020-02-02", "2020-03-01"
    ))
  )
  indicationCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 2, 1),
    subject_id = c(1, 3, 1, 1),
    cohort_start_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    )),
    cohort_end_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    ))
  )
  attr(indicationCohortName, "cohort_set") <- dplyr::tibble(
    cohort_definition_id = c(1, 2),
    cohort_name = c("asthma", "covid")
  )
  condition_occurrence <- dplyr::tibble(
    person_id = 1,
    condition_start_date = as.Date("2020-05-31"),
    condition_end_date = as.Date("2020-05-31"),
    condition_occurrence_id = 1,
    condition_concept_id = 0,
    condition_type_concept_id = 0
  )
  observationPeriod <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 2, 3),
    observation_period_start_date = as.Date(c(
      "2015-01-01", "2016-05-15", "2012-12-30"
    )),
    observation_period_end_date = as.Date("2024-01-01"),
    period_type_concept_id = 44814724
  )

  cdm <-
    mockDrugUtilisation(
      con = connection(),
      writeSchema = schema(),
      cohort1 = targetCohortName,
      cohort2 = indicationCohortName,
      condition_occurrence = condition_occurrence,
      observation_period = observationPeriod
    )

  # original
  res012inf <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2",
      indicationWindow = list(c(0, 0), c(-1, 0), c(-2, 0), c(-Inf, 0)), unknownIndicationTable = NULL
    ) |>
    dplyr::collect()
  expect_equal(
    sort(setdiff(colnames(res012inf), colnames(cdm[["cohort1"]]))),
    sort(c(
      "indication_0_to_0", "indication_m1_to_0", "indication_m2_to_0",
      "indication_minf_to_0"
    ))
  )

  # change indicationDate
  cdm[["cohort1"]] <- cdm[["cohort1"]] |>
    dplyr::rename("start_date" = "cohort_start_date")
  res012infS <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2",
      indicationWindow = list(c(0, 0), c(-1, 0), c(-2, 0), c(-Inf, 0)), unknownIndicationTable = NULL,
      indexDate = "start_date"
    ) |>
    dplyr::collect()
  expect_equal(
    sort(setdiff(colnames(res012infS), colnames(cdm[["cohort1"]]))),
    sort(c(
      "indication_0_to_0", "indication_m1_to_0", "indication_m2_to_0",
      "indication_minf_to_0"
    ))
  )
  expect_true(
    setdiff(colnames(res012inf), colnames(res012infS)) == "cohort_start_date"
  )
  expect_true(identical(
    res012inf |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_0_to_0"),
    res012infS |>
      dplyr::arrange(.data$subject_id, .data$start_date) |>
      dplyr::pull("indication_0_to_0")
  ))
  expect_true(identical(
    res012inf |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m1_to_0"),
    res012infS |>
      dplyr::arrange(.data$subject_id, .data$start_date) |>
      dplyr::pull("indication_m1_to_0")
  ))
  expect_true(identical(
    res012inf |>
      dplyr::arrange(.data$subject_id, .data$cohort_start_date) |>
      dplyr::pull("indication_m2_to_0"),
    res012infS |>
      dplyr::arrange(.data$subject_id, .data$start_date) |>
      dplyr::pull("indication_m2_to_0")
  ))

  mockDisconnect(cdm = cdm)
})

test_that("test attributes", {
  skip_on_cran()
  targetCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 1, 2),
    subject_id = c(1, 1, 2, 3),
    cohort_start_date = as.Date(c(
      "2020-01-01", "2020-06-01", "2020-01-02", "2020-01-01"
    )),
    cohort_end_date = as.Date(c(
      "2020-04-01", "2020-08-01", "2020-02-02", "2020-03-01"
    ))
  )
  indicationCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 2, 1),
    subject_id = c(1, 3, 1, 1),
    cohort_start_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    )),
    cohort_end_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    ))
  )
  attr(indicationCohortName, "cohort_set") <- dplyr::tibble(
    cohort_definition_id = c(1, 2),
    cohort_name = c("asthma", "covid")
  )
  condition_occurrence <- dplyr::tibble(
    person_id = 1,
    condition_start_date = as.Date("2020-05-31"),
    condition_end_date = as.Date("2020-05-31"),
    condition_occurrence_id = 1,
    condition_concept_id = 0,
    condition_type_concept_id = 0
  )
  observationPeriod <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 2, 3),
    observation_period_start_date = as.Date(c(
      "2015-01-01", "2016-05-15", "2012-12-30"
    )),
    observation_period_end_date = as.Date("2024-01-01"),
    period_type_concept_id = 44814724
  )
  cdm <-
    mockDrugUtilisation(
      con = connection(),
      writeSchema = schema(),
      cohort1 = targetCohortName,
      cohort2 = indicationCohortName,
      condition_occurrence = condition_occurrence,
      observation_period = observationPeriod
    )

  cdm[["cohort1new"]] <- cdm[["cohort1"]] |>
    addIndication(
      indicationCohortName = "cohort2",
      indicationWindow = list(c(0, 0), c(-1, 0), c(-2, 0), c(-Inf, 0)), unknownIndicationTable = NULL
    )
  expect_identical(
    sort(names(attributes(cdm[["cohort1"]]))),
    sort(names(attributes(cdm[["cohort1new"]])))
  )


  expect_identical(
    class(cdm[["cohort1"]])[class(cdm[["cohort1"]]) != "GeneratedCohortSet"],
    class(cdm[["cohort1new"]])[class(cdm[["cohort1new"]]) != "GeneratedCohortSet"]
  )

  mockDisconnect(cdm = cdm)
})

test_that("summariseIndication", {
  targetCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 1, 2),
    subject_id = c(1, 1, 2, 3),
    cohort_start_date = as.Date(c(
      "2020-01-01", "2020-06-01", "2020-01-02", "2020-01-01"
    )),
    cohort_end_date = as.Date(c(
      "2020-04-01", "2020-08-01", "2020-02-02", "2020-03-01"
    ))
  )
  indicationCohortName <- dplyr::tibble(
    cohort_definition_id = c(1, 1, 2, 1),
    subject_id = c(1, 3, 1, 1),
    cohort_start_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    )),
    cohort_end_date = as.Date(c(
      "2019-12-30", "2020-01-01", "2020-05-25", "2020-05-25"
    ))
  )
  attr(indicationCohortName, "cohort_set") <- dplyr::tibble(
    cohort_definition_id = c(1, 2),
    cohort_name = c("asthma", "covid")
  )
  condition_occurrence <- dplyr::tibble(
    person_id = 1,
    condition_start_date = as.Date("2020-05-31"),
    condition_end_date = as.Date("2020-05-31"),
    condition_occurrence_id = 1,
    condition_concept_id = 0,
    condition_type_concept_id = 0
  )
  observationPeriod <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 2, 3),
    observation_period_start_date = as.Date(c(
      "2015-01-01", "2016-05-15", "2012-12-30"
    )),
    observation_period_end_date = as.Date("2024-01-01"),
    period_type_concept_id = 44814724
  )
  cdm <-
    mockDrugUtilisation(
      con = connection(),
      writeSchema = schema(),
      cohort1 = targetCohortName,
      cohort2 = indicationCohortName,
      condition_occurrence = condition_occurrence,
      observation_period = observationPeriod
    )

  result <- cdm[["cohort1"]] |>
    summariseIndication(
      indicationCohortName = "cohort2",
      unknownIndicationTable = "condition_occurrence",
      indicationWindow = list(c(0, 0), c(-7, 0), c(-30, 0), c(-Inf, 0))
    )

  expect_true(inherits(result, "summarised_result"))
  expect_true(any(grepl("Indication on index date", result$variable_name)))
  expect_true(any(grepl("Indication from 7 days before to the index date", result$variable_name)))
  expect_true(any(grepl("Indication from 30 days before to the index date", result$variable_name)))
  expect_true(any(grepl("Indication any time before or on index date", result$variable_name)))

  res <- cdm[["cohort1"]] |>
    PatientProfiles::addAge(
      ageGroup = list("<40" = c(0, 39), ">=40" = c(40, 150))
    ) |>
    PatientProfiles::addSex()

  result <- res |>
    summariseIndication(
      strata = list(
        "age_group",
        "sex",
        c("age_group", "sex")
      ),
      indicationCohortName = "cohort2",
      unknownIndicationTable = "condition_occurrence",
      indicationWindow = list(c(0, 0), c(-7, 0), c(-30, 0), c(-Inf, 0))
    )


  expect_true(inherits(result, "summarised_result"))
  x <- tidyr::expand_grid(
    group_level = omopgenerics::settings(res) |> dplyr::pull("cohort_name"),
    strata_name = c("overall", "age_group", "sex", "age_group &&& sex")
  ) |>
    dplyr::left_join(
      dplyr::tibble(
        strata_name = c(
          "age_group", "age_group", "sex", "sex", "age_group &&& sex",
          "age_group &&& sex", "age_group &&& sex", "age_group &&& sex",
          "overall"
        ),
        strata_level = c(
          "<40", ">=40", "Male", "Female", "<40 &&& Female", "<40 &&& Male",
          ">=40 &&& Female", ">=40 &&& Male", "overall"
        )
      ),
      by = "strata_name", relationship = "many-to-many"
    )
  expect_identical(
    nrow(result),
    result |>
      dplyr::inner_join(
        x,
        by = c("group_level", "strata_name", "strata_level")
      ) |>
      nrow()
  )
  expect_true(any(grepl("Indication on index date", result$variable_name)))
  expect_true(any(grepl("Indication from 7 days before to the index date", result$variable_name)))
  expect_true(any(grepl("Indication from 30 days before to the index date", result$variable_name)))
  expect_true(any(grepl("Indication any time before or on index date", result$variable_name)))

  expect_identical(
    "summarise_indication", unique(settings(result)$result_type)
  )

  mockDisconnect(cdm = cdm)
})