tests/testthat/test-studyPopulation.R

In CohortMethod: Comparative Cohort Method with Large Scale Propensity and Outcome Models

library(testthat)
library(CohortMethod)

set.seed(1234)
data(cohortMethodDataSimulationProfile)
sampleSize <- 1
tmpCmd <- simulateCohortMethodData(cohortMethodDataSimulationProfile, n = sampleSize)

cohortRow <- tmpCmd$cohorts |>
  collect()

outcomeRow <- tmpCmd$outcomes |>
  collect()

test_that("createStudyPop: removeSubjectsWithPriorOutcome", {
  tmpCmd$cohorts <- cohortRow
  outcomes <- outcomeRow
  outcomes$rowId[1] <- 1
  outcomes$daysToEvent[1] <- -10
  outcomes$outcomeId[1] <- 123
  tmpCmd$outcomes <- outcomes

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = FALSE)
  )
  expect_equal(nrow(sp), 1)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = TRUE)
  )
  expect_equal(nrow(sp), 0)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 999,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = TRUE)
  )
  expect_equal(nrow(sp), 1)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = TRUE,
                                                                priorOutcomeLookback = 9)
  )
  expect_equal(nrow(sp), 1)
})

test_that("createStudyPop: minDaysAtRisk", {
  cohorts <- cohortRow
  cohorts$rowId[1] <- 1
  cohorts$daysToCohortEnd[1] <- 10
  cohorts$daysToObsEnd[1] <- 10
  tmpCmd$cohorts <- cohorts

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 999,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(minDaysAtRisk = 1,
                                                                endAnchor = "cohort end")
  )
  expect_equal(nrow(sp), 1)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 999,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(minDaysAtRisk = 20,
                                                                endAnchor = "cohort end")
  )
  expect_equal(nrow(sp), 0)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 999,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(minDaysAtRisk = 11,
                                                                endAnchor = "cohort end")
  )
  expect_equal(nrow(sp), 1)

})

test_that("createStudyPop: maxDaysAtRisk", {
  cohorts <- cohortRow
  cohorts$rowId[1] <- 1
  cohorts$daysToCohortEnd[1] <- 10
  cohorts$daysToObsEnd[1] <- 10
  tmpCmd$cohorts <- cohorts

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 999,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(endAnchor = "cohort end")
  )
  expect_equal(sp$riskEnd, 10)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 999,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(maxDaysAtRisk = 5,
                                                                endAnchor = "cohort end")
  )
  expect_equal(sp$riskEnd, 5)
})

test_that("createStudyPop: risk window definition", {
  cohorts <- cohortRow
  cohorts$rowId[1] <- 1
  cohorts$daysToCohortEnd[1] <- 10
  cohorts$daysToObsEnd[1] <- 20
  tmpCmd$cohorts <- cohorts

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = FALSE,
                                                                startAnchor = "cohort start",
                                                                riskWindowStart = 0,
                                                                endAnchor = "cohort end",
                                                                riskWindowEnd = 0)
  )
  expect_equal(sp$timeAtRisk, 11)

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = FALSE,
                                                                startAnchor = "cohort start",
                                                                riskWindowStart = 1,
                                                                endAnchor = "cohort end",
                                                                riskWindowEnd = 0)
  )
  expect_equal(sp$timeAtRisk, 10)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(removeSubjectsWithPriorOutcome = FALSE,
                                                                startAnchor = "cohort start",
                                                                riskWindowStart = 0,
                                                                endAnchor = "cohort end",
                                                                riskWindowEnd = 9999)
  )
  expect_equal(sp$timeAtRisk, 21)
})

test_that("createStudyPop: censor at new risk window start", {
  cohorts <- bind_rows(cohortRow, cohortRow, cohortRow)
  cohorts$rowId <- c(1, 2, 3)
  cohorts$treatment <- c(1, 0, 1)
  cohorts$personSeqId <- c(1, 1, 2)
  cohorts$cohortStartDate <- as.Date(c("2000-01-01", "2000-02-01", "2000-01-01"))
  cohorts$daysToCohortEnd <- c(100, 100, 100)
  cohorts$daysToObsEnd <- c(1000, 1000, 1000)
  tmpCmd$cohorts <- cohorts

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 0,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(censorAtNewRiskWindow = TRUE)
  )
  expect_equal(sp$timeAtRisk, c(31, 101, 101))
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 0,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(censorAtNewRiskWindow = FALSE)
  )
  expect_equal(sp$timeAtRisk, c(101, 101, 101))
})

test_that("createStudyPop: outcomes", {
  outcomes <- outcomeRow
  outcomes$rowId[1] <- 1
  outcomes$daysToEvent[1] <- 15
  outcomes$outcomeId[1] <- 123
  cohorts <- cohortRow
  cohorts$rowId[1] <- 1
  cohorts$daysToCohortEnd[1] <- 10
  cohorts$daysToObsEnd[1] <- 20
  tmpCmd$outcomes <- outcomes
  tmpCmd$cohorts <- cohorts

  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(riskWindowEnd = 999)
  )
  expect_equal(sp$outcomeCount, 1)
  expect_equal(sp$survivalTime, 16)
  expect_equal(sp$daysToEvent, 15)
  sp <- createStudyPopulation(
    cohortMethodData = tmpCmd,
    outcomeId = 123,
    createStudyPopulationArgs = createCreateStudyPopulationArgs(riskWindowEnd = 0,
                                                                endAnchor = "cohort end")
  )
  expect_equal(sp$outcomeCount, 0)
  expect_equal(sp$survivalTime, 11)
})