tests/testthat/test-validation.R

# Copyright 2025 Observational Health Data Sciences and Informatics
#
# This file is part of PatientLevelPrediction
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# Test unit for the creation of the study externalValidatePlp
if (internet &&
  identical(Sys.getenv("NOT_CRAN"), "true") &&
  rlang::is_installed("Eunomia")) {
  modelVal <- loadPlpModel(file.path(saveLoc, "Test", "plpResult", "model"))
  validationDatabaseDetailsVal <- databaseDetails # from run multiple tests
  validationRestrictPlpDataSettingsVal <- createRestrictPlpDataSettings(washoutPeriod = 0, sampleSize = NULL)
  recalSet <- createValidationSettings(recalibrate = "weakRecalibration")
  saveLocation <- file.path(saveLoc, "extern")
  setEV <- function(model = modelVal,
                    validationDatabaseDetails = validationDatabaseDetailsVal,
                    validationRestrictPlpDataSettings = validationRestrictPlpDataSettingsVal,
                    settings = recalSet,
                    outputFolder = saveLocation) {
    result <- externalValidateDbPlp(
      plpModel = model,
      validationDatabaseDetails = validationDatabaseDetails,
      validationRestrictPlpDataSettings = validationRestrictPlpDataSettings,
      settings = settings,
      outputFolder = outputFolder
    )

    return(result)
  }
}

test_that("incorrect input externalValidateDbPlp checks work", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  # fails when plpResult is NULL
  expect_error(externalValidateDbPlp(setEV(model = NULL)))
  # fails when plpResult is not class 'plpResult'
  expect_error(externalValidateDbPlp(setEV(model = list())))


  expect_error(externalValidateDbPlp(
    setEV(validationDatabaseDetails = NULL)
  ))

  expect_error(externalValidateDbPlp(
    setEV(validationRestrictPlpDataSettings = NULL)
  ))

  expect_error(externalValidateDbPlp(
    setEV(outputFolder = NULL)
  ))
})



test_that("external validate", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  exVal <- setEV()
  expect_equal(class(exVal[[1]]), "externalValidatePlp")
})

test_that("fromDesignOrModel helper works", {
  settingName <- "restrictPlpDataSettings"
  validationDesign <- list(
    targetId = 1,
    outcomeId = 2,
    restrictPlpDataSettings = list(a = 1, b = 2)
  )
  modelDesigns <- list(
    list(
      targetId = 1,
      outcomeId = 2,
      restrictPlpDataSettings = list(a = 3, b = 4)
    ),
    list(
      targetId = 1,
      outcomeId = 2,
      restrictPlpDataSettings = list(a = 3, b = 4)
    )
  )
  output <- fromDesignOrModel(validationDesign, modelDesigns, settingName)

  expect_equal(output[[settingName]], list(a = 1, b = 2))
  validationDesign[[settingName]] <- NULL
  output <- fromDesignOrModel(validationDesign, modelDesigns, settingName)
  expect_equal(output[[settingName]], list(a = 3, b = 4))
})

test_that("createValidationDesign errors", {
  expect_error(createValidationDesign(
    targetId = NULL, outcomeId = 2,
    plpModelList = list()
  ))
  expect_error(createValidationDesign(
    targetId = 1, outcomeId = NULL,
    plpModelList = list()
  ))
  expect_error(createValidationDesign(
    targetId = "a", outcomeId = 2,
    plpModelList = list()
  ))
  expect_error(createValidationDesign(
    targetId = 1, outcomeId = "a",
    plpModelList = list()
  ))
  expect_error(createValidationDesign(
    targetId = 1, outcomeId = 2,
    plpModelList = list(),
    populationSettings = list()
  ))
  expect_error(createValidationDesign(
    targetId = 1, outcomeId = 2,
    plpModelList = list(),
    recalibrate = 1
  ))
  expect_error(createValidationDesign(
    targetId = 1, outcomeId = 2,
    plpModelList = list(),
    runCovariateSummary = 1
  ))
})

test_that("createValidationDesign works with minimal required arguments", {
  targetId <- 1
  outcomeId <- 2
  plpModelList <- list()

  design <- createValidationDesign(
    targetId = targetId,
    outcomeId = outcomeId,
    plpModelList = plpModelList
  )
  expect_s3_class(design, "validationDesign")
  expect_equal(design$targetId, targetId)
  expect_equal(design$outcomeId, outcomeId)
  expect_equal(design$plpModelList, plpModelList)
})

test_that("single createValidationDesign works with all arguments", {
  targetId <- 1
  outcomeId <- 2
  plpModelList <- list("model1", "model2")
  populationSettings <- createStudyPopulationSettings()
  restrictPlpDataSettings <- createRestrictPlpDataSettings() 
  recalibrate <- c("recalibrationInTheLarge")
  runCovariateSummary <- FALSE

  design <- createValidationDesign(
    targetId = targetId,
    outcomeId = outcomeId,
    plpModelList = plpModelList,
    populationSettings = populationSettings,
    restrictPlpDataSettings = restrictPlpDataSettings,
    recalibrate = recalibrate,
    runCovariateSummary = runCovariateSummary
  )
  expect_s3_class(design, "validationDesign")
  expect_equal(design$targetId, targetId)
  expect_equal(design$outcomeId, outcomeId)
  expect_equal(design$plpModelList, plpModelList)
  expect_equal(design$populationSettings, populationSettings)
  expect_equal(design$restrictPlpDataSettings, restrictPlpDataSettings)
  expect_equal(design$recalibrate, recalibrate)
  expect_equal(design$runCovariateSummary, runCovariateSummary)
})

test_that("createValidationDesigns correctly handles multiple restrictSettings", {
  targetId <- 1
  outcomeId <- 2
  plpModelList <- list()
  restrictPlpDataSettings <- list(createRestrictPlpDataSettings(), createRestrictPlpDataSettings())

  design <- createValidationDesign(
    targetId = targetId,
    outcomeId = outcomeId,
    plpModelList = plpModelList,
    restrictPlpDataSettings = restrictPlpDataSettings
  )
  expect_s3_class(design[[1]], "validationDesign")
  expect_equal(design[[1]]$targetId, targetId)
  expect_equal(design[[1]]$outcomeId, outcomeId)
  expect_equal(design[[1]]$plpModelList, plpModelList)
  expect_equal(design[[1]]$restrictPlpDataSettings, restrictPlpDataSettings[[1]])
  expect_equal(design[[2]]$restrictPlpDataSettings, restrictPlpDataSettings[[2]])
  expect_equal(length(design), length(restrictPlpDataSettings))
})

test_that("createValidationSettings errors with <10 outcomes", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  tinyRestrictPlpDataSettings <- createRestrictPlpDataSettings(
    sampleSize = 30,
  )

  validationDesign <- createValidationDesign(
    targetId = 1,
    outcomeId = 3,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = tinyRestrictPlpDataSettings
  )

  expect_output(
    validateExternal(
      validationDesignList = validationDesign,
      databaseDetails = databaseDetails,
      logSettings = createLogSettings(),
      outputFolder = saveLocation
    ),
    "skipping validation for design and database"
  )
})

test_that("createDownloadTasks handles single design correctly", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  design <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  result <- createDownloadTasks(list(design))
  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 1)
  expect_equal(ncol(result), 4)
})

test_that("createDownloadTasks handles multiple designs correctly", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  design1 <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  design2 <- createValidationDesign(
    targetId = 3,
    outcomeId = 4,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  result <- createDownloadTasks(list(design1, design2))
  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 2)
  expect_equal(ncol(result), 4)
})

test_that("createDownloadTasks handles duplicated designs correctly", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  design <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  result <- createDownloadTasks(list(design, design))
  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 1)

  design2 <- createValidationDesign(
    targetId = 3,
    outcomeId = 4,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )

  results <- createDownloadTasks(list(design, design2, design))
  expect_s3_class(results, "data.frame")
  expect_equal(nrow(results), 2)
})

test_that("createDownloadTasks with different restrictSettings", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  design <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  design2 <- createValidationDesign(
    targetId = 3,
    outcomeId = 4,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  design3 <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings(sampleSize = 100)
  )

  result <- createDownloadTasks(list(design, design2, design3))

  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 3)
})

test_that("createDownloadTasks works with multiple outcomeIds", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  design1 <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  design2 <- createValidationDesign(
    targetId = 1,
    outcomeId = 3,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  result <- createDownloadTasks(list(design1, design2))
  expect_s3_class(result, "data.frame")
  expect_equal(nrow(result), 1)
  expect_equal(length(result[1, ]$outcomeIds[[1]]), 2)

  design3 <- createValidationDesign(
    targetId = 1,
    outcomeId = 3,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings(sampleSize = 100)
  )
  result <- createDownloadTasks(list(design1, design2, design3))
  expect_equal(nrow(result), 2)
})

test_that("createDownloadTasks with multiple covSettings", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  modelVal2 <- modelVal
  design1 <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  modelVal2$modelDesign$covariateSettings <-
    FeatureExtraction::createCovariateSettings(useChads2 = TRUE)
  design2 <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal2),
    restrictPlpDataSettings = createRestrictPlpDataSettings()
  )
  result <- createDownloadTasks(list(design1, design2))
  expect_equal(nrow(result), 1)
  expect_equal(length(result[1, ]$covariateSettings[[1]]), 2)
})

test_that("createDownloadTasks when restrictSettings come from models", {
  skip_if_not_installed("Eunomia")
  skip_if_offline()
  design1 <- createValidationDesign(
    targetId = 1,
    outcomeId = 2,
    plpModelList = list(modelVal)
  )
  result <- createDownloadTasks(list(design1))
  expect_s3_class(result[1, ]$restrictPlpDataSettings[[1]], "restrictPlpDataSettings")
})

Try the PatientLevelPrediction package in your browser

Any scripts or data that you put into this service are public.

PatientLevelPrediction documentation built on April 3, 2025, 9:58 p.m.