diff --git a/DESCRIPTION b/DESCRIPTION index fcf9f32e..e9331bec 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,6 +32,7 @@ Imports: rlang, SqlRender (>= 1.18.0) Suggests: + aws.s3, Characterization, CirceR, CohortDiagnostics, @@ -43,6 +44,7 @@ Suggests: FeatureExtraction, fs, knitr, + OhdsiSharing, PatientLevelPrediction, rmarkdown, RSQLite, @@ -55,6 +57,7 @@ Remotes: ohdsi/CohortGenerator, ohdsi/CohortIncidence, ohdsi/CohortMethod, + ohdsi/OhdsiSharing, ohdsi/PatientLevelPrediction, ohdsi/ResultModelManager, ohdsi/SelfControlledCaseSeries diff --git a/NAMESPACE b/NAMESPACE index 271384f3..bf554248 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,9 @@ export(CohortGeneratorModule) export(CohortIncidenceModule) export(CohortMethodModule) export(EvidenceSynthesisModule) +export(ModelTransferModule) export(PatientLevelPredictionModule) +export(PatientLevelPredictionValidationModule) export(SelfControlledCaseSeriesModule) export(StrategusModule) export(addCharacterizationModuleSpecifications) diff --git a/R/Module-ModelTransferModule.R b/R/Module-ModelTransferModule.R new file mode 100644 index 00000000..a07cd994 --- /dev/null +++ b/R/Module-ModelTransferModule.R @@ -0,0 +1,340 @@ +# ModelTransferModule ------------- +#' @title Model transfer module +#' @export +#' @description +#' This module contains functionality for moving plpModels to/from S3 buckets +#' and github repositories from your local file system. +ModelTransferModule <- R6::R6Class( + classname = "ModelTransferModule", + inherit = StrategusModule, + public = list( + #' @description Initialize the module + initialize = function() { + super$initialize() + }, + #' @description Generates the cohorts + #' @template connectionDetails + #' @template analysisSpecifications + #' @template executionSettings + execute = function(connectionDetails, analysisSpecifications, executionSettings) { + # TODO: Does this module connect to a DB? If not these + # up-front validation steps done in super$.validateCdmExecutionSettings + # and super$execute may not make sense here. + super$.validateCdmExecutionSettings(executionSettings) + super$execute(connectionDetails, analysisSpecifications, executionSettings) + + jobContext <- private$jobContext + workFolder <- jobContext$moduleExecutionSettings$workSubFolder + resultsFolder <- jobContext$moduleExecutionSettings$resultsSubFolder + + private$.message("Validating inputs") + inherits(jobContext, 'list') + + if (is.null(jobContext$settings)) { + stop("Analysis settings not found in job context") + } + if (is.null(jobContext$sharedResources)) { + stop("Shared resources not found in job context") + } + if (is.null(jobContext$moduleExecutionSettings)) { + stop("Execution settings not found in job context") + } + + # workFolder <- jobContext$moduleExecutionSettings$workSubFolder + # resultsFolder <- jobContext$moduleExecutionSettings$resultsSubFolder + + modelSaveLocation <- jobContext$moduleExecutionSettings$workSubFolder #jobContext$sharedResources$modelSaveLocation + + private$.message("Transfering models") + #moduleInfo <- getModuleInfo() + + # finding S3 details + s3Settings <- jobContext$settings$s3Settings + # finding github details + githubSettings <- jobContext$settings$githubSettings + # finding localFile details + localFileSettings <- jobContext$settings$localFileSettings + + modelLocationsS3 <- tryCatch({.getModelsFromS3( + s3Settings = s3Settings, + saveFolder = modelSaveLocation + )}, error = function(e){ParallelLogger::logInfo(e); return(NULL)} + ) + if(!is.null(modelLocationsS3)){ + readr::write_csv(modelLocationsS3, file = file.path(resultsFolder, 's3_export.csv')) + } + + modelLocationsGithub <- tryCatch({.getModelsFromGithub( + githubSettings = githubSettings$locations, + saveFolder = modelSaveLocation + )}, error = function(e){ParallelLogger::logInfo(e); return(NULL)} + ) + if(!is.null(modelLocationsGithub)){ + readr::write_csv(modelLocationsGithub, file = file.path(resultsFolder, 'github_export.csv')) + } + + modelLocationsLocalFiles <- tryCatch({.getModelsFromLocalFiles( + localFileSettings = localFileSettings$locations, + saveFolder = modelSaveLocation + )}, error = function(e){ParallelLogger::logInfo(e); return(NULL)} + ) + if(!is.null(modelLocationsS3)){ + readr::write_csv(modelLocationsS3, file = file.path(resultsFolder, 'local_export.csv')) + } + + private$.message(paste("Results available at:", resultsFolder)) + }, + #' @description Creates the ModelTransferModule Specifications + #' @param s3Settings description + #' @param githubSettings description + #' @param localFileSettings description + #' include steps to compute inclusion rule statistics. + createModuleSpecifications = function(s3Settings = NULL, + githubSettings = NULL, + localFileSettings = NULL) { + analysis <- list() + for (name in names(formals(self$createModuleSpecifications))) { + analysis[[name]] <- get(name) + } + + specifications <- super$createModuleSpecifications( + moduleSpecifications = analysis + ) + return(specifications) + }, + #' @description Validate the module specifications + #' @param moduleSpecifications The ModelTransfer module specifications + validateModuleSpecifications = function(moduleSpecifications) { + super$validateModuleSpecifications( + moduleSpecifications = moduleSpecifications + ) + } + ), + private = list( + .getModelsFromLocalFiles = function(localFileSettings, saveFolder) { + + if (is.null(localFileSettings)) { + return(NULL) + } + + if (!dir.exists(file.path(saveFolder, "models"))) { + dir.create(file.path(saveFolder, "models"), recursive = TRUE) + } + + saveFolder <- file.path(saveFolder, "models") + + localFileSettings <- fs::path_expand(localFileSettings) + saveFolder <- fs::path_expand(saveFolder) + + contents <- list.files(localFileSettings, recursive = TRUE, full.names = TRUE, include.dirs = FALSE) + + for (item in contents) { + relativePath <- fs::path_rel(item, start = localFileSettings) + targetPath <- file.path(saveFolder, relativePath) + targetDir <- dirname(targetPath) + + if (!dir.exists(targetDir)) { + dir.create(targetDir, recursive = TRUE) + } + + if (fs::dir_exists(item)) { + if (!dir.exists(targetPath)) { + dir.create(targetPath, recursive = TRUE) + } + } else { + file.copy(item, targetPath, overwrite = TRUE) + } + } + + info <- data.frame() + return(info) + }, + # code that takes s3 details and download the models and returns the locations plus details as data.frame + .getModelsFromS3 = function(s3Settings, saveFolder){ + + # need to have settings + # AWS_ACCESS_KEY_ID= + # AWS_SECRET_ACCESS_KEY= + # AWS_DEFAULT_REGION=ap-southeast-2 + + if(is.null(s3Settings)){ + return(NULL) + } + + info <- data.frame() + + for(i in 1:nrow(s3Settings)){ + + modelSaved <- F + saveToLoc <- '' + + validBucket <- aws.s3::bucket_exists( + bucket = s3Settings$bucket[i], + region = s3Settings$region[i] + ) + + if(validBucket){ + subfolder <- s3Settings$modelZipLocation[i] + bucket <- s3Settings$bucket[i] + region <- s3Settings$region[i] + + result <- aws.s3::get_bucket_df(bucket = bucket, region = region, max = Inf) + paths <- fs::path(result$Key) + + workDir <- private$.findWorkDir(bucket, subfolder, region) + analyses <- private$.findAnalysesNames(bucket, workDir, region) + + if(length(analyses) > 0) { + if(!fs::dir_exists(fs::path(saveFolder, "models"))){ + dir.create(fs::path(saveFolder, "models"), recursive = T) + } + saveToLoc <- fs::path(saveFolder, "models") + + for (analysis in analyses) { + analysis_paths <- paths[fs::path_has_parent(paths, fs::path(workDir, analysis))] + + for(obj in analysis_paths) { + # split work directory from path + relative_paths <- fs::path_rel(obj, start = workDir) + # remove artifacts created by current path location + filtered_paths <- relative_paths[relative_paths != "."] + # Construct the file path where you want to save the file locally + local_file_path <- fs::path(saveToLoc, filtered_paths) + + # Download the file from S3 + aws.s3::save_object(obj, bucket, file = local_file_path) + } + ParallelLogger::logInfo(paste0("Downloaded: ", analysis, " to ", saveToLoc)) + } + } else{ + ParallelLogger::logInfo(paste0("No ",s3Settings$modelZipLocation[i]," in bucket ", s3Settings$bucket[i], " in region ", s3Settings$region[i] )) + } + }else{ + ParallelLogger::logInfo(paste0("No bucket ", s3Settings$bucket[i] ," in region ", s3Settings$region[i])) + } + + info <- rbind( + info, + data.frame( + originalLocation = "PLACEHOLDER", + modelSavedLocally = TRUE, + localLocation = saveToLoc + ) + ) + + } + + return(info) + }, + # code that takes github details and download the models and returns the locations plus details as data.frame + .getModelsFromGithub = function(githubSettings,saveFolder){ + + if(is.null(githubSettings)){ + return(NULL) + } + + info <- data.frame() + + for(i in 1:length(githubSettings)){ + + githubUser <- githubSettings[[i]]$githubUser #'ohdsi-studies' + githubRepository <- githubSettings[[i]]$githubRepository #'lungCancerPrognostic' + githubBranch <- githubSettings[[i]]$githubBranch #'master' + + downloadCheck <- tryCatch({ + utils::download.file( + url = file.path("https://github.com",githubUser,githubRepository, "archive", paste0(githubBranch,".zip")), + destfile = file.path(tempdir(), "tempGitHub.zip") + )}, error = function(e){ ParallelLogger::logInfo('GitHub repository download failed') ; return(NULL)} + ) + + if(!is.null(downloadCheck)){ + # unzip into the workFolder + OhdsiSharing::decompressFolder( + sourceFileName = file.path(tempdir(), "tempGitHub.zip"), + targetFolder = file.path(tempdir(), "tempGitHub") + ) + for(j in 1:length(githubSettings[[i]]$githubModelsFolder)){ + githubModelsFolder <- githubSettings[[i]]$githubModelsFolder[j] #'models' + githubModelFolder <- githubSettings[[i]]$githubModelFolder[j] #'full_model' + + tempModelLocation <- file.path(file.path(tempdir(), "tempGitHub"), dir(file.path(file.path(tempdir(), "tempGitHub"))), 'inst', githubModelsFolder, githubModelFolder ) + + if(!dir.exists(file.path(saveFolder,"models",paste0('model_github_', i, '_', j)))){ + dir.create(file.path(saveFolder,"models",paste0('model_github_', i, '_', j)), recursive = T) + } + for(dirEntry in dir(tempModelLocation)){ + file.copy( + from = file.path(tempModelLocation, dirEntry), + to = file.path(saveFolder,"models",paste0('model_github_', i, '_', j)), #issues if same modelFolder name in different github repos + recursive = TRUE + ) + } + + modelSaved <- T + saveToLoc <- file.path(saveFolder,"models",paste0('model_github_', i, '_', j)) + + info <- rbind( + info, + data.frame( + githubLocation = file.path("https://github.com",githubUser,githubRepository, "archive", paste0(githubBranch,".zip")), + githubPath = file.path('inst', githubModelsFolder, githubModelFolder), + modelSavedLocally = modelSaved, + localLocation = saveToLoc + ) + ) + + } + + } else{ + + info <- rbind( + info, + data.frame( + githubLocation = file.path("https://github.com",githubUser,githubRepository, "archive", paste0(githubBranch,".zip")), + githubPath = file.path('inst', githubSettings[[i]]$githubModelsFolder, githubSettings[[i]]$githubModelFolder), + modelSavedLocally = F, + localLocation = '' + ) + ) + } + + + } + + return(info) + }, + .findWorkDir = function(bucket, subfolder, region) { + # list all content in the bucket + result <- aws.s3::get_bucket_df(bucket = bucket, region = region, max = Inf) + # extract paths of all content + paths <- fs::path(result$Key) + # split paths up for easier processing + split_path <- fs::path_split(paths) + + # find the full path of the subfolder with models for validation + results_sapply <- sapply(split_path, function(x) { + identical(tail(x, 1), subfolder) + }) + subfolder_path <- paths[results_sapply] + + return(subfolder_path) + }, + .findAnalysesNames = function(bucket, workDir, region) { + # list all content in the bucket + result <- aws.s3::get_bucket_df(bucket = bucket, region = region, max = Inf) + # extract paths of all content + paths <- fs::path(result$Key) + # filter for paths in work directory + work_dir_paths <- paths[fs::path_has_parent(paths, workDir)] + # split work directory from path + relative_paths <- fs::path_rel(work_dir_paths, start = workDir) + # remove artifacts created by current path location + filtered_paths <- relative_paths[relative_paths != "."] + # get only the top level directories + top_level_dirs <- sapply(fs::path_split(filtered_paths), function(p) p[[1]]) + top_level_dirs <- unique(top_level_dirs) + return(top_level_dirs) + } + ) +) diff --git a/R/Module-PatientLevelPredictionValidation.R b/R/Module-PatientLevelPredictionValidation.R new file mode 100644 index 00000000..ad0410f2 --- /dev/null +++ b/R/Module-PatientLevelPredictionValidation.R @@ -0,0 +1,254 @@ +# PatientLevelPredictionValidationModule ------------- +#' @title Module for performing validation of patient-level prediction models +#' @export +#' @description +#' Module for performing patient-level prediction model validation for models +#' built using the PatientLevelPrediction package. +PatientLevelPredictionValidationModule <- R6::R6Class( + classname = "PatientLevelPredictionValidationModule", + inherit = StrategusModule, + public = list( + #' @field tablePrefix The table prefix to append to the results tables + tablePrefix = "val_", + #' @description Initialize the module + initialize = function() { + super$initialize() + }, + #' @description Executes the PatientLevelPrediction package to validate a + #' PLP model + #' @template connectionDetails + #' @template analysisSpecifications + #' @template executionSettings + execute = function(connectionDetails, analysisSpecifications, executionSettings) { + super$.validateCdmExecutionSettings(executionSettings) + super$execute(connectionDetails, analysisSpecifications, executionSettings) + + jobContext <- private$jobContext + #cohortDefinitionSet <- super$.createCohortDefinitionSetFromJobContext() + workFolder <- jobContext$moduleExecutionSettings$workSubFolder + resultsFolder <- jobContext$moduleExecutionSettings$resultsSubFolder + + #library(PatientLevelPrediction) + private$.message("Validating inputs") + inherits(jobContext, 'list') + + if (is.null(jobContext$settings)) { + stop("Analysis settings not found in job context") + } + # if (is.null(jobContext$sharedResources)) { + # stop("Shared resources not found in job context") + # } + if (is.null(jobContext$moduleExecutionSettings)) { + stop("Execution settings not found in job context") + } + + #workFolder <- jobContext$moduleExecutionSettings$workSubFolder + #resultsFolder <- jobContext$moduleExecutionSettings$resultsSubFolder + + private$.message("Executing PLP Validation") + #moduleInfo <- getModuleInfo() + + # find where cohortDefinitions are as sharedResources is a list + # cohortDefinitionSet <- createCohortDefinitionSetFromJobContext( + # sharedResources = jobContext$sharedResources, + # settings = jobContext$settings + # ) + + # 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 + 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, ] + + 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 + ) + designs <- c(designs, design) + } + databaseNames <- c() + databaseNames <- c(databaseNames, paste0(jobContext$moduleExecutionSettings$connectionDetailsReference)) + + databaseDetails <- PatientLevelPrediction::createDatabaseDetails( + connectionDetails = jobContext$moduleExecutionSettings$connectionDetails, + cdmDatabaseSchema = jobContext$moduleExecutionSettings$cdmDatabaseSchema, + cohortDatabaseSchema = jobContext$moduleExecutionSettings$workDatabaseSchema, + cdmDatabaseName = jobContext$moduleExecutionSettings$connectionDetailsReference, + cdmDatabaseId = jobContext$moduleExecutionSettings$databaseId, + tempEmulationSchema = jobContext$moduleExecutionSettings$tempEmulationSchema, + cohortTable = jobContext$moduleExecutionSettings$cohortTableNames$cohortTable, + outcomeDatabaseSchema = jobContext$moduleExecutionSettings$workDatabaseSchema, + outcomeTable = jobContext$moduleExecutionSettings$cohortTableNames$cohortTable + ) + + PatientLevelPrediction::validateExternal( + validationDesignList = designs, + databaseDetails = databaseDetails, + logSettings = PatientLevelPrediction::createLogSettings(verbosity = 'INFO', logName = 'validatePLP'), + outputFolder = workFolder + ) + + sqliteConnectionDetails <- DatabaseConnector::createConnectionDetails( + dbms = 'sqlite', + server = file.path(workFolder, "sqlite", "databaseFile.sqlite") + ) + + PatientLevelPrediction::extractDatabaseToCsv( + connectionDetails = sqliteConnectionDetails, + databaseSchemaSettings = PatientLevelPrediction::createDatabaseSchemaSettings( + resultSchema = 'main', + tablePrefix = '', + targetDialect = 'sqlite', + tempEmulationSchema = NULL + ), + csvFolder = resultsFolder, + fileAppend = NULL + ) + + private$.message(paste("Results available at:", resultsFolder)) + }, + #' @description Create the results data model for the module + #' @template resultsConnectionDetails + #' @template resultsDatabaseSchema + #' @template tablePrefix + createResultsDataModel = function(resultsConnectionDetails, resultsDatabaseSchema, tablePrefix = self$tablePrefix) { + super$createResultsDataModel(resultsConnectionDetails, resultsDatabaseSchema, tablePrefix) + PatientLevelPrediction::createPlpResultTables( + connectionDetails = resultsConnectionDetails, + targetDialect = resultsConnectionDetails$dbms, + resultSchema = resultsDatabaseSchema, + deleteTables = F, + createTables = T, + tablePrefix = tablePrefix + ) + }, + #' @description Upload the results for the module + #' @template resultsConnectionDetails + #' @template analysisSpecifications + #' @template resultsDataModelSettings + uploadResults = function(resultsConnectionDetails, analysisSpecifications, resultsDataModelSettings) { + super$uploadResults(resultsConnectionDetails, analysisSpecifications, resultsDataModelSettings) + + databaseSchemaSettings <- PatientLevelPrediction::createDatabaseSchemaSettings( + resultSchema = resultsDataModelSettings$resultsDatabaseSchema, + tablePrefix = self$tablePrefix, + targetDialect = resultsConnectionDetails$dbms + ) + + resultsFolder <- private$jobContext$moduleExecutionSettings$resultsSubFolder + # TODO: This function does not expose + # a way to specify the database identifier file + # which makes the purge problematic since I'm + # not sure how it will know what to purge... + PatientLevelPrediction::insertCsvToDatabase( + csvFolder = resultsFolder, + connectionDetails = resultsConnectionDetails, + databaseSchemaSettings = databaseSchemaSettings, + modelSaveLocation = file.path(resultsFolder, "dbmodels"), + csvTableAppend = "" + ) + }, + #' @description Creates the PatientLevelPredictionValidation Module Specifications + #' @param validationComponentsList description + 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 + ) + ), + list( + targetId = 3, + oucomeId = 4, + restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), # vector + validationSettings = PatientLevelPrediction::createValidationSettings( + recalibrate = "weakRecalibration" + ) + + ) + )) { + analysis <- list() + for (name in names(formals(self$createModuleSpecifications))) { + analysis[[name]] <- get(name) + } + + specifications <- super$createModuleSpecifications( + moduleSpecifications = analysis + ) + return(specifications) + }, + #' @description Validate the module specifications + #' @param moduleSpecifications The PatientLevelPredictionValidation module specifications + validateModuleSpecifications = function(moduleSpecifications) { + super$validateModuleSpecifications( + moduleSpecifications = moduleSpecifications + ) + } + ), + private = list( + .getModelInfo = function(strategusOutputPath) { + modelDesigns <- list.files(strategusOutputPath, pattern = "modelDesign.json", + recursive = TRUE, full.names = TRUE) + model <- NULL + for (modelFilePath in modelDesigns) { + directory <- dirname(modelFilePath) + modelDesign <- ParallelLogger::loadSettingsFromJson(modelFilePath) + + if (is.null(model)) { + model <- data.frame( + target_id = modelDesign$targetId, + outcome_id = modelDesign$outcomeId, + modelPath = directory) + } else { + model <- rbind(model, + data.frame( + target_id = modelDesign$targetId, + outcome_id = modelDesign$outcomeId, + modelPath = directory)) + } + } + + models <- model %>% + dplyr::group_by(.data$target_id, .data$outcome_id) %>% + dplyr::summarise(modelPath = list(.data$modelPath), .groups = "drop") + return(models) + }, + # this updates the cohort table details in covariates + .updateCovariates = function(plpModel, cohortTable, cohortDatabaseSchema){ + + covSettings <- plpModel$modelDesign$covariateSettings + # if a single setting make it into a list to force consistency + if (inherits(covSettings, 'covariateSettings')) { + covSettings <- list(covSettings) + } + + for (i in 1:length(covSettings)) { + if ('cohortTable' %in% names(covSettings[[i]])) { + covSettings[[i]]$cohortTable <- cohortTable + } + if ('cohortDatabaseSchema' %in% names(covSettings[[i]])) { + covSettings[[i]]$cohortDatabaseSchema <- cohortDatabaseSchema + } + } + + plpModel$modelDesign$covariateSettings <- covSettings + + return(plpModel) + } + ) +) diff --git a/inst/testdata/plpvmodule/plpModel.rds b/inst/testdata/plpvmodule/plpModel.rds new file mode 100644 index 00000000..8467cdd4 Binary files /dev/null and b/inst/testdata/plpvmodule/plpModel.rds differ diff --git a/man/ModelTransferModule.Rd b/man/ModelTransferModule.Rd new file mode 100644 index 00000000..d643fca0 --- /dev/null +++ b/man/ModelTransferModule.Rd @@ -0,0 +1,131 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Module-ModelTransferModule.R +\name{ModelTransferModule} +\alias{ModelTransferModule} +\title{Model transfer module} +\description{ +This module contains functionality for moving plpModels to/from S3 buckets +and github repositories from your local file system. +} +\section{Super class}{ +\code{\link[Strategus:StrategusModule]{Strategus::StrategusModule}} -> \code{ModelTransferModule} +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-ModelTransferModule-new}{\code{ModelTransferModule$new()}} +\item \href{#method-ModelTransferModule-execute}{\code{ModelTransferModule$execute()}} +\item \href{#method-ModelTransferModule-createModuleSpecifications}{\code{ModelTransferModule$createModuleSpecifications()}} +\item \href{#method-ModelTransferModule-validateModuleSpecifications}{\code{ModelTransferModule$validateModuleSpecifications()}} +\item \href{#method-ModelTransferModule-clone}{\code{ModelTransferModule$clone()}} +} +} +\if{html}{\out{ +
Inherited methods + +
+}} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ModelTransferModule-new}{}}} +\subsection{Method \code{new()}}{ +Initialize the module +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{ModelTransferModule$new()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ModelTransferModule-execute}{}}} +\subsection{Method \code{execute()}}{ +Generates the cohorts +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{ModelTransferModule$execute( + connectionDetails, + analysisSpecifications, + executionSettings +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{connectionDetails}}{An object of class \code{connectionDetails} as created by the +\code{\link[DatabaseConnector:createConnectionDetails]{DatabaseConnector::createConnectionDetails()}} function.} + +\item{\code{analysisSpecifications}}{An object of type \code{AnalysisSpecifications} as created +by \code{\link[=createEmptyAnalysisSpecificiations]{createEmptyAnalysisSpecificiations()}}.} + +\item{\code{executionSettings}}{An object of type \code{ExecutionSettings} as created +by \code{\link[=createCdmExecutionSettings]{createCdmExecutionSettings()}} or \code{\link[=createResultsExecutionSettings]{createResultsExecutionSettings()}}.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ModelTransferModule-createModuleSpecifications}{}}} +\subsection{Method \code{createModuleSpecifications()}}{ +Creates the ModelTransferModule Specifications +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{ModelTransferModule$createModuleSpecifications( + s3Settings = NULL, + githubSettings = NULL, + localFileSettings = NULL +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{s3Settings}}{description} + +\item{\code{githubSettings}}{description} + +\item{\code{localFileSettings}}{description +include steps to compute inclusion rule statistics.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ModelTransferModule-validateModuleSpecifications}{}}} +\subsection{Method \code{validateModuleSpecifications()}}{ +Validate the module specifications +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{ModelTransferModule$validateModuleSpecifications(moduleSpecifications)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{moduleSpecifications}}{The ModelTransfer module specifications} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ModelTransferModule-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{ModelTransferModule$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/man/PatientLevelPredictionValidationModule.Rd b/man/PatientLevelPredictionValidationModule.Rd new file mode 100644 index 00000000..11f08dc5 --- /dev/null +++ b/man/PatientLevelPredictionValidationModule.Rd @@ -0,0 +1,211 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Module-PatientLevelPredictionValidation.R +\name{PatientLevelPredictionValidationModule} +\alias{PatientLevelPredictionValidationModule} +\title{Module for performing validation of patient-level prediction models} +\description{ +Module for performing patient-level prediction model validation for models +built using the PatientLevelPrediction package. +} +\section{Super class}{ +\code{\link[Strategus:StrategusModule]{Strategus::StrategusModule}} -> \code{PatientLevelPredictionValidationModule} +} +\section{Public fields}{ +\if{html}{\out{
}} +\describe{ +\item{\code{tablePrefix}}{The table prefix to append to the results tables} +} +\if{html}{\out{
}} +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-PatientLevelPredictionValidationModule-new}{\code{PatientLevelPredictionValidationModule$new()}} +\item \href{#method-PatientLevelPredictionValidationModule-execute}{\code{PatientLevelPredictionValidationModule$execute()}} +\item \href{#method-PatientLevelPredictionValidationModule-createResultsDataModel}{\code{PatientLevelPredictionValidationModule$createResultsDataModel()}} +\item \href{#method-PatientLevelPredictionValidationModule-uploadResults}{\code{PatientLevelPredictionValidationModule$uploadResults()}} +\item \href{#method-PatientLevelPredictionValidationModule-createModuleSpecifications}{\code{PatientLevelPredictionValidationModule$createModuleSpecifications()}} +\item \href{#method-PatientLevelPredictionValidationModule-validateModuleSpecifications}{\code{PatientLevelPredictionValidationModule$validateModuleSpecifications()}} +\item \href{#method-PatientLevelPredictionValidationModule-clone}{\code{PatientLevelPredictionValidationModule$clone()}} +} +} +\if{html}{\out{ +
Inherited methods + +
+}} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-new}{}}} +\subsection{Method \code{new()}}{ +Initialize the module +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$new()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-execute}{}}} +\subsection{Method \code{execute()}}{ +Executes the PatientLevelPrediction package to validate a +PLP model +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$execute( + connectionDetails, + analysisSpecifications, + executionSettings +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{connectionDetails}}{An object of class \code{connectionDetails} as created by the +\code{\link[DatabaseConnector:createConnectionDetails]{DatabaseConnector::createConnectionDetails()}} function.} + +\item{\code{analysisSpecifications}}{An object of type \code{AnalysisSpecifications} as created +by \code{\link[=createEmptyAnalysisSpecificiations]{createEmptyAnalysisSpecificiations()}}.} + +\item{\code{analysisSpecifications}}{An object of type \code{AnalysisSpecifications} as created +by \code{\link[=createEmptyAnalysisSpecificiations]{createEmptyAnalysisSpecificiations()}}.} + +\item{\code{executionSettings}}{An object of type \code{ExecutionSettings} as created +by \code{\link[=createCdmExecutionSettings]{createCdmExecutionSettings()}} or \code{\link[=createResultsExecutionSettings]{createResultsExecutionSettings()}}.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-createResultsDataModel}{}}} +\subsection{Method \code{createResultsDataModel()}}{ +Create the results data model for the module +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$createResultsDataModel( + resultsConnectionDetails, + resultsDatabaseSchema, + tablePrefix = self$tablePrefix +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{resultsConnectionDetails}}{The connection details to the results database which +is an object of class \code{connectionDetails} as created by the +\code{\link[DatabaseConnector:createConnectionDetails]{DatabaseConnector::createConnectionDetails()}} function.} + +\item{\code{resultsConnectionDetails}}{The connection details to the results database which +is an object of class \code{connectionDetails} as created by the +\code{\link[DatabaseConnector:createConnectionDetails]{DatabaseConnector::createConnectionDetails()}} function.} + +\item{\code{resultsDatabaseSchema}}{The schema in the results database that holds the results data model.} + +\item{\code{tablePrefix}}{A prefix to apply to the database table names (optional).} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-uploadResults}{}}} +\subsection{Method \code{uploadResults()}}{ +Upload the results for the module +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$uploadResults( + resultsConnectionDetails, + analysisSpecifications, + resultsDataModelSettings +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{resultsConnectionDetails}}{The connection details to the results database which +is an object of class \code{connectionDetails} as created by the +\code{\link[DatabaseConnector:createConnectionDetails]{DatabaseConnector::createConnectionDetails()}} function.} + +\item{\code{resultsConnectionDetails}}{The connection details to the results database which +is an object of class \code{connectionDetails} as created by the +\code{\link[DatabaseConnector:createConnectionDetails]{DatabaseConnector::createConnectionDetails()}} function.} + +\item{\code{analysisSpecifications}}{An object of type \code{AnalysisSpecifications} as created +by \code{\link[=createEmptyAnalysisSpecificiations]{createEmptyAnalysisSpecificiations()}}.} + +\item{\code{analysisSpecifications}}{An object of type \code{AnalysisSpecifications} as created +by \code{\link[=createEmptyAnalysisSpecificiations]{createEmptyAnalysisSpecificiations()}}.} + +\item{\code{resultsDataModelSettings}}{The results data model settings as created using [@seealso \code{\link[=createResultsDataModelSettings]{createResultsDataModelSettings()}}]} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-createModuleSpecifications}{}}} +\subsection{Method \code{createModuleSpecifications()}}{ +Creates the PatientLevelPredictionValidation Module Specifications +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$createModuleSpecifications( + validationComponentsList = list(list(targetId = 1, oucomeId = 4, + restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), + validationSettings = PatientLevelPrediction::createValidationSettings(recalibrate = + "weakRecalibration"), populationSettings = + PatientLevelPrediction::createStudyPopulationSettings(riskWindowStart = 90, + riskWindowEnd = 360, requireTimeAtRisk = F)), list(targetId = 3, oucomeId = 4, + restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(), + validationSettings = PatientLevelPrediction::createValidationSettings(recalibrate = + "weakRecalibration"))) +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{validationComponentsList}}{description} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-validateModuleSpecifications}{}}} +\subsection{Method \code{validateModuleSpecifications()}}{ +Validate the module specifications +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$validateModuleSpecifications( + moduleSpecifications +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{moduleSpecifications}}{The PatientLevelPredictionValidation module specifications} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-PatientLevelPredictionValidationModule-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{PatientLevelPredictionValidationModule$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/tests/testthat/test-PatientLevelPredictionValidationModule.R b/tests/testthat/test-PatientLevelPredictionValidationModule.R new file mode 100644 index 00000000..0e4000bb --- /dev/null +++ b/tests/testthat/test-PatientLevelPredictionValidationModule.R @@ -0,0 +1,65 @@ +library(testthat) +library(Strategus) + +test_that("Test PLP Validation Module", { + workFolder <- tempfile("work") + dir.create(workFolder) + resultsFolder <- tempfile("results") + dir.create(resultsFolder) + withr::defer( + { + unlink(workFolder, recursive = TRUE, force = TRUE) + unlink(resultsFolder, recursive = TRUE, force = TRUE) + }, + testthat::teardown_env() + ) + + # jobContext <- readRDS("tests/testJobContext.rds") + # jobContext$moduleExecutionSettings$workSubFolder <- workFolder + # jobContext$moduleExecutionSettings$resultsSubFolder <- resultsFolder + # jobContext$moduleExecutionSettings$connectionDetails <- connectionDetails + + # 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 + PatientLevelPrediction::savePlpModel( + plpModel, + file.path(modelSaveLocation, 'model_1_1') + ) + + # Create the validation settings and run the module + plpvSettingsCreator <- PatientLevelPredictionValidationModule$new() + plpModuleSettings <- plpvSettingsCreator$createModuleSpecifications() + + analysisSpecifications <- createEmptyAnalysisSpecificiations() %>% + addModuleSpecifications(plpModuleSettings) + + executionSettings <- createCdmExecutionSettings( + workDatabaseSchema = workDatabaseSchema, + cdmDatabaseSchema = cdmDatabaseSchema, + cohortTableNames = CohortGenerator::getCohortTableNames(cohortTable = "plpv_unit_test"), + workFolder = workFolder, + resultsFolder = resultsFolder + ) + + #debugonce(Strategus::execute) + # Strategus::execute( + # analysisSpecifications = analysisSpecifications, + # executionSettings = executionSettings, + # connectionDetails = connectionDetails + # ) + + # TODO - Remove in favor of the code + # above once I have more clarity on the + # settings + debugonce(plpvSettingsCreator$execute) + plpvSettingsCreator$execute( + analysisSpecifications = analysisSpecifications, + executionSettings = executionSettings, + connectionDetails = connectionDetails + ) + +})