Skip to content

Commit

Permalink
fix plpv module and test
Browse files Browse the repository at this point in the history
  • Loading branch information
@egillax
egillax committed Oct 7, 2024
1 parent d5a01b2 commit 138bc74
Show file tree
Hide file tree
Showing 2 changed files with 55 additions and 47 deletions.
77 changes: 41 additions & 36 deletions R/Module-PatientLevelPredictionValidation.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
25 changes: 14 additions & 11 deletions tests/testthat/test-PatientLevelPredictionValidationModule.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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()
Expand All @@ -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
Expand Down

0 comments on commit 138bc74

Please sign in to comment.