tests/testthat/setup.R

In FeatureExtraction: Generating Features for a Cohort

library(testthat)
library(FeatureExtraction)
library(dplyr)

dbms <- getOption("dbms", default = "sqlite")
message("************* Testing on ", dbms, " *************\n")

# Unit Test Settings ------
# Set a directory for the JDBC drivers used in the tests
oldJarFolder <- Sys.getenv("DATABASECONNECTOR_JAR_FOLDER")
tempJdbcDriverFolder <- tempfile("jdbcDrivers")
dir.create(tempJdbcDriverFolder, recursive = TRUE)
Sys.setenv("DATABASECONNECTOR_JAR_FOLDER" = tempJdbcDriverFolder)

withr::defer(
  {
    unlink(Sys.getenv("DATABASECONNECTOR_JAR_FOLDER"), recursive = TRUE, force = TRUE)
    Sys.setenv("DATABASECONNECTOR_JAR_FOLDER" = oldJarFolder)
  },
  testthat::teardown_env()
)

# The cohort table is a temp table but uses the same platform/datetime suffix to avoid collisions when running
# tests in parallel
tableSuffix <- paste0(substr(.Platform$OS.type, 1, 3), format(Sys.time(), "%y%m%d%H%M%S"), sample(1:100, 1))
cohortTable <- paste0("#fe", tableSuffix)
cohortAttributeTable <- paste0("c_attr_", tableSuffix)
attributeDefinitionTable <- paste0("attr_def_", tableSuffix)

# Helper functions ------------
getTestResourceFilePath <- function(fileName) {
  return(system.file("testdata", fileName, package = "FeatureExtraction"))
}

# Use this instead of SqlRender directly to avoid errors when running
# individual test files
loadRenderTranslateUnitTestSql <- function(sqlFileName, targetDialect, tempEmulationSchema = NULL, ...) {
  sql <- SqlRender::readSql(system.file("sql/sql_server/unit_tests/", sqlFileName, package = "FeatureExtraction"))
  sql <- SqlRender::render(sql = sql, ...)
  sql <- SqlRender::translate(sql = sql, targetDialect = targetDialect, tempEmulationSchema = tempEmulationSchema)
  return(sql)
}

# create unit test data
createUnitTestData <- function(connectionDetails, cdmDatabaseSchema, ohdsiDatabaseSchema, cohortTable, cohortAttributeTable, attributeDefinitionTable, cohortDefinitionIds = c(1)) {
  connection <- DatabaseConnector::connect(connectionDetails)
  sql <- loadRenderTranslateUnitTestSql(
    sqlFileName = "createTestingData.sql",
    targetDialect = connectionDetails$dbms,
    tempEmulationSchema = ohdsiDatabaseSchema,
    attribute_definition_table = attributeDefinitionTable,
    cdm_database_schema = cdmDatabaseSchema,
    cohort_attribute_table = cohortAttributeTable,
    cohort_database_schema = ohdsiDatabaseSchema,
    cohort_definition_ids = cohortDefinitionIds,
    cohort_table = cohortTable
  )
  DatabaseConnector::executeSql(connection, sql)
  return(connection)
}

dropUnitTestData <- function(connection, ohdsiDatabaseSchema, cohortTable, cohortAttributeTable, attributeDefinitionTable) {
  sql <- loadRenderTranslateUnitTestSql(
    sqlFileName = "dropTestingData.sql",
    targetDialect = connection@dbms,
    tempEmulationSchema = ohdsiDatabaseSchema,
    attribute_definition_table = attributeDefinitionTable,
    cohort_attribute_table = cohortAttributeTable,
    cohort_database_schema = ohdsiDatabaseSchema,
    cohort_table = cohortTable
  )
  DatabaseConnector::executeSql(connection, sql)
  DatabaseConnector::disconnect(connection)
}

checkRemoteFileAvailable <- function(remoteFile) {
  try_GET <- function(x, ...) {
    tryCatch(
      httr::GET(url = x, httr::timeout(1), ...),
      error = function(e) conditionMessage(e),
      warning = function(w) conditionMessage(w)
    )
  }
  is_response <- function(x) {
    class(x) == "response"
  }
  
  # First check internet connection
  if (!curl::has_internet()) {
    message("No internet connection.")
    return(NULL)
  }
  # Then try for timeout problems
  resp <- try_GET(remoteFile)
  if (!is_response(resp)) {
    message(resp)
    return(NULL)
  }
  # Then stop if status > 400
  if (httr::http_error(resp)) { 
    message_for_status(resp)
    return(NULL)
  }
  return("success")
}

# Database Test Settings -----------
# postgres
if (dbms == "postgresql") {
  DatabaseConnector::downloadJdbcDrivers("postgresql")
  pgConnectionDetails <- createConnectionDetails(
    dbms = "postgresql",
    user = Sys.getenv("CDM5_POSTGRESQL_USER"),
    password = URLdecode(Sys.getenv("CDM5_POSTGRESQL_PASSWORD")),
    server = Sys.getenv("CDM5_POSTGRESQL_SERVER")
  )
  pgCdmDatabaseSchema <- Sys.getenv("CDM5_POSTGRESQL_CDM_SCHEMA")
  pgOhdsiDatabaseSchema <- Sys.getenv("CDM5_POSTGRESQL_OHDSI_SCHEMA")
}

# sql server
if (dbms == "sql server") {
  DatabaseConnector::downloadJdbcDrivers("sql server")
  sqlServerConnectionDetails <- createConnectionDetails(
    dbms = "sql server",
    user = Sys.getenv("CDM5_SQL_SERVER_USER"),
    password = URLdecode(Sys.getenv("CDM5_SQL_SERVER_PASSWORD")),
    server = Sys.getenv("CDM5_SQL_SERVER_SERVER")
  )
  sqlServerCdmDatabaseSchema <- Sys.getenv("CDM5_SQL_SERVER_CDM_SCHEMA")
  sqlServerOhdsiDatabaseSchema <- Sys.getenv("CDM5_SQL_SERVER_OHDSI_SCHEMA")
}

# oracle
if (dbms == "oracle") {
  DatabaseConnector::downloadJdbcDrivers("oracle")
  oracleConnectionDetails <- createConnectionDetails(
    dbms = "oracle",
    user = Sys.getenv("CDM5_ORACLE_USER"),
    password = URLdecode(Sys.getenv("CDM5_ORACLE_PASSWORD")),
    server = Sys.getenv("CDM5_ORACLE_SERVER")
  )
  oracleCdmDatabaseSchema <- Sys.getenv("CDM5_ORACLE_CDM_SCHEMA")
  oracleOhdsiDatabaseSchema <- Sys.getenv("CDM5_ORACLE_OHDSI_SCHEMA")
  # Set the tempEmulationSchema globally
  options(sqlRenderTempEmulationSchema = oracleOhdsiDatabaseSchema)
}

# redshift
if (dbms == "redshift") {
  DatabaseConnector::downloadJdbcDrivers("redshift")
  redshiftConnectionDetails <- createConnectionDetails(
    dbms = "redshift",
    user = Sys.getenv("CDM5_REDSHIFT_USER"),
    password = URLdecode(Sys.getenv("CDM5_REDSHIFT_PASSWORD")),
    server = Sys.getenv("CDM5_REDSHIFT_SERVER")
  )
  redshiftCdmDatabaseSchema <- Sys.getenv("CDM5_REDSHIFT_CDM_SCHEMA")
  redshiftOhdsiDatabaseSchema <- Sys.getenv("CDM5_REDSHIFT_OHDSI_SCHEMA")
}

# eunomia
if (dbms == "sqlite") {
  if (!is.null(checkRemoteFileAvailable("https://raw.githubusercontent.com/OHDSI/EunomiaDatasets/main/datasets/GiBleed/GiBleed_5.3.zip"))) {
    eunomiaConnectionDetails <- Eunomia::getEunomiaConnectionDetails(databaseFile = "testEunomia.sqlite")
    eunomiaCdmDatabaseSchema <- "main"
    eunomiaOhdsiDatabaseSchema <- "main"
    eunomiaConnection <- createUnitTestData(eunomiaConnectionDetails, eunomiaCdmDatabaseSchema, eunomiaOhdsiDatabaseSchema, cohortTable, cohortAttributeTable, attributeDefinitionTable)
    Eunomia::createCohorts(
      connectionDetails = eunomiaConnectionDetails,
      cdmDatabaseSchema = eunomiaCdmDatabaseSchema,
      cohortDatabaseSchema = eunomiaOhdsiDatabaseSchema,
      cohortTable = "cohort"
    )
  }
  withr::defer(
    {
      if (exists("eunomiaConnection")) {
        dropUnitTestData(eunomiaConnection, eunomiaOhdsiDatabaseSchema, cohortTable, cohortAttributeTable, attributeDefinitionTable)
        unlink("testEunomia.sqlite", recursive = TRUE, force = TRUE)
      }
    },
    testthat::teardown_env()
  )
}