From 138bc74180e877047b5dc52b5b7f3dacbd7ff14b Mon Sep 17 00:00:00 2001 From: egillax Date: Mon, 7 Oct 2024 14:09:32 +0200 Subject: [PATCH] fix plpv module and test --- R/Module-PatientLevelPredictionValidation.R | 77 ++++++++++--------- ...t-PatientLevelPredictionValidationModule.R | 25 +++--- 2 files changed, 55 insertions(+), 47 deletions(-) diff --git a/R/Module-PatientLevelPredictionValidation.R b/R/Module-PatientLevelPredictionValidation.R index ad0410f2..80613159 100644 --- a/R/Module-PatientLevelPredictionValidation.R +++ b/R/Module-PatientLevelPredictionValidation.R @@ -55,34 +55,37 @@ PatientLevelPredictionValidationModule <- R6::R6Class( # ) # check the model locations are valid and apply model - upperWorkDir <- dirname(jobContext$moduleExecutionSettings$workFolder) # AGS: NOTE - Using the "root" folder as the expection is that the ModelTransferModule output is here + upperWorkDir <- jobContext$moduleExecutionSettings$workFolder # AGS: NOTE - Using the "root" folder as the expection is that the ModelTransferModule output is here modelTransferFolder <- sort(dir(upperWorkDir, pattern = 'ModelTransferModule'), decreasing = T)[1] modelSaveLocation <- file.path( upperWorkDir, modelTransferFolder, 'models') # hack to use work folder for model transfer modelInfo <- private$.getModelInfo(modelSaveLocation) designs <- list() - for (i in seq_len(nrow(modelInfo))) { - df <- modelInfo[i, ] + for (setting in jobContext$settings$validationComponentsList) { + matchingModels <- modelInfo %>% + dplyr::filter(targetId == setting$modelTargetId, outcomeId == setting$modelOutcomeId) + if (nrow(matchingModels) == 0) { + stop("No matching models found with targetId: ", + setting$modelTargetId, " and outcomeId: ", setting$modelOutcomeId) + } design <- PatientLevelPrediction::createValidationDesign( - targetId = df$target_id[1], - outcomeId = df$outcome_id[1], - plpModelList = as.list(df$modelPath), - restrictPlpDataSettings = jobContext$settings[[1]]$restrictPlpDataSettings, - populationSettings = jobContext$settings[[1]]$populationSettings + targetId = setting$targetId[1], + outcomeId = setting$outcomeId[1], + plpModelList = as.list(matchingModels$modelPath), + restrictPlpDataSettings = setting$restrictPlpDataSettings, + populationSettings = setting$populationSettings ) - designs <- c(designs, design) + designs[[length(designs) + 1]] <- design } - databaseNames <- c() - databaseNames <- c(databaseNames, paste0(jobContext$moduleExecutionSettings$connectionDetailsReference)) databaseDetails <- PatientLevelPrediction::createDatabaseDetails( - connectionDetails = jobContext$moduleExecutionSettings$connectionDetails, + connectionDetails = connectionDetails, cdmDatabaseSchema = jobContext$moduleExecutionSettings$cdmDatabaseSchema, cohortDatabaseSchema = jobContext$moduleExecutionSettings$workDatabaseSchema, - cdmDatabaseName = jobContext$moduleExecutionSettings$connectionDetailsReference, - cdmDatabaseId = jobContext$moduleExecutionSettings$databaseId, + cdmDatabaseName = jobContext$moduleExecutionSettings$cdmDatabaseMetaData$cdmSourceAbbreviation, + cdmDatabaseId = jobContext$moduleExecutionSettings$cdmDatabaseMetaData$databaseId, tempEmulationSchema = jobContext$moduleExecutionSettings$tempEmulationSchema, cohortTable = jobContext$moduleExecutionSettings$cohortTableNames$cohortTable, outcomeDatabaseSchema = jobContext$moduleExecutionSettings$workDatabaseSchema, @@ -161,27 +164,26 @@ PatientLevelPredictionValidationModule <- R6::R6Class( createModuleSpecifications = function(validationComponentsList = list( list( targetId = 1, - oucomeId = 4, - restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), # vector - validationSettings = PatientLevelPrediction::createValidationSettings( - recalibrate = "weakRecalibration" - ), - populationSettings = PatientLevelPrediction::createStudyPopulationSettings( - riskWindowStart = 90, - riskWindowEnd = 360, - requireTimeAtRisk = F - ) + outcomeId = 3, + modelTargetId = 1, + modelOutcomeId = 3, + restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), + populationSettings = NULL, + recalibrate = "weakRecalibration", + runCovariateSummary = TRUE ), list( - targetId = 3, - oucomeId = 4, - restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), # vector - validationSettings = PatientLevelPrediction::createValidationSettings( - recalibrate = "weakRecalibration" + targetId = 4, + outcomeId = 3, + modelTargetId = 1, + modelOutcomeId = 3, + restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), + populationSettings = PatientLevelPrediction::createStudyPopulationSettings(), + recalibrate = "weakRecalibration", + runCovariateSummary = FALSE ) - ) - )) { + ) { analysis <- list() for (name in names(formals(self$createModuleSpecifications))) { analysis[[name]] <- get(name) @@ -211,21 +213,24 @@ PatientLevelPredictionValidationModule <- R6::R6Class( if (is.null(model)) { model <- data.frame( - target_id = modelDesign$targetId, - outcome_id = modelDesign$outcomeId, + targetId = modelDesign$targetId, + outcomeId = modelDesign$outcomeId, modelPath = directory) } else { model <- rbind(model, data.frame( - target_id = modelDesign$targetId, - outcome_id = modelDesign$outcomeId, + targetId = modelDesign$targetId, + outcomeId = modelDesign$outcomeId, modelPath = directory)) } } models <- model %>% - dplyr::group_by(.data$target_id, .data$outcome_id) %>% + dplyr::group_by(.data$targetId, .data$outcomeId) %>% dplyr::summarise(modelPath = list(.data$modelPath), .groups = "drop") + if (nrow(models) == 0) { + stop("No models found in ", strategusOutputPath) + } return(models) }, # this updates the cohort table details in covariates diff --git a/tests/testthat/test-PatientLevelPredictionValidationModule.R b/tests/testthat/test-PatientLevelPredictionValidationModule.R index 0e4000bb..008d5060 100644 --- a/tests/testthat/test-PatientLevelPredictionValidationModule.R +++ b/tests/testthat/test-PatientLevelPredictionValidationModule.R @@ -21,15 +21,18 @@ test_that("Test PLP Validation Module", { # add model to folder plpModel <- readRDS(system.file("testdata/plpvmodule/plpModel.rds", package = "Strategus")) #readRDS("tests/plpModel.rds") - upperWorkDir <- dirname(workFolder) - dir.create(file.path(upperWorkDir,'ModelTransferModule_1')) - modelTransferFolder <- sort(dir(upperWorkDir, pattern = 'ModelTransferModule'), decreasing = T)[1] - modelSaveLocation <- file.path( upperWorkDir, modelTransferFolder, 'models') # hack to use work folder for model transfer + dir.create(file.path(workFolder,'ModelTransferModule_1')) + modelTransferFolder <- sort(dir(workFolder, pattern = 'ModelTransferModule'), decreasing = T)[1] + modelSaveLocation <- file.path(workFolder, modelTransferFolder, 'models') # hack to use work folder for model transfer PatientLevelPrediction::savePlpModel( plpModel, file.path(modelSaveLocation, 'model_1_1') ) + createCohorts(connectionDetails = connectionDetails, + cdmDatabaseSchema = cdmDatabaseSchema, + cohortDatabaseSchema = workDatabaseSchema) + # Create the validation settings and run the module plpvSettingsCreator <- PatientLevelPredictionValidationModule$new() plpModuleSettings <- plpvSettingsCreator$createModuleSpecifications() @@ -40,17 +43,17 @@ test_that("Test PLP Validation Module", { executionSettings <- createCdmExecutionSettings( workDatabaseSchema = workDatabaseSchema, cdmDatabaseSchema = cdmDatabaseSchema, - cohortTableNames = CohortGenerator::getCohortTableNames(cohortTable = "plpv_unit_test"), + cohortTableNames = CohortGenerator::getCohortTableNames(cohortTable = "cohort"), workFolder = workFolder, resultsFolder = resultsFolder ) - #debugonce(Strategus::execute) - # Strategus::execute( - # analysisSpecifications = analysisSpecifications, - # executionSettings = executionSettings, - # connectionDetails = connectionDetails - # ) + debugonce(PatientLevelPredictionValidationModule$debug('execute')) + Strategus::execute( + analysisSpecifications = analysisSpecifications, + executionSettings = executionSettings, + connectionDetails = connectionDetails + ) # TODO - Remove in favor of the code # above once I have more clarity on the