tests/testthat/test-removeOverlappingSubjects.R

In CohortAlgebra: Use of Interval Algebra to Create New Cohort(s) from Existing Cohorts

testthat::test_that("Testing Remove Subjects from cohorts", {
  testthat::skip_if(condition = skipCdmTests)

  # make up date for a cohort table
  cohort <- dplyr::tibble(
    cohortDefinitionId = c(1, 1, 3, 5),
    subjectId = c(1, 2, 2, 2),
    cohortStartDate = c(
      as.Date("1999-01-01"),
      as.Date("2010-01-01"),
      as.Date("1999-01-15"),
      as.Date("1999-01-01")
    ),
    cohortEndDate = c(
      as.Date("1999-01-31"),
      as.Date("2010-01-05"),
      as.Date("1999-01-25"),
      as.Date("1999-01-31")
    )
  )

  # upload table
  connection <-
    DatabaseConnector::connect(connectionDetails = connectionDetails)
  DatabaseConnector::insertTable(
    connection = connection,
    databaseSchema = cohortDatabaseSchema,
    tableName = cohortTableName,
    data = cohort,
    dropTableIfExists = TRUE,
    createTable = TRUE,
    tempTable = FALSE,
    camelCaseToSnakeCase = TRUE,
    progressBar = FALSE
  )

  removeOverlappingSubjects(
    connection = connection,
    cohortDatabaseSchema = cohortDatabaseSchema,
    offsetCohortStartDate = -99999,
    offsetCohortEndDate = 99999,
    tempEmulationSchema = tempEmulationSchema,
    cohortId = 1,
    newCohortId = 6,
    cohortsWithSubjectsToRemove = c(3),
    purgeConflicts = FALSE,
    cohortTable = cohortTableName
  )

  cohortExpected <- dplyr::tibble(
    cohortDefinitionId = c(6),
    subjectId = c(1),
    cohortStartDate = as.Date("1999-01-01"),
    cohortEndDate = as.Date("1999-01-31")
  )

  cohortObserved <-
    DatabaseConnector::renderTranslateQuerySql(
      connection = connection,
      sql = paste0(
        "SELECT * FROM @cohort_database_schema.@table_name
        WHERE cohort_definition_id = 6
        order by cohort_definition_id, subject_id, cohort_start_date;"
      ),
      cohort_database_schema = cohortDatabaseSchema,
      table_name = cohortTableName,
      snakeCaseToCamelCase = TRUE
    ) |>
    dplyr::tibble()

  testthat::expect_equal(
    object = cohortObserved |>
      nrow(),
    expected = 1
  )
  testthat::expect_true(object = all.equal(target = cohortExpected, current = cohortObserved))

  ####################

  removeOverlappingSubjects(
    connection = connection,
    cohortDatabaseSchema = cohortDatabaseSchema,
    cohortId = 1,
    newCohortId = 11,
    cohortsWithSubjectsToRemove = c(5),
    purgeConflicts = FALSE,
    offsetCohortStartDate = 0,
    offsetCohortEndDate = 0,
    cohortTable = cohortTableName
  )

  cohortExpected <- cohort |>
    dplyr::filter(cohortDefinitionId == 1)

  cohortObserved <-
    DatabaseConnector::renderTranslateQuerySql(
      connection = connection,
      sql = paste0(
        "SELECT * FROM @cohort_database_schema.@table_name
        WHERE cohort_definition_id = 11
        order by cohort_definition_id, subject_id, cohort_start_date;"
      ),
      cohort_database_schema = cohortDatabaseSchema,
      table_name = cohortTableName,
      snakeCaseToCamelCase = TRUE
    ) |>
    dplyr::tibble()

  testthat::expect_equal(
    object = cohortObserved |>
      nrow(),
    expected = 2
  )
  testthat::expect_true(object = all.equal(
    target = cohortExpected,
    current = cohortObserved |>
      dplyr::mutate(cohortDefinitionId = 1)
  ))


  ####################


  testthat::expect_error(
    removeOverlappingSubjects(
      connection = connection,
      cohortDatabaseSchema = cohortDatabaseSchema,
      cohortId = 1,
      newCohortId = 1,
      cohortsWithSubjectsToRemove = c(3),
      purgeConflicts = FALSE,
      cohortTable = cohortTableName
    )
  )

  removeOverlappingSubjects(
    connection = connection,
    cohortDatabaseSchema = cohortDatabaseSchema,
    cohortId = 1,
    newCohortId = 1,
    cohortsWithSubjectsToRemove = c(3),
    purgeConflicts = TRUE,
    cohortTable = cohortTableName
  )

  cohortExpected <- dplyr::tibble(
    cohortDefinitionId = c(1),
    subjectId = c(1),
    cohortStartDate = as.Date("1999-01-01"),
    cohortEndDate = as.Date("1999-01-31")
  )

  cohortObserved <-
    DatabaseConnector::renderTranslateQuerySql(
      connection = connection,
      sql = paste0(
        "SELECT * FROM @cohort_database_schema.@table_name
        WHERE cohort_definition_id = 1
        order by cohort_definition_id, subject_id, cohort_start_date;"
      ),
      cohort_database_schema = cohortDatabaseSchema,
      table_name = cohortTableName,
      snakeCaseToCamelCase = TRUE
    ) |>
    dplyr::tibble()

  testthat::expect_equal(
    object = cohortObserved |>
      nrow(),
    expected = 1
  )
  testthat::expect_true(object = all.equal(target = cohortExpected, current = cohortObserved))

  DatabaseConnector::disconnect(connection = connection)


  #######################################
  removeOverlappingSubjects(
    connectionDetails = connectionDetails,
    cohortDatabaseSchema = cohortDatabaseSchema,
    cohortId = 5,
    newCohortId = 7,
    cohortsWithSubjectsToRemove = c(3),
    purgeConflicts = TRUE,
    cohortTable = cohortTableName
  )

  cohortExpected <- cohort |>
    dplyr::slice(0)

  cohortObserved <-
    DatabaseConnector::renderTranslateQuerySql(
      connection = DatabaseConnector::connect(connectionDetails = connectionDetails),
      sql = "SELECT * FROM @cohort_database_schema.@table_name
             WHERE cohort_definition_id = 7
             order by cohort_definition_id, subject_id, cohort_start_date;",
      cohort_database_schema = cohortDatabaseSchema,
      table_name = cohortTableName,
      snakeCaseToCamelCase = TRUE
    ) |>
    dplyr::tibble()

  testthat::expect_equal(
    object = cohortObserved |>
      nrow(),
    expected = 0
  )
  testthat::expect_true(object = all.equal(target = cohortExpected, current = cohortObserved))

  DatabaseConnector::renderTranslateExecuteSql(
    connection = DatabaseConnector::connect(connectionDetails = connectionDetails),
    sql = "DROP TABLE IF EXISTS @cohort_database_schema.@table_temp;",
    table_temp = cohortTableName,
    cohort_database_schema = cohortDatabaseSchema
  )
})