tests/testthat/test-ResultsDataModel.R

In SelfControlledCaseSeries: Self-Controlled Case Series

library(SelfControlledCaseSeries)
library(testthat)

credentialsSet <- Sys.getenv("CDM5_POSTGRESQL_SERVER") != ""

if (credentialsSet) {

  if (dir.exists(Sys.getenv("DATABASECONNECTOR_JAR_FOLDER"))) {
    jdbcDriverFolder <- Sys.getenv("DATABASECONNECTOR_JAR_FOLDER")
  } else {
    jdbcDriverFolder <- "~/.jdbcDrivers"
    dir.create(jdbcDriverFolder, showWarnings = FALSE)
    DatabaseConnector::downloadJdbcDrivers("postgresql", pathToDriver = jdbcDriverFolder)
    withr::defer(
      {
        unlink(jdbcDriverFolder, recursive = TRUE, force = TRUE)
      },
      testthat::teardown_env()
    )
  }

  postgresConnectionDetails <- DatabaseConnector::createConnectionDetails(
    dbms = "postgresql",
    user = Sys.getenv("CDM5_POSTGRESQL_USER"),
    password = URLdecode(Sys.getenv("CDM5_POSTGRESQL_PASSWORD")),
    server = Sys.getenv("CDM5_POSTGRESQL_SERVER"),
    pathToDriver = jdbcDriverFolder
  )

  postgresResultsDatabaseSchema <- paste0("r", Sys.getpid(), format(Sys.time(), "%s"), sample(1:100, 1))

  databaseFile <- tempfile(fileext = ".sqlite")
  sqliteConnectionDetails <- DatabaseConnector::createConnectionDetails(
    dbms = "sqlite",
    server = databaseFile
  )
  sqliteResultsDatabaseSchema <- "main"

  withr::defer({
    connection <- DatabaseConnector::connect(connectionDetails = postgresConnectionDetails)
    sql <- "DROP SCHEMA IF EXISTS @resultsDatabaseSchema CASCADE;"
    DatabaseConnector::renderTranslateExecuteSql(
      sql = sql,
      resultsDatabaseSchema = postgresResultsDatabaseSchema,
      connection = connection
    )

    DatabaseConnector::disconnect(connection)
    unlink(databaseFile, force = TRUE)
  },
  testthat::teardown_env()
  )

  testCreateSchema <- function(connectionDetails, resultsDatabaseSchema) {
    connection <- DatabaseConnector::connect(connectionDetails)
    on.exit(DatabaseConnector::disconnect(connection))
    if (connectionDetails$dbms != "sqlite") {
      sql <- "CREATE SCHEMA @resultsDatabaseSchema;"
      DatabaseConnector::renderTranslateExecuteSql(
        sql = sql,
        resultsDatabaseSchema = resultsDatabaseSchema,
        connection = connection
      )
    }
    suppressWarnings(
      createResultsDataModel(
        connectionDetails = connectionDetails,
        databaseSchema = resultsDatabaseSchema,
        tablePrefix = ""
      )
    )
    specifications <- getResultsDataModelSpecifications()
    for (tableName in unique(specifications$tableName)) {
      expect_true(DatabaseConnector::existsTable(connection = connection,
                                                 databaseSchema = resultsDatabaseSchema,
                                                 tableName = tableName))
      row <- DatabaseConnector::renderTranslateQuerySql(
        connection = connection,
        sql = "SELECT TOP 1 * FROM @database_schema.@table;",
        database_schema = resultsDatabaseSchema,
        table = tableName
      )
      observedFields <- sort(tolower(names(row)))
      expectedFields <- sort(tolower(specifications$columnName[specifications$tableName == tableName]))
      expect_equal(observedFields, expectedFields)
    }
    # Bad schema name
    expect_error(createResultsDataModel(
      connectionDetails = connectionDetails,
      databaseSchema = "non_existant_schema"
    ))
  }

  test_that("Create schema", {
    # Skipping to avoid 'vector memory limit of 16.0 Gb reached' error on MacOS in GitHub Actions.
    # Possible caused by large chunk size in ResultModelManager: https://github.com/OHDSI/ResultModelManager/blob/15f3a81acd8b23a571881ddb31e24507688efe83/R/DataModel.R#L507
    # This test does not throw an error on local MacOS machine with same OS and R version, so guessing this is due to limits of GA VM.
    # Note: this test did not throw an error before Nov 2024, and RMM code hasn't changed, so may be related to some updates in tidyverse?
    skip_on_os("mac")
    testCreateSchema(connectionDetails = postgresConnectionDetails,
                     resultsDatabaseSchema = postgresResultsDatabaseSchema)
    testCreateSchema(connectionDetails = sqliteConnectionDetails,
                     resultsDatabaseSchema = sqliteResultsDatabaseSchema)
  })

  testUploadResults <- function(connectionDetails, resultsDatabaseSchema) {
    uploadResults(
      connectionDetails = connectionDetails,
      schema = resultsDatabaseSchema,
      zipFileName = system.file("Results_Eunomia.zip", package = "SelfControlledCaseSeries"),
      purgeSiteDataBeforeUploading = FALSE)

    # Check if there's data:
    connection <- DatabaseConnector::connect(connectionDetails)
    on.exit(DatabaseConnector::disconnect(connection))

    specifications <- getResultsDataModelSpecifications()
    for (tableName in unique(specifications$tableName)) {
      primaryKey <- specifications |>
        dplyr::filter(tableName == !!tableName &
                        primaryKey == "Yes") |>
        dplyr::select(columnName) |>
        dplyr::pull()

      if ("database_id" %in% primaryKey) {
        sql <- "SELECT COUNT(*) FROM @database_schema.@table_name WHERE database_id = '@database_id';"
        databaseIdCount <- DatabaseConnector::renderTranslateQuerySql(
          connection = connection,
          sql = sql,
          database_schema = resultsDatabaseSchema,
          table_name = tableName,
          database_id = "Eunomia"
        )[, 1]
        expect_true(databaseIdCount >= 0)
      }
    }
  }

  test_that("Results upload", {
    # Skipping for reasons described above:
    skip_on_os("mac")
    testUploadResults(connectionDetails = postgresConnectionDetails,
                      resultsDatabaseSchema = postgresResultsDatabaseSchema)
    testUploadResults(connectionDetails = sqliteConnectionDetails,
                      resultsDatabaseSchema = sqliteResultsDatabaseSchema)
  })
}