tests/testthat/test-UploadToDatabaseModelDesign.R

In PatientLevelPrediction: Develop Clinical Prediction Models Using the Common Data Model

test_that("addModelSetting handles minimal modelSettings objects", {
  skip_if_not_installed("RSQLite")

  sqliteFile <- file.path(tempdir(), "plp-model-setting-minimal.sqlite")
  if (file.exists(sqliteFile)) unlink(sqliteFile)

  connectionDetails <- DatabaseConnector::createConnectionDetails(
    dbms = "sqlite",
    server = sqliteFile
  )

  PatientLevelPrediction::createPlpResultTables(
    connectionDetails = connectionDetails,
    targetDialect = "sqlite",
    resultSchema = "main",
    deleteTables = TRUE,
    createTables = TRUE,
    tablePrefix = "",
    tempEmulationSchema = NULL
  )

  conn <- DatabaseConnector::connect(connectionDetails = connectionDetails)
  on.exit(DatabaseConnector::disconnect(conn), add = TRUE)

  minimalModelSettings <- structure(list(model = "existingGlm"), class = "modelSettings")
  modelSettingId <- PatientLevelPrediction:::addModelSetting(
    conn = conn,
    resultSchema = "main",
    targetDialect = "sqlite",
    tablePrefix = "",
    json = minimalModelSettings,
    tempEmulationSchema = NULL
  )

  expect_true(!is.null(modelSettingId))
  expect_true(is.numeric(modelSettingId) || is.integer(modelSettingId))
  expect_true(is.finite(modelSettingId) && modelSettingId > 0)

  res <- DatabaseConnector::querySql(
    conn,
    "select model_type as modelType from main.model_settings;"
  )
  expect_true("modelType" %in% names(res))
  expect_true(any(res$modelType == "NULL"))
})

test_that("addModelSetting derives modelType from supported paths and sanitizes invalid values", {
  skip_if_not_installed("RSQLite")

  sqliteFile <- file.path(tempdir(), "plp-model-setting-branches.sqlite")
  if (file.exists(sqliteFile)) unlink(sqliteFile)

  connectionDetails <- DatabaseConnector::createConnectionDetails(
    dbms = "sqlite",
    server = sqliteFile
  )

  PatientLevelPrediction::createPlpResultTables(
    connectionDetails = connectionDetails,
    targetDialect = "sqlite",
    resultSchema = "main",
    deleteTables = TRUE,
    createTables = TRUE,
    tablePrefix = "",
    tempEmulationSchema = NULL
  )

  conn <- DatabaseConnector::connect(connectionDetails = connectionDetails)
  on.exit(DatabaseConnector::disconnect(conn), add = TRUE)

  settingsModelType <- list(
    settings = list(modelType = "binary"),
    model = "from-settings"
  )
  fallbackModelType <- list(
    settings = list(),
    param = structure(list(alpha = 0.1), settings = list(modelType = "survival")),
    model = "from-param-settings"
  )
  listModelType <- list(settings = list(modelType = list("bad")), model = "list-model-type")
  emptyModelType <- list(settings = list(modelType = character(0)), model = "empty-model-type")
  blankModelType <- list(settings = list(modelType = ""), model = "blank-model-type")
  naModelType <- list(settings = list(modelType = NA_character_), model = "na-model-type")
  charJson <- '{"settings":{"modelType":"ignored"}}'

  inputs <- list(
    settingsModelType,
    fallbackModelType,
    listModelType,
    emptyModelType,
    blankModelType,
    naModelType,
    charJson
  )
  expectedModelTypes <- c("binary", "survival", "NULL", "NULL", "NULL", "NULL", "NULL")

  for (i in seq_along(inputs)) {
    modelSettingId <- PatientLevelPrediction:::addModelSetting(
      conn = conn,
      resultSchema = "main",
      targetDialect = "sqlite",
      tablePrefix = "",
      json = inputs[[i]],
      tempEmulationSchema = NULL
    )

    res <- DatabaseConnector::querySql(
      conn,
      paste0(
        "select model_type as modelType from main.model_settings ",
        "where model_setting_id = ", modelSettingId, ";"
      )
    )
    expect_equal(res$modelType[1], expectedModelTypes[i])
  }
})

test_that("addHyperparameterSetting deduplicates identical settings json", {
  skip_if_not_installed("RSQLite")

  sqliteFile <- file.path(tempdir(), "plp-hyperparameter-setting.sqlite")
  if (file.exists(sqliteFile)) unlink(sqliteFile)

  connectionDetails <- DatabaseConnector::createConnectionDetails(
    dbms = "sqlite",
    server = sqliteFile
  )

  PatientLevelPrediction::createPlpResultTables(
    connectionDetails = connectionDetails,
    targetDialect = "sqlite",
    resultSchema = "main",
    deleteTables = TRUE,
    createTables = TRUE,
    tablePrefix = "",
    tempEmulationSchema = NULL
  )

  conn <- DatabaseConnector::connect(connectionDetails = connectionDetails)
  on.exit(DatabaseConnector::disconnect(conn), add = TRUE)

  hyperparameterSettings <- PatientLevelPrediction::createHyperparameterSettings(
    search = "grid"
  )

  rowCountBefore <- DatabaseConnector::querySql(
    conn,
    "select count(*) as n from main.hyperparameter_settings;"
  )

  firstId <- PatientLevelPrediction:::addHyperparameterSetting(
    conn = conn,
    resultSchema = "main",
    targetDialect = "sqlite",
    tablePrefix = "",
    json = hyperparameterSettings,
    tempEmulationSchema = NULL
  )
  secondId <- PatientLevelPrediction:::addHyperparameterSetting(
    conn = conn,
    resultSchema = "main",
    targetDialect = "sqlite",
    tablePrefix = "",
    json = hyperparameterSettings,
    tempEmulationSchema = NULL
  )

  expect_equal(firstId, secondId)

  rowCountAfter <- DatabaseConnector::querySql(
    conn,
    "select count(*) as n from main.hyperparameter_settings;"
  )
  expect_equal(rowCountAfter$n[1], rowCountBefore$n[1] + 1)
})

test_that("insertModelDesignInDatabase differentiates model_design_id by hyperparameter settings", {
  skip_if_not_installed("RSQLite")

  sqliteFile <- file.path(tempdir(), "plp-model-design-hyperparameter.sqlite")
  if (file.exists(sqliteFile)) unlink(sqliteFile)

  connectionDetails <- DatabaseConnector::createConnectionDetails(
    dbms = "sqlite",
    server = sqliteFile
  )

  PatientLevelPrediction::createPlpResultTables(
    connectionDetails = connectionDetails,
    targetDialect = "sqlite",
    resultSchema = "main",
    deleteTables = TRUE,
    createTables = TRUE,
    tablePrefix = "",
    tempEmulationSchema = NULL
  )

  conn <- DatabaseConnector::connect(connectionDetails = connectionDetails)
  on.exit(DatabaseConnector::disconnect(conn), add = TRUE)

  databaseSchemaSettings <- PatientLevelPrediction::createDatabaseSchemaSettings(
    resultSchema = "main",
    targetDialect = "sqlite",
    tempEmulationSchema = NULL
  )

  baseModelSettings <- PatientLevelPrediction::setLassoLogisticRegression(seed = 42)
  cohortDefinitions <- data.frame(
    cohortName = c("target", "outcome"),
    cohortId = c(1, 2),
    json = c("{}", "{}"),
    stringsAsFactors = FALSE
  )

  modelDesignGrid <- PatientLevelPrediction::createModelDesign(
    targetId = 1,
    outcomeId = 2,
    modelSettings = baseModelSettings,
    hyperparameterSettings = PatientLevelPrediction::createHyperparameterSettings(
      search = "grid"
    )
  )
  modelDesignRandom <- PatientLevelPrediction::createModelDesign(
    targetId = 1,
    outcomeId = 2,
    modelSettings = baseModelSettings,
    hyperparameterSettings = PatientLevelPrediction::createHyperparameterSettings(
      search = "random",
      sampleSize = 1,
      randomSeed = 42
    )
  )

  modelDesignGridId <- PatientLevelPrediction:::insertModelDesignInDatabase(
    object = modelDesignGrid,
    conn = conn,
    databaseSchemaSettings = databaseSchemaSettings,
    cohortDefinitions = cohortDefinitions
  )
  modelDesignRandomId <- PatientLevelPrediction:::insertModelDesignInDatabase(
    object = modelDesignRandom,
    conn = conn,
    databaseSchemaSettings = databaseSchemaSettings,
    cohortDefinitions = cohortDefinitions
  )
  modelDesignGridIdRepeat <- PatientLevelPrediction:::insertModelDesignInDatabase(
    object = modelDesignGrid,
    conn = conn,
    databaseSchemaSettings = databaseSchemaSettings,
    cohortDefinitions = cohortDefinitions
  )

  expect_equal(modelDesignGridId, modelDesignGridIdRepeat)
  expect_false(modelDesignGridId == modelDesignRandomId)

  modelDesignRows <- DatabaseConnector::querySql(
    conn,
    paste0(
      "select model_design_id as modelDesignId, ",
      "hyperparameter_setting_id as hyperparameterSettingId ",
      "from main.model_designs where model_design_id in (",
      modelDesignGridId, ", ", modelDesignRandomId, ");"
    )
  )
  expect_equal(length(unique(modelDesignRows$hyperparameterSettingId)), 2)

  hyperparameterRows <- DatabaseConnector::querySql(
    conn,
    "select count(*) as n from main.hyperparameter_settings;"
  )
  expect_gte(hyperparameterRows$n[1], 2)
})