tests/testthat/test-eunomia.R

In SelfControlledCaseSeries: Self-Controlled Case Series

library(SelfControlledCaseSeries)
library(testthat)

if (!isFALSE(tryCatch(find.package("Eunomia"), error = function(e) FALSE))) {

  connectionDetails <- Eunomia::getEunomiaConnectionDetails()
  Eunomia::createCohorts(connectionDetails)

  # connection <- connect(connectionDetails)

  test_that("Running multiple analyses against Eunomia", {
    outputFolder <- tempfile(pattern = "sccsOutput")
    on.exit(unlink(outputFolder, recursive = TRUE))

    exposuresOutcomeList <- list(
      createExposuresOutcome(
        exposures = list(
          createExposure(exposureId = 1),
          createExposure(exposureId = 2, exposureIdRef = "exposureId2")
        ),
        outcomeId = 3
      ),
      createExposuresOutcome(
        exposures = list(createExposure(exposureId = 1)),
        outcomeId = 4
      ),
      createExposuresOutcome(
        exposures = list(createExposure(exposureId = 1)),
        outcomeId = 3,
        nestingCohortId = 4
      ),
      createExposuresOutcome(
        exposures = list(createExposure(exposureId = 999)),
        outcomeId = 4
      ),
      createExposuresOutcome(
        exposures = list(createExposure(exposureId = 1)),
        outcomeId = 999
      )
    )

    getDbSccsDataArgs <- createGetDbSccsDataArgs(deleteCovariatesSmallCount = 1,
                                                 studyStartDates = "20000101",
                                                 studyEndDates = "20500101")

    createStudyPopulationArgs1 <- createCreateStudyPopulationArgs(
      naivePeriod = 180,
      firstOutcomeOnly = FALSE,
      genderConceptIds = 8507,
      restrictTimeToEraId = "exposureId"
    )

    createStudyPopulationArgs2 <- createCreateStudyPopulationArgs(
      naivePeriod = 180,
      firstOutcomeOnly = FALSE
    )

    covarExposureOfInt <- createEraCovariateSettings(
      label = "Exposure of interest",
      includeEraIds = "exposureId",
      start = 0,
      end = 7,
      endAnchor = "era start",
      profileLikelihood = TRUE,
      exposureOfInterest = TRUE
    )

    covarExposureOfInt2 <- createEraCovariateSettings(
      label = "Exposure of interest 2",
      includeEraIds = "exposureId2",
      start = 0,
      end = 7,
      endAnchor = "era start"
    )

    calendarTimeSettings <- createCalendarTimeCovariateSettings(calendarTimeKnots = 5)

    seasonalitySettings <- createSeasonalityCovariateSettings(seasonKnots = 5)

    covarPreExp <- createEraCovariateSettings(
      label = "Pre-exposure",
      includeEraIds = c("exposureId", "exposureId2"),
      start = -30,
      end = -1,
      endAnchor = "era start",
      exposureOfInterest = FALSE,
      preExposure = TRUE
    )

    createSccsIntervalDataArgs <- createCreateSccsIntervalDataArgs(
      eraCovariateSettings = list(
        covarExposureOfInt,
        covarExposureOfInt2,
        covarPreExp
      ),
      calendarTimeCovariateSettings = calendarTimeSettings,
      seasonalityCovariateSettings = seasonalitySettings
    )

    fitSccsModelArgs <- createFitSccsModelArgs()

    sccsAnalysis1 <- createSccsAnalysis(
      analysisId = 1,
      description = "SCCS",
      getDbSccsDataArgs = getDbSccsDataArgs,
      createStudyPopulationArgs = createStudyPopulationArgs1,
      createIntervalDataArgs = createSccsIntervalDataArgs,
      fitSccsModelArgs = fitSccsModelArgs
    )

    controlIntervalSettings <- createControlIntervalSettings(
      start = -180,
      end = -1,
      endAnchor = "era start"
    )

    createScriIntervalDataArgs <- createCreateScriIntervalDataArgs(
      eraCovariateSettings = covarExposureOfInt,
      controlIntervalSettings = controlIntervalSettings
    )

    sccsAnalysis2 <- createSccsAnalysis(
      analysisId = 2,
      description = "SCRI",
      getDbSccsDataArgs = getDbSccsDataArgs,
      createStudyPopulationArgs = createStudyPopulationArgs2,
      createIntervalDataArgs = createScriIntervalDataArgs,
      fitSccsModelArgs = fitSccsModelArgs
    )

    sccsAnalysisList <- list(sccsAnalysis1, sccsAnalysis2)

    analysesToExclude <- data.frame(
      exposureId = c(1),
      outcomeId = c(4)
    )
    sccsAnalysesSpecifications <- createSccsAnalysesSpecifications(
      exposuresOutcomeList = exposuresOutcomeList,
      sccsAnalysisList = sccsAnalysisList,
      analysesToExclude = analysesToExclude
    )

    # Expect warning because outcome 999 does not exist in data:
    expect_warning(
      {
        result <- runSccsAnalyses(
          connectionDetails = connectionDetails,
          cdmDatabaseSchema = "main",
          exposureDatabaseSchema = "main",
          exposureTable = "cohort",
          outcomeDatabaseSchema = "main",
          outcomeTable = "cohort",
          outputFolder = outputFolder,
          sccsAnalysesSpecifications = sccsAnalysesSpecifications
        )
      },
      "No cases left in study population"
    )
    ref <- getFileReference(outputFolder)
    expect_equal(nrow(ref), 8)

    # analysesToExclude was enforced:
    expect_false(any(ref$exposureId == 1 & ref$outcomeId == 4))

    model <- readRDS(file.path(outputFolder, result$sccsModelFile[1]))
    expect_true(max(grepl("gender", getAttritionTable(model)$description)) == 1)

    model <- readRDS(file.path(outputFolder, pull(filter(ref, nestingCohortId  == 4), sccsModelFile)[1]))
    expect_true(max(grepl("nesting", getAttritionTable(model)$description)) == 1)

    analysisSum <- getResultsSummary(outputFolder)

    expect_equal(nrow(analysisSum), 8)

    # sccsData <- loadSccsData(file.path(outputFolder, ref$sccsDataFile[5]))
    # sccsData$eraRef

    # Assert appropriate designs:
    sccsIntervalData <- loadSccsIntervalData(file.path(outputFolder, pull(filter(ref, analysisId == 1), sccsIntervalDataFile)[1]))
    expect_equal(attr(sccsIntervalData, "metaData")$design, "SCCS")

    sccsIntervalData <- loadSccsIntervalData(file.path(outputFolder, pull(filter(ref, analysisId == 2), sccsIntervalDataFile)[1]))
    expect_equal(attr(sccsIntervalData, "metaData")$design, "SCRI")

    # Test export to CSV:
    exportToCsv(outputFolder)

    # Workaround for issue https://github.com/tidyverse/vroom/issues/519:
    diagnosticsSummary <- readr::read_csv(file.path(outputFolder, "export", "sccs_diagnostics_summary.csv"), show_col_types = FALSE)
    expect_true(all(diagnosticsSummary$ease_diagnostic == "NOT EVALUATED"))

    # Make sure exposures_outcome_set_id is consistent across table:
    exposure <- readr::read_csv(file.path(outputFolder, "export", "sccs_exposure.csv"), show_col_types = FALSE)
    eos <- readr::read_csv(file.path(outputFolder, "export", "sccs_exposures_outcome_set.csv"), show_col_types = FALSE)
    expect_length(setdiff(unique(diagnosticsSummary$exposures_outcome_set_id),
                          unique(exposure$exposures_outcome_set_id)),
                  0)
    expect_length(setdiff(unique(eos$exposures_outcome_set_id),
                          unique(exposure$exposures_outcome_set_id)),
                  0)

    specs <- readr::read_csv(
      file = system.file("csv", "resultsDataModelSpecification.csv", package = "SelfControlledCaseSeries"),
      show_col_types = FALSE
    ) |>
      SqlRender::snakeCaseToCamelCaseNames()

    specs <- split(specs, specs$tableName)
    # tableSpecs = specs[[1]]
    for (tableSpecs in specs) {
      fileName <- file.path(outputFolder, "export", sprintf("%s.csv", tableSpecs$tableName[1]))
      expect_true(file.exists(fileName))
      table <- readr::read_csv(fileName, show_col_types = FALSE)
      expect_setequal(colnames(table), tableSpecs$columnName)
    }

    # unlink(outputFolder, recursive = TRUE)
  })

  test_that("Fetching data from drug_era and condition_era tables from Eunomia", {
    # 192671 = Gastrointestinal haemorrhage
    # 1118084 = Celecoxib
    sccsData <- SelfControlledCaseSeries::getDbSccsData(
      connectionDetails = connectionDetails,
      cdmDatabaseSchema = "main",
      exposureTable = "drug_era",
      outcomeTable = "condition_era",
      outcomeIds = 192671,
      getDbSccsDataArgs = createGetDbSccsDataArgs(
        exposureIds = 1118084
      )
    )
    expect_s4_class(sccsData, "SccsData")
  })

  # Remove the Eunomia database:
  unlink(connectionDetails$server())
}