tests/testthat/test-addPriorObservation.R

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

test_that("check input length and type for each of the arguments", {
  skip_on_cran()
  cdm <- mockPatientProfiles(con = connection(), writeSchema = writeSchema())

  expect_error(addPriorObservation("cdm$cohort1"))

  expect_error(addPriorObservation(cdm$cohort1, indexDate = "end_date"))

  mockDisconnect(cdm = cdm)
})

test_that("check condition_occurrence and cohort1 work", {
  skip_on_cran()
  # mock data
  cdm <- mockPatientProfiles(con = connection(), writeSchema = writeSchema())
  # check it works with cohort1 table in mockdb
  expect_true(typeof(cdm$cohort1 %>% addPriorObservation() %>% dplyr::collect()) == "list")
  expect_true("prior_observation" %in% colnames(cdm$cohort1 %>% addPriorObservation()))
  # check it works with condition_occurrence table in mockdb
  expect_true(typeof(cdm$condition_occurrence %>% addPriorObservation(indexDate = "condition_start_date") %>% dplyr::collect()) == "list")
  expect_true("prior_observation" %in% colnames(cdm$condition_occurrence %>% addPriorObservation(indexDate = "condition_start_date")))

  mockDisconnect(cdm = cdm)
})

test_that("check working example with cohort1", {
  skip_on_cran()
  # create mock tables for testing
  cohort1 <- dplyr::tibble(
    cohort_definition_id = 1:3,
    subject_id = 1:3,
    cohort_start_date = as.Date(c("2010-03-03", "2010-03-01", "2010-02-01")),
    cohort_end_date = as.Date(c("2011-01-01", "2011-01-01", "2011-01-01"))
  )

  obs1 <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 2, 3),
    observation_period_start_date = as.Date(c(
      "2010-02-03", "2010-02-01", "2010-01-01"
    )),
    observation_period_end_date = as.Date(c(
      "2014-01-01", "2012-01-01", "2012-01-01"
    )),
    period_type_concept_id = 0L
  )

  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    seed = 1,
    cohort1 = cohort1,
    observation_period = obs1,
    cohort2 = cohort1
  )

  result <- cdm$cohort1 %>%
    addPriorObservation() %>%
    dplyr::collect()

  expect_true(all(colnames(cohort1) %in% colnames(result)))

  expect_true(all(
    result |>
      dplyr::arrange(.data$subject_id) |>
      dplyr::pull("prior_observation") == c(28, 28, 31)
  ))

  mockDisconnect(cdm = cdm)
})

test_that("check working example with condition_occurrence", {
  skip_on_cran()
  # create mock tables for testing
  condition_occurrence <- dplyr::tibble(
    condition_occurrence_id = 1L,
    person_id = 1:3,
    condition_start_date = as.Date(c("2010-03-03", "2010-03-01", "2010-02-01")),
    condition_end_date = as.Date(c("2015-01-01", "2013-01-01", "2013-01-01")),
    condition_concept_id = 0L,
    condition_type_concept_id = 0L
  )

  obs1 <- dplyr::tibble(
    observation_period_id = 1:3,
    person_id = 1:3,
    observation_period_start_date = as.Date(c(
      "2010-02-03", "2010-02-01", "2010-01-01"
    )),
    observation_period_end_date = as.Date(c(
      "2014-01-01", "2012-01-01", "2012-01-01"
    )),
    period_type_concept_id = 0L
  )

  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    seed = 1,
    condition_occurrence = condition_occurrence,
    observation_period = obs1
  )

  result <- cdm$condition_occurrence %>%
    addPriorObservation(indexDate = "condition_start_date") %>%
    dplyr::collect()

  expect_true(all(
    result |>
      dplyr::arrange(.data$person_id) |>
      dplyr::pull("prior_observation") == c(28, 28, 31)
  ))

  mockDisconnect(cdm = cdm)
})

test_that("different name", {
  skip_on_cran()
  # create mock tables for testing
  conditionOccurrence <- dplyr::tibble(
    condition_occurrence_id = 1L,
    person_id = 1:3,
    condition_start_date = as.Date(c("2010-03-03", "2010-03-01", "2010-02-01")),
    condition_end_date = as.Date(c("2015-01-01", "2013-01-01", "2013-01-01")),
    condition_concept_id = 0L,
    condition_type_concept_id = 0L
  )

  obs1 <- dplyr::tibble(
    observation_period_id = 1:3,
    person_id = 1:3,
    observation_period_start_date = as.Date(c(
      "2010-02-03", "2010-02-01", "2010-01-01"
    )),
    observation_period_end_date = as.Date(c(
      "2014-01-01", "2012-01-01", "2012-01-01"
    )),
    period_type_concept_id = 0L
  )

  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    seed = 1,
    condition_occurrence = conditionOccurrence,
    observation_period = obs1
  )

  cdm$condition_occurrence <- cdm$condition_occurrence %>%
    addPriorObservation(
      indexDate = "condition_start_date", priorObservationName = "ph"
    )
  expect_true("ph" %in% colnames(cdm$condition_occurrence))

  x <- cdm$cohort1 |>
    addPriorObservation(priorObservationType = "days") |>
    addPriorObservation(
      priorObservationType = "date", priorObservationName = "col"
    ) |>
    dplyr::left_join(
      cdm$observation_period |>
        dplyr::select(
          "subject_id" = "person_id",
          "obs_start" = "observation_period_start_date"
        ),
      by = "subject_id"
    ) %>%
    dplyr::mutate("diff" = !!CDMConnector::datediff(
      "cohort_start_date", "obs_start"
    )) |>
    dplyr::collect()

  expect_equal(x$prior_observation, -x$diff)
  expect_equal(x$col, x$obs_start)

  mockDisconnect(cdm = cdm)
})

test_that("multiple observation periods", {
  skip_on_cran()
  # with multiple observation periods,
  # prior history should relate to the most recent observation start date

  person <- dplyr::tibble(
    person_id = c(1, 2),
    gender_concept_id = 1L,
    year_of_birth = 1980L,
    month_of_birth = 1L,
    day_of_birth = 1L,
    race_concept_id = 0L,
    ethnicity_concept_id = 0L
  )
  observation_period <- dplyr::tibble(
    observation_period_id = c(1, 2, 3),
    person_id = c(1, 1, 2),
    observation_period_start_date = as.Date(c(
      "2000-01-01", "2010-01-01", "2010-01-01"
    )),
    observation_period_end_date = as.Date(c(
      "2005-01-01", "2015-01-01", "2015-01-01"
    )),
    period_type_concept_id = 0L
  )
  cohort1 <- dplyr::tibble(
    cohort_definition_id = 1L,
    subject_id = c(1, 2),
    cohort_start_date = as.Date(c("2012-02-01")),
    cohort_end_date = as.Date(c("2013-02-01"))
  )

  cdm <- mockPatientProfiles(
    con = connection(),
    writeSchema = writeSchema(),
    person = person,
    observation_period = observation_period,
    cohort1 = cohort1
  )

  cdm$cohort1a <- cdm$cohort1 %>%
    addPriorObservation(indexDate = "cohort_start_date")

  expect_true(nrow(cdm$cohort1a %>% dplyr::collect()) == 2)
  expect_true(all(
    cdm$cohort1a %>%
      dplyr::pull(prior_observation) == as.numeric(difftime(
      as.Date("2012-02-01"), as.Date("2010-01-01"),
      units = "days"
    ))
  ))

  mockDisconnect(cdm = cdm)
})