diff --git a/DESCRIPTION b/DESCRIPTION index 18851c3e..0fc3c6b6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: OhdsiShinyModules Type: Package Title: Repository of Shiny Modules for OHDSI Result Viewers -Version: 1.1.0.9000 +Version: 1.2.0 Author: Jenna Reps Maintainer: Jenna Reps Description: Install this package to access useful shiny modules for building shiny apps to explore results using the OHDSI tools . @@ -36,6 +36,7 @@ Imports: shinydashboard, shinyWidgets, SqlRender, + stringi, stringr, tibble, tidyr, diff --git a/NAMESPACE b/NAMESPACE index 58efa568..c5afccfa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,19 +3,56 @@ export(aboutHelperFile) export(aboutServer) export(aboutViewer) -export(characterizationView) +export(characterizationAggregateFeaturesServer) +export(characterizationAggregateFeaturesViewer) +export(characterizationDechallengeRechallengeServer) +export(characterizationDechallengeRechallengeViewer) +export(characterizationHelperFile) +export(characterizationIncidenceServer) +export(characterizationIncidenceViewer) +export(characterizationServer) +export(characterizationTableServer) +export(characterizationTableViewer) +export(characterizationTimeToEventServer) +export(characterizationTimeToEventViewer) +export(characterizationViewer) export(cohortCountsView) export(cohortDefinitionsView) +export(cohortDiagCharacterizationView) export(cohortDiagnosticsHelperFile) -export(cohortDiagnosticsSever) +export(cohortDiagnosticsServer) export(cohortDiagnosticsView) export(cohortGeneratorHelperFile) export(cohortGeneratorServer) export(cohortGeneratorViewer) +export(cohortMethodAttritionServer) +export(cohortMethodAttritionViewer) +export(cohortMethodCovariateBalanceServer) +export(cohortMethodCovariateBalanceViewer) +export(cohortMethodDiagnosticsSummaryServer) +export(cohortMethodDiagnosticsSummaryViewer) +export(cohortMethodHelperFile) +export(cohortMethodKaplanMeierServer) +export(cohortMethodKaplanMeierViewer) +export(cohortMethodPopulationCharacteristicsServer) +export(cohortMethodPopulationCharacteristicsViewer) +export(cohortMethodPowerServer) +export(cohortMethodPowerViewer) +export(cohortMethodPropensityModelServer) +export(cohortMethodPropensityModelViewer) +export(cohortMethodPropensityScoreDistServer) +export(cohortMethodPropensityScoreDistViewer) +export(cohortMethodResultSummaryServer) +export(cohortMethodResultSummaryViewer) +export(cohortMethodServer) +export(cohortMethodSystematicErrorServer) +export(cohortMethodSystematicErrorViewer) +export(cohortMethodViewer) export(cohortOverlapView) export(compareCohortCharacterizationView) export(conceptsInDataSourceView) export(createCdDatabaseDataSource) +export(createCustomColDefList) export(dataDiagnosticDrillServer) export(dataDiagnosticDrillViewer) export(dataDiagnosticHelperFile) @@ -24,46 +61,9 @@ export(dataDiagnosticSummaryServer) export(dataDiagnosticSummaryViewer) export(dataDiagnosticViewer) export(databaseInformationView) -export(descriptionAggregateFeaturesServer) -export(descriptionAggregateFeaturesViewer) -export(descriptionDechallengeRechallengeServer) -export(descriptionDechallengeRechallengeViewer) -export(descriptionHelperFile) -export(descriptionIncidenceServer) -export(descriptionIncidenceViewer) -export(descriptionServer) -export(descriptionTableServer) -export(descriptionTableViewer) -export(descriptionTimeToEventServer) -export(descriptionTimeToEventViewer) -export(descriptionViewer) -export(estimationAttritionServer) -export(estimationAttritionViewer) -export(estimationCovariateBalanceServer) -export(estimationCovariateBalanceViewer) -export(estimationDiagnosticsSummaryServer) -export(estimationDiagnosticsSummaryViewer) -export(estimationForestPlotServer) -export(estimationForestPlotViewer) -export(estimationHelperFile) -export(estimationKaplanMeierServer) -export(estimationKaplanMeierViewer) -export(estimationPopulationCharacteristicsServer) -export(estimationPopulationCharacteristicsViewer) -export(estimationPowerServer) -export(estimationPowerViewer) -export(estimationPropensityModelServer) -export(estimationPropensityModelViewer) -export(estimationPropensityScoreDistServer) -export(estimationPropensityScoreDistViewer) -export(estimationResultsTableServer) -export(estimationResultsTableViewer) -export(estimationServer) -export(estimationSubgroupsServer) -export(estimationSubgroupsViewer) -export(estimationSystematicErrorServer) -export(estimationSystematicErrorViewer) -export(estimationViewer) +export(datasourcesHelperFile) +export(datasourcesServer) +export(datasourcesViewer) export(evidenceSynthesisHelperFile) export(evidenceSynthesisServer) export(evidenceSynthesisViewer) @@ -72,32 +72,36 @@ export(getLogoImage) export(incidenceRatesView) export(inclusionRulesView) export(indexEventBreakdownView) +export(makeButtonLabel) export(orpahanConceptsView) -export(predictionCalibrationServer) -export(predictionCalibrationViewer) -export(predictionCovariateSummaryServer) -export(predictionCovariateSummaryViewer) -export(predictionCutoffServer) -export(predictionCutoffViewer) -export(predictionDesignSummaryServer) -export(predictionDesignSummaryViewer) -export(predictionDiagnosticsServer) -export(predictionDiagnosticsViewer) -export(predictionDiscriminationServer) -export(predictionDiscriminationViewer) -export(predictionHelperFile) -export(predictionModelSummaryServer) -export(predictionModelSummaryViewer) -export(predictionNbServer) -export(predictionNbViewer) -export(predictionServer) -export(predictionSettingsServer) -export(predictionSettingsViewer) -export(predictionValidationServer) -export(predictionValidationViewer) -export(predictionViewer) -export(sccsDiagnosticsSummaryServer) -export(sccsDiagnosticsSummaryViewer) +export(patientLevelPredictionCalibrationServer) +export(patientLevelPredictionCalibrationViewer) +export(patientLevelPredictionCovariateSummaryServer) +export(patientLevelPredictionCovariateSummaryViewer) +export(patientLevelPredictionCutoffServer) +export(patientLevelPredictionCutoffViewer) +export(patientLevelPredictionDesignSummaryServer) +export(patientLevelPredictionDesignSummaryViewer) +export(patientLevelPredictionDiagnosticsServer) +export(patientLevelPredictionDiagnosticsViewer) +export(patientLevelPredictionDiscriminationServer) +export(patientLevelPredictionDiscriminationViewer) +export(patientLevelPredictionHelperFile) +export(patientLevelPredictionModelSummaryServer) +export(patientLevelPredictionModelSummaryViewer) +export(patientLevelPredictionNbServer) +export(patientLevelPredictionNbViewer) +export(patientLevelPredictionServer) +export(patientLevelPredictionSettingsServer) +export(patientLevelPredictionSettingsViewer) +export(patientLevelPredictionValidationServer) +export(patientLevelPredictionValidationViewer) +export(patientLevelPredictionViewer) +export(phevaluatorHelperFile) +export(phevaluatorServer) +export(phevaluatorViewer) +export(resultTableServer) +export(resultTableViewer) export(sccsHelperFile) export(sccsServer) export(sccsView) diff --git a/NEWS.md b/NEWS.md index 929c0bc0..63041380 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +OhdsiShinyModules v1.2.0 +======================== +- updated all models to use the same resultDatabaseSettings +- made module function naming consistent (modules named after analysis packages) +- made table prefix inputs consistent across modules + OhdsiShinyModules v1.1.0 ======================== - Udated the style for Characterization diff --git a/R/about-main.R b/R/about-main.R index a08eebbf..00351e85 100644 --- a/R/about-main.R +++ b/R/about-main.R @@ -42,7 +42,9 @@ aboutHelperFile <- function(){ #' The user interface to the home page module #' #' @export -aboutViewer <- function(id = 'homepage') { +aboutViewer <- function( + id = 'homepage' + ) { ns <- shiny::NS(id) shinydashboard::box( @@ -71,12 +73,18 @@ aboutViewer <- function(id = 'homepage') { #' The user specifies the id for the module #' #' @param id the unique reference id for the module +#' @param connectionHandler a connection to the database with the results +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return #' The server for the shiny app home #' #' @export -aboutServer <- function(id = 'homepage') { +aboutServer <- function( + id = 'homepage', + connectionHandler = NULL, + resultDatabaseSettings = NULL + ) { shiny::moduleServer( id, function(input, output, session) { diff --git a/R/description-aggregateFeatures.R b/R/characterization-aggregateFeatures.R similarity index 90% rename from R/description-aggregateFeatures.R rename to R/characterization-aggregateFeatures.R index 9b321df0..1d333c32 100644 --- a/R/description-aggregateFeatures.R +++ b/R/characterization-aggregateFeatures.R @@ -1,4 +1,4 @@ -# @file description-aggregateFeatures.R +# @file characterization-aggregateFeatures.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the description aggregate feature module #' #' @export -descriptionAggregateFeaturesViewer <- function(id) { +characterizationAggregateFeaturesViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -38,7 +38,7 @@ descriptionAggregateFeaturesViewer <- function(id) { collapsed = TRUE, title = "Outcome Stratified", width = "100%", - shiny::htmlTemplate(system.file("description-www", "help-OutcomeStratified.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("characterization-www", "help-OutcomeStratified.html", package = utils::packageName())) ), # summary table @@ -111,23 +111,17 @@ descriptionAggregateFeaturesViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param mainPanelTab the current tab -#' @param schema the database schema for the model results -#' @param tablePrefix a string that appends the tables in the result schema -#' @param cohortTablePrefix a string that appends the COHORT_DEFINITION table in the result schema -#' @param databaseTable The database table name +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return #' The server to the description aggregate features module #' #' @export -descriptionAggregateFeaturesServer <- function( +characterizationAggregateFeaturesServer <- function( id, connectionHandler, mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA' + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -189,18 +183,14 @@ descriptionAggregateFeaturesServer <- function( # get the possible options options <- getAggregateFeatureOptions( connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix, - cohortTablePrefix = cohortTablePrefix - ) + resultDatabaseSettings = resultDatabaseSettings + ) # get databases databases <- getAggregateFeatureDatabases( connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix, - databaseTable = databaseTable - ) + resultDatabaseSettings = resultDatabaseSettings + ) # add buttons @@ -412,10 +402,9 @@ descriptionAggregateFeaturesServer <- function( ) ) - allData <- descriptiveGetAggregateData( + allData <- characterizationGetAggregateData( connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix, + resultDatabaseSettings = resultDatabaseSettings, targetId = input$target, outcomeId = input$outcome, riskWindowStart = options$tarList[[ind]]$riskWindowStart, @@ -429,20 +418,20 @@ descriptionAggregateFeaturesServer <- function( ) output$binaryPlot <- plotly::renderPlotly( - descriptiveFeaturePlot( + characterizationFeaturePlot( data = allData$binary, valueColumn = 'averageValue' ) ) output$continuousPlot <- plotly::renderPlotly( - descriptiveFeaturePlot( + characterizationFeaturePlot( data = allData$continuous, valueColumn = 'averageValue' ) ) - binaryData(descriptiveFeatureTable(data = allData$binary)) - continuousData(descriptiveFeatureTable(data = allData$continuous)) + binaryData(characterizationFeatureTable(data = allData$binary)) + continuousData(characterizationFeatureTable(data = allData$continuous)) output$binaryTable <- reactable::renderReactable({ reactable::reactable( @@ -584,9 +573,7 @@ descriptionAggregateFeaturesServer <- function( getAggregateFeatureOptions <- function( connectionHandler, - schema, - tablePrefix, - cohortTablePrefix + resultDatabaseSettings ){ @@ -595,12 +582,12 @@ getAggregateFeatureOptions <- function( sql <- "SELECT DISTINCT t.COHORT_NAME as TARGET, cd.TARGET_COHORT_ID, o.COHORT_NAME as outcome, cd.OUTCOME_COHORT_ID, s.RISK_WINDOW_START, s.START_ANCHOR, s.RISK_WINDOW_END, s.END_ANCHOR - FROM @result_database_schema.@table_prefixCOHORT_DETAILS cd - inner join @result_database_schema.@table_prefixSETTINGS s + FROM @schema.@c_table_prefixCOHORT_DETAILS cd + inner join @schema.@c_table_prefixSETTINGS s on cd.run_id = s.run_id and cd.database_id = s.database_id - inner join @result_database_schema.@cohort_table_prefixCOHORT_DEFINITION t + inner join @schema.@cg_table_prefixCOHORT_DEFINITION t on cd.TARGET_COHORT_ID = t.COHORT_DEFINITION_ID - inner join @result_database_schema.@cohort_table_prefixCOHORT_DEFINITION o + inner join @schema.@cg_table_prefixCOHORT_DEFINITION o on cd.OUTCOME_COHORT_ID = o.COHORT_DEFINITION_ID WHERE cd.TARGET_COHORT_ID != 0 AND cd.OUTCOME_COHORT_ID != 0;" @@ -608,9 +595,9 @@ getAggregateFeatureOptions <- function( options <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) shiny::incProgress(2/2, detail = paste("Finished")) @@ -668,17 +655,15 @@ getAggregateFeatureOptions <- function( getAggregateFeatureDatabases <- function( connectionHandler, - schema, - tablePrefix, - databaseTable + resultDatabaseSettings ){ shiny::withProgress(message = 'Finding databases', value = 0, { sql <- "SELECT DISTINCT s.DATABASE_ID, d.CDM_SOURCE_ABBREVIATION as database_name - FROM @result_database_schema.@table_prefixCOHORT_DETAILS cd - inner join @result_database_schema.@database_table d + FROM @schema.@c_table_prefixCOHORT_DETAILS cd + inner join @schema.@database_table d on cd.database_id = d.database_id - inner join @result_database_schema.@table_prefixSETTINGS s + inner join @schema.@c_table_prefixSETTINGS s on s.database_id = d.database_id and s.run_id = cd.run_id;" @@ -687,9 +672,9 @@ getAggregateFeatureDatabases <- function( databases <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, - database_table = databaseTable + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + database_table = resultDatabaseSettings$databaseTable ) shiny::incProgress(2/2, detail = paste("Finished")) @@ -704,10 +689,9 @@ getAggregateFeatureDatabases <- function( } # pulls all data for a target and outcome -descriptiveGetAggregateData <- function( +characterizationGetAggregateData <- function( connectionHandler, - schema, - tablePrefix, + resultDatabaseSettings, targetId, outcomeId, riskWindowStart, @@ -722,9 +706,9 @@ descriptiveGetAggregateData <- function( shiny::withProgress(message = 'Getting Feature Comparison Data', value = 0, { sql <- "SELECT s.RUN_ID, cd.COHORT_DEFINITION_ID - FROM @result_database_schema.@table_prefixSETTINGS s + FROM @schema.@c_table_prefixSETTINGS s inner join - @result_database_schema.@table_prefixCOHORT_DETAILS cd + @schema.@c_table_prefixCOHORT_DETAILS cd on cd.database_id = s.database_id and cd.run_id = s.run_id WHERE cd.TARGET_COHORT_ID = @target_id and cd.OUTCOME_COHORT_ID = @outcome_id @@ -734,8 +718,8 @@ descriptiveGetAggregateData <- function( settingsFirst <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, target_id = ifelse(type1 %in% c('firstO','O'), 0, targetId), outcome_id = ifelse(type1 %in% c('T', 'allT'), 0, outcomeId), risk_window_start = riskWindowStart, @@ -750,9 +734,9 @@ descriptiveGetAggregateData <- function( sql <- "SELECT s.RUN_ID, cd.COHORT_DEFINITION_ID - FROM @result_database_schema.@table_prefixSETTINGS s + FROM @schema.@c_table_prefixSETTINGS s inner join - @result_database_schema.@table_prefixCOHORT_DETAILS cd + @schema.@c_table_prefixCOHORT_DETAILS cd on cd.database_id = s.database_id and cd.run_id = s.run_id WHERE cd.TARGET_COHORT_ID = @target_id and cd.OUTCOME_COHORT_ID = @outcome_id @@ -763,8 +747,8 @@ descriptiveGetAggregateData <- function( settingsSecond <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, target_id = ifelse(type1 %in% c('firstO','O'), 0, targetId), outcome_id = ifelse(type1 %in% c('T', 'allT'), 0, outcomeId), risk_window_start = riskWindowStart, @@ -779,14 +763,14 @@ descriptiveGetAggregateData <- function( sql <- "SELECT cov.*, cov_ref.COVARIATE_NAME, an_ref.ANALYSIS_NAME, case when (cov.DATABASE_ID = '@database_id1' and cov.COHORT_DEFINITION_ID = @cohortDef1 and cov.RUN_ID in (@run_id1)) then 'comp1' else 'comp2' end as label - FROM @result_database_schema.@table_prefixCOVARIATES cov + FROM @schema.@c_table_prefixCOVARIATES cov INNER JOIN - @result_database_schema.@table_prefixCOVARIATE_REF cov_ref + @schema.@c_table_prefixCOVARIATE_REF cov_ref ON cov.covariate_id = cov_ref.covariate_id and cov.run_id = cov_ref.run_id and cov.database_id = cov_ref.database_id INNER JOIN - @result_database_schema.@table_prefixANALYSIS_REF an_ref + @schema.@c_table_prefixANALYSIS_REF an_ref ON an_ref.analysis_id = cov_ref.analysis_id and an_ref.run_id = cov_ref.run_id and an_ref.database_id = cov_ref.database_id @@ -801,8 +785,8 @@ descriptiveGetAggregateData <- function( binary <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, cohortDef1 = settingsFirst$cohortDefinitionId[1], cohortDef2 = settingsSecond$cohortDefinitionId[1], database_id1 = database1, @@ -815,14 +799,14 @@ descriptiveGetAggregateData <- function( sql <- "SELECT cov.*, cov_ref.COVARIATE_NAME, an_ref.ANALYSIS_NAME, case when (cov.DATABASE_ID = '@database_id1' and cov.COHORT_DEFINITION_ID = @cohortDef1 and cov.RUN_ID in (@run_id1)) then 'comp1' else 'comp2' end as label - FROM @result_database_schema.@table_prefixCOVARIATES_CONTINUOUS cov + FROM @schema.@c_table_prefixCOVARIATES_CONTINUOUS cov INNER JOIN - @result_database_schema.@table_prefixCOVARIATE_REF cov_ref + @schema.@c_table_prefixCOVARIATE_REF cov_ref ON cov.covariate_id = cov_ref.covariate_id and cov.run_id = cov_ref.run_id and cov.database_id = cov_ref.database_id INNER JOIN - @result_database_schema.@table_prefixANALYSIS_REF an_ref + @schema.@c_table_prefixANALYSIS_REF an_ref ON an_ref.analysis_id = cov_ref.analysis_id and an_ref.run_id = cov_ref.run_id and an_ref.database_id = cov_ref.database_id @@ -835,8 +819,8 @@ descriptiveGetAggregateData <- function( continuous <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, cohortDef1 = settingsFirst$cohortDefinitionId[1], cohortDef2 = settingsSecond$cohortDefinitionId[1], database_id1 = database1, @@ -855,7 +839,7 @@ descriptiveGetAggregateData <- function( )) } -descriptiveFeaturePlot <- function( +characterizationFeaturePlot <- function( data, valueColumn = 'averageValue' ){ @@ -939,7 +923,7 @@ descGetTime <- function(x){ } -descriptiveFeatureTable <- function( +characterizationFeatureTable <- function( data ){ diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R new file mode 100644 index 00000000..3ba834b0 --- /dev/null +++ b/R/characterization-cohorts.R @@ -0,0 +1,371 @@ +# @file characterization-timeToEvent.R +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for exploring 1 or more cohorts features +#' +#' @details +#' The user specifies the id for the module +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the description cohorts features +#' +#' @export +characterizationTableViewer <- function(id) { + ns <- shiny::NS(id) + shiny::div( + shinydashboard::box( + collapsible = TRUE, + collapsed = TRUE, + title = "Target Viewer", + width = "100%", + shiny::htmlTemplate(system.file("characterization-www", "help-targetViewer.html", package = utils::packageName())) + ), + + shinydashboard::box( + width = "100%", + title = 'Options', + collapsible = TRUE, + collapsed = F, + shiny::uiOutput(ns('cohortInputs')) + ), + + shiny::conditionalPanel( + condition = "input.generate != 0", + ns = ns, + + shiny::uiOutput(ns("TinputsText")), + + resultTableViewer(ns("result-table")) + ) + ) +} + + +#' The module server for exploring 1 or more cohorts features +#' +#' @details +#' The user specifies the id for the module +#' +#' @param id the unique reference id for the module +#' @param connectionHandler the connection to the prediction result database +#' @param mainPanelTab the current tab +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix +#' +#' @return +#' The server to the cohorts features server +#' +#' @export +characterizationTableServer <- function( + id, + connectionHandler, + mainPanelTab, + resultDatabaseSettings +) { + shiny::moduleServer( + id, + function(input, output, session) { + + inputVals <- getDecCohortsInputs( + connectionHandler, + resultDatabaseSettings + ) + + # update UI + output$cohortInputs <- shiny::renderUI({ + shiny::fluidPage( + shiny::fluidRow( + shiny::column( + width = 6, + shinyWidgets::pickerInput( + inputId = session$ns('targetIds'), + label = 'Targets: ', + choices = inputVals$cohortIds, + selected = inputVals$cohortIds, + choicesOpt = list(style = rep_len("color: black;", 999)), + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + shiny::column( + width = 6, + shinyWidgets::pickerInput( + inputId = session$ns('databaseId'), + label = 'Database: ', + choices = inputVals$databaseIds, + selected = 1, + choicesOpt = list( + style = rep_len("color: black;", 999) + ), + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ) + ), + + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate Report' + ) + ) + }) + + allData <- + shiny::eventReactive(#we care about returning this value, so we use eventReactive + eventExpr = input$generate, #could add complexity to event if desired + { + if (is.null(input$targetIds)) { + data.frame() + } + getDesFEData( + targetIds = input$targetIds, + databaseId = input$databaseId, + connectionHandler = connectionHandler, + resultDatabaseSettings + ) + }) + + + selectedInputs <- shiny::reactiveVal() + output$TinputsText <- shiny::renderUI( + selectedInputs() + ) + + shiny::observeEvent( + eventExpr = input$generate, + { + if (length(input$targetIds) == 0 | is.null(input$databaseId)) { + print('Null ids value') + return(invisible(NULL)) + } + + selectedInputs( + shinydashboard::box( + status = 'warning', + width = "100%", + title = 'Selected:', + shiny::div(shiny::fluidRow( + shiny::column( + width = 8, + shiny::tags$b("Target/s:"), + + paste(names(inputVals$cohortIds)[inputVals$cohortIds %in% input$targetIds], + collapse = ',') + + ), + shiny::column( + width = 4, + shiny::tags$b("Database:"), + names(inputVals$databaseIds)[inputVals$databaseIds == input$databaseId] + ) + )) + ) + ) + + }) + + + #cols: covariateId, covariateName, analysisName, + #averageValue_"target", countValue_"target" + + custom_colDefs <- list( + covariateId = reactable::colDef( + header = withTooltip("Covariate ID", + "Unique identifier of the covariate") + ), + covariateName = reactable::colDef( + header = withTooltip( + "Covariate Name", + "The name of the covariate" + ) + ), + analysisName = reactable::colDef( + header = withTooltip( + "Covariate Class", + "Class/type of the covariate" + ) + ) + ) + + resultTableServer( + id = "result-table", + df = allData, + colDefsInput = custom_colDefs + ) + + return(invisible(NULL)) + + }) + +} + + +getDesFEData <- function( + targetIds, + databaseId, + connectionHandler, + resultDatabaseSettings +) { + # shiny::withProgress(message = 'Getting target comparison data', value = 0, { + + sql <- + "select distinct ref.covariate_id, ref.covariate_name, an.analysis_name, c.cohort_name, covs.COUNT_VALUE, covs.AVERAGE_VALUE + from + ( + select co.RUN_ID, cd.TARGET_COHORT_ID as COHORT_DEFINITION_ID, co.COVARIATE_ID, + co.SUM_VALUE as COUNT_VALUE, co.AVERAGE_VALUE*100 as AVERAGE_VALUE from + @schema.@c_table_prefixCOVARIATES co + inner join + (select * from @schema.@c_table_prefixcohort_details + where DATABASE_ID = '@database_id' and + TARGET_COHORT_ID in (@cohort_ids) and COHORT_TYPE = 'T' + ) as cd + on co.COHORT_DEFINITION_ID = cd.COHORT_DEFINITION_ID + and co.DATABASE_ID = cd.DATABASE_ID + union + select cc.RUN_ID, cds.TARGET_COHORT_ID as COHORT_DEFINITION_ID, cc.COVARIATE_ID, cc.COUNT_VALUE, cc.AVERAGE_VALUE from + @schema.@c_table_prefixCOVARIATES_continuous cc + inner join + (select * from @schema.@c_table_prefixcohort_details + where DATABASE_ID = '@database_id' and + TARGET_COHORT_ID in (@cohort_ids) and COHORT_TYPE = 'T' + ) as cds + on cc.COHORT_DEFINITION_ID = cds.COHORT_DEFINITION_ID + and cc.DATABASE_ID = cds.DATABASE_ID + ) covs + inner join + @schema.@c_table_prefixcovariate_ref ref + on covs.RUN_ID = ref.RUN_ID and + covs.COVARIATE_ID = ref.COVARIATE_ID + inner join @schema.@c_table_prefixanalysis_ref an + on an.RUN_ID = ref.RUN_ID and + an.analysis_id = ref.analysis_id + inner join @schema.@cg_table_prefixcohort_definition c + on c.cohort_definition_id = covs.COHORT_DEFINITION_ID + ; + " + + # shiny::incProgress(1/3, detail = paste("Created SQL - Extracting...")) + + resultTable <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + cohort_ids = paste(as.double(targetIds), collapse = ','), + database_id = databaseId + ) + + # shiny::incProgress(2/3, detail = paste("Formating")) + + #format + resultTable$averageValue <- round( + x = resultTable$averageValue, + digits = 2 + ) + + resultTable <- resultTable %>% + tidyr::pivot_wider( + names_from = "cohortName", + #.data$cohortName, + values_from = c("averageValue", "countValue"), + #c(.data$averageValue, .data$countValue), + id_cols = c("covariateId", "covariateName", "analysisName") #c(.data$covariateId, .data$covariateName, .data$analysisName) + ) + + resultTable$analysisName <- as.factor(resultTable$analysisName) + + # shiny::incProgress(3/3, detail = paste("Done")) + + # }) + + return(resultTable) +} + + +getDecCohortsInputs <- function( + connectionHandler, + resultDatabaseSettings +) { + #shiny::withProgress(message = 'Getting target comparison inputs', value = 0, { + + + sql <- + ' select distinct c.cohort_definition_id, c.cohort_name from + @schema.@cg_table_prefixcohort_definition c + inner join + (select distinct TARGET_COHORT_ID as id + from @schema.@c_table_prefixcohort_details + ) ids + on ids.id = c.cohort_definition_id + ;' + + #shiny::incProgress(1/4, detail = paste("Extracting targetIds")) + + idVals <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix + ) + ids <- idVals$cohortDefinitionId + names(ids) <- idVals$cohortName + + #shiny::incProgress(2/4, detail = paste("Extracted targetIds")) + + + sql <- 'select d.database_id, d.cdm_source_abbreviation as database_name + from @schema.@database_table d;' + + #shiny::incProgress(3/4, detail = paste("Extracting databaseIds")) + + database <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable + ) + databaseIds <- database$databaseId + names(databaseIds) <- database$databaseName + + #shiny::incProgress(4/4, detail = paste("Done")) + + # }) + + return( + list( + cohortIds = ids, + databaseIds = databaseIds + ) + ) + +} diff --git a/R/description-dechallengeRechallenge.R b/R/characterization-dechallengeRechallenge.R similarity index 92% rename from R/description-dechallengeRechallenge.R rename to R/characterization-dechallengeRechallenge.R index 4ebf9194..ff8a4ae8 100644 --- a/R/description-dechallengeRechallenge.R +++ b/R/characterization-dechallengeRechallenge.R @@ -1,4 +1,4 @@ -# @file description-DechallengeRechallenge.R +# @file characterization-DechallengeRechallenge.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the description Dechallenge Rechallenge module #' #' @export -descriptionDechallengeRechallengeViewer <- function(id) { +characterizationDechallengeRechallengeViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -37,7 +37,7 @@ descriptionDechallengeRechallengeViewer <- function(id) { collapsed = TRUE, title = "Dechallenge Rechallenge", width = "100%", - shiny::htmlTemplate(system.file("description-www", "help-dechallengeRechallenge.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("characterization-www", "help-dechallengeRechallenge.html", package = utils::packageName())) ), shinydashboard::box( @@ -82,23 +82,17 @@ descriptionDechallengeRechallengeViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param mainPanelTab the current tab -#' @param schema the database schema for the model results -#' @param tablePrefix a string that appends the tables in the result schema -#' @param cohortTablePrefix a string that appends the cohort table in the result schema -#' @param databaseTable name of the database table +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return #' The server to the Dechallenge Rechallenge module #' #' @export -descriptionDechallengeRechallengeServer <- function( +characterizationDechallengeRechallengeServer <- function( id, connectionHandler, mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA' + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -111,9 +105,7 @@ descriptionDechallengeRechallengeServer <- function( # get the possible target ids bothIds <- dechalRechalGetIds( connectionHandler, - schema, - tablePrefix, - cohortTablePrefix + resultDatabaseSettings ) shiny::observeEvent( @@ -224,9 +216,7 @@ descriptionDechallengeRechallengeServer <- function( targetId = input$targetId, outcomeId = input$outcomeId, connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix, - databaseTable = databaseTable + resultDatabaseSettings ) reactiveData(allData) @@ -316,9 +306,7 @@ descriptionDechallengeRechallengeServer <- function( databaseId = databases()[input$databaseRowId$index], dechallengeStopInterval = dechallengeStopInterval()[input$databaseRowId$index], dechallengeEvaluationWindow = dechallengeEvaluationWindow()[input$databaseRowId$index], - connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix + resultDatabaseSettings ) # do the plots reactively @@ -359,9 +347,7 @@ descriptionDechallengeRechallengeServer <- function( dechalRechalGetIds <- function( connectionHandler, - schema, - tablePrefix, - cohortTablePrefix + resultDatabaseSettings ){ shiny::withProgress(message = 'Getting dechal Rechal T and O ids', value = 0, { @@ -370,10 +356,10 @@ dechalRechalGetIds <- function( sql <- "SELECT DISTINCT t.COHORT_NAME as target, dr.TARGET_COHORT_DEFINITION_ID, o.COHORT_NAME as outcome, dr.OUTCOME_COHORT_DEFINITION_ID - FROM @result_database_schema.@table_prefixDECHALLENGE_RECHALLENGE dr - inner join @result_database_schema.@cohort_table_prefixCOHORT_DEFINITION t + FROM @schema.@c_table_prefixDECHALLENGE_RECHALLENGE dr + inner join @schema.@cg_table_prefixCOHORT_DEFINITION t on dr.TARGET_COHORT_DEFINITION_ID = t.COHORT_DEFINITION_ID - inner join @result_database_schema.@cohort_table_prefixCOHORT_DEFINITION o + inner join @schema.@cg_table_prefixCOHORT_DEFINITION o on dr.OUTCOME_COHORT_DEFINITION_ID = o.COHORT_DEFINITION_ID ;" @@ -381,9 +367,9 @@ dechalRechalGetIds <- function( bothIds <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) shiny::incProgress(3/4, detail = paste("Processing ids")) @@ -428,17 +414,15 @@ getDechalRechalInputsData <- function( targetId, outcomeId, connectionHandler, - schema, - tablePrefix, - databaseTable + resultDatabaseSettings ){ shiny::withProgress(message = 'Extracting DECHALLENGE_RECHALLENGE data', value = 0, { sql <- "SELECT dr.*, d.CDM_SOURCE_ABBREVIATION as database_name - FROM @result_database_schema.@table_prefixDECHALLENGE_RECHALLENGE dr - inner join @result_database_schema.@database_table d + FROM @schema.@c_table_prefixDECHALLENGE_RECHALLENGE dr + inner join @schema.@database_table d on dr.database_id = d.database_id where dr.TARGET_COHORT_DEFINITION_ID = @target_id and dr.OUTCOME_COHORT_DEFINITION_ID = @outcome_id;" @@ -448,11 +432,11 @@ getDechalRechalInputsData <- function( data <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, target_id = targetId, outcome_id = outcomeId, - database_table = databaseTable + database_table = resultDatabaseSettings$databaseTable ) shiny::incProgress(3/3, detail = paste("Finished")) @@ -470,13 +454,12 @@ getDechalRechalFailData <- function( dechallengeStopInterval, dechallengeEvaluationWindow, connectionHandler, - schema, - tablePrefix + resultDatabaseSettings ){ shiny::withProgress(message = 'Extracting FAILLED DECHALLENGE_RECHALLENGE data', value = 0, { - sql <- "SELECT * FROM @result_database_schema.@table_prefixRECHALLENGE_FAIL_CASE_SERIES + sql <- "SELECT * FROM @schema.@c_table_prefixRECHALLENGE_FAIL_CASE_SERIES where TARGET_COHORT_DEFINITION_ID = @target_id and OUTCOME_COHORT_DEFINITION_ID = @outcome_id and DATABASE_ID = '@database_id' @@ -487,8 +470,8 @@ getDechalRechalFailData <- function( data <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, target_id = targetId, outcome_id = outcomeId, database_id = databaseId, diff --git a/R/description-incidence.R b/R/characterization-incidence.R similarity index 91% rename from R/description-incidence.R rename to R/characterization-incidence.R index a36241f3..8a1e7fa0 100644 --- a/R/description-incidence.R +++ b/R/characterization-incidence.R @@ -1,4 +1,4 @@ -# @file description-timeToEvent.R +# @file characterization-timeToEvent.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the description incidence module #' #' @export -descriptionIncidenceViewer <- function(id) { +characterizationIncidenceViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -37,7 +37,7 @@ descriptionIncidenceViewer <- function(id) { collapsed = TRUE, title = "Incidence Rates", width = "100%", - shiny::htmlTemplate(system.file("description-www", "help-incidenceRate.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("characterization-www", "help-incidenceRate.html", package = utils::packageName())) ), shinydashboard::box( @@ -82,21 +82,17 @@ descriptionIncidenceViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param mainPanelTab the current tab -#' @param schema the database schema for the model results -#' @param incidenceTablePrefix a string that appends the incidence table in the result schema -#' @param databaseTable name of the database table +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return #' The server to the prediction incidence module #' #' @export -descriptionIncidenceServer <- function( +characterizationIncidenceServer <- function( id, connectionHandler, mainPanelTab, - schema, - incidenceTablePrefix, - databaseTable = 'DATABASE_META_DATA' + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -108,8 +104,7 @@ descriptionIncidenceServer <- function( cohorts <- getTargetOutcomes( connectionHandler, - schema, - incidenceTablePrefix + resultDatabaseSettings ) @@ -205,9 +200,7 @@ descriptionIncidenceServer <- function( targetId = input$targetId, outcomeId = input$outcomeId, connectionHandler = connectionHandler, - schema = schema, - incidenceTablePrefix = incidenceTablePrefix, - databaseTable = databaseTable + resultDatabaseSettings ) allDataDownload(allData ) @@ -235,6 +228,7 @@ descriptionIncidenceServer <- function( columns = list( cdmSourceAbbreviation = reactable::colDef( name = 'Database', + sticky = "left", filterInput = function(values, name) { shiny::tags$select( # Set to undefined to clear the filter @@ -311,9 +305,7 @@ getIncidenceData <- function( targetId, outcomeId, connectionHandler, - schema, - incidenceTablePrefix, - databaseTable + resultDatabaseSettings ){ shiny::withProgress(message = 'Getting incidence data', value = 0, { @@ -330,11 +322,11 @@ getIncidenceData <- function( resultTable <- connectionHandler$queryDb( sql = sql, - result_schema = schema, - incidence_table_prefix = incidenceTablePrefix, + result_schema = resultDatabaseSettings$schema, + incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix, target_id = targetId, outcome_id = outcomeId, - database_table_name = databaseTable + database_table_name = resultDatabaseSettings$databaseTable ) shiny::incProgress(2/2, detail = paste("Done...")) @@ -355,8 +347,7 @@ getIncidenceData <- function( getTargetOutcomes <- function( connectionHandler, - schema, - incidenceTablePrefix + resultDatabaseSettings ){ shiny::withProgress(message = 'Getting incidence inputs', value = 0, { @@ -368,8 +359,8 @@ getTargetOutcomes <- function( targets <- connectionHandler$queryDb( sql = sql, - result_schema = schema, - incidence_table_prefix = incidenceTablePrefix + result_schema = resultDatabaseSettings$schema, + incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix ) targetIds <- targets$targetCohortDefinitionId names(targetIds) <- targets$targetName @@ -381,8 +372,8 @@ getTargetOutcomes <- function( outcomes <- connectionHandler$queryDb( sql = sql, - result_schema = schema, - incidence_table_prefix = incidenceTablePrefix + result_schema = resultDatabaseSettings$schema, + incidence_table_prefix = resultDatabaseSettings$incidenceTablePrefix ) outcomeIds <- outcomes$outcomeCohortDefinitionId diff --git a/R/description-main.R b/R/characterization-main.R similarity index 57% rename from R/description-main.R rename to R/characterization-main.R index 1721ead7..4ce63eda 100644 --- a/R/description-main.R +++ b/R/characterization-main.R @@ -1,4 +1,4 @@ -# @file description-main.R +# @file characterization-main.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -17,21 +17,21 @@ # limitations under the License. -#' The location of the description module helper file +#' The location of the characterization module helper file #' #' @details -#' Returns the location of the description helper file +#' Returns the location of the characterization helper file #' #' @return -#' string location of the description helper file +#' string location of the characterization helper file #' #' @export -descriptionHelperFile <- function(){ - fileLoc <- system.file('description-www', "description.html", package = "OhdsiShinyModules") +characterizationHelperFile <- function(){ + fileLoc <- system.file('characterization-www', "characterization.html", package = "OhdsiShinyModules") return(fileLoc) } -#' The module viewer for exploring description studies +#' The module viewer for exploring characterization studies #' #' @details #' The user specifies the id for the module @@ -39,10 +39,10 @@ descriptionHelperFile <- function(){ #' @param id the unique reference id for the module #' #' @return -#' The user interface to the description viewer module +#' The user interface to the characterization viewer module #' #' @export -descriptionViewer <- function(id=1) { +characterizationViewer <- function(id=1) { ns <- shiny::NS(id) shinydashboard::box( @@ -56,47 +56,47 @@ descriptionViewer <- function(id=1) { shiny::tabPanel( "Target Viewer", - descriptionTableViewer(ns('descriptiveTableTab')) + characterizationTableViewer(ns('descriptiveTableTab')) ), shiny::tabPanel( "Outcome Stratified", - descriptionAggregateFeaturesViewer(ns('aggregateFeaturesTab')) + characterizationAggregateFeaturesViewer(ns('aggregateFeaturesTab')) ), shiny::tabPanel( "Incidence Rate", - descriptionIncidenceViewer(ns('incidenceTab')) + characterizationIncidenceViewer(ns('incidenceTab')) ), shiny::tabPanel( "Time To Event", - descriptionTimeToEventViewer(ns('timeToEventTab')) + characterizationTimeToEventViewer(ns('timeToEventTab')) ), shiny::tabPanel( "Dechallenge Rechallenge", - descriptionDechallengeRechallengeViewer(ns('dechallengeRechallengeTab')) + characterizationDechallengeRechallengeViewer(ns('dechallengeRechallengeTab')) ) ) ) } -#' The module server for exploring description studies +#' The module server for exploring characterization studies #' #' @details #' The user specifies the id for the module #' #' @param id the unique reference id for the module #' @param connectionHandler a connection to the database with the results -#' @param resultDatabaseSettings a list containing the description result schema, dbms, tablePrefix, databaseTable and cohortTablePrefix +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return -#' The server for the description module +#' The server for the characterization module #' #' @export -descriptionServer <- function( +characterizationServer <- function( id, connectionHandler, resultDatabaseSettings = list(port = 1) @@ -116,14 +116,11 @@ descriptionServer <- function( # ============================= # Table of cohorts # ============================= - descriptionTableServer( + characterizationTableServer( id = 'descriptiveTableTab', connectionHandler = connectionHandler, mainPanelTab = mainPanelTab, - schema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable + resultDatabaseSettings = resultDatabaseSettings ) @@ -131,26 +128,21 @@ descriptionServer <- function( # Aggregrate Features # ============================= - descriptionAggregateFeaturesServer( + characterizationAggregateFeaturesServer( id = 'aggregateFeaturesTab', connectionHandler = connectionHandler, mainPanelTab = mainPanelTab, - schema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable - ) + resultDatabaseSettings = resultDatabaseSettings + ) # ============================= # Incidence # ============================= - descriptionIncidenceServer( + characterizationIncidenceServer( id = 'incidenceTab', connectionHandler = connectionHandler, mainPanelTab = mainPanelTab, - schema = resultDatabaseSettings$schema, - incidenceTablePrefix = resultDatabaseSettings$incidenceTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable + resultDatabaseSettings = resultDatabaseSettings ) @@ -158,30 +150,24 @@ descriptionServer <- function( # Time To Event # ============================= - descriptionTimeToEventServer( + characterizationTimeToEventServer( id = 'timeToEventTab', connectionHandler = connectionHandler, mainPanelTab = mainPanelTab, - schema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable - ) + resultDatabaseSettings = resultDatabaseSettings + ) # ============================= # Dechallenge Rechallenge # ============================= - descriptionDechallengeRechallengeServer( + characterizationDechallengeRechallengeServer( id = 'dechallengeRechallengeTab', connectionHandler = connectionHandler, mainPanelTab = mainPanelTab, - schema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable - ) + resultDatabaseSettings = resultDatabaseSettings + ) } ) diff --git a/R/description-timeToEvent.R b/R/characterization-timeToEvent.R similarity index 88% rename from R/description-timeToEvent.R rename to R/characterization-timeToEvent.R index a6e80827..44b07d0a 100644 --- a/R/description-timeToEvent.R +++ b/R/characterization-timeToEvent.R @@ -1,4 +1,4 @@ -# @file description-timeToEvent.R +# @file characterization-timeToEvent.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -25,10 +25,10 @@ #' @param id the unique reference id for the module #' #' @return -#' The user interface to the description time to event module +#' The user interface to the characterization time to event module #' #' @export -descriptionTimeToEventViewer <- function(id) { +characterizationTimeToEventViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -37,7 +37,7 @@ descriptionTimeToEventViewer <- function(id) { collapsed = TRUE, title = "Time-to-events", width = "100%", - shiny::htmlTemplate(system.file("description-www", "help-timeToEvent.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("characterization-www", "help-timeToEvent.html", package = utils::packageName())) ), shinydashboard::box( @@ -87,23 +87,17 @@ descriptionTimeToEventViewer <- function(id) { #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database #' @param mainPanelTab the current tab -#' @param schema the database schema for the model results -#' @param tablePrefix a string that appends the tables in the result schema -#' @param cohortTablePrefix a string that appends the cohort table in the result schema -#' @param databaseTable name of the database table +#' @param resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return #' The server to the prediction time to event module #' #' @export -descriptionTimeToEventServer <- function( +characterizationTimeToEventServer <- function( id, connectionHandler, mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA' + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -116,9 +110,7 @@ descriptionTimeToEventServer <- function( # get the possible target ids bothIds <- timeToEventGetIds( connectionHandler, - schema, - tablePrefix, - cohortTablePrefix + resultDatabaseSettings ) shiny::observeEvent( @@ -230,9 +222,7 @@ descriptionTimeToEventServer <- function( targetId = input$targetId, outcomeId = input$outcomeId, connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix, - databaseTable = databaseTable + resultDatabaseSettings ) }, error = function(e){shiny::showNotification(paste0('Error: ', e));return(NULL)} @@ -293,9 +283,7 @@ descriptionTimeToEventServer <- function( timeToEventGetIds <- function( connectionHandler, - schema, - tablePrefix, - cohortTablePrefix + resultDatabaseSettings ){ shiny::withProgress(message = 'Getting time to event T and O ids', value = 0, { @@ -303,10 +291,10 @@ timeToEventGetIds <- function( sql <- "SELECT DISTINCT t.COHORT_NAME as target, TARGET_COHORT_DEFINITION_ID, o.COHORT_NAME as outcome, OUTCOME_COHORT_DEFINITION_ID - FROM @result_database_schema.@table_prefixTIME_TO_EVENT tte - inner join @result_database_schema.@cohort_table_prefixCOHORT_DEFINITION t + FROM @schema.@c_table_prefixTIME_TO_EVENT tte + inner join @schema.@cg_table_prefixCOHORT_DEFINITION t on tte.TARGET_COHORT_DEFINITION_ID = t.COHORT_DEFINITION_ID - inner join @result_database_schema.@cohort_table_prefixCOHORT_DEFINITION o + inner join @schema.@cg_table_prefixCOHORT_DEFINITION o on tte.OUTCOME_COHORT_DEFINITION_ID = o.COHORT_DEFINITION_ID ;" @@ -315,9 +303,9 @@ timeToEventGetIds <- function( bothIds <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) shiny::incProgress(3/4, detail = paste("Processing ids")) @@ -362,17 +350,15 @@ getTimeToEventData <- function( targetId, outcomeId, connectionHandler, - schema, - tablePrefix, - databaseTable + resultDatabaseSettings ){ shiny::withProgress(message = 'Extracting time to event data', value = 0, { sql <- "SELECT tte.*, d.CDM_SOURCE_ABBREVIATION as database_name - FROM @result_database_schema.@table_prefixTIME_TO_EVENT tte - inner join @result_database_schema.@database_table d + FROM @schema.@c_table_prefixTIME_TO_EVENT tte + inner join @schema.@database_table d on tte.database_id = d.database_id where tte.TARGET_COHORT_DEFINITION_ID = @target_id and tte.OUTCOME_COHORT_DEFINITION_ID = @outcome_id;" @@ -381,11 +367,11 @@ getTimeToEventData <- function( data <- connectionHandler$queryDb( sql = sql, - result_database_schema = schema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix, target_id = targetId, outcome_id = outcomeId, - database_table = databaseTable + database_table = resultDatabaseSettings$databaseTable ) shiny::incProgress(3/3, detail = paste("Finished")) diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R index dda8fded..141cc2ad 100644 --- a/R/cohort-diagnostics-characterization.R +++ b/R/cohort-diagnostics-characterization.R @@ -1,6 +1,6 @@ # Copyright 2022 Observational Health Data Sciences and Informatics # -# This file is part of PatientLevelPrediction +# This file is part of OhdsiShinyModules # # Licensed under the Apache License, Version 2.0 (the "License"); # you may not use this file except in compliance with the License. @@ -20,7 +20,7 @@ #' #' @param id Namespace Id - use namespaced id ns("characterization") inside diagnosticsExplorer module #' @export -characterizationView <- function(id) { +cohortDiagCharacterizationView <- function(id) { ns <- shiny::NS(id) shiny::tagList( shinydashboard::box( @@ -426,11 +426,11 @@ prepareTable1 <- function(covariates, return(table) } -characterizationModule <- function( +cohortDiagCharacterizationModule <- function( id, dataSource, cohortTable = dataSource$cohortTable, - databaseTable = dataSource$databaseTable, + databaseTable = dataSource$dbTable, temporalAnalysisRef = dataSource$temporalAnalysisRef, analysisNameOptions = dataSource$analysisNameOptions, domainIdOptions = dataSource$domainIdOptions, @@ -661,8 +661,8 @@ characterizationModule <- function( getPrettyCharacterizationData <- shiny::reactive({ data <- dataSource$connectionHandler$queryDb( sql = "SELECT tcv.*, ref.analysis_id, ref.covariate_name - FROM @results_database_schema.@table_name tcv - INNER JOIN @results_database_schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id + FROM @schema.@table_name tcv + INNER JOIN @schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id WHERE ref.covariate_id IS NOT NULL {@analysis_ids != \"\"} ? { AND ref.analysis_id IN (@analysis_ids)} {@cohort_id != \"\"} ? { AND tcv.cohort_id IN (@cohort_id)} @@ -677,7 +677,7 @@ characterizationModule <- function( table_name = dataSource$prefixTable("temporal_covariate_value"), ref_table_name = dataSource$prefixTable("temporal_covariate_ref"), cohort_id = targetCohortId(), - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, filter_mean_threshold = 0.0 ) %>% dplyr::tibble() %>% @@ -776,10 +776,10 @@ characterizationModule <- function( ref.covariate_name, ref.analysis_id, ref.concept_id, aref.analysis_name, aref.is_binary, aref.domain_id, tref.start_day, tref.end_day - FROM @results_database_schema.@table_name tcv - INNER JOIN @results_database_schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id - INNER JOIN @results_database_schema.@analysis_ref_table_name aref ON aref.analysis_id = ref.analysis_id - LEFT JOIN @results_database_schema.@temporal_time_ref tref ON tref.time_id = tcv.time_id + FROM @schema.@table_name tcv + INNER JOIN @schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id + INNER JOIN @schema.@analysis_ref_table_name aref ON aref.analysis_id = ref.analysis_id + LEFT JOIN @schema.@temporal_time_ref tref ON tref.time_id = tcv.time_id WHERE ref.covariate_id IS NOT NULL {@analysis_ids != \"\"} ? { AND ref.analysis_id IN (@analysis_ids)} {@domain_ids != \"\"} ? { AND aref.domain_id IN (@domain_ids)} @@ -798,7 +798,7 @@ characterizationModule <- function( analysis_ref_table_name = dataSource$prefixTable("temporal_analysis_ref"), temporal_time_ref = dataSource$prefixTable("temporal_time_ref"), cohort_id = targetCohortId(), - results_database_schema = dataSource$resultsDatabaseSchema + schema = dataSource$schema ) %>% dplyr::tibble() %>% tidyr::replace_na(replace = list(timeId = -1)) %>% diff --git a/R/cohort-diagnostics-cohort-overlap.R b/R/cohort-diagnostics-cohort-overlap.R index 31793571..50b105e3 100644 --- a/R/cohort-diagnostics-cohort-overlap.R +++ b/R/cohort-diagnostics-cohort-overlap.R @@ -1,6 +1,6 @@ # Copyright 2022 Observational Health Data Sciences and Informatics # -# This file is part of PatientLevelPrediction +# This file is part of OhdsiShinyModules # # Licensed under the Apache License, Version 2.0 (the "License"); # you may not use this file except in compliance with the License. @@ -259,26 +259,48 @@ getResultsCohortRelationships <- function(dataSource, databaseIds = NULL, startDays = NULL, endDays = NULL) { + #data <- dataSource$connectionHandler$queryDb( + # sql = "SELECT cr.*, db.database_name + # FROM @schema.@table_name cr + # INNER JOIN @schema.@database_table db ON db.database_id = cr.database_id + # WHERE cr.cohort_id IN (@cohort_id) + # AND cr.database_id IN (@database_id) + # {@comparator_cohort_id != \"\"} ? { AND cr.comparator_cohort_id IN (@comparator_cohort_id)} + # {@start_day != \"\"} ? { AND cr.start_day IN (@start_day)} + # {@end_day != \"\"} ? { AND cr.end_day IN (@end_day)};", + # snakeCaseToCamelCase = TRUE, + # schema = dataSource$schema, + # database_id = quoteLiterals(databaseIds), + # table_name = dataSource$prefixTable("cohort_relationships"), + # database_table = paste0(dataSource$databaseTablePrefix, dataSource$databaseTable), + # cohort_id = cohortIds, + # comparator_cohort_id = comparatorCohortIds, + # start_day = startDays, + # end_day = endDays + #) %>% + # dplyr::tibble() + data <- dataSource$connectionHandler$queryDb( - sql = "SELECT cr.*, db.database_name - FROM @results_database_schema.@table_name cr - INNER JOIN @results_database_schema.@database_table db ON db.database_id = cr.database_id + sql = "SELECT cr.* + FROM @schema.@table_name cr WHERE cr.cohort_id IN (@cohort_id) AND cr.database_id IN (@database_id) {@comparator_cohort_id != \"\"} ? { AND cr.comparator_cohort_id IN (@comparator_cohort_id)} {@start_day != \"\"} ? { AND cr.start_day IN (@start_day)} {@end_day != \"\"} ? { AND cr.end_day IN (@end_day)};", snakeCaseToCamelCase = TRUE, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, database_id = quoteLiterals(databaseIds), table_name = dataSource$prefixTable("cohort_relationships"), - database_table = dataSource$databaseTableName, cohort_id = cohortIds, comparator_cohort_id = comparatorCohortIds, start_day = startDays, end_day = endDays ) %>% dplyr::tibble() + + # join with dbTable (moved this outside sql) + data <- merge(data, dataSource$dbTable, by = 'databaseId') return(data) } diff --git a/R/cohort-diagnostics-compareCharacterization.R b/R/cohort-diagnostics-compareCharacterization.R index 72a7c493..59fee63e 100644 --- a/R/cohort-diagnostics-compareCharacterization.R +++ b/R/cohort-diagnostics-compareCharacterization.R @@ -483,11 +483,11 @@ compareCohortCharacterizationView <- function(id, title = "Compare cohort charac # Returns data from cohort table of Cohort Diagnostics results data model getResultsCohort <- function(dataSource, cohortIds = NULL) { data <- dataSource$connectionHandler$queryDb( - sql = "SELECT * FROM @results_database_schema.@table_name + sql = "SELECT * FROM @schema.@table_name {@cohort_id != \"\"} ? { WHERE cohort_id IN (@cohort_id)};", - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_id = cohortIds, - table_name = dataSource$cohortTableName, + table_name = paste0(dataSource$cgTablePrefix,dataSource$cgTable), snakeCaseToCamelCase = TRUE ) return(data) @@ -805,7 +805,7 @@ getCharacterizationOutput <- function(dataSource, compareCohortCharacterizationModule <- function(id, dataSource, cohortTable = dataSource$cohortTable, - databaseTable = dataSource$databaseTable, + databaseTable = dataSource$dbTable, temporalAnalysisRef = dataSource$temporalAnalysisRef, analysisNameOptions = dataSource$analysisNameOptions, domainIdOptions = dataSource$domainIdOptions, diff --git a/R/cohort-diagnostics-conceptsInDataSource.R b/R/cohort-diagnostics-conceptsInDataSource.R index f2550057..ddd891e5 100644 --- a/R/cohort-diagnostics-conceptsInDataSource.R +++ b/R/cohort-diagnostics-conceptsInDataSource.R @@ -89,7 +89,7 @@ getConceptsInCohort <- 0 source_concept_id, max(concept_subjects) concept_subjects, sum(concept_count) concept_count - FROM @results_database_schema.@table_name isc + FROM @schema.@table_name isc WHERE isc.cohort_id = @cohort_id AND isc.database_id IN (@database_ids) GROUP BY isc.database_id, @@ -104,7 +104,7 @@ getConceptsInCohort <- 1 source_concept_id, max(c.concept_subjects) concept_subjects, sum(c.concept_count) concept_count - FROM @results_database_schema.@table_name c + FROM @schema.@table_name c WHERE c.cohort_id = @cohort_id AND c.database_id IN (@database_ids) GROUP BY @@ -112,12 +112,12 @@ getConceptsInCohort <- c.cohort_id, c.source_concept_id ) concepts - INNER JOIN @results_database_schema.@concept_table c ON concepts.concept_id = c.concept_id + INNER JOIN @schema.@concept_table c ON concepts.concept_id = c.concept_id WHERE c.invalid_reason IS NULL;" data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_id = cohortId, database_ids = quoteLiterals(databaseIds), table_name = dataSource$prefixTable("included_source_concept"), @@ -135,7 +135,7 @@ conceptsInDataSourceModule <- function(id, selectedDatabaseIds, targetCohortId, selectedConceptSets, - databaseTable = dataSource$databaseTable) { + databaseTable = dataSource$dbTable) { ns <- shiny::NS(id) shiny::moduleServer(id, function(input, output, session) { output$selectedCohorts <- shiny::renderUI({ selectedCohort() }) diff --git a/R/cohort-diagnostics-counts.R b/R/cohort-diagnostics-counts.R index 733ba599..596efd8b 100644 --- a/R/cohort-diagnostics-counts.R +++ b/R/cohort-diagnostics-counts.R @@ -170,7 +170,7 @@ getInclusionRulesTable <- function( getDisplayTableGroupedByDatabaseId( data = data, - databaseTable = dataSource$databaseTable, + databaseTable = dataSource$dbTable, headerCount = countsForHeader, keyColumns = c("id", "ruleName"), countLocation = 1, @@ -194,7 +194,7 @@ getInclusionRulesTable <- function( cohortCountsModule <- function(id, dataSource, cohortTable = dataSource$cohortTable, - databaseTable = dataSource$databaseTable, + databaseTable = dataSource$dbTable, selectedCohorts, selectedDatabaseIds, cohortIds) { diff --git a/R/cohort-diagnostics-databaseInformation.R b/R/cohort-diagnostics-databaseInformation.R index d0bff6f4..9b239c03 100644 --- a/R/cohort-diagnostics-databaseInformation.R +++ b/R/cohort-diagnostics-databaseInformation.R @@ -58,14 +58,14 @@ databaseInformationView <- function(id) { getMetaDataResults <- function(dataSource, databaseId) { sql <- "SELECT * - FROM @results_database_schema.@metadata + FROM @schema.@metadata WHERE database_id = @database_id;" data <- dataSource$connectionHandler$queryDb( sql = sql, metadata = dataSource$prefixTable("metadata"), - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, database_id = quoteLiterals(databaseId) ) %>% tidyr::tibble() @@ -211,7 +211,7 @@ getExecutionMetadata <- function(dataSource, databaseId) { getDatabaseMetadata <- function(dataSource, databaseTable) { - data <- loadResultsTable(dataSource, "metadata", required = TRUE, tablePrefix = dataSource$tablePrefix) + data <- loadResultsTable(dataSource, "metadata", required = TRUE, cdTablePrefix = dataSource$cdTablePrefix) data <- data %>% tidyr::pivot_wider( id_cols = c("startTime", "databaseId"), @@ -289,10 +289,12 @@ getDatabaseMetadata <- function(dataSource, databaseTable) { } # What this module does is incredibly simple. How it does it is not. -databaseInformationModule <- function(id, - dataSource, - selectedDatabaseIds, - databaseTable = dataSource$databaseTable) { +databaseInformationModule <- function( + id, + dataSource, + selectedDatabaseIds, + databaseTable = dataSource$dbTable +) { ns <- shiny::NS(id) ## Replace this pre-loading nonsense diff --git a/R/cohort-diagnostics-definition.R b/R/cohort-diagnostics-definition.R index 6ff648b2..842979b9 100644 --- a/R/cohort-diagnostics-definition.R +++ b/R/cohort-diagnostics-definition.R @@ -210,11 +210,13 @@ getConceptSetDetailsFromCohortDefinition <- getCohortJsonSql <- function(dataSource, cohortIds) { - sql <- "SELECT * FROM @results_database_schema.@cohort_table WHERE cohort_id IN (@cohort_ids)" - dataSource$connectionHandler$queryDb(sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, - cohort_table = dataSource$cohortTableName, - cohort_ids = cohortIds) + sql <- "SELECT * FROM @schema.@cohort_table WHERE cohort_id IN (@cohort_ids)" + dataSource$connectionHandler$queryDb( + sql = sql, + schema = dataSource$schema, + cohort_table = paste0(dataSource$cgTablePrefix,dataSource$cgTable), + cohort_ids = cohortIds + ) } exportCohortDefinitionsZip <- function(cohortDefinitions, @@ -441,13 +443,13 @@ getCountForConceptIdInCohort <- cohortId, databaseIds) { sql <- "SELECT ics.* - FROM @results_database_schema.@table_name ics + FROM @schema.@table_name ics WHERE ics.cohort_id = @cohort_id AND database_id in (@database_ids);" data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_id = cohortId, database_ids = quoteLiterals(databaseIds), table_name = dataSource$prefixTable("included_source_concept"), @@ -519,12 +521,14 @@ getCountForConceptIdInCohort <- #' @param databaseTable data.frame of databasese, databaseId, name #' @param cohortTable data.frame of cohorts, cohortId, cohortName #' @param cohortCountTable data.frame of cohortCounts, cohortId, subjects records -cohortDefinitionsModule <- function(id, - dataSource, - cohortDefinitions, - cohortTable = dataSource$cohortTable, - cohortCountTable = dataSource$cohortCountTable, - databaseTable = dataSource$databaseTable) { +cohortDefinitionsModule <- function( + id, + dataSource, + cohortDefinitions, + cohortTable = dataSource$cohortTable, + cohortCountTable = dataSource$cohortCountTable, + databaseTable = dataSource$dbTable +) { ns <- shiny::NS(id) cohortDefinitionServer <- function(input, output, session) { diff --git a/R/cohort-diagnostics-incidenceRates.R b/R/cohort-diagnostics-incidenceRates.R index 610138fe..0f3d626e 100644 --- a/R/cohort-diagnostics-incidenceRates.R +++ b/R/cohort-diagnostics-incidenceRates.R @@ -17,22 +17,22 @@ # Global ranges for IR values getIncidenceRateRanges <- function(dataSource, minPersonYears = 0) { - sql <- "SELECT DISTINCT age_group FROM @results_database_schema.@ir_table WHERE person_years >= @person_years" + sql <- "SELECT DISTINCT age_group FROM @schema.@ir_table WHERE person_years >= @person_years" ageGroups <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, ir_table = dataSource$prefixTable("incidence_rate"), person_years = minPersonYears, snakeCaseToCamelCase = TRUE ) %>% dplyr::mutate(ageGroup = dplyr::na_if(.data$ageGroup, "")) - sql <- "SELECT DISTINCT calendar_year FROM @results_database_schema.@ir_table WHERE person_years >= @person_years" + sql <- "SELECT DISTINCT calendar_year FROM @schema.@ir_table WHERE person_years >= @person_years" calendarYear <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, ir_table = dataSource$prefixTable("incidence_rate"), person_years = minPersonYears, snakeCaseToCamelCase = TRUE @@ -42,11 +42,11 @@ getIncidenceRateRanges <- function(dataSource, minPersonYears = 0) { ) %>% dplyr::mutate(calendarYear = as.integer(.data$calendarYear)) - sql <- "SELECT DISTINCT gender FROM @results_database_schema.@ir_table WHERE person_years >= @person_years" + sql <- "SELECT DISTINCT gender FROM @schema.@ir_table WHERE person_years >= @person_years" gender <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, ir_table = dataSource$prefixTable("incidence_rate"), person_years = minPersonYears, snakeCaseToCamelCase = TRUE @@ -57,14 +57,14 @@ getIncidenceRateRanges <- function(dataSource, minPersonYears = 0) { sql <- "SELECT min(incidence_rate) as min_ir, max(incidence_rate) as max_ir - FROM @results_database_schema.@ir_table + FROM @schema.@ir_table WHERE person_years >= @person_years AND incidence_rate > 0.0 " incidenceRate <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, ir_table = dataSource$prefixTable("incidence_rate"), person_years = minPersonYears, snakeCaseToCamelCase = TRUE @@ -115,10 +115,22 @@ getIncidenceRateResult <- function(dataSource, ) checkmate::reportAssertions(collection = errorMessage) - sql <- "SELECT ir.*, dt.database_name, cc.cohort_subjects - FROM @results_database_schema.@ir_table ir - INNER JOIN @results_database_schema.@database_table dt ON ir.database_id = dt.database_id - INNER JOIN @results_database_schema.@cc_table cc ON ( + #sql <- "SELECT ir.*, dt.database_name, cc.cohort_subjects + # FROM @schema.@ir_table ir + # INNER JOIN @schema.@database_table dt ON ir.database_id = dt.database_id + # INNER JOIN @schema.@cc_table cc ON ( + # ir.database_id = cc.database_id AND ir.cohort_id = cc.cohort_id + # ) + # WHERE ir.cohort_id in (@cohort_ids) + # AND ir.database_id in (@database_ids) + # {@gender == TRUE} ? {AND ir.gender != ''} : { AND ir.gender = ''} + # {@age_group == TRUE} ? {AND ir.age_group != ''} : { AND ir.age_group = ''} + # {@calendar_year == TRUE} ? {AND ir.calendar_year != ''} : { AND ir.calendar_year = ''} + # AND ir.person_years > @personYears;" + + sql <- "SELECT ir.*, cc.cohort_subjects + FROM @schema.@ir_table ir + INNER JOIN @schema.@cc_table cc ON ( ir.database_id = cc.database_id AND ir.cohort_id = cc.cohort_id ) WHERE ir.cohort_id in (@cohort_ids) @@ -127,10 +139,11 @@ getIncidenceRateResult <- function(dataSource, {@age_group == TRUE} ? {AND ir.age_group != ''} : { AND ir.age_group = ''} {@calendar_year == TRUE} ? {AND ir.calendar_year != ''} : { AND ir.calendar_year = ''} AND ir.person_years > @personYears;" + data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_ids = cohortIds, database_ids = quoteLiterals(databaseIds), gender = stratifyByGender, @@ -139,11 +152,20 @@ getIncidenceRateResult <- function(dataSource, personYears = minPersonYears, ir_table = dataSource$prefixTable("incidence_rate"), cc_table = dataSource$prefixTable("cohort_count"), - database_table = dataSource$databaseTableName, + #database_table = paste0(dataSource$databaseTablePrefix, dataSource$databaseTable), snakeCaseToCamelCase = TRUE ) %>% tidyr::tibble() - + + # join with dbTable (moved this outside sql) + data <- merge( + data, + dataSource$dbTable, + by = 'databaseId' + ) + + data <- tidyr::as_tibble(data) + data <- data %>% dplyr::mutate( gender = dplyr::na_if(.data$gender, ""), diff --git a/R/cohort-diagnostics-inclusionRules.R b/R/cohort-diagnostics-inclusionRules.R index d2b1d9d8..1b44a5f9 100644 --- a/R/cohort-diagnostics-inclusionRules.R +++ b/R/cohort-diagnostics-inclusionRules.R @@ -77,7 +77,7 @@ inclusionRulesView <- function(id) { # inclusion Rules Module inclusionRulesModule <- function(id, dataSource, - databaseTable = dataSource$databaseTable, + databaseTable = dataSource$dbTable, selectedCohort, targetCohortId, selectedDatabaseIds) { diff --git a/R/cohort-diagnostics-indexEventBreakdown.R b/R/cohort-diagnostics-indexEventBreakdown.R index d407c0cc..e35fc847 100644 --- a/R/cohort-diagnostics-indexEventBreakdown.R +++ b/R/cohort-diagnostics-indexEventBreakdown.R @@ -101,7 +101,7 @@ getIndexEventBreakdown <- function(dataSource, concept.vocabulary_id, concept.standard_concept, concept.concept_code - FROM @results_database_schema.@table_name index_event_breakdown + FROM @schema.@table_name index_event_breakdown INNER JOIN @vocabulary_database_schema.@concept_table concept ON index_event_breakdown.concept_id = concept.concept_id WHERE database_id in (@database_id) @@ -109,7 +109,7 @@ getIndexEventBreakdown <- function(dataSource, data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, vocabulary_database_schema = dataSource$vocabularyDatabaseSchema, cohort_ids = cohortIds, database_id = quoteLiterals(databaseIds), @@ -139,7 +139,7 @@ indexEventBreakdownModule <- function(id, targetCohortId, selectedDatabaseIds, cohortCountTable = dataSource$cohortCountTable, - databaseTable = dataSource$databaseTable) { + databaseTable = dataSource$dbTable) { ns <- shiny::NS(id) serverFunction <- function(input, output, session) { diff --git a/R/cohort-diagnostics-main-ui.R b/R/cohort-diagnostics-main-ui.R index 99409f31..2073d382 100644 --- a/R/cohort-diagnostics-main-ui.R +++ b/R/cohort-diagnostics-main-ui.R @@ -201,7 +201,7 @@ cohortDiagnosticsView <- function(id = "DiagnosticsExplorer") { shiny::conditionalPanel( ns = ns, condition = "input.tabs == 'characterization'", - characterizationView(ns("characterization")) + cohortDiagCharacterizationView(ns("characterization")) ), shiny::conditionalPanel( ns = ns, diff --git a/R/cohort-diagnostics-main.R b/R/cohort-diagnostics-main.R index bc710ede..466aefd6 100644 --- a/R/cohort-diagnostics-main.R +++ b/R/cohort-diagnostics-main.R @@ -17,11 +17,11 @@ # NOTE: here it would be nice to use dbplyr tables - this would allow lazy loading of resources # however, renaming the columns causes an error and its not obvious how it could be resolved -loadResultsTable <- function(dataSource, tableName, required = FALSE, tablePrefix = "") { - selectTableName <- paste0(tablePrefix, tableName) +loadResultsTable <- function(dataSource, tableName, required = FALSE, cdTablePrefix = "") { + selectTableName <- paste0(cdTablePrefix, tableName) resultsTablesOnServer <- tolower(DatabaseConnector::dbListTables(dataSource$connectionHandler$getConnection(), - schema = dataSource$resultsDatabaseSchema)) + schema = dataSource$schema)) if (required || selectTableName %in% resultsTablesOnServer) { if (tableIsEmpty(dataSource, selectTableName)) { @@ -32,7 +32,7 @@ loadResultsTable <- function(dataSource, tableName, required = FALSE, tablePrefi { table <- DatabaseConnector::dbReadTable( dataSource$connectionHandler$getConnection(), - paste(dataSource$resultsDatabaseSchema, selectTableName, sep = ".") + paste(dataSource$schema, selectTableName, sep = ".") ) }, error = function(err) { @@ -54,12 +54,12 @@ loadResultsTable <- function(dataSource, tableName, required = FALSE, tablePrefi # Create empty objects in memory for all other tables. This is used by the Shiny app to decide what tabs to show: tableIsEmpty <- function(dataSource, tableName) { - sql <- "SELECT * FROM @result_schema.@table LIMIT 1" + sql <- "SELECT * FROM @schema.@table LIMIT 1" row <- data.frame() tryCatch({ row <- dataSource$connectionHandler$queryDb( sql, - result_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, table = tableName ) @@ -76,7 +76,7 @@ tableIsEmpty <- function(dataSource, tableName) { getEnabledCdReports <- function(dataSource) { enabledReports <- c() resultsTables <- tolower(DatabaseConnector::dbListTables(dataSource$connectionHandler$getConnection(), - schema = dataSource$resultsDatabaseSchema)) + schema = dataSource$schema)) for (table in dataSource$dataModelSpecifications$tableName %>% unique()) { if (dataSource$prefixTable(table) %in% resultsTables) { @@ -97,51 +97,52 @@ getEnabledCdReports <- function(dataSource) { #' a shiny app. E.g. if you wanted to make a custom R markdown template #' #' @param connectionHandler An instance of a ResultModelManager::connectionHander - manages a connection to a database. -#' @param schema The schema containing the results tables in the database. -#' @param vocabularyDatabaseSchema The schema containing the vocabulary tables in the database. If not provided, defaults to `resultsDatabaseSchema`. -#' @param tablePrefix An optional prefix to add to the table names. -#' @param cohortTableName The name of the cohort table in the database. -#' @param databaseTableName The name of the database table in the database. +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param dataModelSpecificationsPath The path to a file containing specifications for the data model used by the database. #' @param displayProgress display a progress messaage (can only be used inside a shiny reactive context) #' @param dataMigrationsRef The path to a file listing all migrations for the data model that should have been applied #' @return An object of class `CdDataSource`. #' #' @export -createCdDatabaseDataSource <- function(connectionHandler, - schema, - vocabularyDatabaseSchema = schema, - tablePrefix = "", - cohortTableName = paste0(tablePrefix, "cohort"), - databaseTableName = paste0(tablePrefix, "database"), - dataModelSpecificationsPath = system.file("cohort-diagnostics-ref", - "resultsDataModelSpecification.csv", - package = utils::packageName()), - dataMigrationsRef = system.file("cohort-diagnostics-ref", - "migrations.csv", - package = utils::packageName()), - displayProgress = FALSE) { +createCdDatabaseDataSource <- function( + connectionHandler, + resultDatabaseSettings, + dataModelSpecificationsPath = system.file("cohort-diagnostics-ref", + "resultsDataModelSpecification.csv", + package = utils::packageName()), + dataMigrationsRef = system.file("cohort-diagnostics-ref", + "migrations.csv", + package = utils::packageName()), + displayProgress = FALSE +) { checkmate::assertR6(connectionHandler, "ConnectionHandler") - checkmate::assertString(schema) - checkmate::assertString(vocabularyDatabaseSchema, null.ok = TRUE) - checkmate::assertString(tablePrefix, null.ok = TRUE) - checkmate::assertString(cohortTableName, null.ok = TRUE) - checkmate::assertString(databaseTableName, null.ok = TRUE) + checkmate::assertString(resultDatabaseSettings$schema) + checkmate::assertString(resultDatabaseSettings$vocabularyDatabaseSchema, null.ok = TRUE) + checkmate::assertString(resultDatabaseSettings$cdTablePrefix, null.ok = TRUE) + checkmate::assertString(resultDatabaseSettings$cgTable, null.ok = TRUE) + checkmate::assertString(resultDatabaseSettings$databaseTable, null.ok = TRUE) + checkmate::assertString(resultDatabaseSettings$databaseTablePrefix, null.ok = TRUE) checkmate::assertFileExists(dataModelSpecificationsPath) checkmate::assertFileExists(dataMigrationsRef) - if (is.null(vocabularyDatabaseSchema)) { - vocabularyDatabaseSchema <- schema + if (is.null(resultDatabaseSettings$vocabularyDatabaseSchema)) { + resultDatabaseSettings$vocabularyDatabaseSchema <- resultDatabaseSettings$schema } - if (is.null(tablePrefix)) { - tablePrefix <- "" + if (is.null(resultDatabaseSettings$cdTablePrefix)) { + resultDatabaseSettings$cdTablePrefix <- "" } - if (is.null(cohortTableName)) { - cohortTableName <- paste0(tablePrefix, "cohort") + if (is.null(resultDatabaseSettings$cgTable)) { + resultDatabaseSettings$cgTable <- "cohort" } - if (is.null(databaseTableName)) { - databaseTableName <- paste0(tablePrefix, "database") + if (is.null(resultDatabaseSettings$cgTablePrefix)) { + resultDatabaseSettings$cgTablePrefix <- resultDatabaseSettings$cdTablePrefix + } + if (is.null(resultDatabaseSettings$databaseTable)) { + resultDatabaseSettings$databaseTable <- "database" + } + if (is.null(resultDatabaseSettings$databaseTablePrefix)) { + resultDatabaseSettings$databaseTablePrefix <- resultDatabaseSettings$cdTablePrefix } if (displayProgress) { @@ -150,10 +151,10 @@ createCdDatabaseDataSource <- function(connectionHandler, migrations <- data.frame() # Check existence of migrations table - display warnings if not present or if it is out of date tryCatch({ - migrations <- connectionHandler$queryDb("SELECT * FROM @results_database_schema.@table_prefixmigration", + migrations <- connectionHandler$queryDb("SELECT * FROM @schema.@cd_table_prefixmigration", snakeCaseToCamelCase = TRUE, - results_database_schema = schema, - table_prefix = tablePrefix) + schema = resultDatabaseSettings$schema, + cd_table_prefix = resultDatabaseSettings$cdTablePrefix) }, error = function(...) { warning("CohortDiagnotics schema does not contain migrations table. Schema was likely created incorrectly") if (displayProgress) { @@ -177,22 +178,24 @@ createCdDatabaseDataSource <- function(connectionHandler, dataSource <- list( connectionHandler = connectionHandler, - resultsDatabaseSchema = schema, - vocabularyDatabaseSchema = vocabularyDatabaseSchema, + schema = resultDatabaseSettings$schema, + vocabularyDatabaseSchema = resultDatabaseSettings$vocabularyDatabaseSchema, dbms = connectionHandler$dbms(), resultsTablesOnServer = tolower(DatabaseConnector::dbListTables(connectionHandler$getConnection(), - schema = schema)), - tablePrefix = tablePrefix, - prefixTable = function(tableName) { paste0(tablePrefix, tableName) }, + schema = resultDatabaseSettings$schema)), + cdTablePrefix = resultDatabaseSettings$cdTablePrefix, + prefixTable = function(tableName) { paste0(resultDatabaseSettings$cdTablePrefix, tableName) }, prefixVocabTable = function(tableName) { # don't prexfix table if we us a dedicated vocabulary schema - if (vocabularyDatabaseSchema == schema) - return(paste0(tablePrefix, tableName)) + if (resultDatabaseSettings$vocabularyDatabaseSchema == resultDatabaseSettings$schema) + return(paste0(resultDatabaseSettings$cdTablePrefix, tableName)) return(tableName) }, - cohortTableName = cohortTableName, - databaseTableName = databaseTableName, + cgTable = resultDatabaseSettings$cgTable, + cgTablePrefix = resultDatabaseSettings$cgTablePrefix, + databaseTable = resultDatabaseSettings$databaseTable, + databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix, dataModelSpecifications = modelSpec ) @@ -203,7 +206,7 @@ createCdDatabaseDataSource <- function(connectionHandler, if (displayProgress) shiny::setProgress(value = 0.1, message = "Getting database information") - dataSource$databaseTable <- getDatabaseTable(dataSource) + dataSource$dbTable <- getDatabaseTable(dataSource) if (displayProgress) shiny::setProgress(value = 0.2, message = "Getting cohorts") @@ -213,19 +216,19 @@ createCdDatabaseDataSource <- function(connectionHandler, if (displayProgress) shiny::setProgress(value = 0.6, message = "Getting concept sets") - dataSource$conceptSets <- loadResultsTable(dataSource, "concept_sets", tablePrefix = dataSource$tablePrefix) + dataSource$conceptSets <- loadResultsTable(dataSource, "concept_sets", cdTablePrefix = dataSource$cdTablePrefix) if (displayProgress) shiny::setProgress(value = 0.7, message = "Getting counts") - dataSource$cohortCountTable <- loadResultsTable(dataSource, "cohort_count", required = TRUE, tablePrefix = dataSource$tablePrefix) + dataSource$cohortCountTable <- loadResultsTable(dataSource, "cohort_count", required = TRUE, cdTablePrefix = dataSource$cdTablePrefix) dataSource$enabledReports <- dataSource$enabledReports if (displayProgress) shiny::setProgress(value = 0.7, message = "Getting Temporal References") - dataSource$temporalAnalysisRef <- loadResultsTable(dataSource, "temporal_analysis_ref", tablePrefix = dataSource$tablePrefix) + dataSource$temporalAnalysisRef <- loadResultsTable(dataSource, "temporal_analysis_ref", cdTablePrefix = dataSource$cdTablePrefix) dataSource$temporalChoices <- getResultsTemporalTimeRef(dataSource = dataSource) dataSource$temporalCharacterizationTimeIdChoices <- dataSource$temporalChoices %>% @@ -268,7 +271,21 @@ createCdDatabaseDataSource <- function(connectionHandler, # SO much of the app requires this table in memory - it would be much better to re-write queries to not need it! getDatabaseTable <- function(dataSource) { - databaseTable <- loadResultsTable(dataSource, dataSource$databaseTableName, required = TRUE) + + # hot fix + if(tolower(paste0(dataSource$databaseTablePrefix, dataSource$databaseTable)) == 'database_meta_data'){ + databaseTable <- dataSource$connectionHandler$queryDb( + "SELECT *, cdm_source_abbreviation as database_name FROM @schema.@table_name", + schema = dataSource$schema, + table_name = paste0(dataSource$databaseTablePrefix, dataSource$databaseTable) + ) # end hot fix + } else{ + databaseTable <- loadResultsTable( + dataSource = dataSource, + tableName = paste0(dataSource$databaseTablePrefix, dataSource$databaseTable), + required = TRUE + ) + } if (nrow(databaseTable) > 0 & "vocabularyVersion" %in% colnames(databaseTable)) { @@ -283,14 +300,30 @@ getDatabaseTable <- function(dataSource) { # SO much of the app requires this table in memory - it would be much better to re-write queries to not need it! getCohortTable <- function(dataSource) { - if (tableIsEmpty(dataSource, dataSource$cohortTableName)) { + if (tableIsEmpty( + dataSource = dataSource, + tableName = paste0(dataSource$cgTablePrefix, dataSource$cgTable) + ) + ) { return(data.frame()) } - cohortTable <- dataSource$connectionHandler$queryDb("SELECT cohort_id, cohort_name FROM @schema.@table_name", - schema = dataSource$resultsDatabaseSchema, - table_name = dataSource$cohortTableName) + # hot fix + if(paste0(dataSource$cgTablePrefix, dataSource$cgTable) == 'cg_cohort_definition'){ + cohortTable <- dataSource$connectionHandler$queryDb( + "SELECT cohort_definition_id as cohort_id, cohort_name FROM @schema.@table_name", + schema = dataSource$schema, + table_name = paste0(dataSource$cgTablePrefix, dataSource$cgTable) + ) + # end hot fix + } else{ + cohortTable <- dataSource$connectionHandler$queryDb( + "SELECT cohort_id, cohort_name FROM @schema.@table_name", + schema = dataSource$schema, + table_name = paste0(dataSource$cgTablePrefix, dataSource$cgTable) + ) + } - # Old label + # Old label - is this needed?? if ("cohortDefinitionId" %in% names(cohortTable)) { cohortTable <- cohortTable %>% dplyr::mutate(cohortId = .data$cohortDefinitionId) } @@ -305,11 +338,11 @@ getCohortTable <- function(dataSource) { getResultsTemporalTimeRef <- function(dataSource) { sql <- "SELECT * - FROM @results_database_schema.@table_name;" + FROM @schema.@table_name;" temporalTimeRef <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, table_name = dataSource$prefixTable("temporal_time_ref") ) @@ -373,7 +406,7 @@ getResultsTemporalTimeRef <- function(dataSource) { #' @param resultDatabaseSettings results database settings #' @param dataSource dataSource optionally created with createCdDatabaseDataSource #' @export -cohortDiagnosticsSever <- function(id, +cohortDiagnosticsServer <- function(id, connectionHandler, resultDatabaseSettings, dataSource = NULL) { @@ -385,17 +418,18 @@ cohortDiagnosticsSever <- function(id, dataSource <- createCdDatabaseDataSource( connectionHandler = connectionHandler, - schema = resultDatabaseSettings$schema, - vocabularyDatabaseSchema = resultDatabaseSettings$vocabularyDatabaseSchema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTableName = resultDatabaseSettings$cohortTable, - databaseTableName = resultDatabaseSettings$databaseTable, + resultDatabaseSettings = resultDatabaseSettings, + #schema = resultDatabaseSettings$schema, + #vocabularyDatabaseSchema = resultDatabaseSettings$vocabularyDatabaseSchema, # is this in results? + #cdTablePrefix = resultDatabaseSettings$cdTablePrefix, + #cgTableName = resultDatabaseSettings$cgTable, # different for CD? + #databaseTableName = paste0(resultDatabaseSettings$databaseTablePrefix,resultDatabaseSettings$databaseTable), displayProgress = TRUE ) } shiny::moduleServer(id, function(input, output, session) { - databaseTable <- dataSource$databaseTable + databaseTable <- dataSource$dbTable cohortTable <- dataSource$cohortTable conceptSets <- dataSource$conceptSets cohortCountTable <- dataSource$cohortCountTable @@ -667,7 +701,7 @@ cohortDiagnosticsSever <- function(id, cohortIds = cohortIds, selectedDatabaseIds = selectedDatabaseIds) - characterizationModule(id = "characterization", + cohortDiagCharacterizationModule(id = "characterization", dataSource = dataSource) compareCohortCharacterizationModule(id = "compareCohortCharacterization", diff --git a/R/cohort-diagnostics-orphanConcepts.R b/R/cohort-diagnostics-orphanConcepts.R index c921d0be..b816477d 100644 --- a/R/cohort-diagnostics-orphanConcepts.R +++ b/R/cohort-diagnostics-orphanConcepts.R @@ -84,8 +84,8 @@ getOrphanConceptResult <- function(dataSource, c.vocabulary_id, c.concept_code, c.standard_concept - FROM @results_database_schema.@orphan_table_name oc - INNER JOIN @results_database_schema.@cs_table_name cs + FROM @schema.@orphan_table_name oc + INNER JOIN @schema.@cs_table_name cs ON oc.cohort_id = cs.cohort_id AND oc.concept_set_id = cs.concept_set_id INNER JOIN @vocabulary_database_schema.@concept_table c @@ -96,7 +96,7 @@ getOrphanConceptResult <- function(dataSource, data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, vocabulary_database_schema = dataSource$vocabularyDatabaseSchema, cohort_id = cohortId, database_ids = quoteLiterals(databaseIds), @@ -117,7 +117,7 @@ orphanConceptsModule <- function(id, targetCohortId, selectedConceptSets, conceptSetIds, - databaseTable = dataSource$databaseTable) { + databaseTable = dataSource$dbTable) { ns <- shiny::NS(id) shiny::moduleServer(id, function(input, output, session) { output$selectedCohorts <- shiny::renderUI({ selectedCohort() }) diff --git a/R/cohort-diagnostics-shared.R b/R/cohort-diagnostics-shared.R index 6292c503..2be8a991 100644 --- a/R/cohort-diagnostics-shared.R +++ b/R/cohort-diagnostics-shared.R @@ -65,24 +65,36 @@ formatDataCellValueInDisplayTable <- getResultsCohortCounts <- function(dataSource, cohortIds = NULL, databaseIds = NULL) { - sql <- "SELECT cc.*, db.database_name - FROM @results_database_schema.@table_name cc - INNER JOIN @results_database_schema.@database_table db ON db.database_id = cc.database_id + #sql <- "SELECT cc.*, db.database_name + # FROM @schema.@table_name cc + # INNER JOIN @schema.@database_table db ON db.database_id = cc.database_id + # WHERE cc.cohort_id IS NOT NULL + # {@use_database_ids} ? { AND cc.database_id in (@database_ids)} + # {@cohort_ids != ''} ? { AND cc.cohort_id in (@cohort_ids)} + # ;" + + sql <- "SELECT cc.* + FROM @schema.@table_name cc WHERE cc.cohort_id IS NOT NULL {@use_database_ids} ? { AND cc.database_id in (@database_ids)} {@cohort_ids != ''} ? { AND cc.cohort_id in (@cohort_ids)} ;" + data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_ids = cohortIds, use_database_ids = !is.null(databaseIds), database_ids = quoteLiterals(databaseIds), - table_name = dataSource$prefixTable("cohort_count"), - database_table = dataSource$databaseTableName + table_name = dataSource$prefixTable("cohort_count")#, + #database_table = paste0(dataSource$databaseTablePrefix, dataSource$databaseTable) ) %>% tidyr::tibble() + + # join with dbTable (moved this outside sql) + data <- merge(data, dataSource$dbTable, by = 'databaseId') + return(data) } @@ -90,14 +102,14 @@ getResultsCohortCounts <- function(dataSource, getDatabaseCounts <- function(dataSource, databaseIds) { sql <- "SELECT * - FROM @results_database_schema.@database_table + FROM @schema.@database_table WHERE database_id in (@database_ids);" data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, database_ids = quoteLiterals(databaseIds), - database_table = dataSource$databaseTableName, + database_table = paste0(dataSource$databaseTablePrefix, dataSource$databaseTable), snakeCaseToCamelCase = TRUE ) %>% tidyr::tibble() @@ -662,8 +674,8 @@ resolvedConceptSet <- function(dataSource, c.standard_concept, c.concept_code, rc.database_id - FROM @results_database_schema.@resolved_concepts_table rc - LEFT JOIN @results_database_schema.@concept_table c + FROM @schema.@resolved_concepts_table rc + LEFT JOIN @schema.@concept_table c ON rc.concept_id = c.concept_id WHERE rc.database_id IN (@database_ids) AND rc.cohort_id = @cohortId @@ -672,7 +684,7 @@ resolvedConceptSet <- function(dataSource, resolved <- dataSource$connectionHandler$queryDb( sql = sqlResolved, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, database_ids = quoteLiterals(databaseIds), cohortId = cohortId, concept_set_id = conceptSetId, @@ -702,12 +714,12 @@ mappedConceptSet <- function(dataSource, c1.concept_code FROM ( SELECT DISTINCT concept_id - FROM @results_database_schema.@resolved_concepts + FROM @schema.@resolved_concepts WHERE database_id IN (@databaseIds) AND cohort_id = @cohort_id ) concept_sets - INNER JOIN @results_database_schema.@concept_relationship cr ON concept_sets.concept_id = cr.concept_id_2 - INNER JOIN @results_database_schema.@concept c1 ON cr.concept_id_1 = c1.concept_id + INNER JOIN @schema.@concept_relationship cr ON concept_sets.concept_id = cr.concept_id_2 + INNER JOIN @schema.@concept c1 ON cr.concept_id_1 = c1.concept_id WHERE relationship_id = 'Maps to' AND standard_concept IS NULL ) @@ -716,14 +728,14 @@ mappedConceptSet <- function(dataSource, c.cohort_id, c.concept_set_id, mapped.* - FROM (SELECT DISTINCT concept_id, database_id, cohort_id, concept_set_id FROM @results_database_schema.@resolved_concepts) c + FROM (SELECT DISTINCT concept_id, database_id, cohort_id, concept_set_id FROM @schema.@resolved_concepts) c INNER JOIN resolved_concepts_mapped mapped ON c.concept_id = mapped.resolved_concept_id {@cohort_id != ''} ? { WHERE c.cohort_id = @cohort_id}; " mapped <- dataSource$connectionHandler$queryDb( sql = sqlMapped, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, databaseIds = quoteLiterals(databaseIds), concept = dataSource$prefixTable("concept"), concept_relationship = dataSource$prefixTable("concept_relationship"), @@ -816,12 +828,12 @@ queryResultCovariateValue <- function(dataSource, temporalTimeRefData <- dataSource$connectionHandler$queryDb( sql = "SELECT * - FROM @results_database_schema.@table_name + FROM @schema.@table_name WHERE (time_id IS NOT NULL AND time_id != 0) {@start_day != \"\"} ? { AND start_day IN (@start_day)} {@end_day != \"\"} ? { AND end_day IN (@end_day)};", snakeCaseToCamelCase = TRUE, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, table_name = dataSource$prefixTable("temporal_time_ref"), start_day = startDay, end_day = endDay @@ -836,27 +848,27 @@ queryResultCovariateValue <- function(dataSource, temporalAnalysisRefData <- dataSource$connectionHandler$queryDb( sql = "SELECT * - FROM @results_database_schema.@table_name + FROM @schema.@table_name WHERE analysis_id IS NOT NULL {@analysis_ids != \"\"} ? { AND analysis_id IN (@analysis_ids)} ;", analysis_ids = analysisIds, table_name = dataSource$prefixTable("temporal_analysis_ref"), snakeCaseToCamelCase = TRUE, - results_database_schema = dataSource$resultsDatabaseSchema + schema = dataSource$schema ) %>% dplyr::tibble() temporalCovariateRefData <- dataSource$connectionHandler$queryDb( sql = "SELECT * - FROM @results_database_schema.@table_name + FROM @schema.@table_name WHERE covariate_id IS NOT NULL {@analysis_ids != \"\"} ? { AND analysis_id IN (@analysis_ids)};", snakeCaseToCamelCase = TRUE, analysis_ids = analysisIds, table_name = dataSource$prefixTable("temporal_covariate_ref"), - results_database_schema = dataSource$resultsDatabaseSchema + schema = dataSource$schema ) %>% dplyr::tibble() @@ -865,8 +877,8 @@ queryResultCovariateValue <- function(dataSource, temporalCovariateValueData <- dataSource$connectionHandler$queryDb( sql = "SELECT tcv.* - FROM @results_database_schema.@table_name tcv - INNER JOIN @results_database_schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id + FROM @schema.@table_name tcv + INNER JOIN @schema.@ref_table_name ref ON ref.covariate_id = tcv.covariate_id WHERE ref.covariate_id IS NOT NULL {@analysis_ids != \"\"} ? { AND ref.analysis_id IN (@analysis_ids)} {@cohort_id != \"\"} ? { AND tcv.cohort_id IN (@cohort_id)} @@ -881,7 +893,7 @@ queryResultCovariateValue <- function(dataSource, table_name = dataSource$prefixTable("temporal_covariate_value"), ref_table_name = dataSource$prefixTable("temporal_covariate_ref"), cohort_id = cohortIds, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, filter_mean_threshold = meanThreshold ) %>% dplyr::tibble() %>% @@ -893,7 +905,7 @@ queryResultCovariateValue <- function(dataSource, temporalCovariateValueDistData <- dataSource$connectionHandler$queryDb( sql = "SELECT * - FROM @results_database_schema.@table_name tcv + FROM @schema.@table_name tcv WHERE covariate_id IS NOT NULL {@covariate_id != \"\"} ? { AND covariate_id IN (@covariate_id)} {@cohort_id != \"\"} ? { AND cohort_id IN (@cohort_id)} @@ -907,7 +919,7 @@ queryResultCovariateValue <- function(dataSource, database_id = quoteLiterals(databaseIds), cohort_id = cohortIds, table_name = dataSource$prefixTable("temporal_covariate_value_dist"), - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, filter_mean_threshold = meanThreshold ) %>% dplyr::tibble() %>% @@ -946,7 +958,7 @@ getInclusionRuleStats <- function(dataSource, databaseIds, modeId = 1) { sql <- "SELECT * - FROM @resultsDatabaseSchema.@table_name + FROM @schema.@table_name WHERE database_id in (@database_id) {@cohort_ids != ''} ? { AND cohort_id in (@cohort_ids)} ;" @@ -954,7 +966,7 @@ getInclusionRuleStats <- function(dataSource, inclusion <- dataSource$connectionHandler$queryDb( sql = sql, - resultsDatabaseSchema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_ids = cohortIds, database_id = quoteLiterals(databaseIds), table_name = dataSource$prefixTable("cohort_inclusion"), @@ -965,7 +977,7 @@ getInclusionRuleStats <- function(dataSource, inclusionResults <- dataSource$connectionHandler$queryDb( sql = sql, - resultsDatabaseSchema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_ids = cohortIds, database_id = quoteLiterals(databaseIds), table_name = dataSource$prefixTable("cohort_inc_result"), @@ -976,7 +988,7 @@ getInclusionRuleStats <- function(dataSource, inclusionStats <- dataSource$connectionHandler$queryDb( sql = sql, - resultsDatabaseSchema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, cohort_ids = cohortIds, database_id = quoteLiterals(databaseIds), table_name = dataSource$prefixTable("cohort_inc_stats"), diff --git a/R/cohort-diagnostics-timeDistributions.R b/R/cohort-diagnostics-timeDistributions.R index 3df92f77..f786aa46 100644 --- a/R/cohort-diagnostics-timeDistributions.R +++ b/R/cohort-diagnostics-timeDistributions.R @@ -353,7 +353,7 @@ timeDistributionsModule <- function(id, selectedDatabaseIds, cohortIds, cohortTable = dataSource$cohortTable, - databaseTable = dataSource$databaseTable) { + databaseTable = dataSource$dbTable) { shiny::moduleServer(id, function(input, output, session) { ns <- session$ns output$selectedCohorts <- shiny::renderUI({ selectedCohorts() }) diff --git a/R/cohort-diagnostics-visitContext.R b/R/cohort-diagnostics-visitContext.R index 7feee0f4..942848e2 100644 --- a/R/cohort-diagnostics-visitContext.R +++ b/R/cohort-diagnostics-visitContext.R @@ -89,7 +89,7 @@ getVisitContextResults <- function(dataSource, sql <- "SELECT visit_context.*, standard_concept.concept_name AS visit_concept_name - FROM @results_database_schema.@table_name visit_context + FROM @schema.@table_name visit_context INNER JOIN @vocabulary_database_schema.@concept_table standard_concept ON visit_context.visit_concept_id = standard_concept.concept_id WHERE database_id in (@database_id) @@ -97,7 +97,7 @@ getVisitContextResults <- function(dataSource, data <- dataSource$connectionHandler$queryDb( sql = sql, - results_database_schema = dataSource$resultsDatabaseSchema, + schema = dataSource$schema, vocabulary_database_schema = dataSource$vocabularyDatabaseSchema, cohort_ids = cohortIds, database_id = quoteLiterals(databaseIds), @@ -121,7 +121,7 @@ visitContextModule <- function(id = "visitContext", selectedDatabaseIds, targetCohortId, cohortCountTable = dataSource$cohortCountTable, - databaseTable = dataSource$databaseTable) { + databaseTable = dataSource$dbTable) { ns <- shiny::NS(id) shiny::moduleServer(id, function(input, output, session) { output$selectedCohorts <- shiny::renderUI(selectedCohort()) diff --git a/R/cohort-generator-main.R b/R/cohort-generator-main.R new file mode 100644 index 00000000..3ec32e53 --- /dev/null +++ b/R/cohort-generator-main.R @@ -0,0 +1,973 @@ +# @file cohortgenerator-main.R +# +# Copyright 2022 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. + + +#' The location of the cohort-generator module helper file +#' +#' @details +#' Returns the location of the cohort-generator helper file +#' +#' @return +#' string location of the cohort-generator helper file +#' +#' @export +cohortGeneratorHelperFile <- function(){ + fileLoc <- system.file('cohort-generator-www', "cohort-generator.html", package = "OhdsiShinyModules") + return(fileLoc) +} + +#' The viewer of the main cohort generator module +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort generator results viewer +#' +#' @export +cohortGeneratorViewer <- function(id) { + + ns <- shiny::NS(id) + + shiny::div( + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span( shiny::icon("user-gear"),'Cohorts'), + solidHeader = TRUE, + + shinydashboard::box( + collapsible = TRUE, + collapsed = TRUE, + title = shiny::span( shiny::icon("circle-question"), "Help & Information"), + width = "100%", + shiny::htmlTemplate(system.file("cohort-generator-www", "cohort-generator.html", package = utils::packageName())) + ), + + + shiny::tabsetPanel( + id = ns("cohortGeneratorTabs"), + type = "pills", + + + shiny::tabPanel( + title = "Cohort Counts", + + shinydashboard::box( + collapsible = T, + collapsed = F, + width = '100%', + title = shiny::span( shiny::icon("file-arrow-down"),'Download Data'), + #solidHeader = TRUE, + + shiny::downloadButton( + ns('downloadCohortCountsFull'), + label = "Download (Full)", + icon = shiny::icon("download") + ), + + shiny::actionButton( + ns('downloadCohortCountsFiltered'), + label = "Download (Filtered)", + icon = shiny::icon("download"), + onclick = paste0("Reactable.downloadDataCSV('", ns('cohortCounts'), + "', 'cohort-count-data-filtered-", Sys.Date(), ".csv')") + ) + ), + + shinydashboard::box( + width = '100%', + title = shiny::span( shiny::icon("table"), 'Counts Table'), + #solidHeader = TRUE, + + shiny::uiOutput(ns("selectColsCohortCounts") + ), + + reactable::reactableOutput( + outputId = ns("cohortCounts") + ) + ) + ), + + shiny::tabPanel( + title = "Cohort Generation", + + shinydashboard::box( + collapsible = T, + collapsed = F, + width = '100%', + title = shiny::span( shiny::icon("file-arrow-down"),'Download Data'), + #solidHeader = TRUE, + + shiny::downloadButton( + ns('downloadCohortGeneration'), + label = "Download", + icon = shiny::icon("download") + ) + ), + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span( shiny::icon("table"), 'Generation Table'), + #solidHeader = TRUE, + + reactable::reactableOutput( + outputId = ns("cohortGeneration") + ) + ) + ), + + shiny::tabPanel( + title = "Inclusion Rules & Attrition" + , + + shinydashboard::box( + collapsible = T, + collapsed = F, + width = '100%', + title = shiny::span( shiny::icon("gear"), 'Options'), + #solidHeader = TRUE, + + shiny::uiOutput(ns('attritionTableSelect')) + ), + + shiny::conditionalPanel( + condition = "input.generate != 0", + ns = ns, + + shiny::uiOutput(ns("inputsText")), + + shinydashboard::box( + collapsible = T, + collapsed = F, + width = '100%', + title = shiny::span( shiny::icon("file-arrow-down"),'Download Data'), + #solidHeader = TRUE, + + shiny::downloadButton( + ns('downloadAttritionTable'), + label = "Download", + icon = shiny::icon("download") + ) + ), + + + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span( shiny::icon("table"), 'Attrition Table'), + #solidHeader = TRUE, + + reactable::reactableOutput(ns('attritionTable')) + ), + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span( shiny::icon("chart-area"), 'Attrition Plot'), + #solidHeader = TRUE, + + plotly::plotlyOutput(ns('attritionPlot')) + ) + ) + ) + ) + ) + ) +} + + + + +#' The module server for the main cohort generator module +#' +#' @param id the unique reference id for the module +#' @param connectionHandler a connection to the database with the results +#' @param resultDatabaseSettings a named list containing the cohort generator results database details (schema, table prefix) +#' +#' @return +#' the cohort generator results viewer main module server +#' +#' @export + +cohortGeneratorServer <- function( + id, + connectionHandler, + resultDatabaseSettings +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + withTooltip <- function(value, tooltip, ...) { + shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", + tippy::tippy(value, tooltip, ...)) + } + + format_yesorno <- function(value) { + # Render as an X mark or check mark + if (value == "COMPLETE") "\u2714\ufe0f Yes" #if generation complete then green check mark with "yes" + else "\u274c No" #if not then red x with "no" + } + + resultsSchema <- resultDatabaseSettings$schema + + inputColsCohortCounts <- colnames(getCohortGeneratorCohortCounts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cdmSourceName", + "cohortId", + "cohortName", + "cohortSubjects", + "cohortEntries") + ) + + names(inputColsCohortCounts) <- c("Database Name", + "Cohort ID", + "Cohort Name", + "Number of Subjects", + "Number of Records") + + output$selectColsCohortCounts <- shiny::renderUI({ + + shinyWidgets::pickerInput( + inputId = session$ns('cohortCountsCols'), + label = 'Select Columns to Display: ', + choices = inputColsCohortCounts, + selected = inputColsCohortCounts, + choicesOpt = list(style = rep_len("color: black;", 999)), + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ), + width = "50%" + ) + + }) + + data <- getCohortGeneratorCohortCounts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cdmSourceName", + "cohortId", + "cohortName", + "cohortSubjects", + "cohortEntries") + + + rtable <- shiny::reactive({ + + reactable::reactable( + data %>% + dplyr::select(input$cohortCountsCols), + columns = list( + # Render a "show details" button in the last column of the table. + # This button won't do anything by itself, but will trigger the custom + # click action on the column. + cdmSourceName = reactable::colDef( + header = withTooltip( + "Database Name", + "The name of the database" + )), + cohortId = reactable::colDef( + header = withTooltip( + "Cohort ID", + "The unique numeric identifier of the cohort" + )), + cohortName = reactable::colDef( + header = withTooltip( + "Cohort Name", + "The name of the cohort" + )), + cohortSubjects = reactable::colDef( + header = withTooltip( + "Number of Subjects", + "The number of distinct subjects in the cohort" + ), + format = reactable::colFormat(separators = TRUE + )), + cohortEntries = reactable::colDef( + header = withTooltip( + "Number of Records", + "The number of records in the cohort" + ), + format = reactable::colFormat(separators = TRUE + )) + ), + filterable = TRUE, + sortable = TRUE, + resizable = T, + searchable = T, + striped = T, + defaultColDef = reactable::colDef( + align = "left" + ) + ) + + }) + + output$cohortCounts <- reactable::renderReactable({ + + tryCatch({ + + rtable() + }, + + error = function(e){ + shiny::showNotification( + paste0( + 'Error: ', + "Please select at least one column to display" + ) + ); + return(NULL) + } + + ) + }) + + + # download buttons - counts + output$downloadCohortCountsFull <- shiny::downloadHandler( + filename = function() { + paste('cohort-count-data-full', Sys.Date(), '.csv', sep='') + }, + content = function(con) { + utils::write.csv(getCohortGeneratorCohortCounts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cdmSourceName", + "cohortId", + "cohortName", + "cohortSubjects", + "cohortEntries"), con) + } + ) + + # output$downloadCohortCountsFiltered <- shiny::downloadHandler( + # filename = function() { + # paste('cohort-count-data-filtered-', Sys.Date(), '.csv', sep='') + # }, + # content = function(con) { + # filtered_data <- rtable()$reactiveData()$data() + # filtered_rows <- rtable()$reactiveData()$filteredRows() + # + # utils::write.csv(filtered_data[filtered_rows,], + # con) + # } + # ) + + output$cohortGeneration <- reactable::renderReactable({ + data <- getCohortGeneratorCohortMeta( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cdmSourceName", + "cohortId", + "cohortName", + "generationStatus", + "startTime", + "endTime", + "generationDuration") + reactable::reactable(data, + columns = list( + # Render a "show details" button in the last column of the table. + # This button won't do anything by itself, but will trigger the custom + # click action on the column. + cdmSourceName = reactable::colDef( + header = withTooltip( + "Database Name", + "The name of the database" + )), + cohortId = reactable::colDef( + header = withTooltip( + "Cohort ID", + "The unique numeric identifier of the cohort" + )), + cohortName = reactable::colDef( + header = withTooltip( + "Cohort Name", + "The name of the cohort" + )), + generationStatus = reactable::colDef( + header = withTooltip( + "Is the Cohort Generated?", + "Indicator of if the cohort has been generated" + ), + cell = format_yesorno + ), + startTime = reactable::colDef( + header = withTooltip( + "Generation Start Time", + "The time and date the cohort started generating" + ), + format = reactable::colFormat(datetime = TRUE + )), + endTime = reactable::colDef( + header = withTooltip( + "Generation End Time", + "The time and date the cohort finished generating" + ), + format = reactable::colFormat(datetime = TRUE + )), + generationDuration = reactable::colDef( + header = withTooltip( + "Generation Duration (mins)", + "The time it took (in minutes) to generate the cohort" + ), + format = reactable::colFormat(digits = 2) + ) + ), + filterable = TRUE, + sortable = TRUE, + defaultColDef = reactable::colDef( + align = "left" + ) + ) + }) + + # download button - generation + output$downloadCohortGeneration <- shiny::downloadHandler( + filename = function() { + paste('cohort-generation-data-', Sys.Date(), '.csv', sep='') + }, + content = function(con) { + utils::write.csv(getCohortGeneratorCohortMeta( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("cohortId", + "cohortName", + "generationStatus", + "startTime", + "endTime"), con) + } + ) + + #building attrition table using inclusion rules & stats tables + rules <- getCohortGeneratorInclusionRules( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + stats <- getCohortGeneratorInclusionStats( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + #this gets the full attrition table + inputVals <- getCohortGenerationAttritionTable( + rules, + stats + ) + + #making a "clean" version where modeId is renamed to sensible values + cohortNames <- unique(inputVals$cohortName) + databaseIds <- unique(inputVals$cdmSourceName) + inputValsClean <- dplyr::ungroup(inputVals) %>% + dplyr::mutate(modeId = dplyr::case_when( + modeId==1 ~ "Subject", + TRUE ~ "Record" + ) + ) + modeIds <- unique(inputValsClean$modeId) + + + # cohortName <- shiny::reactiveVal(cohortNames[1]) + # databaseId <- shiny::reactiveVal(databaseIds[1]) + # modeId <- shiny::reactiveVal(modeIds[1]) + + #build the selector + output$attritionTableSelect <- shiny::renderUI({ + + shiny::tagList( + shiny::selectInput( + inputId = session$ns('selectedCohortName'), + label = 'Cohort:', + choices = cohortNames, + selected = 1, + multiple = F, + selectize=FALSE + ), + shiny::selectInput( + inputId = session$ns('selectedDatabaseId'), + label = 'Database:', + choices = databaseIds, + selected = 1, + multiple = F, + selectize=FALSE + ), + shiny::radioButtons( + inputId = session$ns('selectedModeId'), + label = "Subject-level or Record-level?", + choices = modeIds, + selected = "Subject" + ), + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate Report' + ) + ) + }) + + reactiveData <- shiny::reactiveVal(NULL) + selectedInputs <- shiny::reactiveVal() + output$inputsText <- shiny::renderUI(selectedInputs()) + + # shiny::observeEvent(input$selectedCohortName,{ + # cohortName(input$selectedCohortName) + # }) + # shiny::observeEvent(input$selectedDatabaseId,{ + # databaseId(input$selectedDatabaseId) + # }) + # shiny::observeEvent(input$selectedModeId,{ + # modeId(input$selectedModeId) + # }) + + #build the reactive data + + shiny::observeEvent( + eventExpr = input$generate, + { + + # if(length(input$selectedCohortName) == 0 | is.null(input$selectedDatabaseId | + # is.null(input$selectedModeId))){ + # print('Null ids value') + # return(invisible(NULL)) + # } + + selectedInputs( + shinydashboard::box( + status = 'warning', + width = "100%", + title = 'Selected:', + collapsible = T, + collapsed = F, + shiny::div( + shiny::fluidRow( + shiny::column( + width = 8, + shiny::tags$b("Cohort:"), + #unique(inputVals$cohortName[inputVals$cohortName %in% input$selectedCohortName]) + input$selectedCohortName + ), + shiny::column( + width = 4, + shiny::tags$b("Database:"), + #unique(inputVals$cdmSourceName[inputVals$cdmSourceName == input$selectedDatabaseId]) + input$selectedDatabaseId + ), + shiny::column( + width = 4, + shiny::tags$b("Level:"), + #unique(inputValsClean$modeId)[inputValsClean$modeId == input$selectedModeId] + input$selectedModeId + ) + ) + ) + ) + ) + + + data <- inputValsClean %>% + dplyr::filter(.data$cdmSourceName %in% input$selectedDatabaseId & + .data$cohortName %in% input$selectedCohortName & + .data$modeId %in% input$selectedModeId + ) + + reactiveData <- shiny::reactive(data) + + if(!is.null(data)){ + + output$attritionTable <- reactable::renderReactable( + reactable::reactable( + data = reactiveData() %>% + dplyr::select(c("cdmSourceName", "cohortName", "ruleName", + "personCount", "dropCount", + "dropPerc", "retainPerc") + ) + + , + rownames = FALSE, + defaultPageSize = 5, + showPageSizeOptions = T, + striped = T, + columns = list( + cdmSourceName = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Database Name", + "The name of the database" + )), + cohortName = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Cohort Name", + "The name of the cohort" + )), + ruleName = reactable::colDef( + header = withTooltip( + "Inclusion Rule Name", + "The name of the inclusion rule" + )), + personCount = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Subject/Record Count", + "The number of subjects or records (depending on your selection) remaining after the inclusion rule was applied" + )), + dropCount = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Number Lost", + "The number of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied" + )), + dropPerc = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Percentage Lost", + "The percentage of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied compared to the previous rule count" + )), + retainPerc = reactable::colDef( + format = reactable::colFormat(separators = TRUE), + header = withTooltip( + "Number Retained", + "The number of subjects or records (depending on your selection) retained after the inclusion rule was applied compared to the previous rule count" + )) + ), + + filterable = TRUE, + sortable = TRUE, + defaultColDef = reactable::colDef( + align = "left" + ) + ) + ) + + #attrition plot + output$attritionPlot <- plotly::renderPlotly( + getCohortAttritionPlot( + data + ) + ) + + # download button + output$downloadAttritionTable <- shiny::downloadHandler( + filename = function() { + paste('cohort-attrition-data-', Sys.Date(), '.csv', sep='') + }, + content = function(con) { + utils::write.csv(data() + , con) + } + ) + } + + else{ + shiny::showNotification('data NULL') + } + + } + ) + + + + + + # end of server + + } + ) +} + + + + +getCohortGeneratorCohortCounts <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT cc.cohort_id, cc.cohort_entries, cc.cohort_subjects, + dt.cdm_source_name, cd.cohort_name + FROM @schema.@cg_table_prefixCOHORT_COUNT cc + join @schema.@database_table_prefix@database_table dt + on cc.database_id = dt.database_id + join @schema.@cg_table_prefixCOHORT_DEFINITION cd + on cd.cohort_definition_id = cc.cohort_id + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix + ) + ) +} + +getCohortGeneratorCohortMeta <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT cg.cohort_id, cg.cohort_name, + cg.generation_status, cg.start_time, cg.end_time, dt.cdm_source_name + from @schema.@cg_table_prefixCOHORT_GENERATION cg + join @schema.@database_table_prefix@database_table dt + on cg.database_id = dt.database_id + ;" + + df <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix + ) + + df2 <- df %>% + dplyr::mutate( + generationDuration = dplyr::case_when( + generationStatus == "COMPLETE" + ~ tryCatch( + { + difftime( + as.POSIXct(as.numeric(.data$endTime), origin = "1970-01-01"), + as.POSIXct(as.numeric(.data$startTime), origin = "1970-01-01"), + units="mins" + ) + }, + error = function(e){return(NA)} + ), + T ~ NA + ) + ) + + return(df2) +} + +getCohortGeneratorCohortInclusionSummary <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT css.cohort_definition_id, css.base_count, css.final_count, css.mode_id, + dt.cdm_source_name, cd.cohort_name + FROM @schema.@cg_table_prefixCOHORT_SUMMARY_STATS css + join @schema.@database_table_prefix@database_table dt + on css.database_id = dt.database_id + join @schema.@cg_table_prefixCOHORT_DEFINITION cd + on cd.cohort_definition_id = css.cohort_definition_id + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema =resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix + ) + ) +} + + + +getCohortGeneratorInclusionRules <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT ci.cohort_definition_id, ci.rule_sequence, ci.name as rule_name, + cd.cohort_name FROM @schema.@cg_table_prefixCOHORT_INCLUSION ci + join @schema.@cg_table_prefixCOHORT_DEFINITION cd + on cd.cohort_definition_id = ci.cohort_definition_id + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix + ) + ) +} + +getCohortGeneratorInclusionStats <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT cir.database_id, cir.cohort_definition_id, cir.inclusion_rule_mask, cir.person_count, cir.mode_id, + dt.cdm_source_name FROM @schema.@cg_table_prefixCOHORT_INC_RESULT cir + join @schema.@database_table_prefix@database_table dt + on cir.database_id = dt.database_id + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix + ) + ) +} + +getCohortGenerationAttritionTable <- function( + rules, + stats +){ + + uniqueCohortIDs <- unique(rules$cohortDefinitionId) + + attritionTable <- data.frame() + + for(cohortId in uniqueCohortIDs){ + + cohortRules <- rules %>% + dplyr::filter(.data$cohortDefinitionId==cohortId) %>% + dplyr::select("ruleSequence", "ruleName", "cohortName") %>% + dplyr::arrange("ruleSequence") + + testMask = 0 + + for(i in 1:nrow(cohortRules)){ + + rule = cohortRules[i,] + + testMask = testMask + 2^(rule$ruleSequence) + + attritionRows <- stats %>% + dplyr::filter((.data$cohortDefinitionId == !!cohortId) & + (bitwAnd(.data$inclusionRuleMask, !!testMask) == !!testMask) + ) %>% + dplyr::select(-c("databaseId")) %>% + dplyr::group_by(.data$cdmSourceName, .data$cohortDefinitionId, .data$modeId) %>% + dplyr::summarise(personCount = sum(.data$personCount), + ) + + startingCounts <- stats %>% + dplyr::select(-c("databaseId")) %>% + dplyr::group_by(.data$cdmSourceName, .data$cohortDefinitionId, .data$modeId) %>% + dplyr::summarise(personCount = sum(.data$personCount), + ) %>% + dplyr::mutate(ruleSequence = -1, + ruleName = "Before any inclusion criteria", + ) + + attritionRowsFull <- cbind(attritionRows, rule) + + startingCountsFull <- cbind(startingCounts, rule %>% dplyr::select("cohortName")) %>% + dplyr::filter(.data$cohortDefinitionId %in% !!attritionRows$cohortDefinitionId) + + attritionTable <- rbind(attritionTable, attritionRowsFull, startingCountsFull) + + } + + } + + attritionTableDistinct <- dplyr::distinct(attritionTable) + + #adding drop counts + attritionTableFinal <- attritionTableDistinct %>% + dplyr::group_by( + .data$cdmSourceName, + .data$cohortDefinitionId, + .data$modeId) %>% + dplyr::mutate( + dropCount = dplyr::case_when( + is.na(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) ~ 0, + TRUE ~ dplyr::lag(.data$personCount, order_by = .data$ruleSequence) - .data$personCount + ), + dropPerc = dplyr::case_when( + is.na(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) ~ "0.00%", + TRUE ~ paste( + round( + (.data$dropCount/(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) * 100), + digits = 2 + ), + "%", + sep="") + ), + retainPerc = dplyr::case_when( + is.na(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) ~ "100.00%", + TRUE ~ paste( + round( + (.data$personCount/(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) * 100), + digits = 2 + ), + "%", + sep="") + + ) + ) + #newdata <- mtcars[order(mpg, -cyl),] + return(attritionTableFinal[order(attritionTableFinal$ruleSequence),]) + +} + +# test <- inputValsClean %>% +# dplyr::filter(cohortDefinitionId == 11057 & cdmSourceName == "Optum EHR" & +# modeId == "Subject") + +getCohortAttritionPlot <- function(data) { + + #colorPal <- colorRampPalette(c("darkgreen", "green", "yellow", "orange", "red")) + + fig <- plotly::plot_ly() + fig %>% + plotly::add_trace( + type = "funnel", + y = data$ruleName, + x = data$personCount, + texttemplate = "N: %{value:,d}
Number Lost: %{text:,d}", + marker = list(color = RColorBrewer::brewer.pal(length(unique(data$ruleName)), + "Greens" + ) + ), + connector = list(fillcolor = "#e9e9bf"), + text = data$dropCount, + hoverinfo = "percent initial+percent previous" , + hovertemplate='% of Previous: %{percentPrevious:.2%}
% of Initial: %{percentInitial:.2%}' + ) %>% + plotly::layout(title = "Cohort Attrition by Inclusion Rules", + yaxis = list(categoryarray = c(order(data$personCount, decreasing = T))) + ) + +} + + + + + + + + + diff --git a/R/cohort-method-attrition.R b/R/cohort-method-attrition.R new file mode 100644 index 00000000..3112c019 --- /dev/null +++ b/R/cohort-method-attrition.R @@ -0,0 +1,295 @@ +# @file cohort-method-attrition +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + +#' The module viewer for rendering the PLE attrition results +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method attrition +#' +#' @export +cohortMethodAttritionViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + shiny::plotOutput(outputId = ns("attritionPlot"), width = 600, height = 600), + shiny::uiOutput(outputId = ns("attritionPlotCaption")), + shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", + shiny::downloadButton(outputId = ns("downloadAttritionPlotPng"), + label = "Download diagram as PNG"), + shiny::downloadButton(outputId = ns("downloadAttritionPlotPdf"), + label = "Download diagram as PDF")) + ) +} + +#' The module server for rendering the PLE attrition results +#' +#' @param id the unique reference id for the module +#' @param selectedRow the selected row from the main results table +#' @param connectionHandler the connection to the PLE results database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' +#' @return +#' the PLE attrition results content server +#' +#' @export +cohortMethodAttritionServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings + ) { + + shiny::moduleServer( + id, + function(input, output, session) { + + attritionPlot <- shiny::reactive({ + attrition <- getCohortMethodAttrition( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow + ) + if(!is.null(attrition)){ + plot <- drawCohortMethodAttritionDiagram(attrition) + return(plot) + } else{ + return(NULL) + } + }) + + output$attritionPlot <- shiny::renderPlot({ + return(attritionPlot()) + }) + + + output$downloadAttritionPlotPng <- shiny::downloadHandler(filename = "Attrition.png", + contentType = "image/png", + content = function(file) { + ggplot2::ggsave(file, plot = attritionPlot(), width = 6, height = 7, dpi = 400) + }) + + + output$downloadAttritionPlotPdf <- shiny::downloadHandler(filename = "Attrition.pdf", + contentType = "application/pdf", + content = function(file) { + ggplot2::ggsave(file = file, plot = attritionPlot(), width = 6, height = 7) + }) + + output$attritionPlotCaption <- shiny::renderUI({ + if (is.null(selectedRow()$target)) { + return(NULL) + } else { + text <- "Figure 1. Attrition diagram, showing the Number of subjects in the target (%s) and + comparator (%s) group after various stages in the analysis." + return(shiny::HTML(sprintf(text, selectedRow()$target, selectedRow()$comparator))) + } + }) + + } + ) +} + + +getCohortMethodAttrition <- function( + connectionHandler, + resultDatabaseSettings, + selectedRow +) { + + if(is.null(selectedRow()$targetId)){ + return(NULL) + } + + sql <- " + SELECT cmat.* + FROM + @schema.@cm_table_prefixattrition cmat + WHERE + cmat.target_id = @target_id + AND cmat.comparator_id = @comparator_id + AND cmat.outcome_id = @outcome_id + AND cmat.analysis_id = @analysis_id + AND cmat.database_id = '@database_id'; + " + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + #database_table = resultDatabaseSettings$databaseTable, + target_id = selectedRow()$targetId, + comparator_id = selectedRow()$comparatorId, + outcome_id = selectedRow()$outcomeId, + analysis_id = selectedRow()$analysisId, + database_id = selectedRow()$databaseId + ) + targetAttrition <- result[result$exposureId == selectedRow()$targetId, ] + comparatorAttrition <- result[result$exposureId == selectedRow()$comparatorId, ] + colnames(targetAttrition)[colnames(targetAttrition) == "subjects"] <- "targetPersons" + targetAttrition$exposureId <- NULL + colnames(comparatorAttrition)[colnames(comparatorAttrition) == "subjects"] <- "comparatorPersons" + comparatorAttrition$exposureId <- NULL + result <- merge(targetAttrition, comparatorAttrition) + result <- result[order(result$sequenceNumber), ] + + return(result) +} + + + + +drawCohortMethodAttritionDiagram <- function( + attrition, + targetLabel = "Target", + comparatorLabel = "Comparator" +) { + addStep <- function(data, attrition, row) { + label <- paste(strwrap(as.character(attrition$description[row]), width = 30), collapse = "\n") + data$leftBoxText[length(data$leftBoxText) + 1] <- label + data$rightBoxText[length(data$rightBoxText) + 1] <- paste(targetLabel, + ": n = ", + data$currentTarget - attrition$targetPersons[row], + "\n", + comparatorLabel, + ": n = ", + data$currentComparator - attrition$comparatorPersons[row], + sep = "") + data$currentTarget <- attrition$targetPersons[row] + data$currentComparator <- attrition$comparatorPersons[row] + return(data) + } + data <- list(leftBoxText = c(paste("Exposed:\n", + targetLabel, + ": n = ", + attrition$targetPersons[1], + "\n", + comparatorLabel, + ": n = ", + attrition$comparatorPersons[1], + sep = "")), rightBoxText = c(""), currentTarget = attrition$targetPersons[1], currentComparator = attrition$comparatorPersons[1]) + for (i in 2:nrow(attrition)) { + data <- addStep(data, attrition, i) + } + + + data$leftBoxText[length(data$leftBoxText) + 1] <- paste("Study population:\n", + targetLabel, + ": n = ", + data$currentTarget, + "\n", + comparatorLabel, + ": n = ", + data$currentComparator, + sep = "") + leftBoxText <- data$leftBoxText + rightBoxText <- data$rightBoxText + nSteps <- length(leftBoxText) + + boxHeight <- (1/nSteps) - 0.03 + boxWidth <- 0.45 + shadowOffset <- 0.01 + arrowLength <- 0.01 + x <- function(x) { + return(0.25 + ((x - 1)/2)) + } + y <- function(y) { + return(1 - (y - 0.5) * (1/nSteps)) + } + + downArrow <- function(p, x1, y1, x2, y2) { + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 + arrowLength, + yend = y2 + arrowLength)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 - arrowLength, + yend = y2 + arrowLength)) + return(p) + } + rightArrow <- function(p, x1, y1, x2, y2) { + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 - arrowLength, + yend = y2 + arrowLength)) + p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, + y = y2, + xend = x2 - arrowLength, + yend = y2 - arrowLength)) + return(p) + } + box <- function(p, x, y) { + p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2) + shadowOffset, + ymin = y - (boxHeight/2) - shadowOffset, + xmax = x + (boxWidth/2) + shadowOffset, + ymax = y + (boxHeight/2) - shadowOffset), fill = grDevices::rgb(0, + 0, + 0, + alpha = 0.2)) + p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2), + ymin = y - (boxHeight/2), + xmax = x + (boxWidth/2), + ymax = y + (boxHeight/2)), fill = grDevices::rgb(0.94, + 0.94, + 0.94), color = "black") + return(p) + } + label <- function(p, x, y, text, hjust = 0) { + p <- p + ggplot2::geom_text(ggplot2::aes_string(x = x, y = y, label = paste("\"", substring(text,1,40), "\"", + sep = "")), + hjust = hjust, + size = 3.7) + return(p) + } + + p <- ggplot2::ggplot() + for (i in 2:nSteps - 1) { + p <- downArrow(p, x(1), y(i) - (boxHeight/2), x(1), y(i + 1) + (boxHeight/2)) + p <- label(p, x(1) + 0.02, y(i + 0.5), "Y") + } + for (i in 2:(nSteps - 1)) { + p <- rightArrow(p, x(1) + boxWidth/2, y(i), x(2) - boxWidth/2, y(i)) + p <- label(p, x(1.5), y(i) - 0.02, "N", 0.5) + } + for (i in 1:nSteps) { + p <- box(p, x(1), y(i)) + } + for (i in 2:(nSteps - 1)) { + p <- box(p, x(2), y(i)) + } + for (i in 1:nSteps) { + p <- label(p, x(1) - boxWidth/2 + 0.02, y(i), text = leftBoxText[i]) + } + for (i in 2:(nSteps - 1)) { + p <- label(p, x(2) - boxWidth/2 + 0.02, y(i), text = rightBoxText[i]) + } + p <- p + ggplot2::theme(legend.position = "none", + plot.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.text = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank()) + + return(p) +} diff --git a/R/estimation-covariateBalance.R b/R/cohort-method-covariateBalance.R similarity index 58% rename from R/estimation-covariateBalance.R rename to R/cohort-method-covariateBalance.R index 026fd0f5..1ecdfccf 100644 --- a/R/estimation-covariateBalance.R +++ b/R/cohort-method-covariateBalance.R @@ -1,4 +1,4 @@ -# @file estimation-covariateBalance +# @file cohort-method-covariateBalance # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -22,41 +22,29 @@ #' @param id the unique reference id for the module #' #' @return -#' The user interface to the estimation covariate balance results +#' The user interface to the cohort method covariate balance results #' #' @export -estimationCovariateBalanceViewer <- function(id) { +cohortMethodCovariateBalanceViewer <- function(id) { ns <- shiny::NS(id) shiny::div( - shiny::conditionalPanel(condition = "output.isMetaAnalysis == false", - ns = ns, - shiny::uiOutput(outputId = ns("hoverInfoBalanceScatter")), - - plotly::plotlyOutput(ns("balancePlot")), - shiny::uiOutput(outputId = ns("balancePlotCaption")), - - shiny::downloadButton( - ns('downloadCovariateBalance'), - label = "Download" - ), - - shiny::textInput(ns("covariateHighlight"), "Highlight covariates containing:", ), - shiny::actionButton(ns("covariateHighlightButton"), "Highlight") - + shiny::uiOutput(outputId = ns("hoverInfoBalanceScatter")), + + plotly::plotlyOutput(ns("balancePlot")), + shiny::uiOutput(outputId = ns("balancePlotCaption")), + + shiny::downloadButton( + ns('downloadCovariateBalance'), + label = "Download" ), - shiny::conditionalPanel(condition = "output.isMetaAnalysis == true", - ns = ns, - shiny::plotOutput(outputId = ns("balanceSummaryPlot")), - shiny::uiOutput(outputId = ns("balanceSummaryPlotCaption")), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadBalanceSummaryPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadBalanceSummaryPlotPdf"), - label = "Download plot as PDF") - )) + + shiny::textInput(ns("covariateHighlight"), "Highlight covariates containing:", ), + shiny::actionButton(ns("covariateHighlightButton"), "Highlight") + ) + } @@ -64,17 +52,20 @@ estimationCovariateBalanceViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param metaAnalysisDbIds metaAnalysisDbIds #' #' @return #' the PLE covariate balance content server #' #' @export -estimationCovariateBalanceServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix, metaAnalysisDbIds = NULL) { +cohortMethodCovariateBalanceServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings, + metaAnalysisDbIds = NULL) { shiny::moduleServer( id, @@ -83,13 +74,15 @@ estimationCovariateBalanceServer <- function(id, selectedRow, inputParams, conne balance <- shiny::reactive({ row <- selectedRow() + if(is.null(row$targetId)){ + return(NULL) + } balance <- tryCatch({ - getEstimationCovariateBalanceShared( + getCohortMethodCovariateBalanceShared( connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, databaseId = row$databaseId, analysisId = row$analysisId)}, error = function(e){return(NULL)} @@ -97,22 +90,13 @@ estimationCovariateBalanceServer <- function(id, selectedRow, inputParams, conne return(balance) }) - output$isMetaAnalysis <- shiny::reactive({ - return(FALSE) - ##TODO: update once MA implemented - row <- selectedRow() - isMetaAnalysis <- !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - return(isMetaAnalysis) - }) - - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - - textSearchEstimation <- shiny::reactiveVal(NULL) + + textSearchCohortMethod <- shiny::reactiveVal(NULL) shiny::observeEvent( input$covariateHighlightButton,{ - textSearchEstimation(input$covariateHighlight) + textSearchCohortMethod(input$covariateHighlight) } ) @@ -121,11 +105,11 @@ estimationCovariateBalanceServer <- function(id, selectedRow, inputParams, conne if (is.null(balance()) || nrow(balance()) == 0) { return(NULL) } else { - plot <- plotEstimationCovariateBalanceScatterPlotNew( + plot <- plotCohortMethodCovariateBalanceScatterPlotNew( balance = balance(), beforeLabel = "Before propensity score adjustment", afterLabel = "After propensity score adjustment", - textsearch = textSearchEstimation + textsearch = textSearchCohortMethod ) return(plot) } @@ -199,19 +183,22 @@ estimationCovariateBalanceServer <- function(id, selectedRow, inputParams, conne if (is.null(row) || !(row$databaseId %in% metaAnalysisDbIds)) { return(NULL) } else { - balanceSummary <- getEstimationCovariateBalanceSummary(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - analysisId = row$analysisId, - databaseId = row$analysisId, - beforeLabel = paste("Before", row$psStrategy), - afterLabel = paste("After", row$psStrategy)) - plot <- plotEstimationCovariateBalanceSummary(balanceSummary, - threshold = 0.1, - beforeLabel = paste("Before", row$psStrategy), - afterLabel = paste("After", row$psStrategy)) + balanceSummary <- getCohortMethodCovariateBalanceSummary( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + analysisId = row$analysisId, + databaseId = row$analysisId, + beforeLabel = paste("Before", row$psStrategy), + afterLabel = paste("After", row$psStrategy) + ) + plot <- plotCohortMethodCovariateBalanceSummary( + balanceSummary, + threshold = 0.1, + beforeLabel = paste("Before", row$psStrategy), + afterLabel = paste("After", row$psStrategy) + ) return(plot) } }) @@ -250,10 +237,9 @@ estimationCovariateBalanceServer <- function(id, selectedRow, inputParams, conne ) } -getEstimationCovariateBalanceShared <- function( +getCohortMethodCovariateBalanceShared <- function( connectionHandler, - resultsSchema, - tablePrefix, + resultDatabaseSettings, targetId, comparatorId, analysisId, @@ -276,9 +262,9 @@ getEstimationCovariateBalanceShared <- function( cmscb.comparator_mean_after after_matching_mean_comparator, abs(cmscb.std_diff_after) abs_after_matching_std_diff FROM - @results_schema.@table_prefixshared_covariate_balance cmscb - JOIN @results_schema.@table_prefixcovariate cmc ON cmscb.covariate_id = cmc.covariate_id AND cmscb.analysis_id = cmc.analysis_id AND cmscb.database_id = cmc.database_id -- database_id optional - -- JOIN @results_schema.@table_prefixcovariate_analysis cmca ON cmca.analysis_id = cmc.analysis_id -- question: shouldn't we have a covariate_analysis_id in @table_prefixcovariate table? + @results_schema.@cm_table_prefixshared_covariate_balance cmscb + JOIN @results_schema.@cm_table_prefixcovariate cmc ON cmscb.covariate_id = cmc.covariate_id AND cmscb.analysis_id = cmc.analysis_id AND cmscb.database_id = cmc.database_id -- database_id optional + -- JOIN @results_schema.@cm_table_prefixcovariate_analysis cmca ON cmca.analysis_id = cmc.analysis_id -- question: shouldn't we have a covariate_analysis_id in @table_prefixcovariate table? WHERE cmscb.target_id = @target_id AND cmscb.comparator_id = @comparator_id @@ -289,8 +275,8 @@ getEstimationCovariateBalanceShared <- function( shiny::incProgress(1/3, detail = paste("Extracting")) result <- connectionHandler$queryDb( sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, + results_schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, target_id = targetId, comparator_id = comparatorId, analysis_id = analysisId, @@ -307,22 +293,24 @@ getEstimationCovariateBalanceShared <- function( } -getEstimationCovariateBalanceSummary <- function(connectionHandler, - resultsSchema, - tablePrefix, - databaseId, - targetId, - comparatorId, analysisId, - beforeLabel = "Before matching", - afterLabel = "After matching") { +getCohortMethodCovariateBalanceSummary <- function( + connectionHandler, + resultDatabaseSettings, + databaseId, + targetId, + comparatorId, analysisId, + beforeLabel = "Before matching", + afterLabel = "After matching" + ) { - balance <- getEstimationCovariateBalanceShared(connectionHandler = connectionHandler, - targetId = targetId, - comparatorId = comparatorId, - analysisId = analysisId, - resultsSchema, - tablePrefix, - databaseId = databaseId) + balance <- getCohortMethodCovariateBalanceShared( + connectionHandler = connectionHandler, + targetId = targetId, + comparatorId = comparatorId, + analysisId = analysisId, + resultDatabaseSettings = resultDatabaseSettings, + databaseId = databaseId + ) balanceBefore <- balance %>% dplyr::group_by(.data$databaseId) %>% dplyr::summarise(covariateCount = dplyr::n(), @@ -345,11 +333,11 @@ getEstimationCovariateBalanceSummary <- function(connectionHandler, -plotEstimationCovariateBalanceScatterPlotNew <- function( +plotCohortMethodCovariateBalanceScatterPlotNew <- function( balance, beforeLabel = "Before propensity score adjustment", afterLabel = "After propensity score adjustment", - textsearch = NULL + textsearch = shiny::reactiveVal(NULL) ){ if(is.null(textsearch())){ @@ -398,3 +386,81 @@ plotEstimationCovariateBalanceScatterPlotNew <- function( return(plot) } + + + +plotCohortMethodCovariateBalanceSummary <- function(balanceSummary, + threshold = 0, + beforeLabel = "Before matching", + afterLabel = "After matching") { + balanceSummary <- balanceSummary[rev(order(balanceSummary$databaseId)), ] + dbs <- data.frame(databaseId = unique(balanceSummary$databaseId), + x = 1:length(unique(balanceSummary$databaseId))) + vizData <- merge(balanceSummary, dbs) + + vizData$type <- factor(vizData$type, levels = c(beforeLabel, afterLabel)) + + plot <- ggplot2::ggplot(vizData, ggplot2::aes(x = .data$x, + ymin = .data$ymin, + lower = .data$lower, + middle = .data$median, + upper = .data$upper, + ymax = .data$ymax, + group = .data$databaseId)) + + ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), size = 1) + + ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), size = 1) + + ggplot2::geom_boxplot(stat = "identity", fill = grDevices::rgb(0, 0, 0.8, alpha = 0.25), size = 1) + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::scale_x_continuous(limits = c(0.5, max(vizData$x) + 1.75)) + + ggplot2::scale_y_continuous("Standardized difference of mean") + + ggplot2::coord_flip() + + ggplot2::facet_grid(~type) + + ggplot2::theme(panel.grid.major.y = ggplot2::element_blank(), + panel.grid.minor.y = ggplot2::element_blank(), + panel.grid.major.x = ggplot2::element_line(color = "#AAAAAA"), + panel.background = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.title.y = ggplot2::element_blank(), + axis.ticks.y = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(size = 11), + axis.title.x = ggplot2::element_text(size = 11), + axis.ticks.x = ggplot2::element_line(color = "#AAAAAA"), + strip.background = ggplot2::element_blank(), + strip.text = ggplot2::element_text(size = 11), + plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + + if (threshold != 0) { + plot <- plot + ggplot2::geom_hline(yintercept = c(threshold, -threshold), linetype = "dotted") + } + after <- vizData[vizData$type == afterLabel, ] + after$max <- pmax(abs(after$ymin), abs(after$ymax)) + text <- data.frame(y = rep(c(after$x, nrow(after) + 1.25) , 3), + x = rep(c(1,2,3), each = nrow(after) + 1), + label = c(c(as.character(after$databaseId), + "Source", + formatC(after$covariateCount, big.mark = ",", format = "d"), + "Covariate\ncount", + formatC(after$max, digits = 2, format = "f"), + paste(afterLabel, "max(absolute)", sep = "\n"))), + dummy = "") + + data_table <- ggplot2::ggplot(text, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label)) + + ggplot2::geom_text(size = 4, hjust=0, vjust=0.5) + + ggplot2::geom_hline(ggplot2::aes(yintercept=nrow(after) + 0.5)) + + ggplot2::theme(panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + legend.position = "none", + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(colour="white"), + axis.text.y = ggplot2::element_blank(), + axis.ticks = ggplot2::element_line(colour="white"), + strip.background = ggplot2::element_blank(), + plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + + ggplot2::labs(x="",y="") + + ggplot2::facet_grid(~dummy) + + ggplot2::coord_cartesian(xlim=c(1,4), ylim = c(0.5, max(vizData$x) + 1.75)) + + plot <- gridExtra::grid.arrange(data_table, plot, ncol = 2) + return(plot) +} diff --git a/R/cohort-method-diagnosticsSummary.R b/R/cohort-method-diagnosticsSummary.R new file mode 100644 index 00000000..a7fa38bc --- /dev/null +++ b/R/cohort-method-diagnosticsSummary.R @@ -0,0 +1,408 @@ +# @file cohort-method-diagnosticsSummary +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for rendering the PLE diagnostics results +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method diagnostics viewer +#' +#' @export +cohortMethodDiagnosticsSummaryViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + + #shiny::conditionalPanel( + # condition = 'input.generate != 0', + # ns = shiny::NS(ns("input-selection")), + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Cohort Method Diagnostics'), + solidHeader = TRUE, + + shiny::tabsetPanel( + type = 'pills', + id = ns('diagnosticsTablePanel'), + shiny::tabPanel( + title = 'Summary', + resultTableViewer(ns("diagnosticsSummaryTable")) + ), + shiny::tabPanel( + title = 'Full', + resultTableViewer(ns("diagnosticsTable")) + ) + ) + ) + ) +} + + +#' The module server for rendering the PLE diagnostics summary +#' +#' @param id the unique reference id for the module +#' @param connectionHandler the connection to the PLE results database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' @param inputSelected The target id, comparator id, outcome id and analysis id selected by the user +#' +#' @return +#' the PLE diagnostics summary results +#' +#' @export +cohortMethodDiagnosticsSummaryServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + inputSelected +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + data <- shiny::reactive({ + getCmDiagnosticsData( + connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + }) + + data2 <- shiny::reactive({ + diagnosticSummaryFormat(data) + }) + + customColDefs <- list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ) + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ), + minWidth = 300 + ), + comparator = reactable::colDef( + header = withTooltip( + "Comparator", + "The comparator cohort of interest " + ), + minWidth = 300 + ), + outcome = reactable::colDef( + header = withTooltip( + "Outcome", + "The outcome of interest " + ) + ), + analysis = reactable::colDef( + header = withTooltip( + "Analysis", + "The analysis name " + ) + ), + + mdrr = reactable::colDef( + header = withTooltip( + "mdrr", + "The minimum detectible relative risk" + ), + format = reactable::colFormat(digits = 4) + ), + ease = reactable::colDef( + header = withTooltip( + "ease", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + maxSdm = reactable::colDef( + header = withTooltip( + "max SDM", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + sharedMaxSdm = reactable::colDef( + header = withTooltip( + "shared max SDM", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + equipoise = reactable::colDef( + header = withTooltip( + "equipoise", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + attritionFraction = reactable::colDef( + header = withTooltip( + "Attrition fraction", + "The ..." + ), + format = reactable::colFormat(digits = 4) + ), + balanceDiagnostic = reactable::colDef( + header = withTooltip( + "balanceDiagnostic", + "The ..." + ) + ), + mdrrDiagnostic = reactable::colDef( + header = withTooltip( + "mdrrDiagnostic", + "The ..." + ) + ), + easeDiagnostic = reactable::colDef( + header = withTooltip( + "easeDiagnostic", + "The ..." + ) + ), + attritionDiagnostic = reactable::colDef( + header = withTooltip( + "attritionDiagnostic", + "The ..." + ) + ), + equipoiseDiagnostic = reactable::colDef( + header = withTooltip( + "equipoiseDiagnostic", + "The ..." + ) + ), + + unblind = reactable::colDef( + header = withTooltip( + "unblind", + "If the value is 1 then the diagnostics passed and results can be unblinded" + ) + ), + + summaryValue = reactable::colDef(show = F) + + ) + + resultTableServer( + id = "diagnosticsTable", + df = data, + colDefsInput = customColDefs + ) + + resultTableServer( + id = "diagnosticsSummaryTable", + df = data2, + colDefsInput = getColDefsCmDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + ) + + } + ) +} + +getColDefsCmDiag <- function( + connectionHandler, + resultDatabaseSettings +){ + + fixedColumns = list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ), + sticky = "left" + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ), + sticky = "left" + ), + comparator = reactable::colDef( + header = withTooltip( + "Comparator", + "The comparator cohort of interest " + ), + sticky = "left" + ) + ) + + outcomes <- getCmCohorts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'outcome' + ) + analyses <- getCmAnalyses( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + colnameFormat <- merge(unique(names(outcomes)), unique(names(analyses))) + colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) + + styleList <- lapply( + colnameFormat, + FUN = function(x){ + reactable::colDef( + header = withTooltip( + substring(x,1,40), + x + ), + style = function(value) { + color <- 'orange' + if(is.na(value)){ + color <- 'black' + }else if(value == 'Pass'){ + color <- '#AFE1AF' + }else if(value == 'Fail'){ + color <- '#E97451' + } + list(background = color) + } + ) + } + ) + names(styleList) <- colnameFormat + result <- append(fixedColumns, styleList) + + return(result) +} + +diagnosticSummaryFormat <- function( + data, + idCols = c('databaseName','target', 'comparator'), + namesFrom = c('outcome','analysis') + ){ + + if(is.null(data())){ + return(NULL) + } + + data2 <- tidyr::pivot_wider( + data = data(), + id_cols = idCols, + names_from = namesFrom, + values_from = c('summaryValue') + ) + + return(data2) +} + + + +getCmDiagnosticsData <- function( + connectionHandler, + resultDatabaseSettings, + inputSelected +) { + + targetIds = inputSelected()$targetIds + outcomeIds = inputSelected()$outcomeIds + comparatorIds = inputSelected()$comparatorIds + analysisIds = inputSelected()$analysisIds + + if(is.null(targetIds) || is.null(outcomeIds)){ + return(NULL) + } + + sql <- " + SELECT DISTINCT + dmd.cdm_source_abbreviation database_name, + cma.description analysis, + cgcd1.cohort_name target, + cgcd2.cohort_name comparator, + cgcd3.cohort_name outcome, + cmds.max_sdm, + cmds.shared_max_sdm, + cmds.equipoise, + cmds.mdrr, + cmds.attrition_fraction, + cmds.ease, + cmds.balance_diagnostic, + --cmds.shared_balance_diagnostic, + cmds.equipoise_diagnostic, + cmds.mdrr_diagnostic, + cmds.attrition_diagnostic, + cmds.ease_diagnostic, + cmds.unblind + FROM + @schema.@cm_table_prefixdiagnostics_summary cmds + INNER JOIN @schema.@cm_table_prefixanalysis cma ON cmds.analysis_id = cma.analysis_id + INNER JOIN @schema.@database_table dmd ON dmd.database_id = cmds.database_id + INNER JOIN @schema.@cg_table_prefixcohort_definition cgcd1 ON cmds.target_id = cgcd1.cohort_definition_id + INNER JOIN @schema.@cg_table_prefixcohort_definition cgcd2 ON cmds.comparator_id = cgcd2.cohort_definition_id + INNER JOIN @schema.@cg_table_prefixcohort_definition cgcd3 ON cmds.outcome_id = cgcd3.cohort_definition_id + + where cgcd1.cohort_definition_id in (@targets) + {@use_comparators}?{and cgcd2.cohort_definition_id in (@comparators)} + and cgcd3.cohort_definition_id in (@outcomes) + {@use_analyses}?{and cma.analysis_id in (@analyses)} + ; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + + targets = paste0(targetIds, collapse = ','), + comparators = paste0(comparatorIds, collapse = ','), + outcomes = paste0(outcomeIds, collapse = ','), + analyses = paste0(analysisIds, collapse = ','), + + use_comparators = !is.null(comparatorIds), + use_analyses = !is.null(analysisIds) + ) + + # adding percent fail for summary + result$summaryValue <- apply( + X = result[, grep('Diagnostic', colnames(result))], + MARGIN = 1, + FUN = function(x){ + + if(sum(x %in% c('FAIL'))>0){ + return('Fail') + } else if(sum(x %in% c('WARNING')) >0){ + return(sum(x %in% c('WARNING'))) + } else{ + return('Pass') + } + } + ) + + return( + result + ) +} \ No newline at end of file diff --git a/R/cohort-method-full-result.R b/R/cohort-method-full-result.R new file mode 100644 index 00000000..7f4e5010 --- /dev/null +++ b/R/cohort-method-full-result.R @@ -0,0 +1,180 @@ +cohortMethodFullResultViewer <- function(id) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Result Explorer'), + solidHeader = TRUE, + + # add selected settings + shinydashboard::box( + status = 'warning', + width = "100%", + title = 'Selected: ', + collapsible = T, + shiny::uiOutput(ns('selection')) + ), + + shiny::tabsetPanel( + id = ns("fullTabsetPanel"), + type = 'pills', + shiny::tabPanel( + title = "Power", + cohortMethodPowerViewer(ns("power")) + ), + shiny::tabPanel( + title = "Attrition", + cohortMethodAttritionViewer(ns("attrition")) + ), + shiny::tabPanel( + title = "Population characteristics", + cohortMethodPopulationCharacteristicsViewer(ns("popCharacteristics")) + ), + shiny::tabPanel( + title = "Propensity model", + cohortMethodPropensityModelViewer(ns("propensityModel")) + ), + shiny::tabPanel( + title = "Propensity scores", + cohortMethodPropensityScoreDistViewer(ns("propensityScoreDist")) + ), + shiny::tabPanel( + title = "Covariate balance", + cohortMethodCovariateBalanceViewer(ns("covariateBalance")) + ), + shiny::tabPanel( + title = "Systematic error", + cohortMethodSystematicErrorViewer(ns("systematicError")) + ), + shiny::tabPanel( + title = "Kaplan-Meier", + cohortMethodKaplanMeierViewer(ns("kaplanMeier")) + ) + ) + ) + +} + +cohortMethodFullResultServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + selectedRow +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + output$selection <- shiny::renderUI({ + otext <- list() + otext[[1]] <- shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b('Target: '), + selectedRow()$target + ), + shiny::column( + width = 6, + shiny::tags$b('Comparator: '), + selectedRow()$comparator + ) + ) + otext[[2]] <- shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b('Outcome: '), + selectedRow()$outcome + ), + shiny::column( + width = 6, + shiny::tags$b('Analysis: '), + selectedRow()$description + ) + ) + otext[[3]] <- shiny::fluidRow( + shiny::column( + width = 3, + shiny::tags$b('Database: '), + selectedRow()$cdmSourceAbbreviation + ), + shiny::column( + width = 6, + shiny::tags$b('') + ) + ) + shiny::div(otext) + }) + + shiny::observeEvent(selectedRow(),{ + if(!is.null(selectedRow()$unblind)){ + if (selectedRow()$unblind == 1) { + shiny::showTab("fullTabsetPanel", "Kaplan-Meier", session = session) + } else{ + shiny::hideTab("fullTabsetPanel", "Kaplan-Meier", session = session) + } + } + }) + + # selected row: : - reactive list with: psStrategy + + cohortMethodPowerServer( + id = "power", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodAttritionServer( + id = "attrition", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodPopulationCharacteristicsServer( + id = "popCharacteristics", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodPropensityModelServer( + id = "propensityModel", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodPropensityScoreDistServer( + id = "propensityScoreDist", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodCovariateBalanceServer( + id = "covariateBalance", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodSystematicErrorServer( + id = "systematicError", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + cohortMethodKaplanMeierServer( + id = "kaplanMeier", + selectedRow = selectedRow, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + } + ) +} \ No newline at end of file diff --git a/R/estimation-kaplainMeier.R b/R/cohort-method-kaplainMeier.R similarity index 72% rename from R/estimation-kaplainMeier.R rename to R/cohort-method-kaplainMeier.R index 703a7644..6eb75396 100644 --- a/R/estimation-kaplainMeier.R +++ b/R/cohort-method-kaplainMeier.R @@ -1,4 +1,4 @@ -# @file estimation-kaplainMeier +# @file cohort-method-kaplainMeier # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -25,7 +25,7 @@ #' The module viewer for Kaplan Meier objects #' #' @export -estimationKaplanMeierViewer <- function(id) { +cohortMethodKaplanMeierViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -43,66 +43,53 @@ estimationKaplanMeierViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param cohortTablePrefix cohortTablePrefix -#' @param databaseTable databaseTable -#' @param metaAnalysisDbIds metaAnalysisDbIds +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' the PLE Kaplain Meier content server #' #' @export -estimationKaplanMeierServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, databaseTable, metaAnalysisDbIds = NULL) { +cohortMethodKaplanMeierServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings + ) { shiny::moduleServer( id, function(input, output, session) { - output$isMetaAnalysis <- shiny::reactive({ - #TODO: update once MA implemented - return(FALSE) - row <- selectedRow() - isMetaAnalysis <- !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - return(isMetaAnalysis) - }) - - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - + kaplanMeierPlot <- shiny::reactive({ row <- selectedRow() if (is.null(row)) { return(NULL) } else { - km <- getEstimationKaplanMeier(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - databaseTable = databaseTable, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, - databaseId = row$databaseId, - analysisId = row$analysisId) + km <- getCohortMethodKaplanMeier( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) # hack to fix data insert replacing NA with 0 removeInd <- km$targetAtRisk == 0 & km$comparatorAtRisk == 0 km$targetAtRisk[removeInd] <- NA km$comparatorAtRisk[removeInd] <- NA - targetName <- getCohortNameFromId(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - cohortTablePrefix = cohortTablePrefix, - cohortId = inputParams()$target) - comparatorName <- getCohortNameFromId(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - cohortTablePrefix = cohortTablePrefix, - cohortId = inputParams()$comparator) + targetName <- row$target + comparatorName <- row$comparator - plot <- plotEstimationKaplanMeier(kaplanMeier = km, - targetName = targetName$cohortName, - comparatorName = comparatorName$cohortName) + plot <- plotCohortMethodKaplanMeier( + kaplanMeier = km, + targetName = targetName, + comparatorName = comparatorName + ) return(plot) } }) @@ -133,7 +120,7 @@ estimationKaplanMeierServer <- function(id, selectedRow, inputParams, connection comparator curve (%s) applies reweighting to approximate the counterfactual of what the target survival would look like had the target cohort been exposed to the comparator instead. The shaded area denotes the 95 percent confidence interval." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, row$target, row$comparator))) } }) @@ -144,10 +131,47 @@ estimationKaplanMeierServer <- function(id, selectedRow, inputParams, connection +getCohortMethodKaplanMeier <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + outcomeId, + databaseId, + analysisId +) { + + sql <- " + SELECT + * + FROM + @schema.@cm_table_prefixkaplan_meier_dist cmkmd + WHERE + cmkmd.target_id = @target_id + AND cmkmd.comparator_id = @comparator_id + AND cmkmd.outcome_id = @outcome_id + AND cmkmd.analysis_id = @analysis_id + AND cmkmd.database_id = '@database_id'; + " + + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + #database_table = resultDatabaseSettings$databaseTable, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + analysis_id = analysisId, + database_id = databaseId + ) + ) +} -# estimation-kaplainMeier -plotEstimationKaplanMeier <- function( +# CohortMethod-kaplainMeier +plotCohortMethodKaplanMeier <- function( kaplanMeier, targetName, comparatorName @@ -159,14 +183,14 @@ plotEstimationKaplanMeier <- function( s = kaplanMeier$targetSurvival, lower = kaplanMeier$targetSurvivalLb, upper = kaplanMeier$targetSurvivalUb, - strata = paste0(" ", targetName, " ") + strata = ' Target' #paste0(" ", targetName, " ") ), data.frame( time = kaplanMeier$time, s = kaplanMeier$comparatorSurvival, lower = kaplanMeier$comparatorSurvivalLb, upper = kaplanMeier$comparatorSurvivalUb, - strata = paste0(" ", comparatorName) + strata = ' Comparator'#paste0(" ", comparatorName) ) ) @@ -217,8 +241,8 @@ plotEstimationKaplanMeier <- function( x = c(0, xBreaks, xBreaks), y = as.factor( c("Number at risk", - rep(targetName, length(xBreaks)), - rep(comparatorName, length(xBreaks)) + rep('Target', length(xBreaks)), + rep('Comparator', length(xBreaks)) ) ), label = c( @@ -227,7 +251,7 @@ plotEstimationKaplanMeier <- function( formatC(comparatorAtRisk, big.mark = ",", mode = "integer") ) ) - labels$y <- factor(labels$y, levels = c(comparatorName, targetName, "Number at risk")) + labels$y <- factor(labels$y, levels = c('Comparator','Target', "Number at risk")) dataTable <- ggplot2::ggplot( data = labels, diff --git a/R/cohort-method-main.R b/R/cohort-method-main.R new file mode 100644 index 00000000..c555d062 --- /dev/null +++ b/R/cohort-method-main.R @@ -0,0 +1,288 @@ +# @file cohort-method-main.R +# +# Copyright 2022 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. + + +#' The location of the cohort method module helper file +#' +#' @details +#' Returns the location of the cohort method helper file +#' +#' @return +#' string location of the cohort method helper file +#' +#' @export +cohortMethodHelperFile <- function(){ + fileLoc <- system.file('cohort-method-www', "cohort-method.html", package = "OhdsiShinyModules") + return(fileLoc) +} + +#' The viewer of the main cohort method module +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method results viewer +#' +#' @export +cohortMethodViewer <- function(id) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = 12, + title = shiny::span( shiny::icon("chart-column"), 'Cohort Method'), + solidHeader = TRUE, + + # Input selection of T, C and Os + inputSelectionViewer(ns("input-selection")), + + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = shiny::NS(ns("input-selection")), + + shiny::tabsetPanel( + type = 'pills', + id = ns('mainPanel'), + + shiny::tabPanel( + title = "Diagnostics", + cohortMethodDiagnosticsSummaryViewer(ns("cmDiganostics")) + ), + + shiny::tabPanel( + title = "Results", + cohortMethodResultSummaryViewer(ns("cmResults")) + ) + ) + ) + + ) +} + + +#' The module server for the main cohort method module +#' +#' @param id the unique reference id for the module +#' @param connectionHandler a connection to the database with the results +#' @param resultDatabaseSettings a named list containing the PLE results database connection details +#' +#' @return +#' the PLE results viewer main module server +#' +#' @export +cohortMethodServer <- function( + id, + connectionHandler, + resultDatabaseSettings + ) { + + shiny::moduleServer( + id, + function(input, output, session) { + + dataFolder <- NULL + + targetIds <- getCmCohorts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'target' + ) + outcomeIds <- getCmCohorts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'outcome' + ) + comparatorIds <- getCmCohorts( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'comparator' + ) + analysisIds <- getCmAnalyses( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + inputSelected <- inputSelectionServer( + id = "input-selection", + inputSettingList = list( + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'targetIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Target: ', + choices = targetIds, + selected = targetIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'outcomeIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Outcome: ', + choices = outcomeIds, + selected = outcomeIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + createInputSetting( + rowNumber = 2, + columnWidth = 6, + varName = 'comparatorIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Comparator: ', + choices = comparatorIds, + selected = comparatorIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + + createInputSetting( + rowNumber = 2, + columnWidth = 6, + varName = 'analysisIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Analysis: ', + choices = analysisIds, + selected = analysisIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ) + ) + ) + + cohortMethodDiagnosticsSummaryServer( + id = "cmDiganostics", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + + cohortMethodResultSummaryServer( + id = "cmResults", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + + } + ) +} + +getCmCohorts <- function( + connectionHandler, + resultDatabaseSettings, + type = 'target' +){ + + sql <- " + SELECT DISTINCT + cgcd1.cohort_name as names, + cgcd1.cohort_definition_id + FROM + @schema.@cm_table_prefixresult cmds + INNER JOIN + @schema.@cg_table_prefixcohort_definition cgcd1 + ON cmds.@type_id = cgcd1.cohort_definition_id; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + type = type + ) + + res <- result$cohortDefinitionId + names(res) <- result$names + + return( + res + ) +} + +getCmAnalyses <- function( + connectionHandler, + resultDatabaseSettings +){ + + sql <- " + SELECT DISTINCT + cma.analysis_id, + cma.description as names + FROM + @schema.@cm_table_prefixresult cmds + INNER JOIN + @schema.@cm_table_prefixanalysis cma + ON cmds.analysis_id = cma.analysis_id + ; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix + ) + + res <- result$analysisId + names(res) <- result$names + + return( + res + ) + +} diff --git a/R/estimation-populationCharacteristics.R b/R/cohort-method-populationCharacteristics.R similarity index 90% rename from R/estimation-populationCharacteristics.R rename to R/cohort-method-populationCharacteristics.R index b7fd83b9..0951d3bd 100644 --- a/R/estimation-populationCharacteristics.R +++ b/R/cohort-method-populationCharacteristics.R @@ -1,4 +1,4 @@ -# @file estimation-populationCharacteristics +# @file cohort-method-populationCharacteristics # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -22,10 +22,10 @@ #' @param id the unique reference id for the module #' #' @return -#' The user interface to the estimation population characteristics objects +#' The user interface to the cohort method population characteristics objects #' #' @export -estimationPopulationCharacteristicsViewer <- function(id) { +cohortMethodPopulationCharacteristicsViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -39,22 +39,18 @@ estimationPopulationCharacteristicsViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' the PLE population characteristics content server #' #' @export -estimationPopulationCharacteristicsServer <- function( +cohortMethodPopulationCharacteristicsServer <- function( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix + resultDatabaseSettings ) { shiny::moduleServer( @@ -70,7 +66,7 @@ estimationPopulationCharacteristicsServer <- function( text <- "Table 2. Select characteristics before and after propensity score adjustment, showing the (weighted) percentage of subjects with the characteristics in the target (%s) and comparator (%s) group, as well as the standardized difference of the means." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) + return(shiny::HTML(sprintf(text, row$target, row$comparator))) } }) @@ -79,20 +75,19 @@ estimationPopulationCharacteristicsServer <- function( if (is.null(row)) { return(NULL) } else { - balance <- getEstimationPopChar( + balance <- getCohortMethodPopChar( connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, databaseId = row$databaseId, analysisId = row$analysisId ) if (nrow(balance) == 0) { return(NULL) } - table1 <- prepareEstimationTable1( + table1 <- prepareCohortMethodTable1( balance = balance, beforeLabel = paste("Before PS adjustment"), afterLabel = paste("After PS adjustment") @@ -133,10 +128,9 @@ estimationPopulationCharacteristicsServer <- function( } -getEstimationPopChar <- function( +getCohortMethodPopChar <- function( connectionHandler, - resultsSchema, - tablePrefix, + resultDatabaseSettings, targetId, comparatorId, analysisId, @@ -160,14 +154,14 @@ getEstimationPopChar <- function( cmcb.comparator_mean_after after_matching_mean_comparator, abs(cmcb.std_diff_after) abs_after_matching_std_diff FROM - (select * from @results_schema.@table_prefixcovariate_balance + (select * from @schema.@cm_table_prefixcovariate_balance WHERE target_id = @target_id AND comparator_id = @comparator_id AND outcome_id = @outcome_id AND analysis_id = @analysis_id AND database_id = '@database_id' ) as cmcb - INNER JOIN @results_schema.@table_prefixcovariate cmc + INNER JOIN @schema.@cm_table_prefixcovariate cmc ON cmcb.covariate_id = cmc.covariate_id AND cmcb.analysis_id = cmc.analysis_id @@ -178,8 +172,8 @@ getEstimationPopChar <- function( shiny::incProgress(1/3, detail = paste("Extracting")) result <- connectionHandler$queryDb( sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, target_id = targetId, comparator_id = comparatorId, outcome_id = outcomeId, @@ -197,8 +191,8 @@ getEstimationPopChar <- function( } -# estimation-populationChar -prepareEstimationTable1 <- function( +# CohortMethod-populationChar +prepareCohortMethodTable1 <- function( balance, beforeLabel = "Before stratification", afterLabel = "After stratification", @@ -212,7 +206,7 @@ prepareEstimationTable1 <- function( if(is.null(pathToCsv)) { - pathToCsv <- system.file("estimation-ref", "Table1Specs.csv", package = "OhdsiShinyModules") + pathToCsv <- system.file("cohort-method-ref", "Table1Specs.csv", package = "OhdsiShinyModules") } if (output == "latex") { space <- " " diff --git a/R/cohort-method-power.R b/R/cohort-method-power.R new file mode 100644 index 00000000..3f9626ae --- /dev/null +++ b/R/cohort-method-power.R @@ -0,0 +1,287 @@ +# @file cohort-method-power +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for rendering the PLE power analysis +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method power calculation results +#' +#' @export +cohortMethodPowerViewer <- function(id) { + + ns <- shiny::NS(id) + + shiny::div( + shiny::uiOutput(outputId = ns("powerTableCaption")), + shiny::tableOutput(outputId = ns("powerTable")), + shiny::uiOutput(outputId = ns("timeAtRiskTableCaption")), + shiny::tableOutput(outputId = ns("timeAtRiskTable")) + ) +} + + +#' The module server for rendering the PLE power analysis results +#' +#' @param id the unique reference id for the module +#' @param selectedRow the selected row from the main results table +#' @param connectionHandler the connection to the PLE results database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' +#' @return +#' the PLE systematic error power server +#' +#' @export +cohortMethodPowerServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings + ) { + + shiny::moduleServer( + id, + function(input, output, session) { + + + output$powerTableCaption <- shiny::renderUI({ + row <- selectedRow() + if (!is.null(row$target)) { + text <- "Table 1a. Number of subjects, follow-up time (in years), number of outcome + events, and event incidence rate (IR) per 1,000 patient years (PY) in the target (%s) and + comparator (%s) group after propensity score adjustment, as well as the minimum detectable relative risk (MDRR). + Note that the IR does not account for any stratification." + return(shiny::HTML(sprintf(text, row$target, row$comparator))) + } else { + return(NULL) + } + }) + + output$powerTable <- shiny::renderTable({ + row <- selectedRow() + if (is.null(row$target)) { + return(NULL) + } else { + table <- prepareCohortMethodPowerTable( + row, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + if (!row$unblind) { + table$targetOutcomes <- NA + table$comparatorOutcomes <- NA + table$targetIr <- NA + table$comparatorIr <- NA + } + colnames(table) <- c("Target subjects", + "Comparator subjects", + "Target years", + "Comparator years", + "Target events", + "Comparator events", + "Target IR (per 1,000 PY)", + "Comparator IR (per 1,000 PY)", + "MDRR") + + return(table) + } + }) + + output$timeAtRiskTableCaption <- shiny::renderUI({ + row <- selectedRow() + if (!is.null(row$target)) { + text <- "Table 1b. Time (days) at risk distribution expressed as + minimum (min), 25th percentile (P25), median, 75th percentile (P75), and maximum (max) in the target + (%s) and comparator (%s) cohort after propensity score adjustment." + return(shiny::HTML(sprintf(text, row$target, row$comparator))) + } else { + return(NULL) + } + }) + + output$timeAtRiskTable <- shiny::renderTable({ + row <- selectedRow() + if (is.null(row$target)) { + return(NULL) + } else { + followUpDist <- getCmFollowUpDist( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + + table <- prepareCohortMethodFollowUpDistTable(followUpDist) + return(table) + } + }) + }) +} + + +prepareCohortMethodFollowUpDistTable <- function(followUpDist) { + targetRow <- data.frame(Database = followUpDist$databaseId, + Cohort = "Target", + Min = followUpDist$targetMinDays, + P10 = followUpDist$targetP10Days, + P25 = followUpDist$targetP25Days, + Median = followUpDist$targetMedianDays, + P75 = followUpDist$targetP75Days, + P90 = followUpDist$targetP90Days, + Max = followUpDist$targetMaxDays) + comparatorRow <- data.frame(Database = followUpDist$databaseId, + Cohort = "Comparator", + Min = followUpDist$comparatorMinDays, + P10 = followUpDist$comparatorP10Days, + P25 = followUpDist$comparatorP25Days, + Median = followUpDist$comparatorMedianDays, + P75 = followUpDist$comparatorP75Days, + P90 = followUpDist$comparatorP90Days, + Max = followUpDist$comparatorMaxDays) + table <- rbind(targetRow, comparatorRow) + table$Min <- formatC(table$Min, big.mark = ",", format = "d") + table$P10 <- formatC(table$P10, big.mark = ",", format = "d") + table$P25 <- formatC(table$P25, big.mark = ",", format = "d") + table$Median <- formatC(table$Median, big.mark = ",", format = "d") + table$P75 <- formatC(table$P75, big.mark = ",", format = "d") + table$P90 <- formatC(table$P90, big.mark = ",", format = "d") + table$Max <- formatC(table$Max, big.mark = ",", format = "d") + if (length(unique(followUpDist$databaseId)) == 1) + table$Database <- NULL + return(table) +} + + +prepareCohortMethodPowerTable <- function( + mainResults, + connectionHandler , + resultDatabaseSettings +) { + #analyses <- getCohortMethodAnalyses( + # connectionHandler = connectionHandler, + # resultDatabaseSettings = resultDatabaseSettings + #) + #table <- merge(mainResults, analyses) + table <- mainResults + alpha <- 0.05 + power <- 0.8 + z1MinAlpha <- stats::qnorm(1 - alpha/2) + zBeta <- -stats::qnorm(1 - power) + pA <- table$targetSubjects/(table$targetSubjects + table$comparatorSubjects) + pB <- 1 - pA + totalEvents <- abs(table$targetOutcomes) + abs(table$comparatorOutcomes) + table$mdrr <- exp(sqrt((zBeta + z1MinAlpha)^2/(totalEvents * pA * pB))) + table$targetYears <- table$targetDays/365.25 + table$comparatorYears <- table$comparatorDays/365.25 + table$targetIr <- 1000 * table$targetOutcomes/table$targetYears + table$comparatorIr <- 1000 * table$comparatorOutcomes/table$comparatorYears + table <- table[, c("targetSubjects", + "comparatorSubjects", + "targetYears", + "comparatorYears", + "targetOutcomes", + "comparatorOutcomes", + "targetIr", + "comparatorIr", + "mdrr"), drop = F] + table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") + table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") + table$targetYears <- formatC(table$targetYears, big.mark = ",", format = "d") + table$comparatorYears <- formatC(table$comparatorYears, big.mark = ",", format = "d") + table$targetOutcomes <- formatC(table$targetOutcomes, big.mark = ",", format = "d") + table$comparatorOutcomes <- formatC(table$comparatorOutcomes, big.mark = ",", format = "d") + table$targetIr <- sprintf("%.2f", table$targetIr) + table$comparatorIr <- sprintf("%.2f", table$comparatorIr) + table$mdrr <- sprintf("%.2f", table$mdrr) + table$targetSubjects <- gsub("^-", "<", table$targetSubjects) + table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) + table$targetOutcomes <- gsub("^-", "<", table$targetOutcomes) + table$comparatorOutcomes <- gsub("^-", "<", table$comparatorOutcomes) + table$targetIr <- gsub("^-", "<", table$targetIr) + table$comparatorIr <- gsub("^-", "<", table$comparatorIr) + idx <- (table$targetOutcomes < 0 | table$comparatorOutcomes < 0) + table$mdrr[idx] <- paste0(">", table$mdrr[idx]) + return(table) +} + + +getCohortMethodAnalyses <- function( + connectionHandler, + resultDatabaseSettings +) { + sql <- " + SELECT + cma.* + FROM + @schema.@cm_table_prefixanalysis cma + " + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix + ) + ) +} + +getCmFollowUpDist <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + outcomeId, + databaseId = NULL, + analysisId +) { + + if(is.null(targetId)){ + return(NULL) + } + + sql <- " + SELECT + * + FROM + @schema.@cm_table_prefixfollow_up_dist cmfud + WHERE + cmfud.target_id = @target_id + AND cmfud.comparator_id = @comparator_id + AND cmfud.outcome_id = @outcome_id + AND cmfud.analysis_id = @analysis_id + " + if(!is.null(databaseId)) { + sql <- paste(sql, paste("AND cmfud.database_id = '@database_id'"), collapse = "\n") + } + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + analysis_id = analysisId, + database_id = databaseId + ) + ) +} diff --git a/R/cohort-method-propensityModel.R b/R/cohort-method-propensityModel.R new file mode 100644 index 00000000..5ce5f48a --- /dev/null +++ b/R/cohort-method-propensityModel.R @@ -0,0 +1,170 @@ +# @file cohort-method-propensityModel +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for rendering the PLE propensity score model covariates/coefficients +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method propensity score model covariates/coefficients +#' +#' @export +cohortMethodPropensityModelViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + shiny::div(shiny::strong("Table 3."),"Fitted propensity model, listing all coviates with non-zero coefficients. Positive coefficients indicate predictive of the target exposure."), + DT::dataTableOutput(outputId = ns("propensityModelTable")) + ) +} + + +#' The module server for rendering the propensity score model +#' +#' @param id the unique reference id for the module +#' @param selectedRow the selected row from the main results table +#' @param connectionHandler the connection to the PLE results database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' +#' @return +#' the PLE propensity score model +#' +#' @export +cohortMethodPropensityModelServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings + ) { + + shiny::moduleServer( + id, + function(input, output, session) { + + output$propensityModelTable <- DT::renderDataTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + model <- getCohortMethodPropensityModel( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + + table <- prepareCohortMethodPropensityModelTable(model) + options = list(columnDefs = list(list(className = 'dt-right', targets = 0)), + pageLength = 15, + searching = FALSE, + lengthChange = TRUE, + ordering = TRUE, + paging = TRUE) + selection = list(mode = "single", target = "row") + table <- DT::datatable(table, + options = options, + selection = selection, + rownames = FALSE, + escape = FALSE, + class = "stripe nowrap compact") + return(table) + } + }) + + } + ) +} + + +getCohortMethodPropensityModel <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + analysisId, + databaseId +) { + sqlTmp <- " + SELECT + cmpm.coefficient, + cmc.covariate_id, + cmc.covariate_name + FROM + @schema.@cm_table_prefixcovariate cmc + JOIN @schema.@cm_table_prefixpropensity_model cmpm + ON cmc.covariate_id = cmpm.covariate_id + AND cmc.database_id = cmpm.database_id + WHERE + cmpm.target_id = @target_id + AND cmpm.comparator_id = @comparator_id + AND cmpm.analysis_id = @analysis_id + AND cmpm.database_id = '@database_id' + " + + sql <- " + SELECT + cmc.covariate_id, + cmc.covariate_name, + cmpm.coefficient + FROM + ( + SELECT + covariate_id, + covariate_name + FROM + @schema.@cm_table_prefixcovariate + WHERE + analysis_id = @analysis_id + AND database_id = '@database_id' + UNION + SELECT + 0 as covariate_id, + 'intercept' as covariate_name) cmc + JOIN @schema.@cm_table_prefixpropensity_model cmpm + ON cmc.covariate_id = cmpm.covariate_id + WHERE + cmpm.target_id = @target_id + AND cmpm.comparator_id = @comparator_id + AND cmpm.analysis_id = @analysis_id + AND cmpm.database_id = '@database_id' + " + + model <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + analysis_id = analysisId, + database_id = databaseId + ) + return(model) +} + +prepareCohortMethodPropensityModelTable <- function(model) { + rnd <- function(x) { + ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) + } + table <- model[order(-abs(model$coefficient)), c("coefficient", "covariateName")] + table$coefficient <- sprintf("%.2f", table$coefficient) + colnames(table) <- c("Beta", "Covariate") + return(table) +} \ No newline at end of file diff --git a/R/estimation-propensityScoreDistribution.R b/R/cohort-method-propensityScoreDistribution.R similarity index 68% rename from R/estimation-propensityScoreDistribution.R rename to R/cohort-method-propensityScoreDistribution.R index 1022c16a..0ece5fd5 100644 --- a/R/estimation-propensityScoreDistribution.R +++ b/R/cohort-method-propensityScoreDistribution.R @@ -1,4 +1,4 @@ -# @file estimation-propensityScoreDistribution +# @file cohort-method-propensityScoreDistribution # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -22,10 +22,10 @@ #' @param id the unique reference id for the module #' #' @return -#' The user interface to the estimation propensity score distribution +#' The user interface to the cohort method propensity score distribution #' #' @export -estimationPropensityScoreDistViewer <- function(id) { +cohortMethodPropensityScoreDistViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -46,18 +46,21 @@ estimationPropensityScoreDistViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest #' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param cohortTablePrefix cohortTablePrefix +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param metaAnalysisDbIds metaAnalysisDbIds #' #' @return #' the PLE propensity score distribution content server #' #' @export -estimationPropensityScoreDistServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, metaAnalysisDbIds = F) { +cohortMethodPropensityScoreDistServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings, + metaAnalysisDbIds = F + ) { shiny::moduleServer( id, @@ -65,41 +68,27 @@ estimationPropensityScoreDistServer <- function(id, selectedRow, inputParams, co psDistPlot <- shiny::reactive({ row <- selectedRow() - if (is.null(row)) { + if (is.null(row$targetId)) { return(NULL) } else { - if (FALSE && row$databaseId %in% metaAnalysisDbIds) { - #TODO: update once MA implemented - ps <- getEstimationPs(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - #targetIds = row$targetId, - #comparatorIds = row$comparatorId, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - analysisId = row$analysisId) - } else { - ps <- getEstimationPs(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - analysisId = row$analysisId, - databaseId = row$databaseId) - } + ps <- getCohortMethodPs( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + analysisId = row$analysisId, + databaseId = row$databaseId + ) + if (nrow(ps) == 0) { return(NULL) #TODO: handle more gracefully } - targetName <- getCohortNameFromId(connectionHandler = connectionHandler , - resultsSchema = resultsSchema, - cohortTablePrefix = cohortTablePrefix, - cohortId = inputParams()$target) - comparatorName <- getCohortNameFromId(connectionHandler = connectionHandler , - resultsSchema = resultsSchema, - cohortTablePrefix = cohortTablePrefix, - cohortId = inputParams()$comparator) - plot <- plotEstimationPs(ps, targetName$cohortName, comparatorName$cohortName) + targetName <- row$target + + comparatorName <- row$comparator + + plot <- plotCohortMethodPs(ps, targetName, comparatorName) return(plot) } }) @@ -124,11 +113,55 @@ estimationPropensityScoreDistServer <- function(id, selectedRow, inputParams, co ) } +getCohortMethodPs <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + analysisId, + databaseId = NULL +) { + if(is.null(targetId)){ + return(NULL) + } + sql <- " + SELECT + * + FROM + @schema.@cm_table_prefixpreference_score_dist cmpsd + WHERE + cmpsd.target_id = @target_id + AND cmpsd.comparator_id = @comparator_id + AND cmpsd.analysis_id = @analysis_id + " + if(!is.null(databaseId)) { + sql <- paste(sql, paste("AND cmpsd.database_id = '@database_id'"), collapse = "\n") + } + + + ps <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + analysis_id = analysisId, + database_id = databaseId + ) + + + if (!is.null(databaseId)) { + ps$databaseId <- NULL + } + return(ps) +} - -# estimation-propensityScoreDist -plotEstimationPs <- function(ps, targetName, comparatorName) { - if (is.null(ps$databaseId)) { +# CohortMethod-propensityScoreDist +plotCohortMethodPs <- function(ps, targetName, comparatorName) { + if(is.null(ps$preferenceScore)){ + return(NULL) + } + if(is.null(ps$databaseId)) { ps <- rbind(data.frame(x = ps$preferenceScore, y = ps$targetDensity, group = targetName), data.frame(x = ps$preferenceScore, y = ps$comparatorDensity, group = comparatorName)) diff --git a/R/cohort-method-resultSummary.R b/R/cohort-method-resultSummary.R new file mode 100644 index 00000000..e90981b1 --- /dev/null +++ b/R/cohort-method-resultSummary.R @@ -0,0 +1,358 @@ +# @file cohort-method-resultSummary +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for rendering the cohort method results +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method diagnostics viewer +#' +#' @export +cohortMethodResultSummaryViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::tabsetPanel( + type = 'hidden', + id = ns('resultPanel'), + + shiny::tabPanel( + title = "Table", + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Result Summary'), + solidHeader = TRUE, + resultTableViewer(ns("resultSummaryTable")) + ) + ), + + shiny::tabPanel( + title = "Results", + shiny::actionButton( + inputId = ns('goBackCmResults'), + label = "Back To Result Summary", + shiny::icon("arrow-left"), + style="color: #fff; background-color: #337ab7; border-color: #2e6da4" + ), + cohortMethodFullResultViewer(ns("cmFullResults")) + ) + + ) + + +} + + +#' The module server for rendering the PLE diagnostics summary +#' +#' @param id the unique reference id for the module +#' @param connectionHandler the connection to the PLE results database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' @param inputSelected The target id, comparator id, outcome id and analysis id selected by the user +#' +#' @return +#' the PLE diagnostics summary results +#' +#' @export +cohortMethodResultSummaryServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + inputSelected +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + shiny::observeEvent( + eventExpr = input$goBackCmResults, + { + shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") + }) + + data <- shiny::reactive({ + getCmResultData( + connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + }) + + resultTableOutputs <- resultTableServer( + id = "resultSummaryTable", + df = data, + colDefsInput = getCmResultSummaryTableColDef(), + addActions = c('results') + ) + + selectedRow <- shiny::reactiveVal(value = NULL) + shiny::observeEvent(resultTableOutputs$actionCount(), { + if(resultTableOutputs$actionType() == 'results'){ + selectedRow(data()[resultTableOutputs$actionIndex()$index,]) + shiny::updateTabsetPanel(session, "resultPanel", selected = "Results") + } + }) + + cohortMethodFullResultServer( + id = "cmFullResults", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow + ) + + } + ) +} + + +getCmResultSummaryTableColDef <- function(){ + result <- list( + + analysisId = reactable::colDef(show = F), + description = reactable::colDef( + header = withTooltip( + "Analysis", + "The analysis description" + ), + minWidth = 140 + ), + databaseId = reactable::colDef(show = F), + + cdmSourceAbbreviation = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ) + ), + + targetId = reactable::colDef(show = F), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest" + ), + minWidth = 300 + ), + + comparatorId = reactable::colDef(show = F), + comparator = reactable::colDef( + header = withTooltip( + "Comparator", + "The comparator cohort of interest" + ), + minWidth = 300 + ), + + outcomeId = reactable::colDef(show = F), + outcome = reactable::colDef( + header = withTooltip( + "Outcome", + "The outcome of interest" + ), + minWidth = 300 + ), + + rr = reactable::colDef( + header = withTooltip( + "rr", + "The uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + ci95Lb = reactable::colDef( + header = withTooltip( + "ci95Lb", + "The lower bound of the 95% confidence internval of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + ci95Ub = reactable::colDef( + header = withTooltip( + "ci95Ub", + "The upper bound of the 95% confidence internval of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + p = reactable::colDef( + header = withTooltip( + "p", + "The p value of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedRr = reactable::colDef( + header = withTooltip( + "calibrated rr", + "The calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedCi95Lb = reactable::colDef( + header = withTooltip( + "calibrated ci95Lb", + "The lower bound of the 95% confidence internval of the calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedCi95Ub = reactable::colDef( + header = withTooltip( + "calibrated ci95Ub", + "The upper bound of the 95% confidence internval of the calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + calibratedP = reactable::colDef( + header = withTooltip( + "calibrated p", + "The p value of the calibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + logRr = reactable::colDef(show = F), + seLogRr = reactable::colDef(show = F), + targetSubjects = reactable::colDef(show = F), + comparatorSubjects = reactable::colDef(show = F), + targetDays = reactable::colDef(show = F), + comparatorDays = reactable::colDef(show = F), + targetOutcomes = reactable::colDef(show = F), + comparatorOutcomes = reactable::colDef(show = F), + calibratedLogRr = reactable::colDef(show = F), + calibratedSeLogRr = reactable::colDef(show = F), + calibratedSeLogRr = reactable::colDef(show = F), + unblind = reactable::colDef(show = F) + ) + + return(result) +} + +getCmResultData <- function( + connectionHandler, + resultDatabaseSettings, + inputSelected +) { + + targetIds = inputSelected()$targetIds + outcomeIds = inputSelected()$outcomeIds + comparatorIds = inputSelected()$comparatorIds + analysisIds = inputSelected()$analysisIds + + if(is.null(comparatorIds) || is.null(targetIds) || is.null(outcomeIds) || is.null(analysisIds)){ + return(NULL) + } + + sql <- " + SELECT + cma.analysis_id, + cma.description description, + dmd.database_id database_id, + dmd.cdm_source_abbreviation cdm_source_abbreviation, + cmr.target_id, + cg1.cohort_name as target, + cmr.outcome_id, + cg2.cohort_name as outcome, + cmr.comparator_id, + cg3.cohort_name as comparator, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.rr end rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.ci_95_lb end ci_95_lb, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.ci_95_ub end ci_95_ub, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.p end p, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.log_rr end log_rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.se_log_rr end se_log_rr, + cmr.target_subjects, + cmr.comparator_subjects, + cmr.target_days, + cmr.comparator_days, + cmr.target_outcomes, + cmr.comparator_outcomes, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_rr end calibrated_rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_ci_95_lb end calibrated_ci_95_lb, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_ci_95_ub end calibrated_ci_95_ub, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_p end calibrated_p, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_log_rr end calibrated_log_rr, + case when COALESCE(cmds.unblind, 0) = 0 then NULL else cmr.calibrated_se_log_rr end calibrated_se_log_rr, + COALESCE(cmds.unblind, 0) unblind +FROM + @schema.@cm_table_prefixanalysis cma + JOIN @schema.@cm_table_prefixresult cmr + on cmr.analysis_id = cma.analysis_id + + JOIN @schema.@database_table dmd + on dmd.database_id = cmr.database_id + + LEFT JOIN @schema.@cm_table_prefixdiagnostics_summary cmds + on cmds.analysis_id = cmr.analysis_id + AND cmds.target_id = cmr.target_id + AND cmds.comparator_id = cmr.comparator_id + AND cmds.outcome_id = cmr.outcome_id + AND cmds.database_id = cmr.database_id + + inner join @schema.@cg_table_prefixcohort_definition cg1 + on cg1.cohort_definition_id = cmr.target_id + + inner join @schema.@cg_table_prefixcohort_definition cg2 + on cg2.cohort_definition_id = cmr.outcome_id + + inner join @schema.@cg_table_prefixcohort_definition cg3 + on cg3.cohort_definition_id = cmr.comparator_id + + where cmr.target_id in (@targets) + {@use_comparators}?{and cmr.comparator_id in (@comparators)} + and cmr.outcome_id in (@outcomes) + {@use_analyses}?{and cmr.analysis_id in (@analyses)} + ; + " + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + + targets = paste0(targetIds, collapse = ','), + comparators = paste0(comparatorIds, collapse = ','), + outcomes = paste0(outcomeIds, collapse = ','), + analyses = paste0(analysisIds, collapse = ','), + + use_comparators = !is.null(comparatorIds), + use_analyses = !is.null(analysisIds) + ) + + return( + result + ) +} \ No newline at end of file diff --git a/R/cohort-method-systematicError.R b/R/cohort-method-systematicError.R new file mode 100644 index 00000000..1c826246 --- /dev/null +++ b/R/cohort-method-systematicError.R @@ -0,0 +1,281 @@ +# @file cohort-method-systematicError +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for rendering the PLE systematic error objects +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the cohort method systematic error module +#' +#' @export +cohortMethodSystematicErrorViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + shiny::plotOutput(outputId = ns("systematicErrorPlot")), + shiny::div(shiny::strong("Figure 4."),"Systematic error. Effect size estimates for the negative controls (true hazard ratio = 1) + and positive controls (true hazard ratio > 1), before and after calibration. Estimates below the diagonal dashed + lines are statistically significant (alpha = 0.05) different from the true effect size. A well-calibrated + estimator should have the true effect size within the 95 percent confidence interval 95 percent of times."), + shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", + shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPng"), + label = "Download plot as PNG"), + shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPdf"), + label = "Download plot as PDF") + ) + ) + +} + + + +#' The module server for rendering the systematic error objects +#' +#' @param id the unique reference id for the module +#' @param selectedRow the selected row from the main results table +#' @param connectionHandler the connection handler to the result databases +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' +#' @return +#' the PLE systematic error content server +#' +#' @export +cohortMethodSystematicErrorServer <- function( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings + ) { + + shiny::moduleServer( + id, + function(input, output, session) { + + systematicErrorPlot <- shiny::reactive({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + controlResults <- getCohortMethodControlResults( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = row$targetId, + comparatorId = row$comparatorId, + analysisId = row$analysisId, + databaseId = row$databaseId + ) + + # remove the RR zeros that replace NAs during data upload + controlResults$logRr[controlResults$logRr == 0] <- NA + controlResults$ci95Lb[controlResults$ci95Lb == 0] <- NA + controlResults$ci95Ub[controlResults$ci95Ub == 0] <- NA + controlResults$calibratedLogRr[controlResults$calibratedLogRr == 0] <- NA + controlResults$calibratedCi95Lb[controlResults$calibratedCi95Lb == 0] <- NA + controlResults$calibratedCi95Ub[controlResults$calibratedCi95Ub == 0] <- NA + + plot <- plotCohortMethodScatter(controlResults) + return(plot) + } + }) + + output$systematicErrorPlot <- shiny::renderPlot({ + return(systematicErrorPlot()) + }) + + output$downloadSystematicErrorPlotPng <- shiny::downloadHandler( + filename = "SystematicError.png", + contentType = "image/png", + content = function(file) { + ggplot2::ggsave(file, plot = systematicErrorPlot(), width = 12, height = 5.5, dpi = 400) + } + ) + + output$downloadSystematicErrorPlotPdf <- shiny::downloadHandler( + filename = "SystematicError.pdf", + contentType = "application/pdf", + content = function(file) { + ggplot2::ggsave(file = file, plot = systematicErrorPlot(), width = 12, height = 5.5) + } + ) + + } + ) +} + + +getCohortMethodControlResults <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + comparatorId, + analysisId, + databaseId = NULL, + includePositiveControls = TRUE, + emptyAsNa = TRUE +) { + + sql <- " + SELECT + cmr.*, + cmtco.true_effect_size effect_size + FROM + @schema.@cm_table_prefixresult cmr + JOIN @schema.@cm_table_prefixtarget_comparator_outcome cmtco + ON cmr.target_id = cmtco.target_id AND cmr.comparator_id = cmtco.comparator_id AND cmr.outcome_id = cmtco.outcome_id + WHERE + cmtco.outcome_of_interest != 1 + AND cmr.target_id = @target_id + AND cmr.comparator_id = @comparator_id + AND cmr.analysis_id = @analysis_id + " + + + if (!is.null(databaseId)) { + # update sql + sql <- paste(sql, paste("AND cmr.database_id = '@database_id'"), collapse = "\n") + } + + if (!includePositiveControls) { + # update sql + sql <- paste(sql, paste("AND cmtco.true_effect_size = 1"), collapse = "\n") + } + + results <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + target_id = targetId, + comparator_id = comparatorId, + analysis_id = analysisId, + database_id = databaseId + ) + + if (emptyAsNa) { + results[results == ''] <- NA + } + + return(results) +} + + +plotCohortMethodScatter <- function(controlResults) { + + if(nrow(controlResults)==0){ + return(NULL) + } + + size <- 2 + labelY <- 0.7 + d <- rbind(data.frame(yGroup = "Uncalibrated", + logRr = controlResults$logRr, + seLogRr = controlResults$seLogRr, + ci95Lb = controlResults$ci95Lb, + ci95Ub = controlResults$ci95Ub, + trueRr = controlResults$effectSize), + data.frame(yGroup = "Calibrated", + logRr = controlResults$calibratedLogRr, + seLogRr = controlResults$calibratedSeLogRr, + ci95Lb = controlResults$calibratedCi95Lb, + ci95Ub = controlResults$calibratedCi95Ub, + trueRr = controlResults$effectSize)) + d <- d[!is.na(d$logRr), ] + d <- d[!is.na(d$ci95Lb), ] + d <- d[!is.na(d$ci95Ub), ] + if (nrow(d) == 0) { + return(NULL) + } + d$Group <- as.factor(d$trueRr) + d$Significant <- d$ci95Lb > d$trueRr | d$ci95Ub < d$trueRr + temp1 <- stats::aggregate(Significant ~ Group + yGroup, data = d, length) + temp2 <- stats::aggregate(Significant ~ Group + yGroup, data = d, mean) + temp1$nLabel <- paste0(formatC(temp1$Significant, big.mark = ","), " estimates") + temp1$Significant <- NULL + + temp2$meanLabel <- paste0(formatC(100 * (1 - temp2$Significant), digits = 1, format = "f"), + "% of CIs include ", + temp2$Group) + temp2$Significant <- NULL + dd <- merge(temp1, temp2) + dd$tes <- as.numeric(as.character(dd$Group)) + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) + theme <- ggplot2::element_text(colour = "#000000", size = 12) + themeRA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 1) + themeLA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 0) + + d$Group <- paste("True hazard ratio =", d$Group) + dd$Group <- paste("True hazard ratio =", dd$Group) + alpha <- 1 - min(0.95 * (nrow(d)/nrow(dd)/50000)^0.1, 0.95) + plot <- ggplot2::ggplot(d, ggplot2::aes(x = .data$logRr, y = .data$seLogRr), environment = environment()) + + ggplot2::geom_vline(xintercept = log(breaks), colour = "#AAAAAA", lty = 1, size = 0.5) + + ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.025), slope = 1/stats::qnorm(0.025)), + colour = grDevices::rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5, + data = dd) + + ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.975), slope = 1/stats::qnorm(0.975)), + colour = grDevices::rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5, + data = dd) + + ggplot2::geom_point(size = size, + color = grDevices::rgb(0, 0, 0, alpha = 0.05), + alpha = alpha, + shape = 16) + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::geom_label(x = log(0.15), + y = 0.9, + alpha = 1, + hjust = "left", + ggplot2::aes(label = .data$nLabel), + size = 5, + data = dd) + + ggplot2::geom_label(x = log(0.15), + y = labelY, + alpha = 1, + hjust = "left", + ggplot2::aes(label = .data$meanLabel), + size = 5, + data = dd) + + ggplot2::scale_x_continuous("Hazard ratio", + limits = log(c(0.1, 10)), + breaks = log(breaks), + labels = breaks) + + ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + + ggplot2::facet_grid(yGroup ~ Group) + + ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.text.y = themeRA, + axis.text.x = theme, + axis.title = theme, + legend.key = ggplot2::element_blank(), + strip.text.x = theme, + strip.text.y = theme, + strip.background = ggplot2::element_blank(), + legend.position = "none") + + return(plot) +} + + diff --git a/R/cohortgenerator-main.R b/R/cohortgenerator-main.R deleted file mode 100644 index 30d5b042..00000000 --- a/R/cohortgenerator-main.R +++ /dev/null @@ -1,626 +0,0 @@ -# @file cohortgenerator-main.R -# -# Copyright 2022 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. - - -#' The location of the cohort-generator module helper file -#' -#' @details -#' Returns the location of the cohort-generator helper file -#' -#' @return -#' string location of the cohort-generator helper file -#' -#' @export -cohortGeneratorHelperFile <- function(){ - fileLoc <- system.file('cohort-generator-www', "cohort-generator.html", package = "OhdsiShinyModules") - return(fileLoc) -} - -#' The viewer of the main cohort generator module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the cohort generator results viewer -#' -#' @export -cohortGeneratorViewer <- function(id) { - - ns <- shiny::NS(id) - - - - shiny::div( - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("user-gear"),'Cohort Generator Viewer'), - solidHeader = TRUE, - - shinydashboard::box( - collapsible = TRUE, - collapsed = TRUE, - title = shiny::span( shiny::icon("circle-question"), "Help & Information"), - width = "100%", - shiny::htmlTemplate(system.file("cohort-generator-www", "cohort-generator.html", package = utils::packageName())) - ), - - - shiny::tabsetPanel( - id = ns("cohortGeneratorTabs"), - type = "pills", - - - shiny::tabPanel( - title = "Cohort Counts", - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("file-arrow-down"),'Download Data'), - solidHeader = TRUE, - - shiny::downloadButton( - ns('downloadCohortCounts'), - label = "Download", - icon = shiny::icon("download") - ) - ), - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("table"), 'Counts Table'), - solidHeader = TRUE, - - reactable::reactableOutput( - outputId = ns("cohortCounts") - ) - ) - # , - # shiny::downloadButton( - # ns('downloadCohortCounts'), - # label = "Download" - # ) - ), - - shiny::tabPanel( - title = "Cohort Generation", - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("file-arrow-down"),'Download Data'), - solidHeader = TRUE, - - shiny::downloadButton( - ns('downloadCohortGeneration'), - label = "Download", - icon = shiny::icon("download") - ) - ), - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("table"), 'Generation Table'), - solidHeader = TRUE, - - reactable::reactableOutput( - outputId = ns("cohortGeneration") - ) - ) - ), - - shiny::tabPanel( - title = "Inclusion Rules & Attrition" - , - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("gear"), 'Options'), - solidHeader = TRUE, - - shiny::uiOutput(ns('attritionTableSelect')) - ), - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("file-arrow-down"),'Download Data'), - solidHeader = TRUE, - - shiny::downloadButton( - ns('downloadAttritionTable'), - label = "Download", - icon = shiny::icon("download") - ) - ), - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("table"), 'Attrition Table'), - solidHeader = TRUE, - - reactable::reactableOutput(ns('attritionTable')) - ), - - shinydashboard::box( - status = 'info', - width = '100%', - title = shiny::span( shiny::icon("chart-area"), 'Attrition Plot'), - solidHeader = TRUE, - - plotly::plotlyOutput(ns('attritionPlot')) - ) - ) - ) - ) - ) -} - - - - -#' The module server for the main cohort generator module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler a connection to the database with the results -#' @param resultDatabaseSettings a named list containing the cohort generator results database details (schema, table prefix) -#' -#' @return -#' the cohort generator results viewer main module server -#' -#' @export - -cohortGeneratorServer <- function( - id, - connectionHandler, - resultDatabaseSettings -) { - - shiny::moduleServer( - id, - function(input, output, session) { - - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - - format_yesorno <- function(value) { - # Render as an X mark or check mark - if (value == "COMPLETE") "\u2714\ufe0f Yes" #if generation complete then green check mark with "yes" - else "\u274c No" #if not then red x with "no" - } - - resultsSchema <- resultDatabaseSettings$schema - - output$cohortCounts <- reactable::renderReactable({ - data <- getCohortGeneratorCohortCounts( - connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = resultDatabaseSettings$tablePrefix, - databaseTable = resultDatabaseSettings$databaseTable, - databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix - ) %>% - dplyr::select("cdmSourceName", - "cohortId", - "cohortName", - "cohortSubjects", - "cohortEntries") - reactable::reactable(data, - columns = list( - # Render a "show details" button in the last column of the table. - # This button won't do anything by itself, but will trigger the custom - # click action on the column. - cdmSourceName = reactable::colDef( - header = withTooltip( - "Database Name", - "The name of the database" - )), - cohortId = reactable::colDef( - header = withTooltip( - "Cohort ID", - "The unique numeric identifier of the cohort" - )), - cohortName = reactable::colDef( - header = withTooltip( - "Cohort Name", - "The name of the cohort" - )), - cohortSubjects = reactable::colDef( - header = withTooltip( - "Number of Subjects", - "The number of distinct subjects in the cohort" - ), - format = reactable::colFormat(separators = TRUE - )), - cohortEntries = reactable::colDef( - header = withTooltip( - "Number of Records", - "The number of records in the cohort" - ), - format = reactable::colFormat(separators = TRUE - )) - ), - filterable = TRUE, - sortable = TRUE, - defaultColDef = reactable::colDef( - align = "left" - ) - ) - }) - - # download button - counts - output$downloadCohortCounts <- shiny::downloadHandler( - filename = function() { - paste('cohort-count-data-', Sys.Date(), '.csv', sep='') - }, - content = function(con) { - utils::write.csv(getCohortGeneratorCohortCounts( - connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = resultDatabaseSettings$tablePrefix, - databaseTable = resultDatabaseSettings$databaseTable, - databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix - ) %>% - dplyr::select("cdmSourceName", - "cohortId", - "cohortName", - "cohortSubjects", - "cohortEntries"), con) - } - ) - - output$cohortGeneration <- reactable::renderReactable({ - data <- getCohortGeneratorCohortMeta( - connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = resultDatabaseSettings$tablePrefix - ) %>% - dplyr::select("cohortId", - "cohortName", - "generationStatus", - "startTime", - "endTime") - reactable::reactable(data, - columns = list( - # Render a "show details" button in the last column of the table. - # This button won't do anything by itself, but will trigger the custom - # click action on the column. - cohortId = reactable::colDef( - header = withTooltip( - "Cohort ID", - "The unique numeric identifier of the cohort" - )), - cohortName = reactable::colDef( - header = withTooltip( - "Cohort Name", - "The name of the cohort" - )), - generationStatus = reactable::colDef( - header = withTooltip( - "Is the Cohort Generated?", - "Indicator of if the cohort has been generated" - ), - cell = format_yesorno - ), - startTime = reactable::colDef( - header = withTooltip( - "Generation Start Time", - "The time and date the cohort started generating" - ), - format = reactable::colFormat(datetime = TRUE - )), - endTime = reactable::colDef( - header = withTooltip( - "Generation End Time", - "The time and date the cohort finished generating" - ), - format = reactable::colFormat(datetime = TRUE - )) - ), - filterable = TRUE, - sortable = TRUE, - defaultColDef = reactable::colDef( - align = "left" - ) - ) - }) - - # download button - generation - output$downloadCohortGeneration <- shiny::downloadHandler( - filename = function() { - paste('cohort-generation-data-', Sys.Date(), '.csv', sep='') - }, - content = function(con) { - utils::write.csv(getCohortGeneratorCohortMeta( - connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = resultDatabaseSettings$tablePrefix - ) %>% - dplyr::select("cohortId", - "cohortName", - "generationStatus", - "startTime", - "endTime"), con) - } - ) - - #building attrition table using inclusion rules & stats tables - rules <- getCohortGeneratorInclusionRules( - connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = resultDatabaseSettings$tablePrefix - ) - - stats <- getCohortGeneratorInclusionStats( - connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = resultDatabaseSettings$tablePrefix, - databaseTable = resultDatabaseSettings$databaseTable, - databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix - ) - - #this gets the full attrition table - inputVals <- getCohortGenerationAttritionTable( - rules, - stats - ) - - #making a "clean" version where modeId is renamed to sensible values - cohortNames <- unique(inputVals$cohortName) - databaseIds <- unique(inputVals$cdmSourceName) - inputValsClean <- dplyr::ungroup(inputVals) %>% - dplyr::mutate(modeId = dplyr::case_when( - modeId==1 ~ "Subject", - TRUE ~ "Record" - ) - ) - modeIds <- unique(inputValsClean$modeId) - - - cohortName <- shiny::reactiveVal(cohortNames[1]) - databaseId <- shiny::reactiveVal(databaseIds[1]) - modeId <- shiny::reactiveVal(modeIds[1]) - - #build the selector - output$attritionTableSelect <- shiny::renderUI({ - - shiny::tagList( - shiny::selectInput( - inputId = session$ns('selectedCohortName'), - label = 'Cohort:', - choices = cohortNames, - selected = 1, - multiple = F, - selectize=FALSE - ), - shiny::selectInput( - inputId = session$ns('selectedDatabaseId'), - label = 'Database:', - choices = databaseIds, - selected = 1, - multiple = F, - selectize=FALSE - ), - shiny::radioButtons( - inputId = session$ns('selectedModeId'), - label = "Subject-level or Record-level?", - choices = modeIds, - selected = "Subject" - ) - ) - }) - - shiny::observeEvent(input$selectedCohortName,{ - cohortName(input$selectedCohortName) - }) - shiny::observeEvent(input$selectedDatabaseId,{ - databaseId(input$selectedDatabaseId) - }) - shiny::observeEvent(input$selectedModeId,{ - modeId(input$selectedModeId) - }) - - #build the reactive data - data <- shiny::reactive({ - inputValsClean %>% - dplyr::filter(.data$cdmSourceName == databaseId() & - .data$cohortName == cohortName() & - .data$modeId == modeId() - ) - }) - - output$attritionTable <- reactable::renderReactable( - reactable::reactable( - data = data() %>% - dplyr::select(c("cdmSourceName", "cohortName", "ruleName", - "personCount", "dropCount", - "dropPerc", "retainPerc") - ) - - , - rownames = FALSE, - defaultPageSize = 5, - showPageSizeOptions = T, - striped = T, - columns = list( - cdmSourceName = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Database Name", - "The name of the database" - )), - cohortName = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cohort Name", - "The name of the cohort" - )), - ruleName = reactable::colDef( - header = withTooltip( - "Inclusion Rule Name", - "The name of the inclusion rule" - )), - personCount = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Subject/Record Count", - "The number of subjects or records (depending on your selection) remaining after the inclusion rule was applied" - )), - dropCount = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Number Lost", - "The number of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied" - )), - dropPerc = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Percentage Lost", - "The percentage of subjects or records (depending on your selection) removed/lost after the inclusion rule was applied compared to the previous rule count" - )), - retainPerc = reactable::colDef( - format = reactable::colFormat(separators = TRUE), - header = withTooltip( - "Number Retained", - "The number of subjects or records (depending on your selection) retained after the inclusion rule was applied compared to the previous rule count" - )) - ), - - filterable = TRUE, - sortable = TRUE, - defaultColDef = reactable::colDef( - align = "left" - ) - ) - ) - - #attrition plot - output$attritionPlot <- plotly::renderPlotly( - getCohortAttritionPlot( - data() - ) - ) - - # download button - output$downloadAttritionTable <- shiny::downloadHandler( - filename = function() { - paste('cohort-attrition-data-', Sys.Date(), '.csv', sep='') - }, - content = function(con) { - utils::write.csv(data() - , con) - } - ) - - #testing funnel plot for attrition visualization - - - - - - - - - - - - - - - - - # output$inclusionSummary <- reactable::renderReactable({ - # data <- getCohortGeneratorCohortInclusionSummary( - # connectionHandler = connectionHandler, - # resultsSchema = resultsSchema, - # tablePrefix = resultDatabaseSettings$tablePrefix, - # databaseTable = resultDatabaseSettings$databaseTable, - # databaseTablePrefix = resultDatabaseSettings$databaseTablePrefix - # ) %>% - # dplyr::select("cdmSourceName", - # "cohortDefinitionId", - # "cohortName", - # "baseCount", - # "finalCount", - # "modeId") %>% - # dplyr::mutate(modeId = - # dplyr::case_when( - # modeId == 1 ~ "Subjects", - # .default = "Records" - # ) - # ) - # reactable::reactable(data, - # columns = list( - # # Render a "show details" button in the last column of the table. - # # This button won't do anything by itself, but will trigger the custom - # # click action on the column. - # cdmSourceName = reactable::colDef( - # header = withTooltip( - # "Database Name", - # "The name of the database" - # )), - # cohortDefinitionId = reactable::colDef( - # header = withTooltip( - # "Cohort ID", - # "The unique numeric identifier of the cohort" - # )), - # cohortName = reactable::colDef( - # header = withTooltip( - # "Cohort Name", - # "The name of the cohort" - # )), - # baseCount = reactable::colDef( - # header = withTooltip( - # "Base Count", - # "The number of records before any inclusion criteria are applied (entry events)" - # ), - # format = reactable::colFormat(separators = TRUE - # )), - # finalCount = reactable::colDef( - # header = withTooltip( - # "Final Count", - # "The number of records after all inclusion criteria are applied" - # ), - # format = reactable::colFormat(separators = TRUE - # )), - # modeId = reactable::colDef( - # header = withTooltip( - # "Records or Subjects?", - # "An indicator of whether the counts shown are the number of subjects or the number of records" - # ), - # format = reactable::colFormat(separators = TRUE - # )) - # ), - # filterable = TRUE, - # sortable = TRUE, - # defaultColDef = reactable::colDef( - # align = "left" - # ) - # ) - # }) - - } - ) -} diff --git a/R/components-data-viewer.R b/R/components-data-viewer.R new file mode 100644 index 00000000..4dd67e54 --- /dev/null +++ b/R/components-data-viewer.R @@ -0,0 +1,386 @@ + + +#inputs: data, named list of colDef options, where name is name of each column, +#potentially: +#output: download buttons, table, and column selector + +#' Result Table Viewer +#' +#' @param id string +#' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used +#' +#' @return shiny module UI +#' @export +#' +resultTableViewer <- function( + id = "result-table", + downloadedFileName = NULL + ) { + ns <- shiny::NS(id) + shiny::div(# UI + shinydashboard::box( + width = "100%", + title = shiny::span(shiny::icon("table"), "Table"), + shiny::fluidPage( + shiny::fluidRow( + shiny::column( + width = 7, + shiny::uiOutput(ns("columnSelector")) + ), + shiny::column( + width = 2, + shiny::downloadButton( + ns('downloadDataFull'), + label = "Download (Full)", + icon = shiny::icon("download") + ) + ), + shiny::column( + width = 3, + shiny::actionButton( + ns('downloadDataFiltered'), + label = "Download (Filtered)", + icon = shiny::icon("download"), + onclick = paste0( + "Reactable.downloadDataCSV('", + ns('resultData'), + "', 'result-data-filtered-", + downloadedFileName, + Sys.Date(), + ".csv')" + ) + ) + ) + ), + shiny::fluidRow( + shinycssloaders::withSpinner( + reactable::reactableOutput(outputId = ns("resultData")) + ) + ) + ) + )) +} + + + + +#tooltip function +withTooltip <- function(value, tooltip, ...) { + shiny::div( + style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", + tippy::tippy(value, tooltip, ...) + ) +} + +# customColDefs needs to be named list of colDefs +# example usage: +# Define custom colDefs for the Name and Age columns +# custom_colDefs <- list( +# mpg = reactable::colDef(align = "left", +# format = reactable::colFormat(digits = 2), +# header = withTooltip("MPG column name", "MPG tooltip")), +# disp = reactable::colDef(align = "center", +# header = withTooltip("Disp column name", "Disp tooltip")) +# ) + +create_colDefs_list <- function( + df, + customColDefs = NULL + ) { + # Get the column names of the input data frame + col_names <- colnames(df) + + # Create an empty list to store the colDefs + colDefs_list <- vector("list", length = length(col_names)) + names(colDefs_list) <- col_names + + # Define custom colDefs for each column if provided + if (!is.null(customColDefs)) { + for (col in seq_along(col_names)) { + if (col_names[col] %in% names(customColDefs)) { + colDefs_list[[col]] <- customColDefs[[col_names[col]]] + } else { + colDefs_list[[col]] <- reactable::colDef(name = col_names[col]) + } + + if (!is.null(customColDefs[[col_names[col]]]$header)) { + colDefs_list[[col]]$header <- customColDefs[[col_names[col]]]$header + } + + if (!is.null(customColDefs[[col_names[col]]]$tooltip)) { + colDefs_list[[col]]$header <- + withTooltip(colDefs_list[[col]]$header, customColDefs[[col_names[col]]]$tooltip) + } + } + } else { + # Define default colDefs if customColDefs is not provided + for (col in seq_along(col_names)) { + colDefs_list[[col]] <- reactable::colDef(name = col_names[col]) + } + } + + # Return the list of colDefs + return(colDefs_list) +} + +ohdsiReactableTheme <- reactable::reactableTheme( + color = "white", + backgroundColor = "#003142", + stripedColor = "#333333", + highlightColor = "#f19119", + style = list( + fontFamily = "-apple-system, BlinkMacSystemFont, Segoe UI, + Roboto, Helvetica, Arial, sans-serif, Apple Color Emoji, + Segoe UI Emoji, Segoe UI Symbol" + ) + #, + #headerStyle = list( + #) +) + + + +#' Result Table Server +#' +#' @param id string, table id must match resultsTableViewer function +#' @param df reactive that returns a data frame +#' @param colDefsInput named list of reactable::colDefs +#' @param addActions add a button row selector column to the table to a column called 'actions'. +#' actions must be a column in df +#' @param downloadedFileName string, desired name of downloaded data file. can use the name from the module that is being used +#' +#' @return shiny module server +#' @export +#' +resultTableServer <- function( + id, #string + df, #data.frame + colDefsInput, + addActions = NULL, + downloadedFileName = NULL +) #list of colDefs, can use checkmate::assertList, need a check that makes sure names = columns) { + shiny::moduleServer( + id, + function(input, output, session) { + + # convert a data.frame to a reactive + if(!inherits(df, 'reactive')){ + df <- shiny::reactiveVal(df) + } + + # initialize the reactables + actionCount <- shiny::reactiveVal(0) + actionIndex <- shiny::reactiveVal(0) + actionType <- shiny::reactiveVal('none') + + # add action column to data + newdf <- shiny::reactive({ + if(!is.null(nrow(df())) & !is.null(addActions)){ + cbind( + actions = rep("", nrow(df())), + df() + )} else{ + df() + } + }) + + # add a new entry to colDefs with an action dropdown menu + # add a onClick action + if(!is.null(addActions)){ + + onClickText <- paste0( + "function(rowInfo, column) {", + paste("if(column.id == 'actions'){ + Shiny.setInputValue('",session$ns(paste0('action_index')),"', { index: rowInfo.index + 1 }, { priority: 'event' }) + }", collapse = ' ', sep = ''), + "}" + ) + onClick <- reactable::JS(onClickText) + + colDefsInput <- addTableActions( + colDefsInput = colDefsInput, + addActions = addActions, + session = session + ) + + } else{ + onClick <- NULL + } + + output$columnSelector <- shiny::renderUI({ + + shinyWidgets::pickerInput( + inputId = session$ns('dataCols'), + label = 'Select Columns to Display: ', + choices = colnames(newdf()), + selected = colnames(newdf()), + choicesOpt = list(style = rep_len("color: black;", 999)), + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ), + width = "75%" + ) + + }) + + #need to try adding browser() to all reactives to see why selected cols isnt working + + colDefs <- shiny::reactive( + if(!is.null(newdf())){ + create_colDefs_list( + df = newdf()[, input$dataCols], + customColDefs = colDefsInput + ) + } else{ + NULL + } + ) + + output$resultData <- reactable::renderReactable({ + if (is.null(input$dataCols)) { + data = newdf() + } + else{ + data = newdf()[, input$dataCols, drop = FALSE] + } + if(is.null(data)){ + return(NULL) + } + if(nrow(data) == 0){ + return(NULL) + } + # set row height based on nchar of table + if(max(apply(data, 1, function(x) max(nchar(x))), na.rm = T) < 100){ + height <- 40*3 + } else{ + height <- NULL + } + + reactable::reactable( + data, + columns = colDefs(), + onClick = onClick, + #these can be turned on/off and will overwrite colDef args + sortable = TRUE, + resizable = TRUE, + filterable = TRUE, + searchable = TRUE, + showPageSizeOptions = TRUE, + outlined = TRUE, + showSortIcon = TRUE, + striped = TRUE, + highlight = TRUE, + defaultColDef = reactable::colDef(align = "left"), + + rowStyle = list( + height = height + ) + #, experimental + #theme = ohdsiReactableTheme + ) + }) + + + # download full data button + output$downloadDataFull <- shiny::downloadHandler( + filename = function() { + paste('result-data-full-', downloadedFileName, Sys.Date(), '.csv', sep = '') + }, + content = function(con) { + utils::write.csv( + x = df(), + file = con, + row.names = F + ) + } + ) + + + # capture the actions + shiny::observeEvent(input$action_index, { + actionIndex(input$action_index) + }) + + shiny::observeEvent(input$action_type, { + # update type + actionType(input$action_type$value) + # update count + actionCount(input$action_type$seed) + }) + + return( + list( + actionType = actionType, + actionIndex = actionIndex, + actionCount = actionCount + ) + ) + }) + + + + + +# HELPERS +addTableActions <- function( + colDefsInput, + addActions, + session +){ + + args <- list( + label = "Actions", + status = "primary", + circle = FALSE, + width = "300px", + margin = "5px", + inline = T + ) + + args <- append( + args, + lapply( + X = addActions, + FUN = function(x){ + shiny::actionLink( + inputId = session$ns(x), + label = paste0('View ',x), + icon = shiny::icon("play"), + onClick = reactable::JS( + paste0( + "function() { + Shiny.setInputValue('",session$ns(paste0('action_type')),"', { value: '",x,"', seed: Math.random()}) + }" + ) + ) + ) + }) + ) + + tableActionfunction <- function(){ + + cellFunction <- do.call( + args = args, + what = shinyWidgets::dropdownButton + ) + return(cellFunction) + } + + # add the actions dropdown + colDefsInput[[length(colDefsInput) + 1 ]] <- reactable::colDef( + name = "", + sortable = FALSE, + filterable = FALSE, + minWidth = 150, + cell = tableActionfunction + ) + names(colDefsInput)[length(colDefsInput)] <- 'actions' + + return(colDefsInput) +} diff --git a/R/components.R b/R/components.R index be1bcdad..db45822e 100644 --- a/R/components.R +++ b/R/components.R @@ -20,7 +20,8 @@ inputSelectionViewer <- function(id = "input-selection") { shinydashboard::box( status = 'warning', width = "100%", - title = 'Selected: ', + title = 'Selected: ', + collapsible = T, shiny::uiOutput(ns("inputsText")) ) ) diff --git a/R/data-diagnostic-drill.R b/R/data-diagnostic-drill.R index 938a013d..d7cd65db 100644 --- a/R/data-diagnostic-drill.R +++ b/R/data-diagnostic-drill.R @@ -52,8 +52,7 @@ dataDiagnosticDrillViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the summary module @@ -62,8 +61,7 @@ dataDiagnosticDrillViewer <- function(id) { dataDiagnosticDrillServer <- function( id, connectionHandler, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -71,15 +69,13 @@ dataDiagnosticDrillServer <- function( analyses <- getAnalysisNames( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend + resultDatabaseSettings = resultDatabaseSettings ) databases <- shiny::reactiveVal({ getDbDataDiagnosticsDatabases( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, + resultDatabaseSettings = resultDatabaseSettings, analysisName = analyses[1] ) }) @@ -115,8 +111,7 @@ dataDiagnosticDrillServer <- function( resultTable <- shiny::reactiveVal( value = getDrugStudyFail( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, + resultDatabaseSettings = resultDatabaseSettings, analysis = analyses[1] )) @@ -126,8 +121,7 @@ dataDiagnosticDrillServer <- function( resultTableTemp <- getDrugStudyFail( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, + resultDatabaseSettings = resultDatabaseSettings, analysis = input$analysisSelected ) resultTable(resultTableTemp) @@ -220,8 +214,7 @@ dataDiagnosticDrillServer <- function( reactable::reactable( data = getDrillDown( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, + resultDatabaseSettings = resultDatabaseSettings, analysisName = analysisName, databaseId = databaseId ) @@ -253,19 +246,18 @@ dataDiagnosticDrillServer <- function( getDrillDown <- function( connectionHandler, - mySchema, - myTableAppend, + resultDatabaseSettings, analysisName, databaseId ){ - sql <- "SELECT * FROM @my_schema.@my_table_appenddata_diagnostics_output + sql <- "SELECT * FROM @schema.@dd_table_prefixdata_diagnostics_output WHERE analysis_name = '@analysis_name' and database_id = '@database_id';" result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + dd_table_prefix = resultDatabaseSettings$ddTablePrefix, analysis_name = analysisName, database_id = databaseId ) @@ -277,17 +269,16 @@ getDrillDown <- function( } getDbDataDiagnostics <- function( - connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend + connectionHandler, + resultDatabaseSettings ){ - sql <- "SELECT distinct database_id FROM @my_schema.@my_table_appenddata_diagnostics_summary;" + sql <- "SELECT distinct database_id FROM @schema.@dd_table_prefixdata_diagnostics_summary;" dbNames <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend + schema = resultDatabaseSettings$schema, + dd_table_prefix = resultDatabaseSettings$ddTablePrefix ) result <- list(dbNames$databaseId) @@ -297,8 +288,7 @@ getDbDataDiagnostics <- function( getDrugStudyFail <- function( connectionHandler, - mySchema, - myTableAppend = '', + resultDatabaseSettings, analysis = NULL ){ @@ -310,13 +300,13 @@ getDrugStudyFail <- function( shiny::incProgress(1/3, detail = paste("Extracting data")) - sql <- "SELECT * FROM @my_schema.@my_table_appenddata_diagnostics_summary + sql <- "SELECT * FROM @schema.@dd_table_prefixdata_diagnostics_summary WHERE analysis_name in ('@analysis');" summaryTable <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + dd_table_prefix = resultDatabaseSettings$ddTablePrefix, analysis = analysis ) @@ -336,18 +326,17 @@ getDrugStudyFail <- function( getDbDataDiagnosticsDatabases <- function( connectionHandler, - mySchema, - myTableAppend, + resultDatabaseSettings, analysisName ){ if(!is.null(analysisName)){ - sql <- "SELECT distinct database_id FROM @my_schema.@my_table_appenddata_diagnostics_summary + sql <- "SELECT distinct database_id FROM @schema.@dd_table_prefixdata_diagnostics_summary WHERE analysis_name in ('@analysis');" res <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + dd_table_prefix = resultDatabaseSettings$ddTablePrefix, analysis = analysisName ) diff --git a/R/data-diagnostic-main.R b/R/data-diagnostic-main.R index 471911e0..814d2f05 100644 --- a/R/data-diagnostic-main.R +++ b/R/data-diagnostic-main.R @@ -93,15 +93,13 @@ dataDiagnosticServer <- function( dataDiagnosticSummaryServer( id = 'summary-tab', connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) dataDiagnosticDrillServer( id = 'drill-down-tab', connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) diff --git a/R/data-diagnostic-summary.R b/R/data-diagnostic-summary.R index cca8a58b..7e8ea0b7 100644 --- a/R/data-diagnostic-summary.R +++ b/R/data-diagnostic-summary.R @@ -46,8 +46,7 @@ dataDiagnosticSummaryViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the summary module @@ -56,8 +55,7 @@ dataDiagnosticSummaryViewer <- function(id) { dataDiagnosticSummaryServer <- function( id, connectionHandler, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -65,8 +63,7 @@ dataDiagnosticSummaryServer <- function( analysisNames <- getAnalysisNames( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend + resultDatabaseSettings = resultDatabaseSettings ) # create UI for selecting analysis of interest @@ -87,8 +84,7 @@ dataDiagnosticSummaryServer <- function( if(!is.null(input$dbDiagAnalysisNameSelected[1])){ getDrugStudyFailSummary( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, + resultDatabaseSettings = resultDatabaseSettings, analysisNames = input$dbDiagAnalysisNameSelected ) } else{ @@ -143,17 +139,16 @@ dataDiagnosticSummaryServer <- function( getAnalysisNames <- function( connectionHandler, - mySchema, - myTableAppend + resultDatabaseSettings ){ sql <- "SELECT distinct sum.analysis_name - FROM @my_schema.@my_table_appenddata_diagnostics_summary as sum;" + FROM @schema.@dd_table_prefixdata_diagnostics_summary as sum;" result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend + schema = resultDatabaseSettings$schema, + dd_table_prefix = resultDatabaseSettings$ddTablePrefix ) return(sort(result$analysisName)) @@ -161,8 +156,7 @@ getAnalysisNames <- function( getDrugStudyFailSummary <- function( connectionHandler, - mySchema, - myTableAppend = '', + resultDatabaseSettings, analysisNames ){ @@ -178,13 +172,13 @@ getDrugStudyFailSummary <- function( sum.database_id, sum.total_fails - FROM @my_schema.@my_table_appenddata_diagnostics_summary as sum + FROM @schema.@dd_table_prefixdata_diagnostics_summary as sum where sum.analysis_name in (@names);" summaryTable <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + dd_table_prefix = resultDatabaseSettings$ddTablePrefix, names = paste(paste0("'",analysisNames,"'"), collapse=',') ) diff --git a/R/datasources-main.R b/R/datasources-main.R new file mode 100644 index 00000000..716909e7 --- /dev/null +++ b/R/datasources-main.R @@ -0,0 +1,209 @@ +# @file datasources-main.R +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + + + +#' Define the helper file for the module +#' +#' @return The helper html file for the datasources module +#' @export +#' +datasourcesHelperFile <- function() { + fileLoc <- + system.file('datasources-www', "datasources.html", package = "OhdsiShinyModules") + return(fileLoc) +} + + + +#' The viewer function for hte datasources module +#' +#' @param id The unique id for the datasources viewer namespace +#' +#' @return The UI for the datasources module +#' @export +#' +datasourcesViewer <- function(id) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = "100%", + title = shiny::span(shiny::icon("database"), "Data Sources"), + solidHeader = TRUE, + + shinydashboard::box( + collapsible = TRUE, + collapsed = FALSE, + title = shiny::span( shiny::icon("circle-question"), "Help & Information"), + width = "100%", + shiny::htmlTemplate(system.file("datasources-www", "datasources.html", package = utils::packageName())) + ), + + shiny::tabsetPanel( + type = 'pills', + id = ns('mainPanel'), + + shiny::tabPanel( + title = "Data Source Information", + resultTableViewer(ns("datasourcesTable"), + downloadedFileName = "datasourcesTable-") + ) + ) + ) +} + + + + +#' The server function for the datasources module +#' +#' @param id The unique id for the datasources server namespace +#' @param connectionHandler A connection to the database with the results +#' @param resultDatabaseSettings A named list containing the cohort generator results database details (schema, table prefix) +#' +#' @return The server for the datasources module +#' @export +#' +datasourcesServer <- function( + id, + connectionHandler, + resultDatabaseSettings +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + withTooltip <- function(value, tooltip, ...) { + shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", + tippy::tippy(value, tooltip, ...)) + } + + datasourcesData <- shiny::reactive({ + getDatasourcesData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + }) + + # # defining column definitions + # datasourcesColDefs <- createCustomColDefList( + # rawColNames = colnames(datasourcesData), + # niceColNames = c("DB Name", + # "DB Abbreviation", + # "DB Holder", + # "DB Description", + # "DB Description Link", + # "DB ETL Link", + # "Source Data Release Date", + # "CDM DB Release Date", + # "CDM Version", + # "Vocabulary Version", + # "DB ID", + # "Max Obs. Period End Date"), + # tooltipText = c("Name of the database (DB)", + # "Abbreviation for the database (DB)", + # "Holder of the database (DB)", + # "Description of the database (DB)", + # "HTML link to the database (DB) description", + # "HTML link to the ETL for the database (DB)", + # "Date the source data was released", + # "Date the CDM database (DB) was accessible", + # "Version of the common data model (CDM)", + # "Version of the vocabulary used in the database (DB)", + # "Unique identifier (ID) of the database (DB)", + # "Maximum/Latest observation period date in the database (DB)"), + # customColDefOptions = list( + # list(NULL), + # list(NULL), + # list(NULL), + # list(show = F), + # list(html = TRUE, cell = htmlwidgets::JS(' + # function(cellInfo) { + # // Render as a link + # const url = cellInfo.value; + # return `RHEALTH Description`; + # } + # ')), + # list(html = TRUE, cell = htmlwidgets::JS(' + # function(cellInfo) { + # // Render as a link + # const url = cellInfo.value; + # return `ETL`; + # } + # ')), + # list(format = reactable::colFormat(date = T)), + # list(format = reactable::colFormat(date = T)), + # list(NULL), + # list(NULL), + # list(NULL), + # list(NULL), + # list(format = reactable::colFormat(date = T)) + # ) + # ) + # + # #save the colDefs as json + # ParallelLogger::saveSettingsToJson(datasourcesColDefs, "./inst/components-columnInformation/datasources-colDefs.json") + + datasourcesColList <- ParallelLogger::loadSettingsFromJson(system.file("components-columnInformation", + "datasources-colDefs.json", + package = "OhdsiShinyModules") + ) + + #need to do for any colDefs that have JS and that are getting loaded in from a JSON + class(datasourcesColList[["sourceDocumentationReference"]]$cell) <- "JS_EVAL" + class(datasourcesColList[["cdmEtlReference"]]$cell) <- "JS_EVAL" + + + resultTableServer(id = "datasourcesTable", + df = datasourcesData, + colDefsInput = datasourcesColList, + downloadedFileName = "datasourcesTable-") + + return(invisible(NULL)) + + + + + }) +} + + +#pull database meta data table +getDatasourcesData <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * from @schema.@database_table + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable + ) + ) +} + + + + + diff --git a/R/description-cohorts.R b/R/description-cohorts.R deleted file mode 100644 index 596cd023..00000000 --- a/R/description-cohorts.R +++ /dev/null @@ -1,505 +0,0 @@ -# @file description-timeToEvent.R -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for exploring 1 or more cohorts features -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the description cohorts features -#' -#' @export -descriptionTableViewer <- function(id) { - ns <- shiny::NS(id) - shiny::div( - - shinydashboard::box( - collapsible = TRUE, - collapsed = TRUE, - title = "Target Viewer", - width = "100%", - shiny::htmlTemplate(system.file("description-www", "help-targetViewer.html", package = utils::packageName())) - ), - - shinydashboard::box( - width = "100%", - title = 'Options', - collapsible = TRUE, - collapsed = F, - shiny::uiOutput(ns('cohortInputs')) - ), - - shiny::conditionalPanel( - condition = "input.generate != 0", - ns = ns, - - shiny::uiOutput(ns("TinputsText")), - - shinydashboard::box( - status = 'info', - width = "100%", - # Title can include an icon - title = shiny::tagList(shiny::icon("gear"), "Table"), - - shiny::checkboxGroupInput( - inputId = ns("columnSelect"), - label = "Columns to show:", - inline = T, - choices = c( - "Mean" = "averageValue", - "Count" = "countValue" - ), - selected = c("averageValue", "countValue") - ), - - shiny::downloadButton( - ns('downloadCohorts'), - label = "Download" - ), - shinycssloaders::withSpinner( - reactable::reactableOutput(ns('feTable')) - ) - ) - ) - ) -} - - -#' The module server for exploring 1 or more cohorts features -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the prediction result database -#' @param mainPanelTab the current tab -#' @param schema the database schema for the model results -#' @param tablePrefix a string that appends the tables in the result schema -#' @param cohortTablePrefix a string that appends the cohort table in the result schema -#' @param databaseTable name of the database table -#' -#' @return -#' The server to the cohorts features server -#' -#' @export -descriptionTableServer <- function( - id, - connectionHandler, - mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix, - databaseTable = 'DATABASE_META_DATA' -) { - shiny::moduleServer( - id, - function(input, output, session) { - - #if(mainPanelTab() != 'Time To Event'){ - # return(invisible(NULL)) - #} - - inputVals <- getDecCohortsInputs( - connectionHandler, - schema, - tablePrefix, - cohortTablePrefix, - databaseTable - ) - - # update UI - output$cohortInputs <- shiny::renderUI({ - - shiny::fluidPage( - shiny::fluidRow( - shiny::column( - width = 6, - shinyWidgets::pickerInput( - inputId = session$ns('targetIds'), - label = 'Targets: ', - choices = inputVals$cohortIds, - selected = inputVals$cohortIds, - choicesOpt = list(style = rep_len("color: black;", 999)), - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), - shiny::column( - width = 6, - shinyWidgets::pickerInput( - inputId = session$ns('databaseId'), - label = 'Database: ', - choices = inputVals$databaseIds, - selected = 1, - choicesOpt = list(style = rep_len("color: black;", 999)), - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - ), - - shiny::actionButton( - inputId = session$ns('generate'), - label = 'Generate Report' - ) - ) - } - ) - - reactiveAllData <- shiny::reactiveVal(NULL) - - selectedInputs <- shiny::reactiveVal() - output$TinputsText <- shiny::renderUI(selectedInputs()) - - shiny::observeEvent( - eventExpr = input$generate, - { - if(length(input$targetIds) == 0 | is.null(input$databaseId)){ - print('Null ids value') - return(invisible(NULL)) - } - - selectedInputs( - shinydashboard::box( - status = 'warning', - width = "100%", - title = 'Selected:', - shiny::div( - shiny::fluidRow( - shiny::column( - width = 8, - shiny::tags$b("Target/s:"), - - paste( - names(inputVals$cohortIds)[inputVals$cohortIds %in% input$targetIds], - collapse = ',' - ) - - ), - shiny::column( - width = 4, - shiny::tags$b("Database:"), - names(inputVals$databaseIds)[inputVals$databaseIds == input$databaseId] - ) - ) - - ) - ) - ) - - # hide/show columns - make allData react - - allData <- tryCatch({ - getDesFEData( - targetIds = input$targetIds, - databaseId = input$databaseId, - connectionHandler = connectionHandler, - schema = schema, - tablePrefix = tablePrefix, - cohortTablePrefix = cohortTablePrefix - )}, - error = function(e){ - shiny::showNotification(paste0('Error: ', e)); return(NULL) - }) - - reactiveAllData(allData) - - if(!is.null(allData)){ - - # do the plots reactively - output$feTable <- reactable::renderReactable( - { - reactable::reactable( - data = allData, - filterable = TRUE, - showPageSizeOptions = TRUE, - pageSizeOptions = c(10, 50, 100,1000), - defaultPageSize = 50, - striped = TRUE, - highlight = TRUE, - - columns = list( - analysisName = reactable::colDef( - filterInput = function(values, name) { - shiny::tags$select( - # Set to undefined to clear the filter - onchange = sprintf("Reactable.setFilter('desc-analysis-select', '%s', event.target.value || undefined)", name), - # "All" has an empty value to clear the filter, and is the default option - shiny::tags$option(value = "", "All"), - lapply(unique(values), shiny::tags$option), - "aria-label" = sprintf("Filter %s", name), - style = "width: 100%; height: 28px;" - ) - } - ) - ), - elementId = "desc-analysis-select" - - - ) - } - ) - } else{ - shiny::showNotification('data NULL') - } - - } - ) - - - # observed the choices to update table - shiny::observeEvent( - eventExpr = input$columnSelect, - { - - if(!is.null(reactiveAllData())){ - # filter columns - columnInd <- input$columnSelect # this tells us whether to include count/mean - - inds <- c() - if(!'countValue' %in% columnInd){ - #remove counts - inds <- c(inds, grep('countValue', colnames(reactiveAllData()))) - } - if(!'averageValue' %in% columnInd){ - #remove averages - inds <- c(inds, grep('averageValue', colnames(reactiveAllData()))) - } - - if(length(inds)>0){ - allData <- reactiveAllData()[, -inds] - } else{ - allData <- reactiveAllData() - } - - # do the plots reactively - output$feTable <- reactable::renderReactable( - { - reactable::reactable( - data = allData, - filterable = TRUE, - showPageSizeOptions = TRUE, - pageSizeOptions = c(10, 50, 100,1000), - defaultPageSize = 50, - striped = TRUE, - highlight = TRUE, - - columns = list( - analysisName = reactable::colDef( - filterInput = function(values, name) { - shiny::tags$select( - # Set to undefined to clear the filter - onchange = sprintf("Reactable.setFilter('desc-analysis-select', '%s', event.target.value || undefined)", name), - # "All" has an empty value to clear the filter, and is the default option - shiny::tags$option(value = "", "All"), - lapply(unique(values), shiny::tags$option), - "aria-label" = sprintf("Filter %s", name), - style = "width: 100%; height: 28px;" - ) - } - ) - ), - elementId = "desc-analysis-select" - - ) - } - ) - } else{ - shiny::showNotification('data NULL') - } - - } - ) - - - # download button - output$downloadCohorts <- shiny::downloadHandler( - filename = function() { - paste('cohort-data-', Sys.Date(), '.csv', sep='') - }, - content = function(con) { - utils::write.csv(reactiveAllData(), con) - } - ) - - - return(invisible(NULL)) - - } - ) -} - - -getDesFEData <- function( - targetIds, - databaseId, - connectionHandler, - schema, - tablePrefix, - cohortTablePrefix -){ - - - shiny::withProgress(message = 'Getting target comparison data', value = 0, { - - sql <- "select distinct ref.covariate_id, ref.covariate_name, an.analysis_name, c.cohort_name, covs.COUNT_VALUE, covs.AVERAGE_VALUE - from - ( - select co.RUN_ID, cd.TARGET_COHORT_ID as COHORT_DEFINITION_ID, co.COVARIATE_ID, - co.SUM_VALUE as COUNT_VALUE, co.AVERAGE_VALUE*100 as AVERAGE_VALUE from - @result_schema.@table_prefixCOVARIATES co - inner join - (select * from @result_schema.@table_prefixcohort_details - where DATABASE_ID = '@database_id' and - TARGET_COHORT_ID in (@cohort_ids) and COHORT_TYPE = 'T' - ) as cd - on co.COHORT_DEFINITION_ID = cd.COHORT_DEFINITION_ID - and co.DATABASE_ID = cd.DATABASE_ID - union - select cc.RUN_ID, cds.TARGET_COHORT_ID as COHORT_DEFINITION_ID, cc.COVARIATE_ID, cc.COUNT_VALUE, cc.AVERAGE_VALUE from - @result_schema.@table_prefixCOVARIATES_continuous cc - inner join - (select * from @result_schema.@table_prefixcohort_details - where DATABASE_ID = '@database_id' and - TARGET_COHORT_ID in (@cohort_ids) and COHORT_TYPE = 'T' - ) as cds - on cc.COHORT_DEFINITION_ID = cds.COHORT_DEFINITION_ID - and cc.DATABASE_ID = cds.DATABASE_ID - ) covs - inner join - @result_schema.@table_prefixcovariate_ref ref - on covs.RUN_ID = ref.RUN_ID and - covs.COVARIATE_ID = ref.COVARIATE_ID - inner join @result_schema.@table_prefixanalysis_ref an - on an.RUN_ID = ref.RUN_ID and - an.analysis_id = ref.analysis_id - inner join @result_schema.@cohort_table_prefixcohort_definition c - on c.cohort_definition_id = covs.COHORT_DEFINITION_ID - ; - " - - shiny::incProgress(1/3, detail = paste("Created SQL - Extracting...")) - - resultTable <- connectionHandler$queryDb( - sql = sql, - result_schema = schema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix, - cohort_ids = paste(as.double(targetIds), collapse = ','), - database_id = databaseId - ) - - shiny::incProgress(2/3, detail = paste("Formating")) - - #format - resultTable$averageValue <- round(resultTable$averageValue, digits = 2) - - resultTable <- resultTable %>% - tidyr::pivot_wider( - names_from = "cohortName", #.data$cohortName, - values_from = c("averageValue", "countValue"), #c(.data$averageValue, .data$countValue), - id_cols = c("covariateId", "covariateName", "analysisName") #c(.data$covariateId, .data$covariateName, .data$analysisName) - ) - - resultTable$analysisName <- as.factor(resultTable$analysisName) - - shiny::incProgress(3/3, detail = paste("Done")) - - }) - - return(resultTable) -} - - -getDecCohortsInputs <- function( - connectionHandler, - schema, - tablePrefix, - cohortTablePrefix, - databaseTable -){ - - - shiny::withProgress(message = 'Getting target comparison inputs', value = 0, { - - - sql <- ' select distinct c.cohort_definition_id, c.cohort_name from - @result_schema.@cohort_table_prefixcohort_definition c - inner join - (select distinct TARGET_COHORT_ID as id - from @result_schema.@table_prefixcohort_details - ) ids - on ids.id = c.cohort_definition_id - ;' - - shiny::incProgress(1/4, detail = paste("Extracting targetIds")) - - idVals <- connectionHandler$queryDb( - sql = sql, - result_schema = schema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix - ) - ids <- idVals$cohortDefinitionId - names(ids) <- idVals$cohortName - - shiny::incProgress(2/4, detail = paste("Extracted targetIds")) - - - sql <- 'select d.database_id, d.cdm_source_abbreviation as database_name - from @result_schema.@database_table d;' - - shiny::incProgress(3/4, detail = paste("Extracting databaseIds")) - - database <- connectionHandler$queryDb( - sql = sql, - result_schema = schema, - database_table = databaseTable - ) - databaseIds <- database$databaseId - names(databaseIds) <- database$databaseName - - shiny::incProgress(4/4, detail = paste("Done")) - - }) - - return( - list( - cohortIds = ids, - databaseIds = databaseIds - ) - ) - -} diff --git a/R/estimation-attrition.R b/R/estimation-attrition.R deleted file mode 100644 index 6f0051a5..00000000 --- a/R/estimation-attrition.R +++ /dev/null @@ -1,110 +0,0 @@ -# @file estimation-attrition -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - -#' The module viewer for rendering the PLE attrition results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation attrition -#' -#' @export -estimationAttritionViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::plotOutput(outputId = ns("attritionPlot"), width = 600, height = 600), - shiny::uiOutput(outputId = ns("attritionPlotCaption")), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadAttritionPlotPng"), - label = "Download diagram as PNG"), - shiny::downloadButton(outputId = ns("downloadAttritionPlotPdf"), - label = "Download diagram as PDF")) - ) -} - -#' The module server for rendering the PLE attrition results -#' -#' @param id the unique reference id for the module -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param databaseTable databaseTable -#' -#' @return -#' the PLE attrition results content server -#' -#' @export -estimationAttritionServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix, databaseTable) { - - shiny::moduleServer( - id, - function(input, output, session) { - - - attritionPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - attrition <- getEstimationAttrition(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - databaseTable = databaseTable, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, - databaseId = row$databaseId, - analysisId = row$analysisId) - plot <- drawEstimationAttritionDiagram(attrition) - return(plot) - } - }) - - output$attritionPlot <- shiny::renderPlot({ - return(attritionPlot()) - }) - - output$downloadAttritionPlotPng <- shiny::downloadHandler(filename = "Attrition.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = attritionPlot(), width = 6, height = 7, dpi = 400) - }) - - output$downloadAttritionPlotPdf <- shiny::downloadHandler(filename = "Attrition.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = attritionPlot(), width = 6, height = 7) - }) - - output$attritionPlotCaption <- shiny::renderUI({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - text <- "Figure 1. Attrition diagram, showing the Number of subjects in the target (%s) and - comparator (%s) group after various stages in the analysis." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) - } - }) - - } - ) -} diff --git a/R/estimation-diagnosticsSummary.R b/R/estimation-diagnosticsSummary.R deleted file mode 100644 index 1396a377..00000000 --- a/R/estimation-diagnosticsSummary.R +++ /dev/null @@ -1,79 +0,0 @@ -# @file estimation-diagnosticsSummary -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for rendering the PLE diagnostics results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation diagnostics viewer -#' -#' @export -estimationDiagnosticsSummaryViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - # div(HTML("Enhancements to come...")), - reactable::reactableOutput(outputId = ns("diagnosticsTable")) - ) -} - - -#' The module server for rendering the PLE diagnostics summary -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param cohortTablePrefix cohortTablePrefix -#' @param databaseTable databaseTable -#' -#' @return -#' the PLE diagnostics summary results -#' -#' @export -estimationDiagnosticsSummaryServer <- function(id, - connectionHandler, - resultsSchema, - tablePrefix, - cohortTablePrefix, - databaseTable) { - - shiny::moduleServer( - id, - function(input, output, session) { - - output$diagnosticsTable <- reactable::renderReactable({ - data <- getDiagnosticsData(connectionHandler, - resultsSchema, - tablePrefix, - cohortTablePrefix, - databaseTable) - - reactable::reactable(data, - striped = TRUE, - filterable = TRUE, - searchable = TRUE, - bordered = TRUE - ) - }) - - } - ) -} diff --git a/R/estimation-forestPlot.R b/R/estimation-forestPlot.R deleted file mode 100644 index 5e19a360..00000000 --- a/R/estimation-forestPlot.R +++ /dev/null @@ -1,118 +0,0 @@ -# @file estimation-forestPlot -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - -#' The module viewer for rendering the PLE results forest plot -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation forest plot -#' -#' @export -estimationForestPlotViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::plotOutput(outputId = ns("forestPlot")), - shiny::uiOutput(outputId = ns("forestPlotCaption")), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadForestPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadForestPlotPdf"), - label = "Download plot as PDF")) - ) -} - - - - - -#' The module server for rendering the PLE multiple results forest plot -#' -#' @param id the unique reference id for the module -#' @param connectionHandler connection -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param metaAnalysisDbIds metaAnalysisDbIds -#' @param resultsSchema resultsSchema -#' @param tablePrefix tablePrefix -#' @param databaseTable databaseTable -#' -#' @return -#' the PLE forest plot content server -#' -#' @export -estimationForestPlotServer <- function( - id, connectionHandler, selectedRow, inputParams, metaAnalysisDbIds = NULL, - resultsSchema, - tablePrefix, - databaseTable - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - forestPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row) || !(row$databaseId %in% metaAnalysisDbIds)) { - return(NULL) - } else { - results <- getEstimationMainResults(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - databaseTable = databaseTable, - targetIds = row$targetId, - comparatorIds = row$comparatorId, - outcomeIds = row$outcomeId, - analysisIds = row$analysisId) - plot <- plotEstimationForest(results) - return(plot) - } - }) - - output$forestPlot <- shiny::renderPlot({ - forestPlot() - }) - - output$forestPlotCaption <- shiny::renderUI({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - text <- "Figure 6. Forest plot showing the per-database and summary hazard ratios (and 95 percent confidence - intervals) comparing %s to %s for the outcome of %s, using %s. Estimates are shown both before and after empirical - calibration. The I2 is computed on the uncalibrated estimates." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator, inputParams()$outcome, row$psStrategy))) - } - }) - - output$downloadForestPlotPng <- shiny::downloadHandler(filename = "ForestPlot.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = forestPlot(), width = 12, height = 9, dpi = 400) - }) - - output$downloadForestPlotPdf <- shiny::downloadHandler(filename = "ForestPlot.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = forestPlot(), width = 12, height = 9) - }) - - } - ) -} diff --git a/R/estimation-main.R b/R/estimation-main.R deleted file mode 100644 index 0a324ad4..00000000 --- a/R/estimation-main.R +++ /dev/null @@ -1,357 +0,0 @@ -# @file estimation-main.R -# -# Copyright 2022 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. - - -#' The location of the estimation module helper file -#' -#' @details -#' Returns the location of the estimation helper file -#' -#' @return -#' string location of the estimation helper file -#' -#' @export -estimationHelperFile <- function(){ - fileLoc <- system.file('estimation-www', "estimation.html", package = "OhdsiShinyModules") - return(fileLoc) -} - -#' The viewer of the main estimation module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation results viewer -#' -#' @export -estimationViewer <- function(id) { - ns <- shiny::NS(id) - - shinydashboard::box( - status = 'info', - width = 12, - title = shiny::span( shiny::icon("chart-column"), 'Cohort Method'), - solidHeader = TRUE, - - #shiny::fluidPage(style = "width:1500px;", - shinydashboard::box( - collapsible = TRUE, - collapsed = TRUE, - title = "Cohort Method Evidence Explorer", - width = "100%"#, - #shiny::htmlTemplate(system.file("cohort-diagnostics-www", "cohortCounts.html", package = utils::packageName())) - ), - - htmltools::tags$head(htmltools::tags$style(type = "text/css", " - #loadmessage { - position: fixed; - top: 0px; - left: 0px; - width: 100%; - padding: 5px 0px 5px 0px; - text-align: center; - font-weight: bold; - font-size: 100%; - color: #000000; - background-color: #ADD8E6; - z-index: 105; - } - ")), - shiny::conditionalPanel(id = ns("loadmessage"), - condition = "$('html').hasClass('shiny-busy')", - htmltools::tags$div("Processing...")), - shiny::tabsetPanel( - type = 'pills', - id = ns("mainTabsetPanel"), - shiny::tabPanel( - title = "Diagnostics", - estimationDiagnosticsSummaryViewer(ns("estimationDiganostics")) - ), - shiny::tabPanel( - title = "Results", - shiny::fluidRow( - shiny::column(width = 3, - shiny::uiOutput(outputId = ns("targetWidget")), - shiny::uiOutput(outputId = ns("comparatorWidget")), - shiny::uiOutput(outputId = ns("outcomeWidget")), - shiny::uiOutput(outputId = ns("databaseWidget")), - shiny::uiOutput(outputId = ns("analysisWidget")) - ), - shiny::column(width = 9, - estimationResultsTableViewer(ns("resultsTable")), - shiny::conditionalPanel("output.rowIsSelected == true", ns = ns, - shiny::tabsetPanel(id = ns("detailsTabsetPanel"), - shiny::tabPanel(title = "Power", - estimationPowerViewer(ns("power")) - ), - shiny::tabPanel(title = "Attrition", - estimationAttritionViewer(ns("attrition")) - ), - shiny::tabPanel(title = "Population characteristics", - estimationPopulationCharacteristicsViewer(ns("popCharacteristics")) - ), - shiny::tabPanel(title = "Propensity model", - estimationPropensityModelViewer(ns("propensityModel")) - ), - shiny::tabPanel(title = "Propensity scores", - estimationPropensityScoreDistViewer(ns("propensityScoreDist")) - ), - shiny::tabPanel(title = "Covariate balance", - estimationCovariateBalanceViewer(ns("covariateBalance")) - ), - shiny::tabPanel(title = "Systematic error", - estimationSystematicErrorViewer(ns("systematicError")) - ), - shiny::tabPanel(title = "Forest plot", - estimationForestPlotViewer(ns("forestPlot")) - ), - shiny::tabPanel(title = "Kaplan-Meier", - estimationKaplanMeierViewer(ns("kaplanMeier")) - ), - shiny::tabPanel(title = "Subgroups", - estimationSubgroupsViewer(ns("subgroups")) - ) - - ) # end tabsetPanel - ) # end conditionalPanel - ) - - ) - ) - ) - ) - -} - - -#' The module server for the main estimation module -#' -#' @param id the unique reference id for the module -#' @param connectionHandler a connection to the database with the results -#' @param resultDatabaseSettings a named list containing the PLE results database connection details -#' -#' @return -#' the PLE results viewer main module server -#' -#' @export -estimationServer <- function( - id, - connectionHandler, - resultDatabaseSettings - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - - dataFolder <- NULL - - output$targetWidget <- shiny::renderUI({ - targets <- getEstimationTargetChoices(connectionHandler, - resultDatabaseSettings$schema, - resultDatabaseSettings$tablePrefix, - resultDatabaseSettings$cohortTablePrefix) - shiny::selectInput(inputId = session$ns("target"), - label = "Target", - choices = getEstimationSelectNamedChoices(targets$targetId, - targets$cohortName)) - }) - - output$comparatorWidget <- shiny::renderUI({ - comparators <- getEstimationComparatorChoices(connectionHandler, - resultDatabaseSettings$schema, - resultDatabaseSettings$tablePrefix, - resultDatabaseSettings$cohortTablePrefix) - shiny::selectInput(inputId = session$ns("comparator"), - label = "Comparator", - choices = getEstimationSelectNamedChoices(comparators$comparatorId, - comparators$cohortName)) - }) - - output$outcomeWidget <- shiny::renderUI({ - outcomes <- getEstimationOutcomeChoices(connectionHandler, - resultDatabaseSettings$schema, - resultDatabaseSettings$tablePrefix, - resultDatabaseSettings$cohortTablePrefix) - shiny::selectInput(inputId = session$ns("outcome"), - label = "Outcome", - choices = getEstimationSelectNamedChoices(outcomes$outcomeId, - outcomes$cohortName)) - }) - output$databaseWidget<- shiny::renderUI({ - databases <- getEstimationDatabaseChoices(connectionHandler, - resultDatabaseSettings$schema, - resultDatabaseSettings$tablePrefix, - resultDatabaseSettings$databaseTable) - shiny::checkboxGroupInput(inputId = session$ns("database"), - label = "Data source", - choices = getEstimationSelectNamedChoices(databases$databaseId, - databases$cdmSourceAbbreviation), - selected = unique(databases$databaseId)) - }) - output$analysisWidget <- shiny::renderUI({ - analyses <- getCmAnalysisOptions(connectionHandler, - resultDatabaseSettings$schema, - resultDatabaseSettings$tablePrefix) - shiny::checkboxGroupInput(inputId = session$ns("analysis"), - label = "Analysis", - choices = getEstimationSelectNamedChoices(analyses$analysisId, - analyses$description), - selected = unique(analyses$analysisId)) - }) - - - inputParams <- shiny::reactive({ - t <- list() - t$target <- input$target - t$comparator <- input$comparator - t$outcome <- input$outcome - t$analysis <- input$analysis - t$database <- input$database - return(t) - }) - - - estimationDiagnosticsSummaryServer(id = "estimationDiganostics", - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable) - - - selectedRow <- estimationResultsTableServer(id = "resultsTable", - connectionHandler = connectionHandler, - inputParams = inputParams, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - databaseTable = resultDatabaseSettings$databaseTable) - - output$rowIsSelected <- shiny::reactive({ - return(!is.null(selectedRow())) - }) - - - if (!exists("cmInteractionResult")) { # ISSUE: this should be an input resultDatabaseSettings$cmInteractionResult and not null check - #TODO: update for testing once subgroup analysis completed - shiny::hideTab(inputId = "detailsTabsetPanel", target = "Subgroups", - session = session) - } - - shiny::outputOptions(output, "rowIsSelected", suspendWhenHidden = FALSE) - - output$isMetaAnalysis <- shiny::reactive({ - #TODO: update once MA implemented - row <- selectedRow() - isMetaAnalysis <- FALSE # !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - if (!is.null(row)) { - if (isMetaAnalysis) { - shiny::hideTab("detailsTabsetPanel", "Attrition", session = session) - shiny::hideTab("detailsTabsetPanel", "Population characteristics", session = session) - shiny::hideTab("detailsTabsetPanel", "Kaplan-Meier", session = session) - shiny::hideTab("detailsTabsetPanel", "Propensity model", session = session) - shiny::showTab("detailsTabsetPanel", "Forest plot", session = session) - } else { - shiny::showTab("detailsTabsetPanel", "Attrition", session = session) - shiny::showTab("detailsTabsetPanel", "Population characteristics", session = session) - if (row$unblind) { - shiny::showTab("detailsTabsetPanel", "Kaplan-Meier", session = session) - } else{ - shiny::hideTab("detailsTabsetPanel", "Kaplan-Meier", session = session) - } - shiny::showTab("detailsTabsetPanel", "Propensity model", session = session) - shiny::hideTab("detailsTabsetPanel", "Forest plot", session = session) - } - } - return(isMetaAnalysis) - }) - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - - - estimationPowerServer(id = "power", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - resultDatabaseSettings$tablePrefix) - - estimationAttritionServer(id = "attrition", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - databaseTable = resultDatabaseSettings$cohortTablePrefix) - - estimationPopulationCharacteristicsServer(id = "popCharacteristics", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix) - - estimationPropensityModelServer(id = "propensityModel", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix) - - estimationPropensityScoreDistServer(id = "propensityScoreDist", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix) - - estimationCovariateBalanceServer(id = "covariateBalance", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix) - - estimationSystematicErrorServer(id = "systematicError", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix) - - estimationKaplanMeierServer(id = "kaplanMeier", - selectedRow = selectedRow, - inputParams = inputParams, - connectionHandler = connectionHandler, - resultsSchema = resultDatabaseSettings$schema, - tablePrefix = resultDatabaseSettings$tablePrefix, - cohortTablePrefix = resultDatabaseSettings$cohortTablePrefix, - databaseTable = resultDatabaseSettings$databaseTable) - - #TODO: complete once MA implemented - # estimationForestPlotServer("forestPlot", connection, selectedRow, inputParams) - - #TODO: revisit once subgroup example conducted - estimationSubgroupsServer(id = "subgroups", - selectedRow = selectedRow, - inputParams = inputParams) - - } - ) -} - diff --git a/R/estimation-power.R b/R/estimation-power.R deleted file mode 100644 index f5152301..00000000 --- a/R/estimation-power.R +++ /dev/null @@ -1,170 +0,0 @@ -# @file estimation-power -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for rendering the PLE power analysis -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation power calculation results -#' -#' @export -estimationPowerViewer <- function(id) { - - ns <- shiny::NS(id) - - shiny::div( - shiny::uiOutput(outputId = ns("powerTableCaption")), - shiny::tableOutput(outputId = ns("powerTable")), - shiny::uiOutput(outputId = ns("timeAtRiskTableCaption")), - shiny::tableOutput(outputId = ns("timeAtRiskTable")) - ) -} - - -#' The module server for rendering the PLE power analysis results -#' -#' @param id the unique reference id for the module -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param metaAnalysisDbIds metaAnalysisDbIds -#' -#' @return -#' the PLE systematic error power server -#' -#' @export -estimationPowerServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix, metaAnalysisDbIds = NULL) { - - shiny::moduleServer( - id, - function(input, output, session) { - - - output$powerTableCaption <- shiny::renderUI({ - row <- selectedRow() - if (!is.null(row)) { - text <- "Table 1a. Number of subjects, follow-up time (in years), number of outcome - events, and event incidence rate (IR) per 1,000 patient years (PY) in the target (%s) and - comparator (%s) group after propensity score adjustment, as well as the minimum detectable relative risk (MDRR). - Note that the IR does not account for any stratification." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) - } else { - return(NULL) - } - }) - - output$powerTable <- shiny::renderTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - #TODO: update once MA implemented - if (FALSE && row$databaseId %in% metaAnalysisDbIds) { - results <- getEstimationMainResults(connectionHandler = connectionHandler, - targetIds = row$targetId, - comparatorIds = row$comparatorId, - outcomeIds = row$outcomeId, - analysisIds = row$analysisId) - table <- prepareEstimationPowerTable(results, connectionHandler, resultsSchema) - table$description <- NULL - if (!row$unblind) { - table$targetOutcomes <- NA - table$comparatorOutcomes <- NA - table$targetIr <- NA - table$comparatorIr <- NA - } - table$databaseId[table$databaseId %in% metaAnalysisDbIds] <- "Summary" - colnames(table) <- c("Source", - "Target subjects", - "Comparator subjects", - "Target years", - "Comparator years", - "Target events", - "Comparator events", - "Target IR (per 1,000 PY)", - "Comparator IR (per 1,000 PY)", - "MDRR") - } else { - table <- prepareEstimationPowerTable(row, connectionHandler, resultsSchema, tablePrefix) - table$description <- NULL - table$databaseId <- NULL - if (!row$unblind) { - table$targetOutcomes <- NA - table$comparatorOutcomes <- NA - table$targetIr <- NA - table$comparatorIr <- NA - } - colnames(table) <- c("Target subjects", - "Comparator subjects", - "Target years", - "Comparator years", - "Target events", - "Comparator events", - "Target IR (per 1,000 PY)", - "Comparator IR (per 1,000 PY)", - "MDRR") - } - return(table) - } - }) - - output$timeAtRiskTableCaption <- shiny::renderUI({ - row <- selectedRow() - if (!is.null(row)) { - text <- "Table 1b. Time (days) at risk distribution expressed as - minimum (min), 25th percentile (P25), median, 75th percentile (P75), and maximum (max) in the target - (%s) and comparator (%s) cohort after propensity score adjustment." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) - } else { - return(NULL) - } - }) - - output$timeAtRiskTable <- shiny::renderTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - if (FALSE && row$databaseId %in% metaAnalysisDbIds) { - # TODO: update when MA implemented - followUpDist <- getCmFollowUpDist(#cmFollowUpDist = cmFollowUpDist, - connectionHandler = connectionHandler, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, - analysisId = row$analysisId) - } else { - followUpDist <- getCmFollowUpDist(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - outcomeId = inputParams()$outcome, - databaseId = row$databaseId, - analysisId = row$analysisId) - } - table <- prepareEstimationFollowUpDistTable(followUpDist) - return(table) - } - }) - }) -} diff --git a/R/estimation-propensityModel.R b/R/estimation-propensityModel.R deleted file mode 100644 index f4a5a11c..00000000 --- a/R/estimation-propensityModel.R +++ /dev/null @@ -1,90 +0,0 @@ -# @file estimation-propensityModel -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for rendering the PLE propensity score model covariates/coefficients -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation propensity score model covariates/coefficients -#' -#' @export -estimationPropensityModelViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::div(shiny::strong("Table 3."),"Fitted propensity model, listing all coviates with non-zero coefficients. Positive coefficients indicate predictive of the target exposure."), - DT::dataTableOutput(outputId = ns("propensityModelTable")) - ) -} - - -#' The module server for rendering the propensity score model -#' -#' @param id the unique reference id for the module -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' -#' @return -#' the PLE propensity score model -#' -#' @export -estimationPropensityModelServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix) { - - shiny::moduleServer( - id, - function(input, output, session) { - - output$propensityModelTable <- DT::renderDataTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - model <- getEstimationPropensityModel(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - databaseId = row$databaseId, - analysisId = row$analysisId) - - table <- prepareEstimationPropensityModelTable(model) - options = list(columnDefs = list(list(className = 'dt-right', targets = 0)), - pageLength = 15, - searching = FALSE, - lengthChange = TRUE, - ordering = TRUE, - paging = TRUE) - selection = list(mode = "single", target = "row") - table <- DT::datatable(table, - options = options, - selection = selection, - rownames = FALSE, - escape = FALSE, - class = "stripe nowrap compact") - return(table) - } - }) - - } - ) -} diff --git a/R/estimation-resultsTable.R b/R/estimation-resultsTable.R deleted file mode 100644 index 5ab5730b..00000000 --- a/R/estimation-resultsTable.R +++ /dev/null @@ -1,213 +0,0 @@ -# @file estimation-resultsTable -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - - - - -#' The module viewer for rendering the PLE main results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the PLE main results -#' -#' @export -estimationResultsTableViewer <- function(id) { - ns <- shiny::NS(id) - - reactable::reactableOutput(outputId = ns("mainTable")) -} - - - - -#' The module server for rendering the PLE results per current selections -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the PLE results database -#' @param inputParams the selected study parameters of interest -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param databaseTable databaseTable -#' -#' @return -#' the PLE main results table server server -#' -#' @export -estimationResultsTableServer <- function( - id, - connectionHandler, - inputParams, - resultsSchema, - tablePrefix, - databaseTable - ) { - - shiny::moduleServer( - id, - function(input, output, session) { - - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - - - mainColumns <- c("description", - "cdmSourceAbbreviation", - "rr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedRr", - "calibratedCi95Lb", - "calibratedCi95Ub", - "calibratedP") - - resultSubset <- shiny::reactive({ - - results <- getEstimationMainResults(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - databaseTable = databaseTable, - targetIds = filterEstimationEmptyNullValues(inputParams()$target), - comparatorIds = filterEstimationEmptyNullValues(inputParams()$comparator), - outcomeIds = filterEstimationEmptyNullValues(inputParams()$outcome), - databaseIds = filterEstimationEmptyNullValues(inputParams()$database), - analysisIds = filterEstimationEmptyNullValues(inputParams()$analysis)) - results <- results[order(results$analysisId), ] - - - results[which(results$unblind == 0), getEstimationColumnsToBlind(results)] <- NA - - return(results) - }) - - selectedRow <- shiny::reactive({ - idx <- reactable::getReactableState( - outputId = 'mainTable', - name = 'selected' - ) - if (is.null(idx)) { - return(NULL) - } else { - subset <- resultSubset() - if (nrow(subset) == 0) { - return(NULL) - } - row <- subset[idx, ] - # row$psStrategy <- gsub("^PS ", "", gsub(", .*$", "", cohortMethodAnalysis$description[cohortMethodAnalysis$analysisId == row$analysisId])) - return(row) - } - }) - - output$mainTable <- reactable::renderReactable({ - table <- resultSubset() - if (is.null(table) || nrow(table) == 0) { - shiny::validate(shiny::need(nrow(table) > 0, "No CM results for selections.")) - return(NULL) - } - table <- table[, mainColumns] - table$rr <- prettyEstimationHr(table$rr) - table$ci95Lb <- prettyEstimationHr(table$ci95Lb) - table$ci95Ub <- prettyEstimationHr(table$ci95Ub) - table$p <- prettyEstimationHr(table$p) - table$calibratedRr <- prettyEstimationHr(table$calibratedRr) - table$calibratedCi95Lb <- prettyEstimationHr(table$calibratedCi95Lb) - table$calibratedCi95Ub <- prettyEstimationHr(table$calibratedCi95Ub) - table$calibratedP <- prettyEstimationHr(table$calibratedP) - #colnames(table) <- mainColumnNames - - reactable::reactable( # add extras - data = table, - rownames = FALSE, - defaultPageSize = 15, - showPageSizeOptions = T, - onClick = 'select', - selection = 'single', - striped = T, - - columns = list( - description = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Analysis", - "Analysis" - )), - cdmSourceAbbreviation = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Data source", - "Data source" - )), - rr = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "HR", - "Hazard ratio (uncalibrated)" - )), - ci95Lb = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "LB", - "Lower bound of the 95 percent confidence interval (uncalibrated)" - )), - ci95Ub = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "UB", - "Upper bound of the 95 percent confidence interval (uncalibrated)" - )), - p = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "P", - "Two-sided p-value (uncalibrated)" - )), - calibratedRr = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.HR", - "Hazard ratio (calibrated)" - )), - calibratedCi95Lb = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.LB", - "Lower bound of the 95 percent confidence interval (calibrated)" - )), - calibratedCi95Ub = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.UB", - "Upper bound of the 95 percent confidence interval (calibrated)" - )), - calibratedP = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Cal.P", - "Two-sided p-value (calibrated)" - )) - ) - ) - }) - - return(selectedRow) - }) -} diff --git a/R/estimation-subgroups.R b/R/estimation-subgroups.R deleted file mode 100644 index 2ad76716..00000000 --- a/R/estimation-subgroups.R +++ /dev/null @@ -1,131 +0,0 @@ -# @file estimation-subgroups -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for rendering the PLE subgroup results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation subgroup results module -#' -#' @export -estimationSubgroupsViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::uiOutput(outputId = ns("subgroupTableCaption")), - DT::dataTableOutput(outputId = ns("subgroupTable")) - ) -} - - -#' The module server for rendering the subgroup results -#' -#' @param id the unique reference id for the module -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param exposureOfInterest exposureOfInterest -#' @param outcomeOfInterest outcomeOfInterest -#' @param connectionHandler connection -#' -#' @return -#' the PLE subgroup results server -#' -#' @export -estimationSubgroupsServer <- function(id, selectedRow, inputParams, exposureOfInterest, outcomeOfInterest, connectionHandler) { - - shiny::moduleServer( - id, - function(input, output, session) { - - interactionEffects <- shiny::reactive({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - targetId <- exposureOfInterest$exposureId[exposureOfInterest$exposureName == inputParams()$target] - comparatorId <- exposureOfInterest$exposureId[exposureOfInterest$exposureName == inputParams()$comparator] - outcomeId <- outcomeOfInterest$outcomeId[outcomeOfInterest$outcomeName == inputParams()$outcome] - subgroupResults <- getEstimationSubgroupResults(connectionHandler = connectionHandler, - targetIds = targetId, - comparatorIds = comparatorId, - outcomeIds = outcomeId, - databaseIds = row$databaseId, - analysisIds = row$analysisId) - if (nrow(subgroupResults) == 0) { - return(NULL) - } else { - if (!row$unblind) { - subgroupResults$rrr <- rep(NA, nrow(subgroupResults)) - subgroupResults$ci95Lb <- rep(NA, nrow(subgroupResults)) - subgroupResults$ci95Ub <- rep(NA, nrow(subgroupResults)) - subgroupResults$logRrr <- rep(NA, nrow(subgroupResults)) - subgroupResults$seLogRrr <- rep(NA, nrow(subgroupResults)) - subgroupResults$p <- rep(NA, nrow(subgroupResults)) - subgroupResults$calibratedP <- rep(NA, nrow(subgroupResults)) - } - return(subgroupResults) - } - } - }) - - output$subgroupTableCaption <- shiny::renderUI({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - text <- "Table 4. Subgroup interactions. For each subgroup, the number of subject within the subroup - in the target (%s) and comparator (%s) cohorts are provided, as well as the hazard ratio ratio (HRR) - with 95 percent confidence interval and p-value (uncalibrated and calibrated) for interaction of the main effect with - the subgroup." - return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator))) - } - }) - - output$subgroupTable <- DT::renderDataTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - subgroupResults <- interactionEffects() - if (is.null(subgroupResults)) { - return(NULL) - } - subgroupTable <- prepareEstimationSubgroupTable(subgroupResults, output = "html") - colnames(subgroupTable) <- c("Subgroup", - "Target subjects", - "Comparator subjects", - "HRR", - "P", - "Cal.P") - options <- list(searching = FALSE, - ordering = FALSE, - paging = FALSE, - bInfo = FALSE) - subgroupTable <- DT::datatable(subgroupTable, - options = options, - rownames = FALSE, - escape = FALSE, - class = "stripe nowrap compact") - return(subgroupTable) - } - }) - } - ) -} diff --git a/R/estimation-systematicError.R b/R/estimation-systematicError.R deleted file mode 100644 index e869d2bc..00000000 --- a/R/estimation-systematicError.R +++ /dev/null @@ -1,169 +0,0 @@ -# @file estimation-systematicError -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for rendering the PLE systematic error objects -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation systematic error module -#' -#' @export -estimationSystematicErrorViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - shiny::plotOutput(outputId = ns("systematicErrorPlot")), - shiny::div(shiny::strong("Figure 4."),"Systematic error. Effect size estimates for the negative controls (true hazard ratio = 1) - and positive controls (true hazard ratio > 1), before and after calibration. Estimates below the diagonal dashed - lines are statistically significant (alpha = 0.05) different from the true effect size. A well-calibrated - estimator should have the true effect size within the 95 percent confidence interval 95 percent of times."), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadSystematicErrorPlotPdf"), - label = "Download plot as PDF") - ), - shiny::conditionalPanel(condition = "output.isMetaAnalysis == true", - ns = ns, - shiny::plotOutput(outputId = ns("systematicErrorSummaryPlot")), - shiny::div(shiny::strong("Figure 8."),"Fitted null distributions per data source."), - shiny::div(style = "display: inline-block;vertical-align: top;margin-bottom: 10px;", - shiny::downloadButton(outputId = ns("downloadSystematicErrorSummaryPlotPng"), - label = "Download plot as PNG"), - shiny::downloadButton(outputId = ns("downloadSystematicErrorSummaryPlotPdf"), - label = "Download plot as PDF"))) - ) -} - - - -#' The module server for rendering the systematic error objects -#' -#' @param id the unique reference id for the module -#' @param selectedRow the selected row from the main results table -#' @param inputParams the selected study parameters of interest -#' @param connectionHandler the connection to the PLE results database -#' @param resultsSchema the schema with the PLE results -#' @param tablePrefix tablePrefix -#' @param metaAnalysisDbIds metaAnalysisDbIds -#' -#' @return -#' the PLE systematic error content server -#' -#' @export -estimationSystematicErrorServer <- function(id, selectedRow, inputParams, connectionHandler, resultsSchema, tablePrefix, metaAnalysisDbIds = NULL) { - - shiny::moduleServer( - id, - function(input, output, session) { - - output$isMetaAnalysis <- shiny::reactive({ - return(FALSE) - # TODO: update once MA implemented - row <- selectedRow() - isMetaAnalysis <- !is.null(row) && (row$databaseId %in% metaAnalysisDbIds) - return(isMetaAnalysis) - }) - - shiny::outputOptions(output, "isMetaAnalysis", suspendWhenHidden = FALSE) - - - - systematicErrorPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - controlResults <- getEstimationControlResults(connectionHandler = connectionHandler, - resultsSchema = resultsSchema, - tablePrefix = tablePrefix, - targetId = inputParams()$target, - comparatorId = inputParams()$comparator, - analysisId = row$analysisId, - databaseId = row$databaseId) - - # remove the RR zeros that replace NAs during data upload - controlResults$logRr[controlResults$logRr == 0] <- NA - controlResults$ci95Lb[controlResults$ci95Lb == 0] <- NA - controlResults$ci95Ub[controlResults$ci95Ub == 0] <- NA - controlResults$calibratedLogRr[controlResults$calibratedLogRr == 0] <- NA - controlResults$calibratedCi95Lb[controlResults$calibratedCi95Lb == 0] <- NA - controlResults$calibratedCi95Ub[controlResults$calibratedCi95Ub == 0] <- NA - - plot <- plotEstimationScatter(controlResults) - return(plot) - } - }) - - output$systematicErrorPlot <- shiny::renderPlot({ - return(systematicErrorPlot()) - }) - - output$downloadSystematicErrorPlotPng <- shiny::downloadHandler(filename = "SystematicError.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = systematicErrorPlot(), width = 12, height = 5.5, dpi = 400) - }) - - output$downloadSystematicErrorPlotPdf <- shiny::downloadHandler(filename = "SystematicError.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = systematicErrorPlot(), width = 12, height = 5.5) - }) - - systematicErrorSummaryPlot <- shiny::reactive({ - row <- selectedRow() - if (is.null(row) || !(row$databaseId %in% metaAnalysisDbIds)) { - return(NULL) - } else { - ##negativeControls <- getEstimationNegativeControlEstimates(connection = connection, - ## #resultsSchema = resultsSchema, unused argument - ## targetId = inputParams()$target, - ## comparatorId = inputParams()$comparator, - ## analysisId = row$analysisId) - ##if (is.null(negativeControls)) - return(NULL) - - ## plotEstimationEmpiricalNulls() not found - #plot <- plotEstimationEmpiricalNulls(negativeControls) - ##return(plot) - } - }) - - output$systematicErrorSummaryPlot <- shiny::renderPlot({ - return(systematicErrorSummaryPlot()) - }, res = 100) - - output$downloadSystematicErrorSummaryPlotPng <- shiny::downloadHandler(filename = "SystematicErrorSummary.png", - contentType = "image/png", - content = function(file) { - ggplot2::ggsave(file, plot = systematicErrorSummaryPlot(), width = 12, height = 5.5, dpi = 400) - }) - - output$downloadSystematicErrorSummaryPlotPdf <- shiny::downloadHandler(filename = "SystematicErrorSummary.pdf", - contentType = "application/pdf", - content = function(file) { - ggplot2::ggsave(file = file, plot = systematicErrorSummaryPlot(), width = 12, height = 5.5) - }) - - - } - ) -} diff --git a/R/evidence-synth-main.R b/R/evidence-synth-main.R index 2092517e..c508fe99 100644 --- a/R/evidence-synth-main.R +++ b/R/evidence-synth-main.R @@ -55,6 +55,12 @@ evidenceSynthesisViewer <- function(id=1) { #title = shiny::tagList(shiny::icon("gear"), "Plot and Table"), id = ns('esCohortTabs'), + # diagnostic view + shiny::tabPanel( + title = 'Diagnostics', + resultTableViewer(ns("diagnosticsSummaryTable")) + ), + shiny::tabPanel( "Cohort Method Plot", shiny::plotOutput(ns('esCohortMethodPlot')) @@ -88,7 +94,7 @@ evidenceSynthesisViewer <- function(id=1) { #' #' @param id the unique reference id for the module #' @param connectionHandler a connection to the database with the results -#' @param resultDatabaseSettings a list containing the prediction result schema and connection details +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server for the PatientLevelPrediction module @@ -111,15 +117,11 @@ evidenceSynthesisServer <- function( targetIds <- getESTargetIds( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - cgTablePrefix = resultDatabaseSettings$cgTablePrefix + resultDatabaseSettings = resultDatabaseSettings ) outcomeIds <- getESOutcomeIds( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - cgTablePrefix = resultDatabaseSettings$cgTablePrefix + resultDatabaseSettings = resultDatabaseSettings ) inputSelected <- inputSelectionServer( @@ -128,7 +130,7 @@ evidenceSynthesisServer <- function( createInputSetting( rowNumber = 1, columnWidth = 6, - varName = 'targetId', + varName = 'targetIds', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( label = 'Target: ', @@ -147,7 +149,7 @@ evidenceSynthesisServer <- function( createInputSetting( rowNumber = 1, columnWidth = 6, - varName = 'outcomeId', + varName = 'outcomeIds', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( label = 'Outcome: ', @@ -170,27 +172,41 @@ evidenceSynthesisServer <- function( data <- shiny::reactive({ getCMEstimation( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - databaseMetaData = resultDatabaseSettings$databaseMetaData, - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId + resultDatabaseSettings = resultDatabaseSettings, + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds ) }) data2 <- shiny::reactive({ getMetaEstimation( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - cmTablePrefix = resultDatabaseSettings$cmTablePrefix, - cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - esTablePrefix = resultDatabaseSettings$tablePrefix, - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId + resultDatabaseSettings = resultDatabaseSettings, + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds + ) + }) + + diagSumData <- shiny::reactive({ + getEvidenceSynthDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected, + targetIds = inputSelected()$targetIds, + outcomeIds = inputSelected()$outcomeIds ) }) + + resultTableServer( + id = "diagnosticsSummaryTable", + df = diagSumData, + colDefsInput = getColDefsESDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + ) + output$esCohortMethodPlot <- shiny::renderPlot( createPlotForAnalysis( unique(rbind(data(),data2())) @@ -281,13 +297,9 @@ evidenceSynthesisServer <- function( sccsData <- shiny::reactive({ getSccsEstimation( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - sccsTablePrefix = resultDatabaseSettings$sccsTablePrefix, - cgTablePrefix = resultDatabaseSettings$cgTablePrefix, - esTablePrefix = resultDatabaseSettings$tablePrefix, - databaseMetaData = resultDatabaseSettings$databaseMetaData, - targetId = inputSelected()$targetId, - outcomeId = inputSelected()$outcomeId + resultDatabaseSettings = resultDatabaseSettings, + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds ) }) @@ -369,9 +381,7 @@ evidenceSynthesisServer <- function( getESTargetIds <- function( connectionHandler, - mySchema, - cmTablePrefix, - cgTablePrefix + resultDatabaseSettings ){ sql <- "select distinct @@ -379,17 +389,17 @@ getESTargetIds <- function( r.target_id from - @my_schema.@cm_table_prefixresult as r + @schema.@cm_table_prefixresult as r inner join - @my_schema.@cg_table_prefixcohort_definition as c1 + @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = r.target_id ;" result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - cm_table_prefix = cmTablePrefix, - cg_table_prefix = cgTablePrefix + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) output <- as.list(result$targetId) @@ -401,25 +411,23 @@ getESTargetIds <- function( getESOutcomeIds <- function( connectionHandler, - mySchema, - cmTablePrefix, - cgTablePrefix + resultDatabaseSettings ) { sql <- "select distinct c1.cohort_name as outcome, r.outcome_id from - @my_schema.@cm_table_prefixresult as r + @schema.@cm_table_prefixresult as r inner join - @my_schema.@cm_table_prefixtarget_comparator_outcome as tco + @schema.@cm_table_prefixtarget_comparator_outcome as tco on r.target_id = tco.target_id and r.comparator_id = tco.comparator_id and r.outcome_id = tco.outcome_id inner join - @my_schema.@cg_table_prefixcohort_definition as c1 + @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = r.outcome_id where @@ -428,9 +436,9 @@ getESOutcomeIds <- function( result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - cm_table_prefix = cmTablePrefix, - cg_table_prefix = cgTablePrefix + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) output <- as.list(result$outcomeId) @@ -443,10 +451,7 @@ getESOutcomeIds <- function( getCMEstimation <- function( connectionHandler, - mySchema, - cmTablePrefix = 'cm_', - cgTablePrefix = 'cg_', - databaseMetaData = 'database_meta_data', + resultDatabaseSettings, targetId, outcomeId ){ @@ -466,9 +471,9 @@ getCMEstimation <- function( r.calibrated_log_rr, r.calibrated_se_log_rr from - @my_schema.@cm_table_prefixresult as r + @schema.@cm_table_prefixresult as r inner join - @my_schema.@cm_table_prefixtarget_comparator_outcome as tco + @schema.@cm_table_prefixtarget_comparator_outcome as tco on r.target_id = tco.target_id and r.comparator_id = tco.comparator_id and @@ -476,7 +481,7 @@ getCMEstimation <- function( inner join - @my_schema.@cm_table_prefixdiagnostics_summary as unblind + @schema.@cm_table_prefixdiagnostics_summary as unblind on r.analysis_id = unblind.analysis_id and r.target_id = unblind.target_id and @@ -485,23 +490,23 @@ getCMEstimation <- function( r.database_id = unblind.database_id inner join - @my_schema.@database_meta_data as db + @schema.@database_table as db on db.database_id = r.database_id inner join - @my_schema.@cg_table_prefixcohort_definition as c1 + @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = r.target_id inner join - @my_schema.@cg_table_prefixcohort_definition as c2 + @schema.@cg_table_prefixcohort_definition as c2 on c2.cohort_definition_id = r.comparator_id inner join - @my_schema.@cg_table_prefixcohort_definition as c3 + @schema.@cg_table_prefixcohort_definition as c3 on c3.cohort_definition_id = r.outcome_id inner join - @my_schema.@cm_table_prefixanalysis as a + @schema.@cm_table_prefixanalysis as a on a.analysis_id = r.analysis_id where @@ -514,10 +519,10 @@ getCMEstimation <- function( result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - database_meta_data = databaseMetaData, - cm_table_prefix = cmTablePrefix, - cg_table_prefix = cgTablePrefix, + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, outcome_id = outcomeId, target_id = targetId ) %>% @@ -538,10 +543,7 @@ getCMEstimation <- function( getMetaEstimation <- function( connectionHandler, - mySchema, - cmTablePrefix = 'cm_', - cgTablePrefix = 'cg_', - esTablePrefix = 'es_', + resultDatabaseSettings, targetId, outcomeId ){ @@ -562,9 +564,9 @@ sql <- "select r.calibrated_log_rr, r.calibrated_se_log_rr from - @my_schema.@es_table_prefixcm_result as r + @schema.@es_table_prefixcm_result as r inner join - @my_schema.@cm_table_prefixtarget_comparator_outcome as tco + @schema.@cm_table_prefixtarget_comparator_outcome as tco on r.target_id = tco.target_id and r.comparator_id = tco.comparator_id and @@ -572,7 +574,7 @@ sql <- "select inner join - @my_schema.@es_table_prefixcm_diagnostics_summary as unblind + @schema.@es_table_prefixcm_diagnostics_summary as unblind on r.analysis_id = unblind.analysis_id and r.target_id = unblind.target_id and @@ -580,23 +582,23 @@ sql <- "select r.outcome_id = unblind.outcome_id inner join - @my_schema.@cg_table_prefixcohort_definition as c1 + @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = r.target_id inner join - @my_schema.@cg_table_prefixcohort_definition as c2 + @schema.@cg_table_prefixcohort_definition as c2 on c2.cohort_definition_id = r.comparator_id inner join - @my_schema.@cg_table_prefixcohort_definition as c3 + @schema.@cg_table_prefixcohort_definition as c3 on c3.cohort_definition_id = r.outcome_id inner join - @my_schema.@cm_table_prefixanalysis as a + @schema.@cm_table_prefixanalysis as a on a.analysis_id = r.analysis_id inner join - @my_schema.@es_table_prefixanalysis as ev + @schema.@es_table_prefixanalysis as ev on ev.evidence_synthesis_analysis_id = r.evidence_synthesis_analysis_id where @@ -609,10 +611,10 @@ sql <- "select result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - cm_table_prefix = cmTablePrefix, - cg_table_prefix = cgTablePrefix, - es_table_prefix = esTablePrefix, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + es_table_prefix = resultDatabaseSettings$esTablePrefix, outcome_id = outcomeId, target_id = targetId ) %>% @@ -633,6 +635,10 @@ return(unique(result)) createPlotForAnalysis <- function(data) { + if(is.null(data$comparator)){ + return(NULL) + } + compText <- data.frame( comparatorText = paste0('Comp', 1:length(unique(data$comparator))), comparator = unique(data$comparator) @@ -715,15 +721,15 @@ computeTraditionalP <- function( getSccsEstimation <- function( connectionHandler, - mySchema, - sccsTablePrefix, - cgTablePrefix, - esTablePrefix, - databaseMetaData, + resultDatabaseSettings, targetId, outcomeId ){ + if(is.null(targetId)){ + return(NULL) + } + sql <- "select c1.cohort_name as target, c3.cohort_name as outcome, @@ -739,14 +745,14 @@ getSccsEstimation <- function( r.calibrated_se_log_rr from - @my_schema.@sccs_table_prefixresult as r + @schema.@sccs_table_prefixresult as r inner join - @my_schema.@sccs_table_prefixexposures_outcome_set as eos + @schema.@sccs_table_prefixexposures_outcome_set as eos on r.exposures_outcome_set_id = eos.exposures_outcome_set_id inner join - @my_schema.@sccs_table_prefixcovariate as cov + @schema.@sccs_table_prefixcovariate as cov on r.covariate_id = cov.covariate_id and r.database_id = cov.database_id and @@ -754,14 +760,14 @@ getSccsEstimation <- function( r.exposures_outcome_set_id = cov.exposures_outcome_set_id inner join - @my_schema.@sccs_table_prefixexposure as ex + @schema.@sccs_table_prefixexposure as ex on ex.era_id = cov.era_id and ex.exposures_outcome_set_id = cov.exposures_outcome_set_id inner join - @my_schema.@sccs_table_prefixdiagnostics_summary as unblind + @schema.@sccs_table_prefixdiagnostics_summary as unblind on r.analysis_id = unblind.analysis_id and r.exposures_outcome_set_id = unblind.exposures_outcome_set_id and @@ -769,19 +775,19 @@ getSccsEstimation <- function( r.database_id = unblind.database_id inner join - @my_schema.@database_meta_data as db + @schema.@database_table as db on db.database_id = r.database_id inner join - @my_schema.@cg_table_prefixcohort_definition as c1 + @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = cov.era_id inner join - @my_schema.@cg_table_prefixcohort_definition as c3 + @schema.@cg_table_prefixcohort_definition as c3 on c3.cohort_definition_id = eos.outcome_id inner join - @my_schema.@sccs_table_prefixanalysis as a + @schema.@sccs_table_prefixanalysis as a on a.analysis_id = r.analysis_id where @@ -795,10 +801,10 @@ getSccsEstimation <- function( result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - database_meta_data = databaseMetaData, - sccs_table_prefix = sccsTablePrefix, - cg_table_prefix = cgTablePrefix, + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, outcome_id = outcomeId, target_id = targetId ) @@ -818,28 +824,28 @@ getSccsEstimation <- function( r.calibrated_se_log_rr from - @my_schema.@es_table_prefixsccs_result as r + @schema.@es_table_prefixsccs_result as r inner join - @my_schema.@sccs_table_prefixexposures_outcome_set as eos + @schema.@sccs_table_prefixexposures_outcome_set as eos on r.exposures_outcome_set_id = eos.exposures_outcome_set_id inner join - @my_schema.@sccs_table_prefixcovariate as cov + @schema.@sccs_table_prefixcovariate as cov on r.covariate_id = cov.covariate_id and r.analysis_id = cov.analysis_id and r.exposures_outcome_set_id = cov.exposures_outcome_set_id inner join - @my_schema.@sccs_table_prefixexposure as ex + @schema.@sccs_table_prefixexposure as ex on ex.era_id = cov.era_id and ex.exposures_outcome_set_id = cov.exposures_outcome_set_id inner join - @my_schema.@es_table_prefixsccs_diagnostics_summary as unblind + @schema.@es_table_prefixsccs_diagnostics_summary as unblind on r.analysis_id = unblind.analysis_id and r.exposures_outcome_set_id = unblind.exposures_outcome_set_id and @@ -847,19 +853,19 @@ getSccsEstimation <- function( r.evidence_synthesis_analysis_id = unblind.evidence_synthesis_analysis_id inner join - @my_schema.@cg_table_prefixcohort_definition as c1 + @schema.@cg_table_prefixcohort_definition as c1 on c1.cohort_definition_id = cov.era_id inner join - @my_schema.@cg_table_prefixcohort_definition as c3 + @schema.@cg_table_prefixcohort_definition as c3 on c3.cohort_definition_id = eos.outcome_id inner join - @my_schema.@sccs_table_prefixanalysis as a + @schema.@sccs_table_prefixanalysis as a on a.analysis_id = r.analysis_id inner join - @my_schema.@es_table_prefixanalysis as ev + @schema.@es_table_prefixanalysis as ev on ev.evidence_synthesis_analysis_id = r.evidence_synthesis_analysis_id where @@ -873,10 +879,10 @@ getSccsEstimation <- function( result2 <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - es_table_prefix = esTablePrefix, - sccs_table_prefix = sccsTablePrefix, - cg_table_prefix = cgTablePrefix, + schema = resultDatabaseSettings$schema, + es_table_prefix = resultDatabaseSettings$esTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, outcome_id = outcomeId, target_id = targetId ) @@ -890,6 +896,10 @@ createPlotForSccsAnalysis <- function( data ){ + if(is.null(data)){ + return(NULL) + } + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8) plot <- ggplot2::ggplot( data = data, @@ -922,3 +932,167 @@ createPlotForSccsAnalysis <- function( return(plot) } + +getOACcombinations <- function( + connectionHandler, + resultDatabaseSettings + ){ + + sql <- "SELECT DISTINCT + CONCAT(cma.description, '_', cgcd2.cohort_name) as col_names + FROM + @schema.@cm_table_prefixdiagnostics_summary cmds + INNER JOIN @schema.@cm_table_prefixanalysis cma + ON cmds.analysis_id = cma.analysis_id + INNER JOIN @schema.@cg_table_prefixcohort_definition cgcd2 + ON cmds.comparator_id = cgcd2.cohort_definition_id + + union + + SELECT + CONCAT(a.description, '_', cov.covariate_name) as col_names + + FROM @schema.@sccs_table_prefixdiagnostics_summary ds + + INNER JOIN + @schema.@sccs_table_prefixanalysis a + on a.analysis_id = ds.analysis_id + + INNER JOIN + @schema.@sccs_table_prefixcovariate cov + on cov.covariate_id = ds.covariate_id and + cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and + cov.analysis_id = ds.analysis_id + ;" + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable + ) + + res <- result$colNames + names(res) <- result$colNames + + return(res) +} + +getEvidenceSynthDiagnostics <- function( + connectionHandler, + resultDatabaseSettings, + inputSelected, + targetIds, + outcomeIds + ){ + + if(is.null(targetIds)){ + return(NULL) + } + + sccsDiagTemp <- getSccsAllDiagnosticsSummary( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeIds = outcomeIds + ) + + cmDiagTemp <- getCmDiagnosticsData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + + if(is.null(cmDiagTemp) | is.null(sccsDiagTemp)){ + return(NULL) + } + + # select columns of interest and rename for consistency + sccsDiagTemp <- diagnosticSummaryFormat( + data = shiny::reactive({sccsDiagTemp}), + idCols = c('databaseName','target'), + namesFrom = c('analysis','covariateName','outcome') + ) + + cmDiagTemp <- diagnosticSummaryFormat( + data = shiny::reactive({cmDiagTemp}), + idCols = c('databaseName','target'), + namesFrom = c('analysis','comparator','outcome') + ) + + allResult <- merge( + x = sccsDiagTemp, + y = cmDiagTemp, + by = c('databaseName','target'), + all = T + ) + + # return + return(allResult) +} + + + +getColDefsESDiag <- function( + connectionHandler, + resultDatabaseSettings +){ + + fixedColumns = list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ), + sticky = "left" + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ), + sticky = "left" + ) + ) + + outcomes <- getESOutcomeIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + analyses <- getOACcombinations( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + colnameFormat <- merge(unique(names(analyses)), unique(names(outcomes))) + colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) + + styleList <- lapply( + colnameFormat, + FUN = function(x){ + reactable::colDef( + header = withTooltip( + substring(x,1,40), + x + ), + style = function(value) { + color <- 'orange' + if(is.na(value)){ + color <- 'black' + }else if(value == 'Pass'){ + color <- '#AFE1AF' + }else if(value == 'Fail'){ + color <- '#E97451' + } + list(background = color) + } + ) + } + ) + names(styleList) <- colnameFormat + result <- append(fixedColumns, styleList) + + return(result) +} \ No newline at end of file diff --git a/R/helper-getPredictionProtocol.R b/R/helper-getPredictionProtocol.R index c4a787a4..54eed021 100644 --- a/R/helper-getPredictionProtocol.R +++ b/R/helper-getPredictionProtocol.R @@ -1,9 +1,6 @@ createPredictionProtocol <- function( connectionHandler, - mySchema, - myTableAppend, - databaseTableAppend, - cohortTableAppend, + resultDatabaseSettings, modelDesignId, output, intermediatesDir = file.path(tempdir(), 'plp-prot') @@ -24,11 +21,11 @@ createPredictionProtocol <- function( output_dir = output, params = list( connectionHandler = connectionHandler, - resultSchema = mySchema, - myTableAppend = myTableAppend, + resultSchema = resultDatabaseSettings$schema, + myTableAppend = resultDatabaseSettings$plpTablePrefix, modelDesignIds = modelDesignId, - databaseTableAppend = databaseTableAppend, - cohortTableAppend = cohortTableAppend + databaseTableAppend = resultDatabaseSettings$databaseTablePrefix, + cohortTableAppend = resultDatabaseSettings$cgTablePrefix ) ) diff --git a/R/helpers-cohortGeneratorDataPulls.R b/R/helpers-cohortGeneratorDataPulls.R index 61ae033a..07fcb0a3 100644 --- a/R/helpers-cohortGeneratorDataPulls.R +++ b/R/helpers-cohortGeneratorDataPulls.R @@ -2,43 +2,62 @@ getCohortGeneratorCohortCounts <- function( connectionHandler, - resultsSchema, - tablePrefix = 'cg_', - databaseTable, - databaseTablePrefix + resultDatabaseSettings ) { sql <- "SELECT cc.cohort_id, cc.cohort_entries, cc.cohort_subjects, - dt.cdm_source_name, cd.cohort_name FROM @results_schema.@table_prefixCOHORT_COUNT cc - join @results_schema.@database_table_prefix@database_table dt + dt.cdm_source_name, cd.cohort_name + FROM @schema.@cg_table_prefixCOHORT_COUNT cc + join @schema.@database_table_prefix@database_table dt on cc.database_id = dt.database_id - join @results_schema.@table_prefixCOHORT_DEFINITION cd + join @schema.@cg_table_prefixCOHORT_DEFINITION cd on cd.cohort_definition_id = cc.cohort_id ;" return( connectionHandler$queryDb( sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable, - database_table_prefix = databaseTablePrefix + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) ) } getCohortGeneratorCohortMeta <- function( connectionHandler, - resultsSchema, - tablePrefix = 'cg_' + resultDatabaseSettings ) { - sql <- "SELECT * FROM @results_schema.@table_prefixCOHORT_GENERATION;" - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix + sql <- "SELECT cg.cohort_id, cg.cohort_name, + cg.generation_status, cg.start_time, cg.end_time, dt.cdm_source_name + from @schema.@cg_table_prefixCOHORT_GENERATION cg + join @schema.@database_table_prefix@database_table dt + on cg.database_id = dt.database_id + ;" + + df <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix + ) + + df2 <- df %>% + dplyr::mutate( + generationDuration = dplyr::case_when( + generationStatus == "COMPLETE" + ~ tryCatch( + {difftime(.data$endTime, .data$startTime, units="mins")}, + error = function(e){return(NA)} + ), + T ~ NA ) + ) + + return( + df2 ) } @@ -47,26 +66,24 @@ getCohortGeneratorCohortMeta <- function( getCohortGeneratorCohortInclusionSummary <- function( connectionHandler, - resultsSchema, - tablePrefix = 'cg_', - databaseTable, - databaseTablePrefix + resultDatabaseSettings ) { sql <- "SELECT css.cohort_definition_id, css.base_count, css.final_count, css.mode_id, - dt.cdm_source_name, cd.cohort_name FROM @results_schema.@table_prefixCOHORT_SUMMARY_STATS css - join @results_schema.@database_table_prefix@database_table dt + dt.cdm_source_name, cd.cohort_name + FROM @schema.@cg_table_prefixCOHORT_SUMMARY_STATS css + join @schema.@database_table_prefix@database_table dt on css.database_id = dt.database_id - join @results_schema.@table_prefixCOHORT_DEFINITION cd + join @schema.@cg_table_prefixCOHORT_DEFINITION cd on cd.cohort_definition_id = css.cohort_definition_id ;" return( connectionHandler$queryDb( sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable, - database_table_prefix = databaseTablePrefix + schema =resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) ) } @@ -75,44 +92,40 @@ getCohortGeneratorCohortInclusionSummary <- function( getCohortGeneratorInclusionRules <- function( connectionHandler, - resultsSchema, - tablePrefix = 'cg_' + resultDatabaseSettings ) { sql <- "SELECT ci.cohort_definition_id, ci.rule_sequence, ci.name as rule_name, - cd.cohort_name FROM @results_schema.@table_prefixCOHORT_INCLUSION ci - join @results_schema.@table_prefixCOHORT_DEFINITION cd + cd.cohort_name FROM @schema.@cg_table_prefixCOHORT_INCLUSION ci + join @schema.@cg_table_prefixCOHORT_DEFINITION cd on cd.cohort_definition_id = ci.cohort_definition_id ;" return( connectionHandler$queryDb( sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) ) } getCohortGeneratorInclusionStats <- function( connectionHandler, - resultsSchema, - tablePrefix = 'cg_', - databaseTable, - databaseTablePrefix + resultDatabaseSettings ) { sql <- "SELECT cir.database_id, cir.cohort_definition_id, cir.inclusion_rule_mask, cir.person_count, cir.mode_id, - dt.cdm_source_name FROM @results_schema.@table_prefixCOHORT_INC_RESULT cir - join @results_schema.@database_table_prefix@database_table dt + dt.cdm_source_name FROM @schema.@cg_table_prefixCOHORT_INC_RESULT cir + join @schema.@database_table_prefix@database_table dt on cir.database_id = dt.database_id ;" return( connectionHandler$queryDb( sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable, - database_table_prefix = databaseTablePrefix + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) ) } @@ -128,8 +141,8 @@ getCohortGenerationAttritionTable <- function( for(cohortId in uniqueCohortIDs){ - cohortRules <- rules %>% - dplyr::filter(.data$cohortDefinitionId == !!cohortId) %>% + cohortRules <- rules %>% + dplyr::filter(.data$cohortDefinitionId==cohortId) %>% dplyr::select("ruleSequence", "ruleName", "cohortName") %>% dplyr::arrange("ruleSequence") @@ -144,7 +157,7 @@ getCohortGenerationAttritionTable <- function( attritionRows <- stats %>% dplyr::filter((.data$cohortDefinitionId == !!cohortId) & (bitwAnd(.data$inclusionRuleMask, !!testMask) == !!testMask) - ) %>% + ) %>% dplyr::select(-c("databaseId")) %>% dplyr::group_by(.data$cdmSourceName, .data$cohortDefinitionId, .data$modeId) %>% dplyr::summarise(personCount = sum(.data$personCount), @@ -175,8 +188,8 @@ getCohortGenerationAttritionTable <- function( #adding drop counts attritionTableFinal <- attritionTableDistinct %>% dplyr::group_by( - .data$cdmSourceName, - .data$cohortDefinitionId, + .data$cdmSourceName, + .data$cohortDefinitionId, .data$modeId) %>% dplyr::mutate( dropCount = dplyr::case_when( @@ -185,9 +198,9 @@ getCohortGenerationAttritionTable <- function( ), dropPerc = dplyr::case_when( is.na(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) ~ "0.00%", - TRUE ~ paste( + TRUE ~ paste( round( - (.data$dropCount/(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) * 100), + (.data$dropCount/(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) * 100), digits = 2 ), "%", @@ -197,7 +210,7 @@ getCohortGenerationAttritionTable <- function( is.na(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) ~ "100.00%", TRUE ~ paste( round( - (.data$personCount/(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) * 100), + (.data$personCount/(dplyr::lag(.data$personCount, order_by = .data$ruleSequence)) * 100), digits = 2 ), "%", @@ -205,6 +218,7 @@ getCohortGenerationAttritionTable <- function( ) ) + #newdata <- mtcars[order(mpg, -cyl),] return(attritionTableFinal[order(attritionTableFinal$ruleSequence),]) } diff --git a/R/helpers-componentsCreateCustomColDefList.R b/R/helpers-componentsCreateCustomColDefList.R new file mode 100644 index 00000000..e17f7c30 --- /dev/null +++ b/R/helpers-componentsCreateCustomColDefList.R @@ -0,0 +1,92 @@ +#' Creating a list of custom column definitions for use in reactables +#' +#' @param rawColNames The raw column names taken directly from the source +#' data table that are to be overwritten in the reactable +#' @param niceColNames The formatted column names that will appear as-specified in +#' the reactable +#' @param tooltipText The text to be displayed in a toolTip when hovering over the +#' column in the reactable +#' @param case Optional argument to convert raw column names to snake or camel case. Defaults to NULL and preserves +#' whatever raw column names are passed in +#' @param customColDefOptions A list of lists, where the inner lists are any custom options from +#' reactable::colDef for each column +#' +#' @return A named list of reactable::colDef objects +#' @export +#' +createCustomColDefList <- function(rawColNames, niceColNames = NULL, + tooltipText = NULL, case = NULL, + customColDefOptions = NULL) { + withTooltip <- function(value, tooltip, ...) { + shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", + tippy::tippy(value, tooltip, ...)) + } + + if (is.null(niceColNames)) { + niceColNames <- rawColNames + } + + if (is.null(tooltipText)) { + tooltipText <- rep("", length(rawColNames)) + } + + if (!is.null(case)) { + if (case == "snakeCaseToCamelCase") { + rawColNames <- SqlRender::snakeCaseToCamelCase(rawColNames) + } else if (case == "camelCaseToSnakeCase") { + rawColNames <- SqlRender::camelCaseToSnakeCase(rawColNames) + } + } + + result <- vector("list", length(rawColNames)) + + if (is.null(customColDefOptions)) { + customColDefOptions <- vector("list", length(rawColNames)) + for (i in seq_along(rawColNames)) { + customColDefOptions[[i]] <- list() + } + } + + for (i in seq_along(rawColNames)) { + colDefOptions <- c( + list(name = rawColNames[[i]], header = withTooltip(niceColNames[[i]], tooltipText[[i]])), + customColDefOptions[[i]] + ) + + result[[i]] <- do.call(reactable::colDef, colDefOptions) + } + + names(result) <- rawColNames + + return(result) +} + + +# examples +# Define custom column definitions +# customColDefs <- createCustomColDefList( +# rawColNames = mydf$raw, +# niceColNames = c("Name", "Age", "Country"), +# tooltipText = c("Person's Name", "Person's Age", "Country"), +# customColDefOptions = list( +# list(NULL), # No aggregation for "Name" column +# list(aggregate = "mean"), # Aggregate "Age" column using mean +# list(NULL) # No aggregation for "Country" column +# ) +# ) + +# use the below as a guide to save named colDef list as JSON then read it back! +# test <- ParallelLogger::saveSettingsToJson(colDefs, "./inst/components-columnInformation/test.json") +#loadTest <- ParallelLogger::loadSettingsFromJson("./inst/components-columnInformation/test.json") + + +#' Make a label for an html button +#' +#' @param label The desired label for hte button +#' +#' @return html code to make a button label +#' @export +#' +makeButtonLabel <- function(label) { + as.character(htmltools::tags$div(htmltools::tags$button(paste(label)))) +} \ No newline at end of file diff --git a/R/helpers-estimationDataPulls.R b/R/helpers-estimationDataPulls.R deleted file mode 100644 index 5988c566..00000000 --- a/R/helpers-estimationDataPulls.R +++ /dev/null @@ -1,668 +0,0 @@ - -getCohortNameFromId <- function(connectionHandler, resultsSchema, cohortTablePrefix, cohortId) { - sql <- " - SELECT - cohort_name - FROM - @results_schema.@cohort_table_prefixcohort_definition cd - WHERE - cd.cohort_definition_id = @cohort_id; - " - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - cohort_table_prefix = cohortTablePrefix, - cohort_id = cohortId - ) - ) -} - - -getEstimationTcoChoice <- function(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, tcoVar, sorted = TRUE) { - sql <- " - SELECT - DISTINCT - cmtco.@tco_var, - cd.cohort_name -FROM - @results_schema.@table_prefixtarget_comparator_outcome cmtco - join @results_schema.@cohort_table_prefixcohort_definition cd on cmtco.@tco_var = cd.cohort_definition_id - " - - if (sorted) { - sql <- paste(sql, "ORDER BY\n cd.cohort_name desc;", collapse = "\n") - } else{ - sql <- paste(sql, ';') - } - - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix, - tco_var = tcoVar - ) - ) -} - - -getEstimationTargetChoices <- function(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix) { - return( - getEstimationTcoChoice(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, "target_id") - ) -} - - -getEstimationComparatorChoices <- function(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix) { - return( - getEstimationTcoChoice(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, "comparator_id") - ) -} - - -getEstimationOutcomeChoices <- function(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix) { - return( - getEstimationTcoChoice(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, "outcome_id") - ) -} - - -getEstimationDatabaseChoices <- function(connectionHandler, resultsSchema, tablePrefix, databaseTable, sorted = TRUE) { - sql <- " -SELECT -DISTINCT -dmd.database_id, -dmd.cdm_source_abbreviation -FROM - @results_schema.@table_prefixresult cmr - join @results_schema.@database_table dmd on dmd.database_id = cmr.database_id - - " - - if (sorted) { - sql <- paste(sql, "ORDER BY\n dmd.cdm_source_abbreviation desc;", collapse = "\n") - } else{ - sql <- paste(sql, ';') - } - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable - ) - ) -} - - -getCmAnalysisOptions <- function(connectionHandler, resultsSchema, tablePrefix, sorted = TRUE) { - sql <- " -SELECT -DISTINCT -cma.analysis_id, -cma.description -FROM - @results_schema.@table_prefixanalysis cma - " - - if (sorted) { - sql <- paste(sql, "ORDER BY\n cma.description desc;", collapse = "\n") - } else{ - sql <- paste(sql, ';') - } - - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix - ) - ) -} - -getAllEstimationResults <- function(connectionHandler, resultsSchema, tablePrefix, databaseTable) { - sql <- " -SELECT - cma.analysis_id, - cma.description description, - dmd.database_id database_id, -- break? - dmd.cdm_source_abbreviation cdm_source_abbreviation, - cmr.rr rr, - cmr.ci_95_lb ci_95_lb, - cmr.ci_95_ub ci_95_ub, - cmr.p p, - cmr.log_rr, - cmr.se_log_rr, - cmr.target_subjects, - cmr.comparator_subjects, - cmr.target_days, - cmr.comparator_days, - cmr.target_outcomes, - cmr.comparator_outcomes, - cmr.calibrated_rr calibrated_rr, - cmr.calibrated_ci_95_lb calibrated_ci_95_lb, - cmr.calibrated_ci_95_ub calibrated_ci_95_ub, - cmr.calibrated_p calibrated_p, - cmr.calibrated_log_rr, - cmr.calibrated_se_log_rr, - COALESCE(cmds.unblind, 0) unblind -- TODO: assume unblinded? (or always populated and moot) -FROM - @results_schema.@table_prefixanalysis cma - JOIN @results_schema.@table_prefixresult cmr on cmr.analysis_id = cma.analysis_id - JOIN @results_schema.@database_table dmd on dmd.database_id = cmr.database_id - LEFT JOIN @results_schema.@table_prefixdiagnostics_summary cmds on cmds.analysis_id = cmr.analysis_id; - " - - - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable - ) - ) -} - - -getEstimationMainResults <- function(connectionHandler, - resultsSchema, - tablePrefix, - databaseTable, - targetIds = c(), - comparatorIds = c(), - outcomeIds = c(), - databaseIds = c(), - analysisIds = c()) { - - sql <- " -SELECT - cma.analysis_id, - cma.description description, - dmd.database_id database_id, -- break? - dmd.cdm_source_abbreviation cdm_source_abbreviation, - cmr.rr rr, - cmr.ci_95_lb ci_95_lb, - cmr.ci_95_ub ci_95_ub, - cmr.p p, - cmr.log_rr, - cmr.se_log_rr, - cmr.target_subjects, - cmr.comparator_subjects, - cmr.target_days, - cmr.comparator_days, - cmr.target_outcomes, - cmr.comparator_outcomes, - cmr.calibrated_rr calibrated_rr, - cmr.calibrated_ci_95_lb calibrated_ci_95_lb, - cmr.calibrated_ci_95_ub calibrated_ci_95_ub, - cmr.calibrated_p calibrated_p, - cmr.calibrated_log_rr, - cmr.calibrated_se_log_rr, - COALESCE(cmds.unblind, 0) unblind -- TODO: assume unblinded? (or always populated and moot) -FROM - @results_schema.@table_prefixanalysis cma - JOIN @results_schema.@table_prefixresult cmr on cmr.analysis_id = cma.analysis_id - JOIN @results_schema.@database_table dmd on dmd.database_id = cmr.database_id - LEFT JOIN @results_schema.@table_prefixdiagnostics_summary cmds on cmds.analysis_id = cmr.analysis_id - AND cmds.target_id = cmr.target_id - AND cmds.comparator_id = cmr.comparator_id - AND cmds.outcome_id = cmr.outcome_id - AND cmds.database_id = cmr.database_id - " - if (length(targetIds) > 0 || - length(comparatorIds) > 0 || - length(outcomeIds) > 0 || - length(databaseIds) > 0 || - length(analysisIds) > 0) { - sql <- paste0(sql, "\nWHERE\n\t") - } - - clauses <- c() - if (length(targetIds) > 0 ) { - clauses <- c(clauses, "cmr.target_id IN (@target_ids)\n\t") - } - if (length(comparatorIds) > 0) { - clauses <- c(clauses, "cmr.comparator_id IN (@comparator_ids)\n\t") - } - if (length(outcomeIds) > 0) { - clauses <- c(clauses, "cmr.outcome_id IN (@outcome_ids)\n\t") - } - if (length(databaseIds) > 0) { - clauses <- c(clauses, "cmr.database_id IN (@database_ids)\n\t") - } - if (length(analysisIds) > 0) { - clauses <- c(clauses, "cmr.analysis_id IN (@analysis_ids)\n\t") - } - sql <- paste0(sql, paste(clauses, collapse = " AND "), ";") - return( - suppressWarnings( # ignoring warnings due to parameter not found - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable, - target_ids = paste0("'", paste(targetIds, collapse = "', '"), "'"), - comparator_ids = paste0("'", paste(comparatorIds, collapse = "', '"), "'"), - outcome_ids = paste0("'", paste(outcomeIds, collapse = "', '"), "'"), - database_ids = paste0("'", paste(databaseIds, collapse = "', '"), "'"), - analysis_ids = paste0("'", paste(analysisIds, collapse = "', '"), "'") - ) - ) - ) - -} - - -getCohortMethodAnalyses <- function(connectionHandler, resultsSchema, tablePrefix) { - sql <- " - SELECT - cma.* - FROM - @results_schema.@table_prefixanalysis cma - " - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix - ) - ) -} - - -getEstimationSubgroupResults <- function(connectionHandler, # not used? - targetIds = c(), - comparatorIds = c(), - outcomeIds = c(), - databaseIds = c(), - analysisIds = c(), - subgroupIds = c(), - estimatesOnly = FALSE, - cmInteractionResult = c(), # added to clean check - covariate = c() # added to clean check - ) { - idx <- rep(TRUE, nrow(cmInteractionResult)) - if (length(targetIds) != 0) { - idx <- idx & cmInteractionResult$targetId %in% targetIds - } - if (length(comparatorIds) != 0) { - idx <- idx & cmInteractionResult$comparatorId %in% comparatorIds - } - if (length(outcomeIds) != 0) { - idx <- idx & cmInteractionResult$outcomeId %in% outcomeIds - } - if (length(databaseIds) != 0) { - idx <- idx & cmInteractionResult$databaseId %in% databaseIds - } - if (length(analysisIds) != 0) { - idx <- idx & cmInteractionResult$analysisId %in% analysisIds - } - if (length(subgroupIds) != 0) { - idx <- idx & cmInteractionResult$interactionCovariateId %in% subgroupIds - } - result <- cmInteractionResult[idx, ] - result <- merge(result, data.frame(interactionCovariateId = covariate$covariateId, - databaseId = covariate$databaseId, - covariateName = covariate$covariateName)) - result <- result[, c("covariateName", - "targetSubjects", - "comparatorSubjects", - "rrr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedP")] - colnames(result) <- c("interactionCovariateName", - "targetSubjects", - "comparatorSubjects", - "rrr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedP") - return(result) -} - - -getEstimationControlResults <- function(connectionHandler, resultsSchema, tablePrefix, targetId, - comparatorId, analysisId, databaseId = NULL, - includePositiveControls = TRUE, emptyAsNa = TRUE) { - - sql <- " - SELECT - cmr.*, - cmtco.true_effect_size effect_size - FROM - @results_schema.@table_prefixresult cmr - JOIN @results_schema.@table_prefixtarget_comparator_outcome cmtco ON cmr.target_id = cmtco.target_id AND cmr.comparator_id = cmtco.comparator_id AND cmr.outcome_id = cmtco.outcome_id - WHERE - cmtco.outcome_of_interest != 1 - AND cmr.target_id = @target_id - AND cmr.comparator_id = @comparator_id - AND cmr.analysis_id = @analysis_id - " - - - if (!is.null(databaseId)) { - # update sql - sql <- paste(sql, paste("AND cmr.database_id = '@database_id'"), collapse = "\n") - } - - if (!includePositiveControls) { - # update sql - sql <- paste(sql, paste("AND cmtco.true_effect_size = 1"), collapse = "\n") - } - - results <- connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - target_id = targetId, - comparator_id = comparatorId, - analysis_id = analysisId, - database_id = databaseId - ) - - if (emptyAsNa) { - results[results == ''] <- NA - } - - return(results) -} - - -getCmFollowUpDist <- function(connectionHandler, - resultsSchema, - tablePrefix, - targetId, - comparatorId, - outcomeId, - databaseId = NULL, - analysisId) { - - sql <- " - SELECT - * - FROM - @results_schema.@table_prefixfollow_up_dist cmfud - WHERE - cmfud.target_id = @target_id - AND cmfud.comparator_id = @comparator_id - AND cmfud.outcome_id = @outcome_id - AND cmfud.analysis_id = @analysis_id - " - if(!is.null(databaseId)) { - sql <- paste(sql, paste("AND cmfud.database_id = '@database_id'"), collapse = "\n") - } - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - target_id = targetId, - comparator_id = comparatorId, - outcome_id = outcomeId, - analysis_id = analysisId, - database_id = databaseId - ) - ) -} - - - - -getEstimationPs <- function(connectionHandler, resultsSchema, tablePrefix, targetId, comparatorId, analysisId, databaseId = NULL) { - sql <- " - SELECT - * - FROM - @results_schema.@table_prefixpreference_score_dist cmpsd - WHERE - cmpsd.target_id = @target_id - AND cmpsd.comparator_id = @comparator_id - AND cmpsd.analysis_id = @analysis_id - " - if(!is.null(databaseId)) { - sql <- paste(sql, paste("AND cmpsd.database_id = '@database_id'"), collapse = "\n") - } - - - ps <- connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - target_id = targetId, - comparator_id = comparatorId, - analysis_id = analysisId, - database_id = databaseId - ) - - - if (!is.null(databaseId)) { - ps$databaseId <- NULL - } - return(ps) -} - - -getEstimationKaplanMeier <- function(connectionHandler, resultsSchema, tablePrefix, databaseTable, targetId, comparatorId, outcomeId, databaseId, analysisId) { - sqlTmp <- " - SELECT - * - FROM - @results_schema.@table_prefixkaplan_meier_dist cmkmd - JOIN @results_schema.@database_table dmd on dmd.database_id = cmkmd.database_id - WHERE - cmkmd.target_id = @target_id - AND cmkmd.comparator_id = @comparator_id - AND cmkmd.outcome_id = @outcome_id - AND cmkmd.analysis_id = @analysis_id - AND dmd.cdm_source_abbreviation = '@database_id'; - " - sql <- " - SELECT - * - FROM - @results_schema.@table_prefixkaplan_meier_dist cmkmd - WHERE - cmkmd.target_id = @target_id - AND cmkmd.comparator_id = @comparator_id - AND cmkmd.outcome_id = @outcome_id - AND cmkmd.analysis_id = @analysis_id - AND cmkmd.database_id = '@database_id'; - " - - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable, - target_id = targetId, - comparator_id = comparatorId, - outcome_id = outcomeId, - analysis_id = analysisId, - database_id = databaseId - ) - ) -} - - -getEstimationAttrition <- function(connectionHandler, resultsSchema, tablePrefix, databaseTable, targetId, comparatorId, outcomeId, analysisId, databaseId) { - sqlTmp <- " - SELECT - cmat.* - FROM - @results_schema.@table_prefixattrition cmat - JOIN @results_schema.@database_table dmd on dmd.database_id = cmat.database_id - WHERE - cmat.target_id = @target_id - AND cmat.comparator_id = @comparator_id - AND cmat.outcome_id = @outcome_id - AND cmat.analysis_id = @analysis_id - AND dmd.cdm_source_abbreviation = '@database_id'; - " - sql <- " - SELECT - cmat.* - FROM - @results_schema.@table_prefixattrition cmat - WHERE - cmat.target_id = @target_id - AND cmat.comparator_id = @comparator_id - AND cmat.outcome_id = @outcome_id - AND cmat.analysis_id = @analysis_id - AND cmat.database_id = '@database_id'; - " - result <- connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - database_table = databaseTable, - target_id = targetId, - comparator_id = comparatorId, - outcome_id = outcomeId, - analysis_id = analysisId, - database_id = databaseId - ) - targetAttrition <- result[result$exposureId == targetId, ] - comparatorAttrition <- result[result$exposureId == comparatorId, ] - colnames(targetAttrition)[colnames(targetAttrition) == "subjects"] <- "targetPersons" - targetAttrition$exposureId <- NULL - colnames(comparatorAttrition)[colnames(comparatorAttrition) == "subjects"] <- "comparatorPersons" - comparatorAttrition$exposureId <- NULL - result <- merge(targetAttrition, comparatorAttrition) - result <- result[order(result$sequenceNumber), ] - return(result) -} - - -getEstimationStudyPeriod <- function(connectionHandler, targetId, comparatorId, databaseId) { - sql <- "SELECT min_date, - max_date - FROM comparison_summary - WHERE target_id = @target_id - AND comparator_id = @comparator_id - AND database_id = '@database_id';" - - studyPeriod <- connectionHandler$queryDb( - sql = sql, - target_id = targetId, - comparator_id = comparatorId, - database_id = databaseId - ) - return(studyPeriod) -} - - -getEstimationPropensityModel <- function(connectionHandler, resultsSchema, tablePrefix, targetId, comparatorId, analysisId, databaseId) { - sqlTmp <- " - SELECT - cmpm.coefficient, - cmc.covariate_id, - cmc.covariate_name - FROM - @results_schema.@table_prefixcovariate cmc - JOIN @results_schema.@table_prefixpropensity_model cmpm ON cmc.covariate_id = cmpm.covariate_id AND cmc.database_id = cmpm.database_id - WHERE - cmpm.target_id = @target_id - AND cmpm.comparator_id = @comparator_id - AND cmpm.analysis_id = @analysis_id - AND cmpm.database_id = '@database_id' - " - - sql <- " - SELECT - cmc.covariate_id, - cmc.covariate_name, - cmpm.coefficient - FROM - ( - SELECT - covariate_id, - covariate_name - FROM - @results_schema.@table_prefixcovariate - WHERE - analysis_id = @analysis_id - AND database_id = '@database_id' - UNION - SELECT - 0 as covariate_id, - 'intercept' as covariate_name) cmc - JOIN @results_schema.@table_prefixpropensity_model cmpm ON cmc.covariate_id = cmpm.covariate_id - WHERE - cmpm.target_id = @target_id - AND cmpm.comparator_id = @comparator_id - AND cmpm.analysis_id = @analysis_id - AND cmpm.database_id = '@database_id' - " - - model <- connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - target_id = targetId, - comparator_id = comparatorId, - analysis_id = analysisId, - database_id = databaseId - ) - return(model) -} - - - - -getEstimationNegativeControlEstimates <- function(cohortMethodResult, connectionHandler, targetId, comparatorId, analysisId) { - subset <- getEstimationControlResults(cohortMethodResult, connectionHandler, targetId, comparatorId, analysisId, includePositiveControls = FALSE) - subset <- subset[, c("databaseId", "logRr", "seLogRr")] - if(nrow(subset) == 0) - return(NULL) - return(subset) -} - - - -getDiagnosticsData <- function(connectionHandler, resultsSchema, tablePrefix, cohortTablePrefix, databaseTable) { - sql <- " - SELECT - dmd.cdm_source_abbreviation database_name, - cma.description analysis_desc, - cgcd1.cohort_name target, - cgcd2.cohort_name comparator, - cgcd3.cohort_name outcome, - cmds.max_sdm, - cmds.shared_max_sdm, - cmds.equipoise, - cmds.mdrr, - cmds.attrition_fraction, - cmds.ease, - cmds.balance_diagnostic, - cmds.shared_balance_diagnostic, - cmds.equipoise_diagnostic, - cmds.mdrr_diagnostic, - cmds.attrition_diagnostic, - cmds.ease_diagnostic, - cmds.unblind - FROM - @results_schema.@table_prefixdiagnostics_summary cmds - JOIN @results_schema.@table_prefixanalysis cma ON cmds.analysis_id = cma.analysis_id - JOIN @results_schema.@database_table dmd ON dmd.database_id = cmds.database_id - JOIN @results_schema.@cohort_table_prefixcohort_definition cgcd1 ON cmds.target_id = cgcd1.cohort_definition_id - JOIN @results_schema.@cohort_table_prefixcohort_definition cgcd2 ON cmds.comparator_id = cgcd2.cohort_definition_id - JOIN @results_schema.@cohort_table_prefixcohort_definition cgcd3 ON cmds.outcome_id = cgcd3.cohort_definition_id - " - - return( - connectionHandler$queryDb( - sql = sql, - results_schema = resultsSchema, - table_prefix = tablePrefix, - cohort_table_prefix = cohortTablePrefix, - database_table = databaseTable - ) - ) -} diff --git a/R/helpers-estimationPlotsAndTables.R b/R/helpers-estimationPlotsAndTables.R deleted file mode 100644 index 5bee185e..00000000 --- a/R/helpers-estimationPlotsAndTables.R +++ /dev/null @@ -1,614 +0,0 @@ -# used in estimation-power -prepareEstimationFollowUpDistTable <- function(followUpDist) { - targetRow <- data.frame(Database = followUpDist$databaseId, - Cohort = "Target", - Min = followUpDist$targetMinDays, - P10 = followUpDist$targetP10Days, - P25 = followUpDist$targetP25Days, - Median = followUpDist$targetMedianDays, - P75 = followUpDist$targetP75Days, - P90 = followUpDist$targetP90Days, - Max = followUpDist$targetMaxDays) - comparatorRow <- data.frame(Database = followUpDist$databaseId, - Cohort = "Comparator", - Min = followUpDist$comparatorMinDays, - P10 = followUpDist$comparatorP10Days, - P25 = followUpDist$comparatorP25Days, - Median = followUpDist$comparatorMedianDays, - P75 = followUpDist$comparatorP75Days, - P90 = followUpDist$comparatorP90Days, - Max = followUpDist$comparatorMaxDays) - table <- rbind(targetRow, comparatorRow) - table$Min <- formatC(table$Min, big.mark = ",", format = "d") - table$P10 <- formatC(table$P10, big.mark = ",", format = "d") - table$P25 <- formatC(table$P25, big.mark = ",", format = "d") - table$Median <- formatC(table$Median, big.mark = ",", format = "d") - table$P75 <- formatC(table$P75, big.mark = ",", format = "d") - table$P90 <- formatC(table$P90, big.mark = ",", format = "d") - table$Max <- formatC(table$Max, big.mark = ",", format = "d") - if (length(unique(followUpDist$databaseId)) == 1) - table$Database <- NULL - return(table) -} - - -# used in estimation-power -prepareEstimationPowerTable <- function(mainResults, connectionHandler , resultsSchema, tablePrefix) { - analyses <- getCohortMethodAnalyses(connectionHandler , resultsSchema, tablePrefix) - table <- merge(mainResults, analyses) - alpha <- 0.05 - power <- 0.8 - z1MinAlpha <- stats::qnorm(1 - alpha/2) - zBeta <- -stats::qnorm(1 - power) - pA <- table$targetSubjects/(table$targetSubjects + table$comparatorSubjects) - pB <- 1 - pA - totalEvents <- abs(table$targetOutcomes) + abs(table$comparatorOutcomes) - table$mdrr <- exp(sqrt((zBeta + z1MinAlpha)^2/(totalEvents * pA * pB))) - table$targetYears <- table$targetDays/365.25 - table$comparatorYears <- table$comparatorDays/365.25 - table$targetIr <- 1000 * table$targetOutcomes/table$targetYears - table$comparatorIr <- 1000 * table$comparatorOutcomes/table$comparatorYears - table <- table[, c("description", - "databaseId", - "targetSubjects", - "comparatorSubjects", - "targetYears", - "comparatorYears", - "targetOutcomes", - "comparatorOutcomes", - "targetIr", - "comparatorIr", - "mdrr")] - table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") - table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") - table$targetYears <- formatC(table$targetYears, big.mark = ",", format = "d") - table$comparatorYears <- formatC(table$comparatorYears, big.mark = ",", format = "d") - table$targetOutcomes <- formatC(table$targetOutcomes, big.mark = ",", format = "d") - table$comparatorOutcomes <- formatC(table$comparatorOutcomes, big.mark = ",", format = "d") - table$targetIr <- sprintf("%.2f", table$targetIr) - table$comparatorIr <- sprintf("%.2f", table$comparatorIr) - table$mdrr <- sprintf("%.2f", table$mdrr) - table$targetSubjects <- gsub("^-", "<", table$targetSubjects) - table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) - table$targetOutcomes <- gsub("^-", "<", table$targetOutcomes) - table$comparatorOutcomes <- gsub("^-", "<", table$comparatorOutcomes) - table$targetIr <- gsub("^-", "<", table$targetIr) - table$comparatorIr <- gsub("^-", "<", table$comparatorIr) - idx <- (table$targetOutcomes < 0 | table$comparatorOutcomes < 0) - table$mdrr[idx] <- paste0(">", table$mdrr[idx]) - return(table) -} - -# estimation-subgroups -prepareEstimationSubgroupTable <- function(subgroupResults, output = "latex") { - rnd <- function(x) { - ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) - } - - subgroupResults$hrr <- paste0(rnd(subgroupResults$rrr), - " (", - rnd(subgroupResults$ci95Lb), - " - ", - rnd(subgroupResults$ci95Ub), - ")") - - subgroupResults$hrr[is.na(subgroupResults$rrr)] <- "" - subgroupResults$p <- sprintf("%.2f", subgroupResults$p) - subgroupResults$p[subgroupResults$p == "NA"] <- "" - subgroupResults$calibratedP <- sprintf("%.2f", subgroupResults$calibratedP) - subgroupResults$calibratedP[subgroupResults$calibratedP == "NA"] <- "" - - if (any(grepl("on-treatment", subgroupResults$analysisDescription)) && - any(grepl("intent-to-treat", subgroupResults$analysisDescription))) { - idx <- grepl("on-treatment", subgroupResults$analysisDescription) - onTreatment <- subgroupResults[idx, c("interactionCovariateName", - "targetSubjects", - "comparatorSubjects", - "hrr", - "p", - "calibratedP")] - itt <- subgroupResults[!idx, c("interactionCovariateName", "hrr", "p", "calibratedP")] - colnames(onTreatment)[4:6] <- paste("onTreatment", colnames(onTreatment)[4:6], sep = "_") - colnames(itt)[2:4] <- paste("itt", colnames(itt)[2:4], sep = "_") - table <- merge(onTreatment, itt) - } else { - table <- subgroupResults[, c("interactionCovariateName", - "targetSubjects", - "comparatorSubjects", - "hrr", - "p", - "calibratedP")] - } - table$interactionCovariateName <- gsub("Subgroup: ", "", table$interactionCovariateName) - if (output == "latex") { - table$interactionCovariateName <- gsub(">=", "$\\\\ge$ ", table$interactionCovariateName) - } - table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") - table$targetSubjects <- gsub("^-", "<", table$targetSubjects) - table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") - table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) - table$comparatorSubjects <- gsub("^<", "$<$", table$comparatorSubjects) - return(table) -} - - - - - - -# estiamtion-covariateBal -plotEstimationCovariateBalanceSummary <- function(balanceSummary, - threshold = 0, - beforeLabel = "Before matching", - afterLabel = "After matching") { - balanceSummary <- balanceSummary[rev(order(balanceSummary$databaseId)), ] - dbs <- data.frame(databaseId = unique(balanceSummary$databaseId), - x = 1:length(unique(balanceSummary$databaseId))) - vizData <- merge(balanceSummary, dbs) - - vizData$type <- factor(vizData$type, levels = c(beforeLabel, afterLabel)) - - plot <- ggplot2::ggplot(vizData, ggplot2::aes(x = .data$x, - ymin = .data$ymin, - lower = .data$lower, - middle = .data$median, - upper = .data$upper, - ymax = .data$ymax, - group = .data$databaseId)) + - ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), size = 1) + - ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), size = 1) + - ggplot2::geom_boxplot(stat = "identity", fill = grDevices::rgb(0, 0, 0.8, alpha = 0.25), size = 1) + - ggplot2::geom_hline(yintercept = 0) + - ggplot2::scale_x_continuous(limits = c(0.5, max(vizData$x) + 1.75)) + - ggplot2::scale_y_continuous("Standardized difference of mean") + - ggplot2::coord_flip() + - ggplot2::facet_grid(~type) + - ggplot2::theme(panel.grid.major.y = ggplot2::element_blank(), - panel.grid.minor.y = ggplot2::element_blank(), - panel.grid.major.x = ggplot2::element_line(color = "#AAAAAA"), - panel.background = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(size = 11), - axis.title.x = ggplot2::element_text(size = 11), - axis.ticks.x = ggplot2::element_line(color = "#AAAAAA"), - strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(size = 11), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) - - if (threshold != 0) { - plot <- plot + ggplot2::geom_hline(yintercept = c(threshold, -threshold), linetype = "dotted") - } - after <- vizData[vizData$type == afterLabel, ] - after$max <- pmax(abs(after$ymin), abs(after$ymax)) - text <- data.frame(y = rep(c(after$x, nrow(after) + 1.25) , 3), - x = rep(c(1,2,3), each = nrow(after) + 1), - label = c(c(as.character(after$databaseId), - "Source", - formatC(after$covariateCount, big.mark = ",", format = "d"), - "Covariate\ncount", - formatC(after$max, digits = 2, format = "f"), - paste(afterLabel, "max(absolute)", sep = "\n"))), - dummy = "") - - data_table <- ggplot2::ggplot(text, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label)) + - ggplot2::geom_text(size = 4, hjust=0, vjust=0.5) + - ggplot2::geom_hline(ggplot2::aes(yintercept=nrow(after) + 0.5)) + - ggplot2::theme(panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.position = "none", - panel.border = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(colour="white"), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_line(colour="white"), - strip.background = ggplot2::element_blank(), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + - ggplot2::labs(x="",y="") + - ggplot2::facet_grid(~dummy) + - ggplot2::coord_cartesian(xlim=c(1,4), ylim = c(0.5, max(vizData$x) + 1.75)) - - plot <- gridExtra::grid.arrange(data_table, plot, ncol = 2) - return(plot) -} - -# estimation-systematicError -plotEstimationScatter <- function(controlResults) { - - if(nrow(controlResults)==0){ - return(NULL) - } - - size <- 2 - labelY <- 0.7 - d <- rbind(data.frame(yGroup = "Uncalibrated", - logRr = controlResults$logRr, - seLogRr = controlResults$seLogRr, - ci95Lb = controlResults$ci95Lb, - ci95Ub = controlResults$ci95Ub, - trueRr = controlResults$effectSize), - data.frame(yGroup = "Calibrated", - logRr = controlResults$calibratedLogRr, - seLogRr = controlResults$calibratedSeLogRr, - ci95Lb = controlResults$calibratedCi95Lb, - ci95Ub = controlResults$calibratedCi95Ub, - trueRr = controlResults$effectSize)) - d <- d[!is.na(d$logRr), ] - d <- d[!is.na(d$ci95Lb), ] - d <- d[!is.na(d$ci95Ub), ] - if (nrow(d) == 0) { - return(NULL) - } - d$Group <- as.factor(d$trueRr) - d$Significant <- d$ci95Lb > d$trueRr | d$ci95Ub < d$trueRr - temp1 <- stats::aggregate(Significant ~ Group + yGroup, data = d, length) - temp2 <- stats::aggregate(Significant ~ Group + yGroup, data = d, mean) - temp1$nLabel <- paste0(formatC(temp1$Significant, big.mark = ","), " estimates") - temp1$Significant <- NULL - - temp2$meanLabel <- paste0(formatC(100 * (1 - temp2$Significant), digits = 1, format = "f"), - "% of CIs include ", - temp2$Group) - temp2$Significant <- NULL - dd <- merge(temp1, temp2) - dd$tes <- as.numeric(as.character(dd$Group)) - - breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) - theme <- ggplot2::element_text(colour = "#000000", size = 12) - themeRA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 1) - themeLA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 0) - - d$Group <- paste("True hazard ratio =", d$Group) - dd$Group <- paste("True hazard ratio =", dd$Group) - alpha <- 1 - min(0.95 * (nrow(d)/nrow(dd)/50000)^0.1, 0.95) - plot <- ggplot2::ggplot(d, ggplot2::aes(x = .data$logRr, y = .data$seLogRr), environment = environment()) + - ggplot2::geom_vline(xintercept = log(breaks), colour = "#AAAAAA", lty = 1, size = 0.5) + - ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.025), slope = 1/stats::qnorm(0.025)), - colour = grDevices::rgb(0.8, 0, 0), - linetype = "dashed", - size = 1, - alpha = 0.5, - data = dd) + - ggplot2::geom_abline(ggplot2::aes(intercept = (-log(.data$tes))/stats::qnorm(0.975), slope = 1/stats::qnorm(0.975)), - colour = grDevices::rgb(0.8, 0, 0), - linetype = "dashed", - size = 1, - alpha = 0.5, - data = dd) + - ggplot2::geom_point(size = size, - color = grDevices::rgb(0, 0, 0, alpha = 0.05), - alpha = alpha, - shape = 16) + - ggplot2::geom_hline(yintercept = 0) + - ggplot2::geom_label(x = log(0.15), - y = 0.9, - alpha = 1, - hjust = "left", - ggplot2::aes(label = .data$nLabel), - size = 5, - data = dd) + - ggplot2::geom_label(x = log(0.15), - y = labelY, - alpha = 1, - hjust = "left", - ggplot2::aes(label = .data$meanLabel), - size = 5, - data = dd) + - ggplot2::scale_x_continuous("Hazard ratio", - limits = log(c(0.1, 10)), - breaks = log(breaks), - labels = breaks) + - ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + - ggplot2::facet_grid(yGroup ~ Group) + - ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - axis.text.y = themeRA, - axis.text.x = theme, - axis.title = theme, - legend.key = ggplot2::element_blank(), - strip.text.x = theme, - strip.text.y = theme, - strip.background = ggplot2::element_blank(), - legend.position = "none") - - return(plot) -} - -# estimation-attrition -drawEstimationAttritionDiagram <- function(attrition, - targetLabel = "Target", - comparatorLabel = "Comparator") { - addStep <- function(data, attrition, row) { - label <- paste(strwrap(as.character(attrition$description[row]), width = 30), collapse = "\n") - data$leftBoxText[length(data$leftBoxText) + 1] <- label - data$rightBoxText[length(data$rightBoxText) + 1] <- paste(targetLabel, - ": n = ", - data$currentTarget - attrition$targetPersons[row], - "\n", - comparatorLabel, - ": n = ", - data$currentComparator - attrition$comparatorPersons[row], - sep = "") - data$currentTarget <- attrition$targetPersons[row] - data$currentComparator <- attrition$comparatorPersons[row] - return(data) - } - data <- list(leftBoxText = c(paste("Exposed:\n", - targetLabel, - ": n = ", - attrition$targetPersons[1], - "\n", - comparatorLabel, - ": n = ", - attrition$comparatorPersons[1], - sep = "")), rightBoxText = c(""), currentTarget = attrition$targetPersons[1], currentComparator = attrition$comparatorPersons[1]) - for (i in 2:nrow(attrition)) { - data <- addStep(data, attrition, i) - } - - - data$leftBoxText[length(data$leftBoxText) + 1] <- paste("Study population:\n", - targetLabel, - ": n = ", - data$currentTarget, - "\n", - comparatorLabel, - ": n = ", - data$currentComparator, - sep = "") - leftBoxText <- data$leftBoxText - rightBoxText <- data$rightBoxText - nSteps <- length(leftBoxText) - - boxHeight <- (1/nSteps) - 0.03 - boxWidth <- 0.45 - shadowOffset <- 0.01 - arrowLength <- 0.01 - x <- function(x) { - return(0.25 + ((x - 1)/2)) - } - y <- function(y) { - return(1 - (y - 0.5) * (1/nSteps)) - } - - downArrow <- function(p, x1, y1, x2, y2) { - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 + arrowLength, - yend = y2 + arrowLength)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 - arrowLength, - yend = y2 + arrowLength)) - return(p) - } - rightArrow <- function(p, x1, y1, x2, y2) { - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 - arrowLength, - yend = y2 + arrowLength)) - p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2, - y = y2, - xend = x2 - arrowLength, - yend = y2 - arrowLength)) - return(p) - } - box <- function(p, x, y) { - p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2) + shadowOffset, - ymin = y - (boxHeight/2) - shadowOffset, - xmax = x + (boxWidth/2) + shadowOffset, - ymax = y + (boxHeight/2) - shadowOffset), fill = grDevices::rgb(0, - 0, - 0, - alpha = 0.2)) - p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2), - ymin = y - (boxHeight/2), - xmax = x + (boxWidth/2), - ymax = y + (boxHeight/2)), fill = grDevices::rgb(0.94, - 0.94, - 0.94), color = "black") - return(p) - } - label <- function(p, x, y, text, hjust = 0) { - p <- p + ggplot2::geom_text(ggplot2::aes_string(x = x, y = y, label = paste("\"", text, "\"", - sep = "")), - hjust = hjust, - size = 3.7) - return(p) - } - - p <- ggplot2::ggplot() - for (i in 2:nSteps - 1) { - p <- downArrow(p, x(1), y(i) - (boxHeight/2), x(1), y(i + 1) + (boxHeight/2)) - p <- label(p, x(1) + 0.02, y(i + 0.5), "Y") - } - for (i in 2:(nSteps - 1)) { - p <- rightArrow(p, x(1) + boxWidth/2, y(i), x(2) - boxWidth/2, y(i)) - p <- label(p, x(1.5), y(i) - 0.02, "N", 0.5) - } - for (i in 1:nSteps) { - p <- box(p, x(1), y(i)) - } - for (i in 2:(nSteps - 1)) { - p <- box(p, x(2), y(i)) - } - for (i in 1:nSteps) { - p <- label(p, x(1) - boxWidth/2 + 0.02, y(i), text = leftBoxText[i]) - } - for (i in 2:(nSteps - 1)) { - p <- label(p, x(2) - boxWidth/2 + 0.02, y(i), text = rightBoxText[i]) - } - p <- p + ggplot2::theme(legend.position = "none", - plot.background = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - axis.text = ggplot2::element_blank(), - axis.title = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank()) - - return(p) -} - -# used in helpers-estPandT -nonZeroEstimationHazardRatio <- function(hrLower, hrUpper, terms) { - if (hrUpper < 1) { - return(terms[1]) - } else if (hrLower > 1) { - return(terms[2]) - } else { - return(terms[3]) - } -} - -# estimation-resultsTable -prettyEstimationHr <- function(x) { - if (!is.numeric(x)) { - x <- as.numeric(x) - } - result <- sprintf("%.2f", x) - result[is.na(x) | x > 100] <- "NA" - return(result) -} - -# used in here -goodEstimationPropensityScore <- function(value) { - return(value > 1) -} - -# used in here -goodEstimationSystematicBias <- function(value) { - return(value > 1) -} - - -# estmation-propensity -prepareEstimationPropensityModelTable <- function(model) { - rnd <- function(x) { - ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) - } - table <- model[order(-abs(model$coefficient)), c("coefficient", "covariateName")] - table$coefficient <- sprintf("%.2f", table$coefficient) - colnames(table) <- c("Beta", "Covariate") - return(table) -} - -# estimation-forestPlot -plotEstimationForest <- function(results, limits = c(0.1, 10), metaAnalysisDbIds = NULL) { - - dbResults <- results[!(results$databaseId %in% metaAnalysisDbIds), ] - dbResults <- dbResults[!is.na(dbResults$seLogRr), ] - dbResults <- dbResults[order(dbResults$databaseId), ] - maResult <- results[results$databaseId %in% metaAnalysisDbIds, ] - summaryLabel <- sprintf("Summary (I\u00B2 = %.2f)", as.numeric(maResult$i2)) - d1 <- data.frame(x = "Uncalibrated", - logRr = -100, - logLb95Ci = -100, - logUb95Ci = -100, - name = "Source", - type = "header", - stringsAsFactors = FALSE) - d2 <- data.frame(x = "Uncalibrated", - logRr = dbResults$logRr, - logLb95Ci = log(dbResults$ci95Lb), - logUb95Ci = log(dbResults$ci95Ub), - name = dbResults$databaseId, - type = "db", - stringsAsFactors = FALSE) - d3 <- data.frame(x = "Uncalibrated", - logRr = maResult$logRr, - logLb95Ci = log(maResult$ci95Lb), - logUb95Ci = log(maResult$ci95Ub), - name = summaryLabel, - type = "ma", - stringsAsFactors = FALSE) - d4 <- data.frame(x = "Calibrated", - logRr = -100, - logLb95Ci = -100, - logUb95Ci = -100, - name = "Source", - type = "header", - stringsAsFactors = FALSE) - d5 <- data.frame(x = "Calibrated", - logRr = dbResults$calibratedLogRr, - logLb95Ci = log(dbResults$calibratedCi95Lb), - logUb95Ci = log(dbResults$calibratedCi95Ub), - name = dbResults$databaseId, - type = "db", - stringsAsFactors = FALSE) - d6 <- data.frame(x = "Calibrated", - logRr = maResult$calibratedLogRr, - logLb95Ci = log(maResult$calibratedCi95Lb), - logUb95Ci = log(maResult$calibratedCi95Ub), - name = summaryLabel, - type = "ma", - stringsAsFactors = FALSE) - - d <- rbind(d1, d2, d3, d4, d5, d6) - d$name <- factor(d$name, levels = c(summaryLabel, rev(as.character(dbResults$databaseId)), "Source")) - d$x <- factor(d$x, levels = c("Uncalibrated", "Calibrated")) - - breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) - plot <- ggplot2::ggplot(d,ggplot2::aes(x = exp(.data$logRr), y = .data$name, xmin = exp(.data$logLb95Ci), xmax = exp(.data$logUb95Ci))) + - ggplot2::geom_vline(xintercept = breaks, colour = "#AAAAAA", lty = 1, size = 0.2) + - ggplot2::geom_vline(xintercept = 1, size = 0.5) + - ggplot2::geom_errorbarh(height = 0.15) + - ggplot2::geom_point(size=3, shape = 23, ggplot2::aes(fill=.data$type)) + - ggplot2::scale_fill_manual(values = c("#000000", "#000000", "#FFFFFF")) + - ggplot2::scale_x_continuous("Hazard ratio", trans = "log10", breaks = breaks, labels = breaks) + - ggplot2::coord_cartesian(xlim = limits) + - ggplot2::facet_grid(~ x) + - ggplot2::theme(text = ggplot2::element_text(size = 18), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - legend.position = "none", - panel.border = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_blank(), - strip.background = ggplot2::element_blank(), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) - - d$hr <- paste0(formatC(exp(d$logRr), digits = 2, format = "f"), - " (", - formatC(exp(d$logLb95Ci), digits = 2, format = "f"), - "-", - formatC(exp(d$logUb95Ci), digits = 2, format = "f"), - ")") - d <- d[order(d$x), ] - - labels <- data.frame(y = factor(c(as.character(d$name[d$x == "Uncalibrated"]), as.character(d$name)), levels = levels(d$name)), - x = rep(1:3, each = nrow(d)/2), - label = c(as.character(d$name[d$x == "Uncalibrated"]), d$hr), - dummy = "dummy", - stringsAsFactors = FALSE) - labels$label[nrow(d)/2 + 1] <- paste("HR (95% CI)") - labels$label[nrow(d) + 1] <- paste("Calibrated HR (95% CI)") - dataTable <- ggplot2::ggplot(labels, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label)) + - ggplot2::geom_text(size = 5, hjust = 0, vjust = 0.5) + - ggplot2::geom_hline(ggplot2::aes(yintercept = nrow(d) - 0.5)) + - ggplot2::facet_grid(~dummy) + - ggplot2::theme(text = ggplot2::element_text(size = 18), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - legend.position = "none", - panel.border = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(colour = "white"), - axis.text.y = ggplot2::element_blank(), - axis.ticks = ggplot2::element_line(colour = "white"), - strip.background = ggplot2::element_blank(), - strip.text = ggplot2::element_text(colour = "white"), - plot.margin = grid::unit(c(0,0,0.1,0), "lines")) + - ggplot2::labs(x = "", y = "") + - ggplot2::coord_cartesian(xlim = c(1,4)) - plot <- gridExtra::grid.arrange(dataTable, plot, ncol = 2) - return(plot) -} diff --git a/R/helpers-getEstimationUtility.R b/R/helpers-getEstimationUtility.R deleted file mode 100644 index 9528f66e..00000000 --- a/R/helpers-getEstimationUtility.R +++ /dev/null @@ -1,26 +0,0 @@ - -getEstimationColumnsToBlind <- function(results) { - columnsToBlind <- c("rr", "ci95Ub", "ci95Lb", - "logRr", "seLogRr", "p", - "calibratedRr", "calibratedCi95Ub", - "calibratedCi95Lb", "calibratedLogRr", - "calibratedSeLogRr", - "calibratedP") - - return(intersect(columnsToBlind, colnames(results))) - -} - -getEstimationSelectNamedChoices <- function(v1, v2) { - l <- as.list(v1) - names(l) <- as.vector(v2) - return(l) -} - - -filterEstimationEmptyNullValues <- function(v, includeNull=TRUE) { - valsToFilter <- c('') - if (includeNull) - valsToFilter <- c(valsToFilter, NULL) - return(v[! v %in% valsToFilter]) -} diff --git a/R/helpers-getHelp.R b/R/helpers-getHelp.R index f49b1e94..a4860cd8 100644 --- a/R/helpers-getHelp.R +++ b/R/helpers-getHelp.R @@ -1,6 +1,6 @@ getPredictionHelp <- function(file){ fileLoc <- system.file( - 'prediction-www', + 'patient-level-prediction-www', file, package = "OhdsiShinyModules" ) diff --git a/R/helpers-getPredictionResult.R b/R/helpers-getPredictionResult.R index b4a459b4..e68d72ac 100644 --- a/R/helpers-getPredictionResult.R +++ b/R/helpers-getPredictionResult.R @@ -1,21 +1,24 @@ getPredictionResult <- function( connectionHandler, + resultDatabaseSettings, tableName, - performanceId, - mySchema + performanceId ){ + # add prefix to tableName + tableName <- paste0(resultDatabaseSettings$plpTablePrefix,tableName) + shiny::withProgress(message = paste('Extracting PLP results from', tableName), value = 0, { shiny::incProgress(1/3, detail = paste("Translating and rendering ")) - sql <- "SELECT * FROM @my_schema.@table_name WHERE performance_id = @performance_id" + sql <- "SELECT * FROM @schema.@table_name WHERE performance_id = @performance_id" shiny::incProgress(2/3, detail = paste("Extracting data ")) result <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, table_name = tableName, performance_id = performanceId() ) diff --git a/R/helpers-sccsDataPulls.R b/R/helpers-sccsDataPulls.R index 0c4d2648..d2b7e928 100644 --- a/R/helpers-sccsDataPulls.R +++ b/R/helpers-sccsDataPulls.R @@ -9,12 +9,12 @@ sccsGetOutcomes <- function( eos.outcome_id from - @my_schema.@sccs_table_prefixexposures_outcome_set as eos + @schema.@sccs_table_prefixexposures_outcome_set as eos inner join - @my_schema.@cg_table_prefixcohort_definition as c + @schema.@cg_table_prefixcohort_definition as c on c.cohort_definition_id = eos.outcome_id inner join - @my_schema.@sccs_table_prefixexposure as e + @schema.@sccs_table_prefixexposure as e on e.exposures_outcome_set_id = eos.exposures_outcome_set_id --where e.true_effect_size != 1 @@ -22,9 +22,9 @@ sccsGetOutcomes <- function( " outcomes <- connectionHandler$queryDb( sql, - my_schema = resultDatabaseSettings$schema, - cg_table_prefix = resultDatabaseSettings$cohortTablePrefix, - sccs_table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, snakeCaseToCamelCase = TRUE ) @@ -46,16 +46,16 @@ sccsGetExposures <- function( e.era_id as exposure_id from - @my_schema.@cg_table_prefixcohort_definition as c + @schema.@cg_table_prefixcohort_definition as c inner join - @my_schema.@sccs_table_prefixexposure as e + @schema.@sccs_table_prefixexposure as e on e.era_id = c.cohort_definition_id; " exposures <- connectionHandler$queryDb( sql, - my_schema = resultDatabaseSettings$schema, - cg_table_prefix = resultDatabaseSettings$cohortTablePrefix, - sccs_table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, snakeCaseToCamelCase = TRUE ) @@ -77,17 +77,17 @@ sccsGetDatabases <- function( r.database_id from - @my_schema.@database_table_prefix@database_table ds + @schema.@database_table_prefix@database_table ds inner join - @my_schema.@sccs_table_prefixresult as r + @schema.@sccs_table_prefixresult as r on r.database_id = ds.database_id; " dbs <- connectionHandler$queryDb( sql, - my_schema = resultDatabaseSettings$schema, + schema = resultDatabaseSettings$schema, database_table_prefix = resultDatabaseSettings$databaseTablePrefix, database_table = resultDatabaseSettings$databaseTable, - sccs_table_prefix = resultDatabaseSettings$tablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, snakeCaseToCamelCase = TRUE ) @@ -108,16 +108,16 @@ sccsGetAnalyses <- function( r.analysis_id from - @my_schema.@sccs_table_prefixresult as r + @schema.@sccs_table_prefixresult as r inner join - @my_schema.@sccs_table_prefixanalysis as a + @schema.@sccs_table_prefixanalysis as a on r.analysis_id = a.analysis_id ; " analyses <- connectionHandler$queryDb( sql, - my_schema = resultDatabaseSettings$schema, - sccs_table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, snakeCaseToCamelCase = TRUE ) @@ -130,76 +130,7 @@ sccsGetAnalyses <- function( return(result2) } -getSccsResults <- function(connectionHandler, - resultDatabaseSettings, - exposureIds, - outcomeIds, - databaseIds, - analysisIds) { - sql <- " - SELECT - sr.*, - ds.cdm_source_abbreviation as database_name, - sds.mdrr, - sds.ease, - sds.time_trend_p, - sds.pre_exposure_p, - sds.mdrr_diagnostic, - sds.ease_diagnostic, - sds.time_trend_diagnostic, - sds.pre_exposure_diagnostic, - sds.unblind, - sc.covariate_name, - sc.era_id, - sc.covariate_analysis_id, - a.description, - eos.outcome_id - FROM @database_schema.@table_prefixresult sr - INNER JOIN - @database_schema.@database_table_prefix@database_table ds - ON sr.database_id = ds.database_id - INNER JOIN - @database_schema.@table_prefixdiagnostics_summary sds ON ( - sds.exposures_outcome_set_id = sr.exposures_outcome_set_id AND - sds.database_id = sr.database_id AND - sds.analysis_id = sr.analysis_id AND - sds.covariate_id = sr.covariate_id - ) - INNER JOIN - @database_schema.@table_prefixcovariate sc ON ( - sc.exposures_outcome_set_id = sr.exposures_outcome_set_id AND - sc.database_id = sr.database_id AND - sc.analysis_id = sr.analysis_id AND - sc.covariate_id = sr.covariate_id - ) - INNER JOIN @database_schema.@table_prefixexposures_outcome_set eos - ON - eos.exposures_outcome_set_id = sr.exposures_outcome_set_id - INNER JOIN - @database_schema.@table_prefixanalysis a - on a.analysis_id = sr.analysis_id - - WHERE sr.analysis_id IN (@analysis_ids) - AND sr.database_id IN (@database_ids) - AND eos.outcome_id IN (@outcome_ids) - AND sc.era_id IN (@exposure_ids) - " - results <- connectionHandler$queryDb( - sql, - database_schema = resultDatabaseSettings$schema, - database_table_prefix = resultDatabaseSettings$databaseTablePrefix, - database_table = resultDatabaseSettings$databaseTable, - table_prefix = resultDatabaseSettings$tablePrefix, - database_ids = paste(quoteLiterals(databaseIds), collapse = ','), - analysis_ids = analysisIds, - outcome_ids = paste(outcomeIds, collapse = ','), - exposure_ids = paste(exposureIds, collapse = ','), - snakeCaseToCamelCase = TRUE - ) - - return(results) -} getSccsModel <- function(connectionHandler, resultDatabaseSettings, @@ -214,22 +145,22 @@ getSccsModel <- function(connectionHandler, ELSE CONCAT(sc.covariate_name, ' : ', era.era_name) END as covariate_name, scr.covariate_id, scr.rr, scr.ci_95_lb, scr.ci_95_ub - FROM @database_schema.@table_prefixcovariate_result scr - INNER JOIN @database_schema.@table_prefixcovariate sc ON ( + FROM @schema.@sccs_table_prefixcovariate_result scr + INNER JOIN @schema.@sccs_table_prefixcovariate sc ON ( sc.exposures_outcome_set_id = scr.exposures_outcome_set_id AND sc.database_id = scr.database_id AND sc.analysis_id = scr.analysis_id AND sc.covariate_id = scr.covariate_id ) - LEFT JOIN @database_schema.@cg_table_prefixcohort_definition cd + LEFT JOIN @schema.@cg_table_prefixcohort_definition cd ON cd.cohort_definition_id = sc.era_id - LEFT JOIN @database_schema.@table_prefixera era ON ( + LEFT JOIN @schema.@sccs_table_prefixera era ON ( era.exposures_outcome_set_id = scr.exposures_outcome_set_id AND era.database_id = scr.database_id AND era.analysis_id = scr.analysis_id AND era.era_id = sc.era_id ) - INNER JOIN @database_schema.@table_prefixexposures_outcome_set eos + INNER JOIN @schema.@sccs_table_prefixexposures_outcome_set eos ON eos.exposures_outcome_set_id = scr.exposures_outcome_set_id @@ -241,9 +172,9 @@ getSccsModel <- function(connectionHandler, " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, - cg_table_prefix = resultDatabaseSettings$cohortTablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -259,9 +190,9 @@ getSccsTimeTrend <- function(connectionHandler, analysisId) { sql <- " SELECT tt.* - FROM @database_schema.@table_prefixtime_trend tt + FROM @schema.@sccs_table_prefixtime_trend tt inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on tt.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE database_id = '@database_id' AND analysis_id = @analysis_id @@ -269,8 +200,8 @@ getSccsTimeTrend <- function(connectionHandler, " connectionHandler$queryDb( sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -289,9 +220,9 @@ getSccsTimeToEvent <- function(connectionHandler, sql <- " SELECT ds.pre_exposure_p - FROM @database_schema.@table_prefixdiagnostics_summary ds + FROM @schema.@sccs_table_prefixdiagnostics_summary ds inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE ds.database_id = '@database_id' AND ds.covariate_id = @covariate_id @@ -301,8 +232,8 @@ getSccsTimeToEvent <- function(connectionHandler, p <- connectionHandler$queryDb( sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -312,9 +243,9 @@ getSccsTimeToEvent <- function(connectionHandler, sql <- " SELECT tte.*, @p as p - FROM @database_schema.@table_prefixtime_to_event tte + FROM @schema.@sccs_table_prefixtime_to_event tte inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on tte.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE tte.database_id = '@database_id' AND tte.era_id = @exposure_id @@ -324,8 +255,8 @@ getSccsTimeToEvent <- function(connectionHandler, timeToEvent <- connectionHandler$queryDb( sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -348,9 +279,9 @@ getSccsAttrition <- function(connectionHandler, covariateId) { sql <- " SELECT a.* - FROM @database_schema.@table_prefixattrition a + FROM @schema.@sccs_table_prefixattrition a inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on a.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE a.database_id = '@database_id' @@ -359,8 +290,8 @@ getSccsAttrition <- function(connectionHandler, AND a.covariate_id = @covariate_id " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -375,9 +306,9 @@ getSccsEventDepObservation <- function(connectionHandler, analysisId) { sql <- " SELECT o.* - FROM @database_schema.@table_prefixevent_dep_observation o + FROM @schema.@sccs_table_prefixevent_dep_observation o inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on o.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE o.database_id = '@database_id' @@ -385,8 +316,8 @@ getSccsEventDepObservation <- function(connectionHandler, AND eos.outcome_id = @outcome_id " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -400,9 +331,9 @@ getSccsAgeSpanning <- function(connectionHandler, analysisId) { sql <- " SELECT asp.* - FROM @database_schema.@table_prefixage_spanning asp + FROM @schema.@sccs_table_prefixage_spanning asp inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on asp.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE asp.database_id = '@database_id' @@ -410,8 +341,8 @@ getSccsAgeSpanning <- function(connectionHandler, AND eos.outcome_id = @outcome_id " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -425,9 +356,9 @@ getSccsCalendarTimeSpanning <- function(connectionHandler, analysisId) { sql <- " SELECT ts.* - FROM @database_schema.@table_prefixcalendar_time_spanning ts + FROM @schema.@sccs_table_prefixcalendar_time_spanning ts inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on ts.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE ts.database_id = '@database_id' @@ -435,8 +366,8 @@ getSccsCalendarTimeSpanning <- function(connectionHandler, AND eos.outcome_id = @outcome_id " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, analysis_id = analysisId, outcome_id = outcomeId, @@ -452,9 +383,9 @@ getSccsSpline <- function(connectionHandler, sql <- " SELECT s.* - FROM @database_schema.@table_prefixspline s + FROM @schema.@sccs_table_prefixspline s inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on s.exposures_outcome_set_id = eos.exposures_outcome_set_id WHERE s.database_id = '@database_id' @@ -463,8 +394,8 @@ getSccsSpline <- function(connectionHandler, AND s.spline_type = '@spline_type'; " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, spline_type = splineType, analysis_id = analysisId, @@ -482,14 +413,14 @@ getSccsControlEstimates <- function(connectionHandler, sql <- " SELECT ci_95_lb, ci_95_ub, log_rr, se_log_rr, calibrated_ci_95_lb, calibrated_ci_95_ub, calibrated_log_rr, calibrated_se_log_rr, true_effect_size - FROM @database_schema.@table_prefixresult sr - INNER JOIN @database_schema.@table_prefixcovariate sc ON ( + FROM @schema.@sccs_table_prefixresult sr + INNER JOIN @schema.@sccs_table_prefixcovariate sc ON ( sc.exposures_outcome_set_id = sr.exposures_outcome_set_id AND sc.database_id = sr.database_id AND sc.analysis_id = sr.analysis_id AND sc.covariate_id = sr.covariate_id ) - INNER JOIN @database_schema.@table_prefixexposure se ON ( + INNER JOIN @schema.@sccs_table_prefixexposure se ON ( se.exposures_outcome_set_id = sr.exposures_outcome_set_id AND se.era_id = sc.era_id ) @@ -498,8 +429,8 @@ getSccsControlEstimates <- function(connectionHandler, AND sr.covariate_id = @covariate_id " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, covariate_id = covariateId, analysis_id = analysisId, @@ -515,13 +446,13 @@ getSccsDiagnosticsSummary <- function(connectionHandler, exposureId) { sql <- " SELECT ds.* - FROM @database_schema.@table_prefixdiagnostics_summary ds + FROM @schema.@sccs_table_prefixdiagnostics_summary ds inner join - @database_schema.@table_prefixexposures_outcome_set eos + @schema.@sccs_table_prefixexposures_outcome_set eos on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id inner join - @database_schema.@table_prefixcovariate cov + @schema.@sccs_table_prefixcovariate cov on cov.covariate_id = ds.covariate_id and cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and cov.analysis_id = ds.analysis_id and @@ -534,71 +465,18 @@ getSccsDiagnosticsSummary <- function(connectionHandler, AND cov.era_id = @exposure_id " connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - table_prefix = resultDatabaseSettings$tablePrefix, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, database_id = databaseId, covariate_id = covariateId, analysis_id = analysisId, outcome_id = outcomeId, exposure_id = exposureId, snakeCaseToCamelCase = TRUE) - + } -getSccsAllDiagnosticsSummary <- function( - connectionHandler, - resultDatabaseSettings -) { - sql <- " - SELECT - d.cdm_source_abbreviation as database_name, - c.cohort_name as outcome, - c2.cohort_name as exposure, - a.description as analysis, - cov.covariate_name, - ds.* - FROM @database_schema.@table_prefixdiagnostics_summary ds - inner join - @database_schema.@table_prefixexposures_outcome_set eos - on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id - inner join - @database_schema.@cg_table_prefixcohort_definition as c - on c.cohort_definition_id = eos.outcome_id - - INNER JOIN - @database_schema.@database_table_prefix@database_table d - on d.database_id = ds.database_id - - INNER JOIN - @database_schema.@table_prefixanalysis a - on a.analysis_id = ds.analysis_id - - INNER JOIN - @database_schema.@table_prefixcovariate cov - on cov.covariate_id = ds.covariate_id and - cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and - cov.analysis_id = ds.analysis_id and - cov.database_id = ds.database_id - - inner join - @database_schema.@cg_table_prefixcohort_definition as c2 - on cov.era_id = c2.cohort_definition_id - ; - " - result <- connectionHandler$queryDb(sql, - database_schema = resultDatabaseSettings$schema, - cg_table_prefix = resultDatabaseSettings$cohortTablePrefix, - table_prefix = resultDatabaseSettings$tablePrefix, - database_table_prefix = resultDatabaseSettings$databaseTablePrefix, - database_table = resultDatabaseSettings$databaseTable, - snakeCaseToCamelCase = TRUE) - - result <- result %>% - dplyr::select(-c("analysisId","exposuresOutcomeSetId","databaseId","covariateId")) - - return(result) - -} + diff --git a/R/helpers-sccsPlots.R b/R/helpers-sccsPlots.R index 8c545eb3..e8308c36 100644 --- a/R/helpers-sccsPlots.R +++ b/R/helpers-sccsPlots.R @@ -1,9 +1,3 @@ -prettyHr <- function(x) { - result <- sprintf("%.2f", x) - result[is.na(x) | x > 100] <- "NA" - return(result) -} - convertToStartDate <- function(year, month) { return(as.Date(sprintf( "%s-%s-%s", diff --git a/R/prediction-calibration.R b/R/patient-level-prediction-calibration.R similarity index 95% rename from R/prediction-calibration.R rename to R/patient-level-prediction-calibration.R index 3c9a5b28..3e3e0d97 100644 --- a/R/prediction-calibration.R +++ b/R/patient-level-prediction-calibration.R @@ -1,4 +1,4 @@ -# @file prediction-calibration.R +# @file patient-level-prediction-calibration.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the prediction model calibration module #' #' @export -predictionCalibrationViewer <- function(id) { +patientLevelPredictionCalibrationViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -79,20 +79,18 @@ predictionCalibrationViewer <- function(id) { #' @param performanceId the performance id in the database #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the prediction calibration module #' #' @export -predictionCalibrationServer <- function( +patientLevelPredictionCalibrationServer <- function( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -104,8 +102,8 @@ predictionCalibrationServer <- function( data <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'evaluation_statistics'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'evaluation_statistics' ) } else{ data <- NULL @@ -194,16 +192,16 @@ predictionCalibrationServer <- function( value <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'calibration_summary'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'calibration_summary' ) calibrationSummary(value) value <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'demographic_summary'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'demographic_summary' ) demographicSummary(value) } diff --git a/R/prediction-covariateSummary.R b/R/patient-level-prediction-covariateSummary.R similarity index 73% rename from R/prediction-covariateSummary.R rename to R/patient-level-prediction-covariateSummary.R index e6370949..06acb5c0 100644 --- a/R/prediction-covariateSummary.R +++ b/R/patient-level-prediction-covariateSummary.R @@ -1,4 +1,4 @@ -# @file prediction-covariateSummary.R +# @file patient-level-prediction-covariateSummary.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the covariate summary module #' #' @export -predictionCovariateSummaryViewer <- function(id) { +patientLevelPredictionCovariateSummaryViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -60,8 +60,11 @@ predictionCovariateSummaryViewer <- function(id) { width=12, shinydashboard::box( status = 'info', width = 12, - title = "Covariates", solidHeader = TRUE, - DT::dataTableOutput(ns('modelCovariateInfo')) + title = "Details", solidHeader = TRUE, + shinydashboard::infoBoxOutput(ns("covariateCount"), width = 6), + shinydashboard::infoBoxOutput(ns("nonZeroCount"), width = 6), + shinydashboard::infoBoxOutput(ns("intercept"), width = 6), + shinydashboard::infoBoxOutput(ns("hyperparameters"), width = 6) ) ), shiny::fluidRow( @@ -89,22 +92,20 @@ predictionCovariateSummaryViewer <- function(id) { #' @param performanceId unique id for the performance results #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the covariate summary module #' #' @export -predictionCovariateSummaryServer <- function( +patientLevelPredictionCovariateSummaryServer <- function( id, modelDesignId, developmentDatabaseId, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend = '' + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -115,11 +116,10 @@ predictionCovariateSummaryServer <- function( !is.null(performanceId()) & inputSingleView() == 'Model' ){ - loadCovSumFromDb( + loadPredictionCovSumFromDb( performanceId = performanceId, - mySchema = mySchema, - connectionHandler = connectionHandler, - myTableAppend = myTableAppend + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings ) } else{ NULL @@ -132,29 +132,85 @@ predictionCovariateSummaryServer <- function( !is.null(developmentDatabaseId()) & inputSingleView() == 'Model' ){ - getIntercept( + getPredictionIntercept( modelDesignId = modelDesignId, databaseId = developmentDatabaseId, connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend + resultDatabaseSettings = resultDatabaseSettings ) } else{ NULL } }) - output$modelView <- DT::renderDataTable( - editCovariates(covariateSummary())$table, - colnames = editCovariates(covariateSummary())$colnames + hyperParamSearch <- shiny::reactive({getPredictionHyperParamSearch( + inputSingleView = inputSingleView, + modelDesignId = modelDesignId, + databaseId = developmentDatabaseId, + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) }) + + # hyper-param + output$hyperparameters<- shinydashboard::renderInfoBox({ + shinydashboard::infoBox( + 'Hyper-parameters', + shiny::actionButton(session$ns("showHyperparameters"),"View"), + icon = shiny::icon('gear'), + color = "light-blue" + ) + }) + shiny::observeEvent( + input$showHyperparameters, { + shiny::showModal(shiny::modalDialog( + title = "Hyper-parameters", + shiny::div( + DT::renderDataTable( + DT::datatable( + as.data.frame( + hyperParamSearch() + ), + options = list(scrollX = TRUE), + colnames = 'Fold AUROC' + ) + ) + ), + easyClose = TRUE + )) + } ) - output$modelCovariateInfo <- DT::renderDataTable( - data.frame( - covariates = nrow(covariateSummary()), - nonZeroCount = sum(covariateSummary()$covariateValue!=0, na.rm = T), - intercept = intercept() + output$covariateCount <- shinydashboard::renderInfoBox({ + shinydashboard::infoBox( + '# Covariates', + nrow(covariateSummary()), + icon = shiny::icon('hashtag'), + color = "light-blue" ) + }) + + + output$nonZeroCount <- shinydashboard::renderInfoBox({ + shinydashboard::infoBox( + '# Non-zero covariates', + sum(covariateSummary()$covariateValue!=0, na.rm = T), + icon = shiny::icon('square-full'), + color = "light-blue" + ) + }) + + output$intercept <- shinydashboard::renderInfoBox({ + shinydashboard::infoBox( + 'Intercept', + format(intercept(), digits =3), + icon = shiny::icon('a'), + color = "light-blue" + ) + }) + + output$modelView <- DT::renderDataTable( + editCovariates(covariateSummary())$table, + colnames = editCovariates(covariateSummary())$colnames ) # covariate model plots @@ -209,6 +265,35 @@ editCovariates <- function(covs){ } } + +# get hyper parameters +getPredictionHyperParamSearch <- function( + inputSingleView, + modelDesignId, + databaseId, + connectionHandler, + resultDatabaseSettings +){ + + if(!is.null(modelDesignId()) & inputSingleView() == 'Design Settings'){ + + sql <- "SELECT train_details FROM @schema.@plp_table_prefixmodels WHERE database_id = @database_id + and model_design_id = @model_design_id;" + + models <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + database_id = databaseId(), + model_design_id = modelDesignId(), + plp_table_prefix = resultDatabaseSettings$plpTablePrefix + ) + trainDetails <- ParallelLogger::convertJsonToSettings(models$trainDetails) + + return(trainDetails$hyperParamSearch) + } +} + + # format covariate summary table plotCovariateSummary <- function(covariateSummary){ @@ -339,11 +424,10 @@ plotCovariateSummary <- function(covariateSummary){ # code for database covariate extract -loadCovSumFromDb <- function( +loadPredictionCovSumFromDb <- function( performanceId, - mySchema, connectionHandler, - myTableAppend = '' + resultDatabaseSettings ){ ParallelLogger::logInfo("starting covsum") @@ -351,15 +435,15 @@ loadCovSumFromDb <- function( shiny::incProgress(2/3, detail = paste("Extracting data")) - sql <- "SELECT * FROM @my_schema.@my_table_appendcovariate_summary WHERE performance_id = @performance_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixcovariate_summary WHERE performance_id = @performance_id;" shiny::incProgress(2/3, detail = paste("Data extracted")) covariateSummary <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, performance_id = performanceId(), - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) # format @@ -378,22 +462,21 @@ loadCovSumFromDb <- function( return(covariateSummary) } -getIntercept <- function( +getPredictionIntercept <- function( modelDesignId, databaseId, connectionHandler, - mySchema, - myTableAppend + resultDatabaseSettings ){ - sql <- "SELECT intercept FROM @my_schema.@my_table_appendmodels WHERE database_id = @database_id + sql <- "SELECT intercept FROM @schema.@plp_table_prefixmodels WHERE database_id = @database_id and model_design_id = @model_design_id" models <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, database_id = databaseId(), model_design_id = modelDesignId(), - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) intercept <- models$intercept diff --git a/R/prediction-cutoff.R b/R/patient-level-prediction-cutoff.R similarity index 96% rename from R/prediction-cutoff.R rename to R/patient-level-prediction-cutoff.R index 55a3cdfa..0d70a104 100644 --- a/R/prediction-cutoff.R +++ b/R/patient-level-prediction-cutoff.R @@ -1,4 +1,4 @@ -# @file prediction-cutoff.R +# @file patient-level-prediction-cutoff.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the prediction cut-off module #' #' @export -predictionCutoffViewer <- function(id) { +patientLevelPredictionCutoffViewer <- function(id) { ns <- shiny::NS(id) @@ -95,20 +95,18 @@ predictionCutoffViewer <- function(id) { #' @param performanceId the performance id in the database #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the prediction cut-off module #' #' @export -predictionCutoffServer <- function( +patientLevelPredictionCutoffServer <- function( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -116,14 +114,12 @@ predictionCutoffServer <- function( thresholdSummary <- shiny::reactive({ if(!is.null(performanceId()) & inputSingleView() == 'Threshold Dependant'){ - - print('getting thresholdSummary') - + value <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - mySchema = mySchema, - tableName = paste0(myTableAppend, 'threshold_summary') + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'threshold_summary' ) return(value) } else{ diff --git a/R/prediction-designSummary.R b/R/patient-level-prediction-designSummary.R similarity index 52% rename from R/prediction-designSummary.R rename to R/patient-level-prediction-designSummary.R index 324d79e1..72861356 100644 --- a/R/prediction-designSummary.R +++ b/R/patient-level-prediction-designSummary.R @@ -1,4 +1,4 @@ -# @file prediction-designSummary.R +# @file patient-level-prediction-designSummary.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,9 +28,16 @@ #' The user interface to the prediction design module #' #' @export -predictionDesignSummaryViewer <- function(id) { +patientLevelPredictionDesignSummaryViewer <- function(id) { ns <- shiny::NS(id) - reactable::reactableOutput(ns('designSummaryTable')) + shiny::div( + inputSelectionViewer(ns("input-selection")), + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = shiny::NS(ns("input-selection")), + resultTableViewer(ns('designSummaryTable')) + ) + ) } #' The module server for exploring prediction designs in the results @@ -40,47 +47,89 @@ predictionDesignSummaryViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the prediction design module #' #' @export -predictionDesignSummaryServer <- function( +patientLevelPredictionDesignSummaryServer <- function( id, connectionHandler, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, function(input, output, session) { - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } + targetIds <- getPlpCohortIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'target' + ) + outcomeIds <- getPlpCohortIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + type = 'outcome' + ) - designSummaryTable <- getDesignSummary( - connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend + # input selection component + inputSelected <- inputSelectionServer( + id = "input-selection", + inputSettingList = list( + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'targetIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Target: ', + choices = targetIds, + selected = targetIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ), + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'outcomeIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Outcome: ', + choices = outcomeIds, + selected = outcomeIds[1], + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ) + ) ) - # check if this makes drpdwn filter - designSummaryTable$target <- as.factor(designSummaryTable$target) - designSummaryTable$outcome <- as.factor(designSummaryTable$outcome) + designSummaryTable <- shiny::reactive({ + getPredictionDesignSummary( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = inputSelected()$targetIds, + outcomeIds = inputSelected()$outcomeIds + ) + }) - output$designSummaryTable <- reactable::renderReactable({ - reactable::reactable( - data = cbind( - designSummaryTable, - diagnostic = rep("",nrow(designSummaryTable)), - details = rep("",nrow(designSummaryTable)), - report = rep("",nrow(designSummaryTable)) - ), - columns = list( + colDefsInput = list( # Render a "show details" button in the last column of the table. # This button won't do anything by itself, but will trigger the custom # click action on the column. @@ -162,89 +211,40 @@ predictionDesignSummaryServer <- function( ), sortable = TRUE, filterable = FALSE - ), - diagnostic = reactable::colDef( - name = "", - sortable = FALSE, - filterable = FALSE, - cell = function() htmltools::tags$button("View Diagnostics") - ), - details = reactable::colDef( - name = "", - sortable = FALSE, - filterable = FALSE, - cell = function() htmltools::tags$button("View Results") - ), - report = reactable::colDef( - name = "", - sortable = FALSE, - filterable = FALSE, - cell = function() htmltools::tags$button("View Report") ) - ), - onClick = reactable::JS(paste0("function(rowInfo, column) { - // Only handle click events on the 'details' column - if (column.id !== 'details' & column.id !== 'report' & column.id !== 'diagnostic') { - return - } - - // Display an alert dialog with details for the row - //window.alert('Details for row ' + rowInfo.index + ':\\n' + JSON.stringify(rowInfo.values, null, 2)) - - // Send the click event to Shiny, which will be available in input$show_details - // Note that the row index starts at 0 in JavaScript, so we add 1 - if(column.id == 'details'){ - Shiny.setInputValue('",session$ns('show_details'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - if(column.id == 'report'){ - Shiny.setInputValue('",session$ns('show_report'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - if(column.id == 'diagnostic'){ - Shiny.setInputValue('",session$ns('show_diagnostic'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - }") - ), - #groupBy = c("outcome","TAR", "target"), feedback was this wasnt nice - filterable = TRUE - ) - }) + ) + tableOutputs <- resultTableServer( + id = "designSummaryTable", # how is this working without session$ns + df = designSummaryTable, + colDefsInput = colDefsInput, + addActions = c('models', 'diagnostics', 'report') + ) + # reactive of modelDesignId for exporing results modelDesignId <- shiny::reactiveVal(value = NULL) - - shiny::observeEvent(input$show_details, { - #print(designSummaryTable$modelDesignId[input$show_details$index]) - if(designSummaryTable$devDatabases[input$show_details$index] > 0){ - modelDesignId(NULL) - modelDesignId(designSummaryTable$modelDesignId[input$show_details$index]) - } else{ - shiny::showNotification("No models available for this model design.") - } - }) - reportId <- shiny::reactiveVal(NULL) - shiny::observeEvent(input$show_report, { - reportId(NULL) - idForReport <- designSummaryTable$modelDesignId[input$show_report$index] - reportId(idForReport) - #writeLines('Testing123', file.path(tempdir(), 'report.html')) - #createProtocol(connection = connection, modelDesignId = idForReport, outputLocation = file.path(tempdir(), 'report.html')) - }) - diagnosticId <- shiny::reactiveVal(value = NULL) - shiny::observeEvent(input$show_diagnostic, { - - if(designSummaryTable$diagDatabases[input$show_diagnostic$index] > 0){ - diagnosticId(NULL) - diagnosticId(designSummaryTable$modelDesignId[input$show_diagnostic$index]) - } else{ - shiny::showNotification("No diagnostic results available for this model design.") + + shiny::observeEvent(tableOutputs$actionCount(), { + if(!is.null(tableOutputs$actionType())){ + if(tableOutputs$actionType() == 'diagnostics'){ + diagnosticId(NULL) + diagnosticId(designSummaryTable()$modelDesignId[tableOutputs$actionIndex()$index]) + } + if(tableOutputs$actionType() == 'report'){ + reportId(NULL) + reportId(designSummaryTable()$modelDesignId[tableOutputs$actionIndex()$index]) + } + if(tableOutputs$actionType() == 'models'){ + modelDesignId(NULL) + modelDesignId(designSummaryTable()$modelDesignId[tableOutputs$actionIndex()$index]) + } } }) - + return( list( - designSummaryTable = designSummaryTable, modelDesignId = modelDesignId, # a reactive diagnosticId = diagnosticId, # a reactive reportId = reportId # a reactive @@ -256,13 +256,49 @@ predictionDesignSummaryServer <- function( } +getPlpCohortIds <- function( + connectionHandler, + resultDatabaseSettings, + type = 'target' +){ + + sql <- "SELECT distinct cohorts.cohort_id, cohorts.cohort_name + + FROM + @schema.@plp_table_prefixmodel_designs as model_designs + inner join + (SELECT c.cohort_id, cd.cohort_name FROM @schema.@plp_table_prefixcohorts c + inner join @schema.@cg_table_prefixcohort_definition cd + on c.cohort_definition_id = cd.cohort_definition_id + ) AS cohorts + ON model_designs.@type_id = cohorts.cohort_id + ;" + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + type = type + ) + + res <- result$cohortId + names(res) <- result$cohortName + + return(res) +} -getDesignSummary <- function( +getPredictionDesignSummary <- function( connectionHandler, - mySchema, - myTableAppend = '' + resultDatabaseSettings, + targetIds, + outcomeIds ){ + if(length(targetIds) == 0 | length(outcomeIds) == 0){ + return(data.frame()) + } + shiny::withProgress(message = 'Generating model design summary', value = 0, { sql <- "SELECT @@ -282,27 +318,44 @@ getDesignSummary <- function( COUNT(distinct v.database_id) val_databases FROM - @my_schema.@my_table_appendmodel_designs as model_designs + @schema.@plp_table_prefixmodel_designs as model_designs inner join - @my_schema.@my_table_appendmodel_settings as model_settings + @schema.@plp_table_prefixmodel_settings as model_settings on model_designs.model_setting_id = model_settings.model_setting_id LEFT JOIN - @my_schema.@my_table_appendperformances AS results + @schema.@plp_table_prefixperformances AS results on model_designs.model_design_id = results.model_design_id - LEFT JOIN (select * from @my_schema.@my_table_appendEVALUATION_STATISTICS where EVALUATION = 'Test' and METRIC = 'AUROC') p + LEFT JOIN (select * from @schema.@plp_table_prefixEVALUATION_STATISTICS where EVALUATION = 'Test' and METRIC = 'AUROC') p on p.performance_id = results.performance_id - LEFT JOIN (SELECT cohort_id, cohort_name FROM @my_schema.@my_table_appendcohorts) AS targets ON model_designs.target_id = targets.cohort_id - LEFT JOIN (SELECT cohort_id, cohort_name FROM @my_schema.@my_table_appendcohorts) AS outcomes ON model_designs.outcome_id = outcomes.cohort_id - LEFT JOIN @my_schema.@my_table_appendtars AS tars ON model_designs.tar_id = tars.tar_id + LEFT JOIN + (SELECT c.cohort_id, cd.cohort_name FROM @schema.@plp_table_prefixcohorts c + inner join @schema.@cg_table_prefixcohort_definition cd + on c.cohort_definition_id = cd.cohort_definition_id + ) AS targets + ON model_designs.target_id = targets.cohort_id + LEFT JOIN + (SELECT c.cohort_id, cd.cohort_name FROM @schema.@plp_table_prefixcohorts c + inner join @schema.@cg_table_prefixcohort_definition cd + on c.cohort_definition_id = cd.cohort_definition_id + ) AS outcomes + ON model_designs.outcome_id = outcomes.cohort_id + LEFT JOIN @schema.@plp_table_prefixtars AS tars + ON model_designs.tar_id = tars.tar_id - LEFT JOIN @my_schema.@my_table_appenddatabase_details AS d ON results.development_database_id = d.database_id - LEFT JOIN @my_schema.@my_table_appenddatabase_details AS v ON results.validation_database_id = v.database_id + LEFT JOIN @schema.@plp_table_prefixdatabase_details AS d + ON results.development_database_id = d.database_id + LEFT JOIN @schema.@plp_table_prefixdatabase_details AS v + ON results.validation_database_id = v.database_id - LEFT JOIN @my_schema.@my_table_appenddiagnostics AS diag ON results.development_database_id = diag.database_id + LEFT JOIN @schema.@plp_table_prefixdiagnostics AS diag + ON results.development_database_id = diag.database_id + + WHERE targets.cohort_id in (@target_ids) + AND outcomes.cohort_id in (@outcome_ids) GROUP BY model_designs.model_design_id, model_settings.model_type, targets.cohort_name, outcomes.cohort_name, tars.tar_start_day, tars.tar_start_anchor, @@ -313,8 +366,11 @@ getDesignSummary <- function( summaryTable <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + target_ids = paste(targetIds, collapse = ','), + outcome_ids = paste(outcomeIds, collapse = ',') ) shiny::incProgress(2/3, detail = paste("Extracted data")) @@ -324,11 +380,15 @@ getDesignSummary <- function( dplyr::relocate("devDatabases", .before = "valDatabases") %>% dplyr::relocate("diagDatabases", .before = "devDatabases") + ##summaryTable <- cbind( + ## actions = rep("",nrow(summaryTable)), + ## summaryTable + ##) + shiny::incProgress(3/3, detail = paste("Finished")) }) - return(summaryTable) } diff --git a/R/patient-level-prediction-diagnostics.R b/R/patient-level-prediction-diagnostics.R new file mode 100644 index 00000000..3755264e --- /dev/null +++ b/R/patient-level-prediction-diagnostics.R @@ -0,0 +1,568 @@ +# @file patient-level-prediction-diagnostics.R +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + +#' The module viewer for exploring prediction diagnostic results +#' +#' @details +#' The user specifies the id for the module +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the prediction diagnostic module +#' +#' @export +patientLevelPredictionDiagnosticsViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::tagList( + shinydashboard::box( + collapsible = TRUE, + collapsed = TRUE, + title = "All Database Diagnostics For Selected Model Design", + width = "100%", + shiny::htmlTemplate(system.file("patient-level-prediction-www", "main-diagnosticsSummaryHelp.html", package = utils::packageName())) + ), + shinydashboard::box( + status = "warning", + width = "100%", + shiny::uiOutput(outputId = ns("diagnosticSummaryText")) + ), + shinydashboard::box( + width = "100%", + shiny::div( + resultTableViewer(ns('diagnosticSummaryTable')), + shiny::uiOutput(ns('main')) + ) + ) + ) + + +} + +#' The module server for exploring prediction diagnostic results +#' +#' @details +#' The user specifies the id for the module +#' +#' @param id the unique reference id for the module +#' @param modelDesignId the unique id for the model design +#' @param connectionHandler the connection to the prediction result database +#' @param resultDatabaseSettings a list containing the result schema and prefixes +#' +#' @return +#' The server to the prediction diagnostic module +#' +#' @export +patientLevelPredictionDiagnosticsServer <- function( + id, + modelDesignId, + connectionHandler, + resultDatabaseSettings +) { + shiny::moduleServer( + id, + function(input, output, session) { + + + selectedModelDesign <- shiny::reactive( + getModelDesignInfo( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + modelDesignId = modelDesignId + ) + ) + output$diagnosticSummaryText <- shiny::renderUI(selectedModelDesign()) + + diagnosticTable <- shiny::reactive({ + getPredictionDiagnostics( + modelDesignId = modelDesignId(), + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + }) + + colDefsInput <- list( + '1.1' = reactable::colDef( + header = withTooltip( + "1.1", + "Participants: Were appropriate data sources used, e.g. cohort, RCT or nested case-control study data?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '1.2' = reactable::colDef( + header = withTooltip( + "1.2", + "Participants: Were all inclusions and exclusions of participants appropriate?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '2.1' = reactable::colDef( + header = withTooltip( + "2.1", + "Predictors: Were predictors defined and assessed in a similar way for all participants?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '2.2' = reactable::colDef( + header = withTooltip( + "2.2", + "Predictors: Were predictor assessments made without knowledge of outcome data?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '2.3' = reactable::colDef( + header = withTooltip( + "2.3", + "Predictors: Are all predictors available at the time the model is intended to be used?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '3.4' = reactable::colDef( + header = withTooltip( + "3.4", + "Outcome: Was the outcome defined and determined in a similar way for all participants?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '3.6' = reactable::colDef( + header = withTooltip( + "3.6", + "Outcome: Was the time interval between predictor assessment and outcome determination appropriate?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")), + '4.1' = reactable::colDef( + header = withTooltip( + "4.1", + "Design: Were there a reasonable number of participants with the outcome?" + ), + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} + } + ")) + ) + + modelTableOutputs <- resultTableServer( + id = "diagnosticSummaryTable", + df = diagnosticTable, + colDefsInput = colDefsInput, + addActions = c('participants','predictors', 'outcomes') + ) + + + # listen + # PARTICIPANTS + #============ + shiny::observeEvent(modelTableOutputs$actionCount(), { + + if(modelTableOutputs$actionType() == 'participants'){ + { + participants <- getPredictionDiagnosticParticipants( + diagnosticId = diagnosticTable()$diagnosticId[modelTableOutputs$actionIndex()$index], + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + output$participants <- reactable::renderReactable({ + reactable::reactable( + data = participants %>% + dplyr::filter(.data$parameter == ifelse(is.null(input$participantParameters), unique(participants$parameter)[1], input$participantParameters)) %>% + dplyr::select( + c( + "probastId", + "paramvalue", + "metric", + "value" + ) + ) %>% + dplyr::mutate( + value = format(.data$value, nsmall = 2, ) + ) %>% + tidyr::pivot_wider( + names_from = "paramvalue", #.data$paramvalue, + values_from = "value" #.data$value + ) + ) + }) + + + shiny::showModal( + shiny::modalDialog( + title = "Participant Diagnostics", + shiny::basicPage( + shiny::tags$head(shiny::tags$style(".modal-dialog{ width:95%}")), + shiny::div( + shiny::selectInput( + inputId = session$ns('participantParameters'), + label = 'Select Parameter', + multiple = F, + choices = unique(participants$parameter) + ), + reactable::reactableOutput(session$ns('participants')) + ) + ), + size = "l", + easyClose = T + )) + + } + + } + }) + + + # PREDICTOR + #================== + shiny::observeEvent(modelTableOutputs$actionCount(), { + if(modelTableOutputs$actionType() == 'predictors'){ + predTable <- getPredictionDiagnosticPredictors( + diagnosticId = diagnosticTable()$diagnosticId[modelTableOutputs$actionIndex()$index], + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + output$predictorPlot <- plotly::renderPlotly({ + + tempPredTable <- predTable %>% + dplyr::filter( + .data$inputType == ifelse( + is.null(input$predictorParameters), + unique(predTable$inputType)[1], + input$predictorParameters + ) + ) %>% + dplyr::select( + c( + "daysToEvent", + "outcomeAtTime", + "observedAtStartOfDay" + ) + ) %>% + dplyr::mutate( + survivalT = (.data$observedAtStartOfDay -.data$outcomeAtTime)/.data$observedAtStartOfDay + ) %>% + dplyr::filter( + !is.na(.data$daysToEvent) + ) + + tempPredTable$probSurvT <- unlist( + lapply( + 1:length(tempPredTable$daysToEvent), + function(x){prod(tempPredTable$survivalT[tempPredTable$daysToEvent <= tempPredTable$daysToEvent[x]])} + ) + ) + + plotly::plot_ly(x = ~ tempPredTable$daysToEvent) %>% + plotly::add_lines( + y = tempPredTable$probSurvT, + name = "hv", + line = list(shape = "hv") + ) %>% + plotly::layout( + title = 'Outcome survival', + plot_bgcolor = "#e5ecf6", + xaxis = list(title = 'Time (days)'), + yaxis = list(title = 'Outcome free (0 = 0%, 1 = 100%)') + ) + }) + + + shiny::showModal( + shiny::modalDialog( + title = "Predictor Diagnostics", + shiny::basicPage( + shiny::tags$head(shiny::tags$style(".modal-dialog{ width:95%}")), + shiny::div( + shiny::p('Were predictor assessments made without knowledge of outcome data? (if outcome occur shortly after index this may be problematic)'), + shiny::p(''), + + shiny::selectInput( + inputId = session$ns('predictorParameters'), + label = 'Select Parameter', + multiple = F, + choices = unique(predTable$inputType) + ), + + plotly::plotlyOutput(session$ns('predictorPlot')) + ) + ), + size = "l", + easyClose = T + )) + + } + }) + + # OUTCOME + # ================= + shiny::observeEvent(modelTableOutputs$actionCount(), { + if(modelTableOutputs$actionType() == 'outcomes'){ + + outcomeTable <- getPredictionDiagnosticOutcomes( + diagnosticId = diagnosticTable()$diagnosticId[modelTableOutputs$actionIndex()$index], + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + #output$predictorPlot <- + output$outcomePlot <- plotly::renderPlotly({ + plotly::plot_ly( + data = outcomeTable %>% + dplyr::filter( + .data$aggregation == ifelse( + is.null(input$outcomeParameters), + unique(outcomeTable$aggregation)[1], + input$outcomeParameters + ) + ) %>% + dplyr::group_by(.data$inputType), # dep fix + x = ~ xvalue, + y = ~ outcomePercent, + #group = ~ inputType, + color = ~ inputType, + type = 'scatter', + mode = 'lines' + ) %>% + plotly::layout( + title = "Outcome rate", + xaxis = list(title = "Value"), + yaxis = list (title = "Percent of cohort with outcome") + ) + }) + + + shiny::showModal( + shiny::modalDialog( + title = "Outcome Diagnostics", + shiny::basicPage( + shiny::tags$head(shiny::tags$style(".modal-dialog{ width:95%}")), + shiny::div( + shiny::p('Was the outcome determined appropriately? (Are age/sex/year/month trends expected?)'), + shiny::p(''), + + shiny::selectInput( + inputId = session$ns('outcomeParameters'), + label = 'Select Parameter', + multiple = F, + choices = unique(outcomeTable$aggregation) + ), + + plotly::plotlyOutput(session$ns('outcomePlot')) + ) + ), + size = "l", + easyClose = T + )) + + } + }) + + + } + ) # server +} + + +# helpers + + +# get the data +getPredictionDiagnostics <- function( + modelDesignId, + connectionHandler, + resultDatabaseSettings, + threshold1_2 = 0.9 +){ + if(!is.null(modelDesignId)){ + print(paste0('model design: ', modelDesignId)) + } + + sql <- "SELECT distinct design.MODEL_DESIGN_ID, + diagnostics.diagnostic_id, + database.DATABASE_NAME, + cohortT.COHORT_NAME target_name, + cohortO.COHORT_NAME outcome_name, + summary.PROBAST_ID, + summary.RESULT_VALUE + + from + (select * from @schema.@plp_table_prefixDIAGNOSTICS where MODEL_DESIGN_ID = @model_design_id) as diagnostics + inner join + @schema.@plp_table_prefixMODEL_DESIGNS design + on diagnostics.MODEL_DESIGN_ID = design.MODEL_DESIGN_ID + + inner join + @schema.@plp_table_prefixDIAGNOSTIC_SUMMARY summary + on diagnostics.DIAGNOSTIC_ID = summary.DIAGNOSTIC_ID + + inner join + (select dd.database_id, md.cdm_source_abbreviation as database_name + from @schema.@database_table_prefixdatabase_meta_data md inner join + @schema.@plp_table_prefixdatabase_details dd + on md.database_id = dd.database_meta_data_id) as database + on database.database_id = diagnostics.database_id + + inner join + @schema.@plp_table_prefixCOHORTS cohortT + on cohortT.cohort_id = design.target_id + + inner join + @schema.@plp_table_prefixCOHORTS cohortO + on cohortO.cohort_id = design.outcome_id; + " + + summaryTable <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + model_design_id = modelDesignId, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix + ) + + if(nrow(summaryTable)==0){ + ParallelLogger::logInfo("No diagnostic summary") + return(NULL) + } + + summary <- summaryTable %>% tidyr::pivot_wider( + id_cols = c( + 'diagnosticId', + 'databaseName', + 'targetName', + 'outcomeName' + ), + names_from = 'probastId', + values_from = 'resultValue' + ) + + summary$`1.2` <- ifelse( + apply(summary[,grep('1.2.', colnames(summary))] > threshold1_2, 1, sum) == length(grep('1.2.', colnames(summary))), + 'Pass', + 'Fail' + ) + + summary <- summary[, - grep('1.2.', colnames(summary))] %>% + dplyr::relocate("1.2", .after = "1.1") + ParallelLogger::logInfo("got summary") + return(summary) +} + + +getPredictionDiagnosticParticipants <- function( + diagnosticId, + connectionHandler, + resultDatabaseSettings +){ + + sql <- "SELECT * FROM @schema.@plp_table_prefix@table_name WHERE diagnostic_id = @diagnostic_id;" + + participants <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + table_name = 'diagnostic_participants', + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + diagnostic_id = diagnosticId + ) + + participants$parameter <- unlist( + lapply( + participants$design, + function(x){strsplit(x, ':')[[1]][1]} + ) + ) + participants$paramvalue <- unlist( + lapply( + participants$design, + function(x){gsub(' ', '', strsplit(x, ':')[[1]][2])} + ) + ) + + return(participants) + +} + +getPredictionDiagnosticPredictors <- function( + diagnosticId, + connectionHandler, + resultDatabaseSettings +){ + + sql <- "SELECT * FROM @schema.@plp_table_prefix@table_name WHERE diagnostic_id = @diagnostic_id;" + + predictors <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + table_name = 'diagnostic_predictors', + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + diagnostic_id = diagnosticId + ) + + return(predictors) +} + +getPredictionDiagnosticOutcomes <- function( + diagnosticId, + connectionHandler, + resultDatabaseSettings +){ + + sql <- "SELECT * FROM @schema.@plp_table_prefix@table_name WHERE diagnostic_id = @diagnostic_id;" + + outcomes <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + table_name = 'diagnostic_outcomes', + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + diagnostic_id = diagnosticId + ) + + return(outcomes) + +} diff --git a/R/prediction-discrimination.R b/R/patient-level-prediction-discrimination.R similarity index 90% rename from R/prediction-discrimination.R rename to R/patient-level-prediction-discrimination.R index 91203745..c457c451 100644 --- a/R/prediction-discrimination.R +++ b/R/patient-level-prediction-discrimination.R @@ -1,4 +1,4 @@ -# @file prediction-discrimination.R +# @file patient-level-prediction-discrimination.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the model discrimination results module #' #' @export -predictionDiscriminationViewer <- function(id) { +patientLevelPredictionDiscriminationViewer <- function(id) { ns <- shiny::NS(id) @@ -42,11 +42,14 @@ predictionDiscriminationViewer <- function(id) { title = 'Summary', solidHeader = TRUE, shiny::p('Click view to see the corresponding plots:'), - reactable::reactableOutput(ns('summaryTable')) + resultTableViewer(ns('summaryTable')) ) ), - + #shiny::conditionalPanel( + # condition = "output.generate == 1", + # ns = ns, + shiny::fluidRow( shinydashboard::box( status = 'info', @@ -129,7 +132,11 @@ predictionDiscriminationViewer <- function(id) { shiny::plotOutput(ns('prefdist')) ) ) + ) + + #) # cond panel + ) } @@ -142,20 +149,18 @@ predictionDiscriminationViewer <- function(id) { #' @param performanceId the performance id in the database #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the model discrimination module #' #' @export -predictionDiscriminationServer <- function( +patientLevelPredictionDiscriminationServer <- function( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -163,14 +168,14 @@ predictionDiscriminationServer <- function( sumTable <- shiny::reactive({ if(!is.null(performanceId()) & inputSingleView() == 'Discrimination'){ - print('Discrimination started') + data <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'evaluation_statistics'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'evaluation_statistics' ) - print('Discrimination ended') + } else{ data <- NULL } @@ -191,50 +196,28 @@ predictionDiscriminationServer <- function( ) - tidyr::pivot_wider( + data <- tidyr::pivot_wider( data = data[ind,], names_from = 'metric', values_from = 'value' ) + ##cbind( + ## actions = rep('', nrow(data)), + ## data + ## ) + data + }) + modelTableOutputs <- resultTableServer( + id = "summaryTable", + colDefsInput = NULL, + df = sumTable, + addActions = c('performance') + ) - output$summaryTable <- reactable::renderReactable({ - reactable::reactable( - data = - if(is.null(sumTable())){ - NULL - } else{ - cbind( - view = rep("",nrow( sumTable())), - sumTable() - ) - }, - columns = - list( - view = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View") - ) - ),onClick = reactable::JS(paste0("function(rowInfo, column) { - // Only handle click events on the 'details' column - if (column.id !== 'view' ) { - return - } - // Send the click event to Shiny, which will be available in input$show_details - // Note that the row index starts at 0 in JavaScript, so we add 1 - if(column.id == 'view'){ - Shiny.setInputValue('",session$ns('show_view'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - }") - ), - filterable = TRUE - ) - }) - predictionDistribution <- shiny::reactiveVal(NULL) thresholdSummary <- shiny::reactiveVal(NULL) @@ -253,16 +236,16 @@ predictionDiscriminationServer <- function( value <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'prediction_distribution'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'prediction_distribution' ) predictionDistribution(value) value <- getPredictionResult( performanceId = performanceId, connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'threshold_summary'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'threshold_summary' ) thresholdSummary(value) } @@ -301,37 +284,42 @@ predictionDiscriminationServer <- function( } ) + #generate <- shiny::reactiveVal(0) + #output$generate <- generate() + #shiny::outputOptions(output,"generate",suspendWhenHidden=FALSE) + shiny::observeEvent( - input$show_view, { + modelTableOutputs$actionCount(), { + #generate(1) output$roc <- plotly::renderPlotly({ - type <- trimws(sumTable()$evaluation[input$show_view$index]) + type <- trimws(sumTable()$evaluation[modelTableOutputs$actionIndex()$index]) tryCatch({plots()$roc[[type]]}, error = function(err){emptyPlot(title = err)}) }) output$pr <- plotly::renderPlotly({ - type <- trimws(sumTable()$evaluation[input$show_view$index]) + type <- trimws(sumTable()$evaluation[modelTableOutputs$actionIndex()$index]) tryCatch({plots()$pr[[type]]}, error = function(err){emptyPlot(title = err)}) }) output$f1 <- plotly::renderPlotly({ - type <- trimws(sumTable()$evaluation[input$show_view$index]) + type <- trimws(sumTable()$evaluation[modelTableOutputs$actionIndex()$index]) tryCatch({plots()$f1[[type]]}, error = function(err){emptyPlot(title = err)}) }) # preference plot output$prefdist <- shiny::renderPlot({ - type <- trimws(sumTable()$evaluation[input$show_view$index]) + type <- trimws(sumTable()$evaluation[modelTableOutputs$actionIndex()$index]) tryCatch({plots()$prefpdf[[type]]}, error = function(err){emptyPlot(title = err)}) }) output$preddist <- shiny::renderPlot({ - type <- trimws(sumTable()$evaluation[input$show_view$index]) + type <- trimws(sumTable()$evaluation[modelTableOutputs$actionIndex()$index]) tryCatch({plots()$predpdf[[type]]}, error = function(err){emptyPlot(title = err)}) }) output$box <- shiny::renderPlot({ - type <- trimws(sumTable()$evaluation[input$show_view$index]) + type <- trimws(sumTable()$evaluation[modelTableOutputs$actionIndex()$index]) tryCatch({plots()$box[[type]]}, error = function(err){emptyPlot(title = err)}) }) } diff --git a/R/prediction-main.R b/R/patient-level-prediction-main.R similarity index 66% rename from R/prediction-main.R rename to R/patient-level-prediction-main.R index 79344421..5fd1191a 100644 --- a/R/prediction-main.R +++ b/R/patient-level-prediction-main.R @@ -1,4 +1,4 @@ -# @file prediction-main.R +# @file patient-level-prediction-main.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -26,8 +26,8 @@ #' string location of the prediction helper file #' #' @export -predictionHelperFile <- function(){ - fileLoc <- system.file('prediction-www', "prediction.html", package = "OhdsiShinyModules") +patientLevelPredictionHelperFile <- function(){ + fileLoc <- system.file('patient-level-prediction-www', "patient-level-prediction.html", package = "OhdsiShinyModules") return(fileLoc) } @@ -42,7 +42,7 @@ predictionHelperFile <- function(){ #' The user interface to the PatientLevelPrediction viewer module #' #' @export -predictionViewer <- function(id=1) { +patientLevelPredictionViewer <- function(id=1) { ns <- shiny::NS(id) shinydashboard::box( @@ -62,10 +62,10 @@ predictionViewer <- function(id=1) { collapsed = TRUE, title = "Model Designs Summary", width = "100%", - shiny::htmlTemplate(system.file("prediction-www", "help-designSummary.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("patient-level-prediction-www", "help-designSummary.html", package = utils::packageName())) ), - predictionDesignSummaryViewer(ns('designSummaryTab')) + patientLevelPredictionDesignSummaryViewer(ns('designSummaryTab')) ), shiny::tabPanel( @@ -76,7 +76,18 @@ predictionViewer <- function(id=1) { shiny::icon("arrow-left"), style="color: #fff; background-color: #337ab7; border-color: #2e6da4" ), - predictionModelSummaryViewer(ns('modelSummaryTab')) + patientLevelPredictionModelSummaryViewer(ns('modelSummaryTab')) + ), + + shiny::tabPanel( + "Diagnostic Summary", + shiny::actionButton( + inputId = ns("backToDesignSummaryD"), + label = "Back To Design Summary", + shiny::icon("arrow-left"), + style="color: #fff; background-color: #337ab7; border-color: #2e6da4" + ), + patientLevelPredictionDiagnosticsViewer(ns('diagnostics')) ), shiny::tabPanel( @@ -94,7 +105,7 @@ predictionViewer <- function(id=1) { collapsed = TRUE, title = "Full Result Explorer", width = "100%", - shiny::htmlTemplate(system.file("prediction-www", "help-fullResults.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("patient-level-prediction-www", "help-fullResults.html", package = utils::packageName())) ), shinydashboard::box( @@ -106,40 +117,41 @@ predictionViewer <- function(id=1) { shiny::tabsetPanel( type = 'pills', id = ns('singleView'), - shiny::tabPanel( - "Design Settings", - predictionSettingsViewer(ns('settings')) - ), shiny::tabPanel( "Model", - predictionCovariateSummaryViewer(ns('covariateSummary')) + patientLevelPredictionCovariateSummaryViewer(ns('covariateSummary')) ), - shiny::tabPanel( - "Threshold Dependant", - predictionCutoffViewer(ns('cutoff')) - ), - shiny::tabPanel( "Discrimination", - predictionDiscriminationViewer(ns('discrimination')) + patientLevelPredictionDiscriminationViewer(ns('discrimination')) ), shiny::tabPanel( "Calibration", - predictionCalibrationViewer(ns('calibration')) + patientLevelPredictionCalibrationViewer(ns('calibration')) ), + shiny::tabPanel( + "Threshold Dependant", + patientLevelPredictionCutoffViewer(ns('cutoff')) + ), + shiny::tabPanel( "Net Benefit", - predictionNbViewer(ns('netBenefit')) + patientLevelPredictionNbViewer(ns('netBenefit')) ), shiny::tabPanel( "Validation", - predictionValidationViewer(ns('validation')) + patientLevelPredictionValidationViewer(ns('validation')) + ), + + shiny::tabPanel( + "Design Settings", + patientLevelPredictionSettingsViewer(ns('settings')) ) @@ -165,7 +177,7 @@ predictionViewer <- function(id=1) { #' The server for the PatientLevelPrediction module #' #' @export -predictionServer <- function( +patientLevelPredictionServer <- function( id, connectionHandler, resultDatabaseSettings = list(port = 1) @@ -188,7 +200,7 @@ predictionServer <- function( shiny::updateTabsetPanel( session = session, inputId = 'singleView', - selected = 'Design Settings' + selected = 'Model' ) # @@ -216,6 +228,14 @@ predictionServer <- function( ) }) + shiny::observeEvent(input$backToDesignSummaryD, { + shiny::updateTabsetPanel( + session = session, + inputId = 'allView', + selected = 'Model Designs Summary' + ) + }) + # keep a reactive variable tracking the active tab singleViewValue <- shiny::reactive({ input$singleView @@ -231,11 +251,10 @@ predictionServer <- function( # per prediction model design and lets the user # select a model design id to explore modelDesignId <- shiny::reactiveVal() - designSummary <- predictionDesignSummaryServer( + designSummary <- patientLevelPredictionDesignSummaryServer( id = 'designSummaryTab', connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) @@ -246,10 +265,8 @@ predictionServer <- function( shiny::observeEvent(designSummary$modelDesignId(), { modelDesignId(designSummary$modelDesignId()) if(!is.null(designSummary$modelDesignId())){ - #shiny::showTab(inputId = "allView", session = session, target = "Models Summary") shiny::updateTabsetPanel(session, "allView", selected = "Models Summary") - #shiny::hideTab(inputId = "allView", session = session, target = "Explore Selected Model") - } + } }) @@ -263,17 +280,11 @@ predictionServer <- function( # development database id performanceId <- shiny::reactiveVal() developmentDatabaseId <- shiny::reactiveVal() - performance <- predictionModelSummaryServer( + performance <- patientLevelPredictionModelSummaryServer( id = 'modelSummaryTab', connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix, modelDesignId = modelDesignId, - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ) + resultDatabaseSettings = resultDatabaseSettings ) @@ -285,10 +296,8 @@ predictionServer <- function( performanceId(performance$performanceId()) developmentDatabaseId(performance$developmentDatabaseId()) if(!is.null(performance$performanceId())){ - #shiny::showTab(inputId = "allView", session = session, target = "Explore Selected Model") shiny::updateTabsetPanel(session, "allView", selected = "Explore Selected Model") - #shiny::hideTab(inputId = "allView", session = session, target = "Models Summary") - } + } # hide validation tab if non internal val if(performance$modelDevelopment() == 1){ @@ -305,22 +314,16 @@ predictionServer <- function( # ============================= # diagnostic viewer - show model diagnostic results shiny::observeEvent(designSummary$diagnosticId(), { - shiny::showModal(shiny::modalDialog( - title = "Diagnostic", - predictionDiagnosticsViewer(session$ns('diagnostics')) - )) + if(!is.null(designSummary$diagnosticId())){ + shiny::updateTabsetPanel(session, "allView", selected = "Diagnostic Summary") + } }) - predictionDiagnosticsServer( + + patientLevelPredictionDiagnosticsServer( id = 'diagnostics', modelDesignId = designSummary$diagnosticId, - mySchema = resultDatabaseSettings$schema, connectionHandler = connectionHandler, - myTableAppend = resultDatabaseSettings$tablePrefix, - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ) + resultDatabaseSettings = resultDatabaseSettings ) # ============================= @@ -350,20 +353,9 @@ predictionServer <- function( file.remove(file.path(protocolOutputLoc, 'main.html')) } tryCatch( - {createPredictionProtocol( # add database_table_append and cohort_table_append + {createPredictionProtocol( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix, - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ), - cohortTableAppend = ifelse( - !is.null(resultDatabaseSettings$cohortTablePrefix), - resultDatabaseSettings$cohortTablePrefix, - resultDatabaseSettings$tablePrefix - ), + resultDatabaseSettings = resultDatabaseSettings, modelDesignId = designSummary$reportId(), output = protocolOutputLoc, intermediatesDir = file.path(protocolOutputLoc, 'plp-prot') @@ -408,26 +400,18 @@ predictionServer <- function( rmarkdown::render( input = system.file( - 'prediction-document', + 'patient-level-prediction-document', "export-main.Rmd", package = "OhdsiShinyModules" ), intermediates_dir = file.path(tempdir(), 'plp-prot'), output_dir = file.path(input$plpProtocolDownload, paste0('plp_report',designSummary$reportId())), - params = list( - connectionHandler = connectionHandler, - resultSchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix, - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ), - cohortTableAppend = ifelse( - !is.null(resultDatabaseSettings$cohortTablePrefix), - resultDatabaseSettings$cohortTablePrefix, - resultDatabaseSettings$tablePrefix - ), + params = list( #TODO UPDATE DOC + connectionHandler = connectionHandler, + resultSchema = resultDatabaseSettings$schema, + myTableAppend = resultDatabaseSettings$plpTablePrefix, + databaseTableAppend = resultDatabaseSettings$databaseTablePrefix, + cohortTableAppend = resultDatabaseSettings$cgTablePrefix, modelDesignIds = designSummary$reportId() ) ) @@ -439,107 +423,74 @@ predictionServer <- function( # =========================================== output$resultSelectText <- shiny::renderUI( - getResultSelection( + getPlpResultSelection( connectionHandler = connectionHandler, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix, + resultDatabaseSettings = resultDatabaseSettings, modelDesignId = modelDesignId, - performanceId = performanceId, - cohortTableAppend = ifelse( - !is.null(resultDatabaseSettings$cohortTablePrefix), - resultDatabaseSettings$cohortTablePrefix, - resultDatabaseSettings$tablePrefix - ), - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ) + performanceId = performanceId ) ) - predictionCovariateSummaryServer( + patientLevelPredictionCovariateSummaryServer( id = 'covariateSummary', modelDesignId = modelDesignId, # reactive developmentDatabaseId = developmentDatabaseId, # reactive performanceId = performanceId, # reactive connectionHandler = connectionHandler, inputSingleView = singleViewValue, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) - predictionSettingsServer( + patientLevelPredictionSettingsServer( id = 'settings', modelDesignId = modelDesignId, # reactive developmentDatabaseId = developmentDatabaseId, # reactive performanceId = performanceId, # reactive - mySchema = resultDatabaseSettings$schema, connectionHandler = connectionHandler, inputSingleView = singleViewValue, - myTableAppend = resultDatabaseSettings$tablePrefix, - cohortTableAppend = ifelse( - !is.null(resultDatabaseSettings$cohortTablePrefix), - resultDatabaseSettings$cohortTablePrefix, - resultDatabaseSettings$tablePrefix - ), - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ) + resultDatabaseSettings = resultDatabaseSettings ) - predictionCutoffServer( + patientLevelPredictionCutoffServer( id = 'cutoff', performanceId = performanceId, - mySchema = resultDatabaseSettings$schema, connectionHandler = connectionHandler, inputSingleView = singleViewValue, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) - predictionDiscriminationServer( + patientLevelPredictionDiscriminationServer( id = 'discrimination', performanceId = performanceId, - mySchema = resultDatabaseSettings$schema, connectionHandler = connectionHandler, inputSingleView = singleViewValue, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) - predictionCalibrationServer( + patientLevelPredictionCalibrationServer( id = 'calibration', performanceId = performanceId, - mySchema = resultDatabaseSettings$schema, connectionHandler = connectionHandler, inputSingleView = singleViewValue, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) - predictionNbServer( + patientLevelPredictionNbServer( id = 'netBenefit', performanceId = performanceId, - mySchema = resultDatabaseSettings$schema, connectionHandler = connectionHandler, inputSingleView = singleViewValue, - myTableAppend = resultDatabaseSettings$tablePrefix + resultDatabaseSettings = resultDatabaseSettings ) - predictionValidationServer( + patientLevelPredictionValidationServer( id = 'validation', modelDesignId = modelDesignId, # reactive developmentDatabaseId = developmentDatabaseId, # reactive performanceId = performanceId, # reactive connectionHandler = connectionHandler, inputSingleView = singleViewValue, - mySchema = resultDatabaseSettings$schema, - myTableAppend = resultDatabaseSettings$tablePrefix, - databaseTableAppend = ifelse( - !is.null(resultDatabaseSettings$databaseTablePrefix), - resultDatabaseSettings$databaseTablePrefix, - resultDatabaseSettings$tablePrefix - ) + resultDatabaseSettings = resultDatabaseSettings ) } @@ -547,87 +498,85 @@ predictionServer <- function( } - -getResultSelection <- function( +# name too generic +getPlpResultSelection <- function( connectionHandler, - mySchema, - myTableAppend, + resultDatabaseSettings, modelDesignId, - performanceId, - cohortTableAppend, - databaseTableAppend + performanceId ){ + + if(!inherits(modelDesignId, 'reactive')){ + modelDesignId <- shiny::reactiveVal(modelDesignId) + } + if(!inherits(performanceId, 'reactive')){ + performanceId <- shiny::reactiveVal(performanceId) + } + if(!is.null(modelDesignId()) & !is.null(performanceId())){ modelType <- connectionHandler$queryDb( - 'select distinct model_type from @my_schema.@my_table_appendmodels where model_design_id = @model_design_id;', - my_schema = mySchema, - my_table_append = myTableAppend, + 'select distinct model_type from @schema.@plp_table_prefixmodels where model_design_id = @model_design_id;', + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, model_design_id = modelDesignId() ) - print(modelType) - developmentDb = connectionHandler$queryDb( 'select distinct d.cdm_source_abbreviation from - @my_schema.@database_table_appenddatabase_meta_data d + @schema.@database_table_prefixdatabase_meta_data d inner join - @my_schema.@my_table_appenddatabase_details dd + @schema.@plp_table_prefixdatabase_details dd on dd.database_meta_data_id = d.database_id inner join - @my_schema.@my_table_appendperformances p + @schema.@plp_table_prefixperformances p on dd.database_id = p.development_database_id where p.performance_id = @performance_id;', - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, performance_id = performanceId(), - database_table_append = databaseTableAppend + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) - - print(developmentDb) - + validationDb = connectionHandler$queryDb( 'select distinct d.cdm_source_abbreviation from - @my_schema.@database_table_appenddatabase_meta_data d + @schema.@database_table_prefixdatabase_meta_data d inner join - @my_schema.@my_table_appenddatabase_details dd + @schema.@plp_table_prefixdatabase_details dd on dd.database_meta_data_id = d.database_id inner join - @my_schema.@my_table_appendperformances p + @schema.@plp_table_prefixperformances p on dd.database_id = p.validation_database_id where p.performance_id = @performance_id;', - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, performance_id = performanceId(), - database_table_append = databaseTableAppend + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) - print(validationDb) - + target <- connectionHandler$queryDb( 'select distinct c.cohort_name from - @my_schema.@my_table_appendcohorts c + @schema.@plp_table_prefixcohorts c inner join - @my_schema.@my_table_appendperformances p + @schema.@plp_table_prefixperformances p on c.cohort_id = p.target_id where p.performance_id = @performance_id;', - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, performance_id = performanceId() ) - print(target) outcome <- connectionHandler$queryDb( 'select distinct c.cohort_name from - @my_schema.@my_table_appendcohorts c + @schema.@plp_table_prefixcohorts c inner join - @my_schema.@my_table_appendperformances p + @schema.@plp_table_prefixperformances p on c.cohort_id = p.outcome_id where p.performance_id = @performance_id;', - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, performance_id = performanceId() ) - print(outcome) - + return( shiny::fluidPage( shiny::fluidRow( diff --git a/R/prediction-modelSummary.R b/R/patient-level-prediction-modelSummary.R similarity index 52% rename from R/prediction-modelSummary.R rename to R/patient-level-prediction-modelSummary.R index 12aac32b..47b7f41e 100644 --- a/R/prediction-modelSummary.R +++ b/R/patient-level-prediction-modelSummary.R @@ -1,4 +1,4 @@ -# @file prediction-modelSummary.R +# @file patient-level-prediction-modelSummary.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the summary module #' #' @export -predictionModelSummaryViewer <- function(id) { +patientLevelPredictionModelSummaryViewer <- function(id) { ns <- shiny::NS(id) shiny::tagList( @@ -37,7 +37,7 @@ predictionModelSummaryViewer <- function(id) { collapsed = TRUE, title = "All Database Results For Selected Model Design", width = "100%", - shiny::htmlTemplate(system.file("prediction-www", "main-modelSummaryHelp.html", package = utils::packageName())) + shiny::htmlTemplate(system.file("patient-level-prediction-www", "main-modelSummaryHelp.html", package = utils::packageName())) ), shinydashboard::box( status = "warning", @@ -46,7 +46,7 @@ predictionModelSummaryViewer <- function(id) { ), shinydashboard::box( width = "100%", - reactable::reactableOutput(ns('performanceSummaryTable')) + resultTableViewer(ns('performanceSummaryTable')) ) ) } @@ -58,148 +58,138 @@ predictionModelSummaryViewer <- function(id) { #' #' @param id the unique reference id for the module #' @param connectionHandler the connection to the prediction result database -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' @param modelDesignId a reactable id specifying the prediction model design identifier -#' @param databaseTableAppend a string that appends the database_meta_data table #' #' @return #' The server to the summary module #' #' @export -predictionModelSummaryServer <- function( +patientLevelPredictionModelSummaryServer <- function( id, connectionHandler, - mySchema, - myTableAppend, - modelDesignId, - databaseTableAppend = myTableAppend + resultDatabaseSettings, + modelDesignId ) { shiny::moduleServer( id, function(input, output, session) { - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - selectedModelDesign <- shiny::reactive( getModelDesignInfo( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, - modelDesignId = modelDesignId, - databaseTableAppend = databaseTableAppend + resultDatabaseSettings = resultDatabaseSettings, + modelDesignId = modelDesignId ) ) output$performanceSummaryText <- shiny::renderUI(selectedModelDesign()) - resultTable <- shiny::reactive( getModelDesignPerformanceSummary( connectionHandler = connectionHandler, - mySchema = mySchema, - myTableAppend = myTableAppend, - modelDesignId = modelDesignId, - databaseTableAppend = databaseTableAppend + resultDatabaseSettings = resultDatabaseSettings, + modelDesignId = modelDesignId ) ) - shinyInput <- function(FUN,id,num,label = NULL,...) { - inputs <- character(num) - for (i in seq_len(num)) { - inputs[i] <- as.character(FUN(paste0(id,i),label=label,...)) - } - inputs - } - - output$performanceSummaryTable <- reactable::renderReactable({ - reactable::reactable( - data = cbind( - view = rep("",nrow(resultTable())), - resultTable()[,!colnames(resultTable())%in% c('performanceId', 'developmentDatabaseId', 'modelDevelopment', 'modelDesignId')] - ), - - columns = list( - Dev = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Dev Db", - "The database used to develop the model" - )), - Val = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Val Db", - "The database used to evaluate the model" - )), - T = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Target Pop", - "The patients who the risk model is applied to" - )), - O = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Outcome", - "The outcome being predicted" - )), - TAR = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "TAR", - "The time-at-risk when the outcome is being predicted relative to the target pop index" - ), - sortable = TRUE - ), - type = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Type", - "Development contains the model and internal validation; Validation contains the external validation" - ), - sortable = TRUE - ), - - view = reactable::colDef( - name = "", - sortable = FALSE, - filterable = FALSE, - cell = function() htmltools::tags$button("View Result") - ) + colDefsInput = list( + Dev = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Dev Db", + "The database used to develop the model" + )), + Val = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Val Db", + "The database used to evaluate the model" + )), + T = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Target Pop", + "The patients who the risk model is applied to" + )), + O = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Outcome", + "The outcome being predicted" + )), + TAR = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "TAR", + "The time-at-risk when the outcome is being predicted relative to the target pop index" ), - onClick = reactable::JS(paste0("function(rowInfo, column) { - // Only handle click events on the 'details' column - if (column.id !== 'view') { - return - } - - - // Send the click event to Shiny, which will be available in input$show_details - // Note that the row index starts at 0 in JavaScript, so we add 1 - // if (window.Shiny) { - if(column.id == 'view'){ - Shiny.setInputValue('",session$ns('view_details'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - // } - }") - ) - + sortable = TRUE + ), + type = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Type", + "Development contains the model and internal validation; Validation contains the external validation" + ), + sortable = TRUE + ), + modelDevelopment = reactable::colDef( + show = F + ), + performanceId = reactable::colDef( + show = F + ), + modelDesignId = reactable::colDef( + show = F + ), + developmentDatabaseId = reactable::colDef( + show = F ) - - }) + ) + + modelTableOutputs <- resultTableServer( + id = "performanceSummaryTable", + df = resultTable, + colDefsInput = colDefsInput, + addActions = c('results','attrition') + ) performanceId <- shiny::reactiveVal(value = NULL) developmentDatabaseId <- shiny::reactiveVal(value = NULL) modelDevelopment <- shiny::reactiveVal(value = NULL) - shiny::observeEvent(input$view_details, { - #print('perf updated') - performanceId(NULL) - performanceId(resultTable()$performanceId[input$view_details$index]) - developmentDatabaseId(resultTable()$developmentDatabaseId[input$view_details$index]) - modelDevelopment(resultTable()$modelDevelopment[input$view_details$index]) + shiny::observeEvent(modelTableOutputs$actionCount(), { + if(modelTableOutputs$actionType() == 'results'){ + performanceId(NULL) + performanceId(resultTable()$performanceId[modelTableOutputs$actionIndex()$index]) + developmentDatabaseId(resultTable()$developmentDatabaseId[modelTableOutputs$actionIndex()$index]) + modelDevelopment(resultTable()$modelDevelopment[modelTableOutputs$actionIndex()$index]) + } + }) + + shiny::observeEvent(modelTableOutputs$actionCount(), { + if(modelTableOutputs$actionType() == 'attrition'){ + + attrition <- shiny::reactive({ + getAttrition( + performanceId = resultTable()$performanceId[modelTableOutputs$actionIndex()$index], + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + }) + + shiny::showModal( + shiny::modalDialog( + title = "Attrition", + shiny::div( + DT::renderDataTable( + attrition() %>% dplyr::select(-c("performanceId", "outcomeId")) + ) + ), + easyClose = TRUE + ) + ) + + } }) return( @@ -214,14 +204,31 @@ predictionModelSummaryServer <- function( ) } - +getAttrition <- function( + performanceId, + connectionHandler, + resultDatabaseSettings +){ + + if(!is.null(performanceId)){ + + sql <- "SELECT * FROM @schema.@plp_table_prefixattrition WHERE performance_id = @performance_id;" + + attrition <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + performance_id = performanceId, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix + ) + + return(attrition) + } +} getModelDesignPerformanceSummary <- function( connectionHandler, - mySchema, - myTableAppend = '', - modelDesignId, - databaseTableAppend + resultDatabaseSettings, + modelDesignId ){ if(is.null(modelDesignId())){ @@ -256,9 +263,9 @@ getModelDesignPerformanceSummary <- function( ROUND(oResult.outcome_count*100.0/nResult.population_size,4) as outcome_percent, results.model_development - FROM (select * from @my_schema.@my_table_appendperformances where model_design_id = @model_design_id) AS results + FROM (select * from @schema.@plp_table_prefixperformances where model_design_id = @model_design_id) AS results - inner join @my_schema.@my_table_appendmodel_designs as model_designs + inner join @schema.@plp_table_prefixmodel_designs as model_designs on model_designs.model_design_id = results.model_design_id -- and results.target_id = model_designs.target_id -- and results.outcome_id = model_designs.outcome_id and @@ -266,30 +273,30 @@ getModelDesignPerformanceSummary <- function( -- results.population_setting_id = model_designs.population_setting_id -- and results.plp_data_setting_id = model_designs.plp_data_setting_id - LEFT JOIN (SELECT cohort_id, cohort_name FROM @my_schema.@my_table_appendcohorts) AS targets ON results.target_id = targets.cohort_id - LEFT JOIN (SELECT cohort_id, cohort_name FROM @my_schema.@my_table_appendcohorts) AS outcomes ON results.outcome_id = outcomes.cohort_id + LEFT JOIN (SELECT cohort_id, cohort_name FROM @schema.@plp_table_prefixcohorts) AS targets ON results.target_id = targets.cohort_id + LEFT JOIN (SELECT cohort_id, cohort_name FROM @schema.@plp_table_prefixcohorts) AS outcomes ON results.outcome_id = outcomes.cohort_id LEFT JOIN (select dd.database_id, md.cdm_source_abbreviation database_acronym - from @my_schema.@database_table_appenddatabase_meta_data md inner join - @my_schema.@my_table_appenddatabase_details dd + from @schema.@database_table_prefixdatabase_meta_data md inner join + @schema.@plp_table_prefixdatabase_details dd on md.database_id = dd.database_meta_data_id) AS d ON results.development_database_id = d.database_id LEFT JOIN (select dd.database_id, md.cdm_source_abbreviation database_acronym - from @my_schema.@database_table_appenddatabase_meta_data md inner join - @my_schema.@my_table_appenddatabase_details dd + from @schema.@database_table_prefixdatabase_meta_data md inner join + @schema.@plp_table_prefixdatabase_details dd on md.database_id = dd.database_meta_data_id) AS v ON results.validation_database_id = v.database_id - LEFT JOIN @my_schema.@my_table_appendtars AS tars ON results.tar_id = tars.tar_id - LEFT JOIN (SELECT performance_id, value AS auc FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'AUROC' and evaluation in ('Test','Validation') ) AS aucResult ON results.performance_id = aucResult.performance_id - LEFT JOIN (SELECT performance_id, value AS auprc FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'AUPRC' and evaluation in ('Test','Validation') ) AS auprcResult ON results.performance_id = auprcResult.performance_id - LEFT JOIN (SELECT performance_id, sum(value) AS population_size FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'populationSize' and evaluation in ('Train','Test','Validation') group by performance_id) AS nResult ON results.performance_id = nResult.performance_id - LEFT JOIN (SELECT performance_id, sum(value) AS outcome_count FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'outcomeCount' and evaluation in ('Train','Test','Validation') group by performance_id) AS oResult ON results.performance_id = oResult.performance_id - LEFT JOIN (SELECT performance_id, value AS test_size FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'populationSize' and evaluation in ('Test', 'Validation') ) AS nTest ON results.performance_id = nTest.performance_id;" + LEFT JOIN @schema.@plp_table_prefixtars AS tars ON results.tar_id = tars.tar_id + LEFT JOIN (SELECT performance_id, value AS auc FROM @schema.@plp_table_prefixevaluation_statistics where metric = 'AUROC' and evaluation in ('Test','Validation') ) AS aucResult ON results.performance_id = aucResult.performance_id + LEFT JOIN (SELECT performance_id, value AS auprc FROM @schema.@plp_table_prefixevaluation_statistics where metric = 'AUPRC' and evaluation in ('Test','Validation') ) AS auprcResult ON results.performance_id = auprcResult.performance_id + LEFT JOIN (SELECT performance_id, sum(value) AS population_size FROM @schema.@plp_table_prefixevaluation_statistics where metric = 'populationSize' and evaluation in ('Train','Test','Validation') group by performance_id) AS nResult ON results.performance_id = nResult.performance_id + LEFT JOIN (SELECT performance_id, sum(value) AS outcome_count FROM @schema.@plp_table_prefixevaluation_statistics where metric = 'outcomeCount' and evaluation in ('Train','Test','Validation') group by performance_id) AS oResult ON results.performance_id = oResult.performance_id + LEFT JOIN (SELECT performance_id, value AS test_size FROM @schema.@plp_table_prefixevaluation_statistics where metric = 'populationSize' and evaluation in ('Test', 'Validation') ) AS nTest ON results.performance_id = nTest.performance_id;" summaryTable <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend, + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, model_design_id = modelDesignId(), - database_table_append = databaseTableAppend + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) shiny::incProgress(2/3, detail = paste("Data extracted")) @@ -320,6 +327,12 @@ getModelDesignPerformanceSummary <- function( }) + # adding actions column to left + ##summaryTable <- cbind( + ## actions = rep("", nrow(summaryTable)), + ## summaryTable + ##) + return(summaryTable[,c('Dev', 'Val', 'T','O', 'modelDesignId', 'TAR', 'AUROC', 'AUPRC', 'T Size', 'O Count','Val (%)', 'O Incidence (%)', 'timeStamp', 'performanceId', 'developmentDatabaseId', 'modelDevelopment', 'type')]) @@ -350,16 +363,14 @@ editColnames <- function(cnames, edits){ getModelDesignInfo <- function( connectionHandler, - mySchema, - myTableAppend, - modelDesignId, - databaseTableAppend + resultDatabaseSettings, + modelDesignId ){ modelType <- connectionHandler$queryDb( - 'select distinct model_type from @my_schema.@my_table_appendmodels where model_design_id = @model_design_id;', - my_schema = mySchema, - my_table_append = myTableAppend, + 'select distinct model_type from @schema.@plp_table_prefixmodels where model_design_id = @model_design_id;', + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, model_design_id = modelDesignId() ) diff --git a/R/prediction-netbenefit.R b/R/patient-level-prediction-netbenefit.R similarity index 93% rename from R/prediction-netbenefit.R rename to R/patient-level-prediction-netbenefit.R index 5027986f..3b19dbf0 100644 --- a/R/prediction-netbenefit.R +++ b/R/patient-level-prediction-netbenefit.R @@ -1,4 +1,4 @@ -# @file prediction-netbenefit.R +# @file patient-level-prediction-netbenefit.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the net-benefit module #' #' @export -predictionNbViewer <- function(id) { +patientLevelPredictionNbViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -75,20 +75,18 @@ predictionNbViewer <- function(id) { #' @param performanceId the performance id in the database #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the net-benefit module #' #' @export -predictionNbServer <- function( +patientLevelPredictionNbServer <- function( id, performanceId, # reactive connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( id, @@ -101,8 +99,8 @@ predictionNbServer <- function( getPredictionResult( performanceId = performanceId, connectionHandler= connectionHandler, - tableName = paste0(myTableAppend,'threshold_summary'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'threshold_summary' ) } else{ NULL diff --git a/R/prediction-settings.R b/R/patient-level-prediction-settings.R similarity index 68% rename from R/prediction-settings.R rename to R/patient-level-prediction-settings.R index 0b0874c6..79f8de14 100644 --- a/R/prediction-settings.R +++ b/R/patient-level-prediction-settings.R @@ -1,4 +1,4 @@ -# @file prediction-settings.R +# @file patient-level-prediction-settings.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the settings module #' #' @export -predictionSettingsViewer <- function(id) { +patientLevelPredictionSettingsViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -46,9 +46,7 @@ predictionSettingsViewer <- function(id) { shinydashboard::infoBoxOutput(ns("preprocess"), width = 4), shinydashboard::infoBoxOutput(ns("split"), width = 4), shinydashboard::infoBoxOutput(ns("sample"), width = 4), - shinydashboard::infoBoxOutput(ns("model"), width = 4), - shinydashboard::infoBoxOutput(ns("hyperparameters"), width = 4), - shinydashboard::infoBoxOutput(ns("attrition"), width = 4) + shinydashboard::infoBoxOutput(ns("model"), width = 4) ) ) @@ -65,26 +63,20 @@ predictionSettingsViewer <- function(id) { #' @param performanceId unique id for the performance results #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema -#' @param cohortTableAppend a string that appends the cohort_definition table -#' @param databaseTableAppend a string that appends the database_meta_data table +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the settings module #' #' @export -predictionSettingsServer <- function( +patientLevelPredictionSettingsServer <- function( id, modelDesignId, developmentDatabaseId, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend, - cohortTableAppend = myTableAppend, - databaseTableAppend = myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( @@ -94,43 +86,20 @@ predictionSettingsServer <- function( # objects modelDesign <- shiny::reactive({ - getModelDesign( + getPredictionModelDesign( inputSingleView = inputSingleView, modelDesignId = modelDesignId, - mySchema, connectionHandler = connectionHandler, - myTableAppend, - cohortTableAppend + resultDatabaseSettings = resultDatabaseSettings )}) - - hyperParamSearch <- shiny::reactive({getHyperParamSearch( - inputSingleView = inputSingleView, - modelDesignId = modelDesignId, - databaseId = developmentDatabaseId, - mySchema, - connectionHandler = connectionHandler, - myTableAppend - ) }) - - attrition <- shiny::reactive({ - getAttrition( - inputSingleView = inputSingleView, - performanceId = performanceId, - mySchema, - connectionHandler = connectionHandler, - myTableAppend - ) - }) - + # databases databases <- shiny::reactive({ getPlpSettingDatabase( inputSingleView = inputSingleView, performanceId = performanceId, - mySchema = mySchema, connectionHandler = connectionHandler, - myTableAppend = myTableAppend, - databaseTableAppend = databaseTableAppend + resultDatabaseSettings = resultDatabaseSettings ) }) @@ -151,8 +120,7 @@ predictionSettingsServer <- function( shiny::showModal(shiny::modalDialog( title = "Cohort description", shiny::p(modelDesign()$cohort$cohortJson), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) @@ -173,8 +141,7 @@ predictionSettingsServer <- function( shiny::showModal(shiny::modalDialog( title = "Cohort description", shiny::p(modelDesign()$outcome$cohortJson), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -194,8 +161,7 @@ predictionSettingsServer <- function( shiny::showModal(shiny::modalDialog( title = "Exclusions done during data extraction", shiny::p(modelDesign()$RestrictPlpData), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -221,8 +187,7 @@ predictionSettingsServer <- function( formatPopSettings(modelDesign()$populationSettings) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -246,8 +211,7 @@ predictionSettingsServer <- function( formatCovSettings(modelDesign()$covariateSettings) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -273,8 +237,7 @@ predictionSettingsServer <- function( formatModSettings(modelDesign()$modelSettings ) ) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -295,8 +258,7 @@ predictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$featureEngineeringSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -317,8 +279,7 @@ predictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$preprocessSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -339,8 +300,7 @@ predictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$splitSettings) ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) @@ -361,68 +321,11 @@ predictionSettingsServer <- function( shiny::div( shiny::p(modelDesign()$sampleSettings) ), - easyClose = TRUE, - footer = NULL - )) - } - ) - - # extras - - # hyper-param - output$hyperparameters<- shinydashboard::renderInfoBox({ - shinydashboard::infoBox( - 'Hyper-parameters', - shiny::actionButton(session$ns("showHyperparameters"),"View"), - icon = shiny::icon('gear'), - color = "light-blue" - ) - }) - shiny::observeEvent( - input$showHyperparameters, { - shiny::showModal(shiny::modalDialog( - title = "Hyper-parameters", - shiny::div( - DT::renderDataTable( - DT::datatable( - as.data.frame( - hyperParamSearch() - ), - options = list(scrollX = TRUE), - colnames = 'Fold AUROC' - ) - ) - ), - easyClose = TRUE, - footer = NULL + easyClose = TRUE )) } ) - # attrition - output$attrition <- shinydashboard::renderInfoBox({ - shinydashboard::infoBox( - 'Attrition', - shiny::actionButton(session$ns("showAttrition"),"View"), - icon = shiny::icon('magnet'), - color = "light-blue" - ) - }) - shiny::observeEvent( - input$showAttrition, { - shiny::showModal(shiny::modalDialog( - title = "Attrition", - shiny::div( - DT::renderDataTable( - attrition() %>% dplyr::select(-c("performanceId", "outcomeId")) - ) - ), - easyClose = TRUE, - footer = NULL - )) - } - ) - } ) @@ -438,10 +341,8 @@ predictionSettingsServer <- function( getPlpSettingDatabase <- function( inputSingleView, performanceId, - mySchema, connectionHandler, - myTableAppend, - databaseTableAppend = myTableAppend + resultDatabaseSettings ){ if(!is.null(performanceId()) & inputSingleView() == 'Design Settings'){ @@ -454,14 +355,14 @@ getPlpSettingDatabase <- function( FROM - (select * from @my_schema.@my_table_appendperformances + (select * from @schema.@plp_table_prefixperformances WHERE performance_id = @performance_id) perf inner join (select dd.database_id, dmd.cdm_source_name as dev_db - from @my_schema.@my_table_appenddatabase_details as dd inner join - @my_schema.@database_table_appenddatabase_meta_data as dmd on + from @schema.@plp_table_prefixdatabase_details as dd inner join + @schema.@database_table_prefixdatabase_meta_data as dmd on dd.database_meta_data_id = dmd.database_id) tempD on tempD.database_id = perf.development_database_id @@ -469,8 +370,8 @@ getPlpSettingDatabase <- function( inner join (select dd.database_id, dmd.cdm_source_name as val_db - from @my_schema.@my_table_appenddatabase_details as dd inner join - @my_schema.@database_table_appenddatabase_meta_data dmd on + from @schema.@plp_table_prefixdatabase_details as dd inner join + @schema.@database_table_prefixdatabase_meta_data dmd on dd.database_meta_data_id = dmd.database_id) tempV on tempV.database_id = perf.validation_database_id @@ -480,10 +381,10 @@ getPlpSettingDatabase <- function( databaseNames <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, performance_id = performanceId(), - my_table_append = myTableAppend, - database_table_append = databaseTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix ) return(databaseNames) @@ -494,13 +395,11 @@ getPlpSettingDatabase <- function( # get the data -getModelDesign <- function( +getPredictionModelDesign <- function( inputSingleView, modelDesignId, - mySchema, connectionHandler, - myTableAppend, - cohortTableAppend = myTableAppend + resultDatabaseSettings ){ if(!is.null(modelDesignId()) & inputSingleView() == 'Design Settings'){ @@ -511,14 +410,14 @@ getModelDesign <- function( shiny::incProgress(1/12, detail = paste("Extracting ids")) sql <- "SELECT * FROM - @my_schema.@my_table_appendmodel_designs + @schema.@plp_table_prefixmodel_designs WHERE model_design_id = @model_design_id;" ids <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, model_design_id = modelDesignId(), - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) @@ -535,13 +434,13 @@ getModelDesign <- function( shiny::incProgress(2/12, detail = paste("Extracting model settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendmodel_settings WHERE model_setting_id = @model_setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixmodel_settings WHERE model_setting_id = @model_setting_id;" tempModSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, model_setting_id = modSetId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$modelSettings <- ParallelLogger::convertJsonToSettings( @@ -550,13 +449,13 @@ getModelDesign <- function( shiny::incProgress(3/12, detail = paste("Extracting covariate settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendcovariate_settings WHERE covariate_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixcovariate_settings WHERE covariate_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = covSetId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$covariateSettings <- ParallelLogger::convertJsonToSettings( tempSettings$covariateSettingsJson @@ -565,13 +464,13 @@ getModelDesign <- function( shiny::incProgress(4/12, detail = paste("Extracting population settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendpopulation_settings WHERE population_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixpopulation_settings WHERE population_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = popSetId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$populationSettings <- ParallelLogger::convertJsonToSettings( @@ -580,64 +479,64 @@ getModelDesign <- function( shiny::incProgress(5/12, detail = paste("Extracting feature engineering settingd")) - sql <- "SELECT * FROM @my_schema.@my_table_appendfeature_engineering_settings WHERE feature_engineering_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixfeature_engineering_settings WHERE feature_engineering_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = feSetId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$featureEngineeringSettings <- tempSettings$featureEngineeringSettingsJson shiny::incProgress(6/12, detail = paste("Extracting tidy covariate settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendtidy_covariates_settings WHERE tidy_covariates_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixtidy_covariates_settings WHERE tidy_covariates_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = tidyCovariatesSettingId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$preprocessSettings <- tempSettings$tidyCovariatesSettingsJson shiny::incProgress(7/12, detail = paste("Extracting restrict plp settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendplp_data_settings WHERE plp_data_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixplp_data_settings WHERE plp_data_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = plpDataSettingId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$RestrictPlpData <- tempSettings$plpDataSettingsJson shiny::incProgress(8/12, detail = paste("Extracting sample settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendsample_settings WHERE sample_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixsample_settings WHERE sample_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = sampleSetId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$sampleSettings <- tempSettings$sampleSettingsJson shiny::incProgress(9/12, detail = paste("Extracting split settings")) - sql <- "SELECT * FROM @my_schema.@my_table_appendsplit_settings WHERE split_setting_id = @setting_id;" + sql <- "SELECT * FROM @schema.@plp_table_prefixsplit_settings WHERE split_setting_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = splitId, - my_table_append = myTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix ) modelDesign$splitSettings <- tempSettings$splitSettingsJson @@ -645,17 +544,17 @@ getModelDesign <- function( shiny::incProgress(10/12, detail = paste("Extracting target cohort")) sql <- "SELECT c.*, cd.json as cohort_json - FROM @my_schema.@my_table_appendcohorts c inner join - @my_schema.@cohort_table_appendcohort_definition cd + FROM @schema.@plp_table_prefixcohorts c inner join + @schema.@cg_table_prefixcohort_definition cd on c.cohort_definition_id = cd.cohort_definition_id WHERE c.cohort_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = tId, - my_table_append = myTableAppend, - cohort_table_append = cohortTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) modelDesign$cohort <- tempSettings @@ -663,17 +562,17 @@ getModelDesign <- function( shiny::incProgress(11/12, detail = paste("Extracting outcome cohort")) sql <- "SELECT c.*, cd.json as cohort_json - FROM @my_schema.@my_table_appendcohorts c inner join - @my_schema.@cohort_table_appendcohort_definition cd + FROM @schema.@plp_table_prefixcohorts c inner join + @schema.@cg_table_prefixcohort_definition cd on c.cohort_definition_id = cd.cohort_definition_id WHERE c.cohort_id = @setting_id;" tempSettings <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, setting_id = oId, - my_table_append = myTableAppend, - cohort_table_append = cohortTableAppend + plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) modelDesign$outcome <- tempSettings @@ -687,56 +586,9 @@ getModelDesign <- function( } -getHyperParamSearch <- function( - inputSingleView, - modelDesignId, - databaseId, - mySchema, - connectionHandler, - myTableAppend -){ - - if(!is.null(modelDesignId()) & inputSingleView() == 'Design Settings'){ - - sql <- "SELECT train_details FROM @my_schema.@my_table_appendmodels WHERE database_id = @database_id - and model_design_id = @model_design_id;" - - models <- connectionHandler$queryDb( - sql = sql, - my_schema = mySchema, - database_id = databaseId(), - model_design_id = modelDesignId(), - my_table_append = myTableAppend - ) - trainDetails <- ParallelLogger::convertJsonToSettings(models$trainDetails) - - return(trainDetails$hyperParamSearch) - } -} -getAttrition <- function( - inputSingleView, - performanceId, - mySchema, - connectionHandler, - myTableAppend -){ - - if(!is.null(performanceId()) & inputSingleView() == 'Design Settings'){ - - sql <- "SELECT * FROM @my_schema.@my_table_appendattrition WHERE performance_id = @performance_id;" - attrition <- connectionHandler$queryDb( - sql = sql, - my_schema = mySchema, - performance_id = performanceId(), - my_table_append = myTableAppend - ) - - return(attrition) - } -} # formating formatModSettings <- function(modelSettings){ diff --git a/R/prediction-validation.R b/R/patient-level-prediction-validation.R similarity index 79% rename from R/prediction-validation.R rename to R/patient-level-prediction-validation.R index 8035eb92..6bcfa78a 100644 --- a/R/prediction-validation.R +++ b/R/patient-level-prediction-validation.R @@ -1,4 +1,4 @@ -# @file prediction-validation.R +# @file patient-level-prediction-validation.R # # Copyright 2022 Observational Health Data Sciences and Informatics # @@ -28,7 +28,7 @@ #' The user interface to the validation module #' #' @export -predictionValidationViewer <- function(id) { +patientLevelPredictionValidationViewer <- function(id) { ns <- shiny::NS(id) shiny::div( @@ -65,24 +65,20 @@ predictionValidationViewer <- function(id) { #' @param performanceId identifier for the performance #' @param connectionHandler the connection to the prediction result database #' @param inputSingleView the current tab -#' @param mySchema the database schema for the model results -#' @param myTableAppend a string that appends the tables in the result schema -#' @param databaseTableAppend a string that appends the database_meta_data table +#' @param resultDatabaseSettings a list containing the result schema and prefixes #' #' @return #' The server to the validation module #' #' @export -predictionValidationServer <- function( +patientLevelPredictionValidationServer <- function( id, modelDesignId, # reactive developmentDatabaseId, # reactive performanceId, # reactive connectionHandler, inputSingleView, - mySchema, - myTableAppend = NULL, - databaseTableAppend = myTableAppend + resultDatabaseSettings ) { shiny::moduleServer( @@ -93,13 +89,11 @@ predictionValidationServer <- function( validationTable <- shiny::eventReactive(inputSingleView(), { - getValSummary( + getPredictionValSummary( connectionHandler = connectionHandler, - mySchema, + resultDatabaseSettings = resultDatabaseSettings, modelDesignId = modelDesignId(), developmentDatabaseId = developmentDatabaseId(), - myTableAppend = myTableAppend, - databaseTableAppend = databaseTableAppend, inputSingleView = inputSingleView() ) @@ -129,12 +123,11 @@ predictionValidationServer <- function( # get validation results valResult <- shiny::reactive({ - getValidationResults( + getPredictionValidationResults( validationTable = validationTable, validationRowIds = input$validationTable_rows_selected, connectionHandler = connectionHandler, - myTableAppend = myTableAppend, - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings ) }) @@ -168,12 +161,11 @@ predictionValidationServer <- function( ) } -getValidationResults <- function( +getPredictionValidationResults <- function( validationTable, validationRowIds, connectionHandler, - myTableAppend, - mySchema + resultDatabaseSettings ){ if(!is.null(validationTable()) & !is.null(validationRowIds)){ @@ -185,14 +177,14 @@ getValidationResults <- function( thresholdSummaryList[[i]] <- getPredictionResult( performanceId = shiny::reactiveVal(valTable$performanceId[i]), connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'threshold_summary'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'threshold_summary' ) calibrationSummaryList[[i]] <- getPredictionResult( performanceId = shiny::reactiveVal(valTable$performanceId[i]), connectionHandler = connectionHandler, - tableName = paste0(myTableAppend,'calibration_summary'), - mySchema = mySchema + resultDatabaseSettings = resultDatabaseSettings, + tableName = 'calibration_summary' ) } return( @@ -216,13 +208,11 @@ getValidationResults <- function( } } -getValSummary <- function( +getPredictionValSummary <- function( connectionHandler, - mySchema, + resultDatabaseSettings, modelDesignId, developmentDatabaseId, - myTableAppend = '', - databaseTableAppend = myTableAppend, inputSingleView ){ @@ -258,36 +248,36 @@ getValSummary <- function( FROM - (SELECT * FROM @my_schema.@my_table_appendperformances + (SELECT * FROM @schema.@plp_table_appendperformances where model_design_id = @model_design_id and development_database_id = @development_database_id ) AS results - LEFT JOIN (SELECT cohort_id, cohort_name FROM @my_schema.@my_table_appendcohorts) AS targets ON results.target_id = targets.cohort_id - LEFT JOIN (SELECT cohort_id, cohort_name FROM @my_schema.@my_table_appendcohorts) AS outcomes ON results.outcome_id = outcomes.cohort_id + LEFT JOIN (SELECT cohort_id, cohort_name FROM @schema.@plp_table_appendcohorts) AS targets ON results.target_id = targets.cohort_id + LEFT JOIN (SELECT cohort_id, cohort_name FROM @schema.@plp_table_appendcohorts) AS outcomes ON results.outcome_id = outcomes.cohort_id LEFT JOIN (select dd.database_id, md.cdm_source_abbreviation database_acronym - from @my_schema.@database_table_appenddatabase_meta_data md inner join - @my_schema.@my_table_appenddatabase_details dd + from @schema.@database_table_appenddatabase_meta_data md inner join + @schema.@plp_table_appenddatabase_details dd on md.database_id = dd.database_meta_data_id) AS d ON results.validation_database_id = d.database_id - LEFT JOIN @my_schema.@my_table_appendtars AS tars ON results.tar_id = tars.tar_id - LEFT JOIN (SELECT performance_id, value AS auc FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'AUROC' and evaluation in ('Test','Validation') ) AS aucResult ON results.performance_id = aucResult.performance_id - LEFT JOIN (SELECT performance_id, value AS auclb FROM @my_schema.@my_table_appendevaluation_statistics where metric = '95% lower AUROC' and evaluation in ('Test','Validation') ) AS auclbResult ON results.performance_id = auclbResult.performance_id - LEFT JOIN (SELECT performance_id, value AS aucub FROM @my_schema.@my_table_appendevaluation_statistics where metric = '95% upper AUROC' and evaluation in ('Test','Validation') ) AS aucubResult ON results.performance_id = aucubResult.performance_id - LEFT JOIN (SELECT performance_id, value AS auprc FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'AUPRC' and evaluation in ('Test','Validation') ) AS auprcResult ON results.performance_id = auprcResult.performance_id + LEFT JOIN @schema.@plp_table_appendtars AS tars ON results.tar_id = tars.tar_id + LEFT JOIN (SELECT performance_id, value AS auc FROM @schema.@plp_table_appendevaluation_statistics where metric = 'AUROC' and evaluation in ('Test','Validation') ) AS aucResult ON results.performance_id = aucResult.performance_id + LEFT JOIN (SELECT performance_id, value AS auclb FROM @schema.@plp_table_appendevaluation_statistics where metric = '95% lower AUROC' and evaluation in ('Test','Validation') ) AS auclbResult ON results.performance_id = auclbResult.performance_id + LEFT JOIN (SELECT performance_id, value AS aucub FROM @schema.@plp_table_appendevaluation_statistics where metric = '95% upper AUROC' and evaluation in ('Test','Validation') ) AS aucubResult ON results.performance_id = aucubResult.performance_id + LEFT JOIN (SELECT performance_id, value AS auprc FROM @schema.@plp_table_appendevaluation_statistics where metric = 'AUPRC' and evaluation in ('Test','Validation') ) AS auprcResult ON results.performance_id = auprcResult.performance_id - LEFT JOIN (SELECT performance_id, value AS calibration_in_large FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'calibrationInLarge intercept' and evaluation in ('Test','Validation') ) AS CalibrationInLargeResult ON results.performance_id = CalibrationInLargeResult.performance_id + LEFT JOIN (SELECT performance_id, value AS calibration_in_large FROM @schema.@plp_table_appendevaluation_statistics where metric = 'calibrationInLarge intercept' and evaluation in ('Test','Validation') ) AS CalibrationInLargeResult ON results.performance_id = CalibrationInLargeResult.performance_id - LEFT JOIN (SELECT performance_id, sum(value) AS population_size FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'populationSize' and evaluation in ('Test','Train','Validation') group by performance_id) AS nResult ON results.performance_id = nResult.performance_id - LEFT JOIN (SELECT performance_id, sum(value) AS outcome_count FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'outcomeCount' and evaluation in ('Test','Train','Validation') group by performance_id) AS oResult ON results.performance_id = oResult.performance_id - LEFT JOIN (SELECT performance_id, value AS test_size FROM @my_schema.@my_table_appendevaluation_statistics where metric = 'populationSize' and evaluation in ('Test','Validation')) AS nTest ON results.performance_id = nTest.performance_id;" + LEFT JOIN (SELECT performance_id, sum(value) AS population_size FROM @schema.@plp_table_appendevaluation_statistics where metric = 'populationSize' and evaluation in ('Test','Train','Validation') group by performance_id) AS nResult ON results.performance_id = nResult.performance_id + LEFT JOIN (SELECT performance_id, sum(value) AS outcome_count FROM @schema.@plp_table_appendevaluation_statistics where metric = 'outcomeCount' and evaluation in ('Test','Train','Validation') group by performance_id) AS oResult ON results.performance_id = oResult.performance_id + LEFT JOIN (SELECT performance_id, value AS test_size FROM @schema.@plp_table_appendevaluation_statistics where metric = 'populationSize' and evaluation in ('Test','Validation')) AS nTest ON results.performance_id = nTest.performance_id;" valTable <- connectionHandler$queryDb( sql = sql, - my_schema = mySchema, + schema = resultDatabaseSettings$schema, model_design_id = modelDesignId, development_database_id = developmentDatabaseId, - my_table_append = myTableAppend, - database_table_append = databaseTableAppend + plp_table_append = resultDatabaseSettings$plpTablePrefix, + database_table_append = resultDatabaseSettings$databaseTablePrefix ) valTable$target <- trimws(valTable$target) # not needed diff --git a/R/phevaluator-main.R b/R/phevaluator-main.R new file mode 100644 index 00000000..22d3d809 --- /dev/null +++ b/R/phevaluator-main.R @@ -0,0 +1,696 @@ +# @file phevaluator-main.R +# +# Copyright 2022 Observational Health Data Sciences and Informatics +# +# This file is part of OhdsiShinyModules +# +# 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. + + + +#' The location of the phevaluator module helper file +#' +#' @details Returns the location of the cohort-generator helper file +#' +#' @return String location of the phevaluator helper file +#' +#' @export +#' +phevaluatorHelperFile <- function() { + fileLoc <- + system.file('phevaluator-www', "phevaluator.html", package = "OhdsiShinyModules") + return(fileLoc) +} + + +#' The viewer of the phevaluator module +#' +#' @param id The unique reference id for the module +#' +#' @return The user interface to the phevaluator results viewer +#' +#' @export +#' +phevaluatorViewer <- function(id) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = "100%", + title = shiny::span(shiny::icon("gauge"), "PheValuator"), + solidHeader = TRUE, + + shinydashboard::box( + collapsible = TRUE, + collapsed = FALSE, + title = shiny::span( shiny::icon("circle-question"), "Help & Information"), + width = "100%", + shiny::htmlTemplate(system.file("phevaluator-www", "phevaluator.html", package = utils::packageName())) + ), + + shinydashboard::box( + collapsible = TRUE, + collapsed = FALSE, + title = shiny::span( shiny::icon("gear"), "Options"), + width = "100%", + shiny::uiOutput(ns('phevalOptionsSelector')) + ), + + shiny::conditionalPanel( + condition = "input.generate != 0", + ns = ns, + + shiny::uiOutput(ns("inputsText")), + + shiny::tabsetPanel( + type = 'pills', + id = ns('mainPanel'), + + shiny::tabPanel( + title = "Phenotypes", + resultTableViewer(ns("cohortDefinitionSetTable"), + downloadedFileName = "cohortDefinitionSetTable-") + ), + shiny::tabPanel( + title = "Phenotype Performance Characteristics", + resultTableViewer(ns("algorithmPerformanceResultsTable"), + downloadedFileName = "algorithmPerformanceResultsTable-") + ), + shiny::tabPanel( + title = "Model Covariates", + resultTableViewer(ns("modelCovariatesTable"), + downloadedFileName = "modelCovariatesTable-") + ), + shiny::tabPanel( + title = "Model Performance", + resultTableViewer(ns("modelPerformanceTable"), + downloadedFileName = "modelPerformanceTable-") + ), + shiny::tabPanel( + title = "Model Input Parameters", + resultTableViewer(ns("modelInputParametersTable"), + downloadedFileName = "modelInputParametersTable-") + ), + shiny::tabPanel( + title = "Evaluation Cohort Diagnostics", + resultTableViewer(ns("diagnosticsTable"), + downloadedFileName = "diagnosticsTable-") + ), + shiny::tabPanel( + title = "Evaluation Cohort Parameters", + resultTableViewer(ns("evaluationInputParametersTable"), + downloadedFileName = "evaluationInputParametersTable-") + ), + shiny::tabPanel( + title = "Test Subjects", + resultTableViewer(ns("testSubjectsTable"), + downloadedFileName = "testSubjectsTable-") + ), + shiny::tabPanel( + title = "Test Subjects Covariates", + resultTableViewer(ns("testSubjectsCovariatesTable"), + downloadedFileName = "testSubjectsCovariatesTable-") + ) + ) + ) + ) +} + + +#' The module server for the main phevaluator module +#' +#' @param id The unique reference id for the module +#' @param connectionHandler A connection to the database with the results +#' @param resultDatabaseSettings A named list containing the cohort generator results database details (schema, table prefix) +#' +#' @return The phevaluator main module server +#' +#' @export +#' + +phevaluatorServer <- function( + id, + connectionHandler, + resultDatabaseSettings +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + ns <- session$ns + + withTooltip <- function(value, tooltip, ...) { + shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", + tippy::tippy(value, tooltip, ...)) + } + + #use algorithm performance table to get "option columns", + #which will be used to make choices before generating result(s) + optionCols <- getPhevalAlgorithmPerformance( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::select("databaseId", "phenotype") + + databaseIds = unique(optionCols$databaseId) + phenotypeNames = unique(optionCols$phenotype) + + #build the selector + output$phevalOptionsSelector <- shiny::renderUI({ + + shiny::fluidPage( + shiny::fluidRow( + shiny::column( + width = 6, + shinyWidgets::pickerInput( + inputId = session$ns('selectedDatabaseIds'), + label = 'Database(s):', + choices = databaseIds, + selected = databaseIds, + choicesOpt = list(style = rep_len("color: black;", 999)), + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ), + width = "100%" + ) + ), + shiny::column( + width = 6, + shinyWidgets::pickerInput( + inputId = session$ns('selectedPhenotypes'), + label = 'Phenotype(s):', + choices = phenotypeNames, + selected = phenotypeNames, + choicesOpt = list(style = rep_len("color: black;", 999)), + multiple = T, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ), + width = "100%" + ) + ) + ), + shiny::actionButton( + inputId = session$ns('generate'), + label = 'Generate Results' + ) + ) + }) + + #if generate is pushed, extract the data + dataAlgorithmPerformance <- shiny::eventReactive( #we care about returning this value, so we use eventReactive + eventExpr = input$generate, #could add complexity to event if desired + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalAlgorithmPerformance( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter(.data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes) %>% + dplyr::select("databaseId":"cohortId", "description", "sensitivity95Ci":"analysisId") + } + ) + + dataCohortDefinitionSet <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalCohortDefinitionSet( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::mutate(buttonSQL = makeButtonLabel("SQL"), + buttonJSON = makeButtonLabel("JSON")) %>% + dplyr::filter(.data$phenotype %in% input$selectedPhenotypes) + } + ) + + dataDiagnostics <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + dataEvalInputParams <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalEvalInputParams( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + dataModelCovars <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalModelCovars( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + dataModelInputParams <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalModelInputParams( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + dataModelPerformance <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalModelPerformance( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + dataTestSubjects <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalTestSubjects( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + dataTestSubjectsCovars <- shiny::eventReactive( + eventExpr = input$generate, + { + if (is.null(input$selectedDatabaseIds) | + is.null(input$selectedPhenotypes)) { + data.frame() + } + + getPhevalTestSubjectsCovars( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) %>% + dplyr::filter( + .data$databaseId %in% input$selectedDatabaseIds & + .data$phenotype %in% input$selectedPhenotypes + ) + } + ) + + + + + selectedInputs <- shiny::reactiveVal() + output$inputsText <- shiny::renderUI(selectedInputs()) + + #when generate is pushed, return as text what was selected + shiny::observeEvent( + eventExpr = input$generate, + { + selectedInputs( + shinydashboard::box( + status = 'warning', + width = "100%", + title = 'Selected:', + shiny::div(shiny::fluidRow( + shiny::column( + width = 8, + shiny::tags$b("Phenotype(s):"), + + paste(unique(optionCols$databaseId[optionCols$databaseId %in% input$selectedDatabaseIds]), + collapse = ', ') + + ), + shiny::column( + width = 4, + shiny::tags$b("Database(s):"), + paste(unique(optionCols$phenotype[optionCols$phenotype %in% input$selectedPhenotypes]), + collapse = ', ') + ) + )) + ) + ) + } + ) + + #read in custom column name colDef list from rds file, generated by + #heplers-componentsCreateCustomColDefList.R + + phevalColList <- ParallelLogger::loadSettingsFromJson(system.file("components-columnInformation", + "phevaluator-colDefs.json", + package = "OhdsiShinyModules") + ) + + #define custom colDefs for SQL and JSON buttons + buttonColDefs <- list( + buttonSQL = reactable::colDef(header = withTooltip("SQL", "Downloads SQL code for the cohort"), + html = T + ), + buttonJSON = reactable::colDef(header = withTooltip("JSON", "Downloads JSON code for the cohort"), + html = T + ), + sql = reactable::colDef(show = F), + json = reactable::colDef(show = F) + ) + + #define custom column definitions and render the result table + customColDefs <- utils::modifyList(phevalColList, buttonColDefs) + + + resultTableServer(id = ns("algorithmPerformanceResultsTable"), + df = dataAlgorithmPerformance, + colDefsInput = customColDefs, + downloadedFileName = "algorithmPerformanceResultsTable-") + + resultTableServer(id = ns("cohortDefinitionSetTable"), + df = dataCohortDefinitionSet, + colDefsInput = customColDefs, + downloadedFileName = "cohortDefinitionSetTable-") + + resultTableServer(id = ns("diagnosticsTable"), + df = dataDiagnostics, + colDefsInput = customColDefs, + downloadedFileName = "diagnosticsTable-") + + resultTableServer(id = ns("evaluationInputParametersTable"), + df = dataEvalInputParams, + colDefsInput = customColDefs, + downloadedFileName = "evaluationInputParametersTable-") + + resultTableServer(id = ns("modelCovariatesTable"), + df = dataModelCovars, + colDefsInput = customColDefs, + downloadedFileName = "modelCovariatesTable-") + + resultTableServer(id = ns("modelInputParametersTable"), + df = dataModelInputParams, + colDefsInput = customColDefs, + downloadedFileName = "modelInputParametersTable-") + + resultTableServer(id = ns("modelPerformanceTable"), + df = dataModelPerformance, + colDefsInput = customColDefs, + downloadedFileName = "modelPerformanceTable-") + + resultTableServer(id = ns("testSubjectsTable"), + df = dataTestSubjects, + colDefsInput = customColDefs, + downloadedFileName = "testSubjectsTable-") + + resultTableServer(id = ns("testSubjectsCovariatesTable"), + df = dataTestSubjectsCovars, + colDefsInput = customColDefs, + downloadedFileName = "testSubjectsCovariatesTable-") + + return(invisible(NULL)) + + }) +} + +#add databaseId and phenotype as args into the function +#pass these into the sql code with 'where' + +getPhevalAlgorithmPerformance <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixALGORITHM_PERFORMANCE_RESULTS + ;" + + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +#test it + +# databaseIds = c("CCAE_RS", "Germany_RS") +# phenotypes = c("hyperprolactinemia") +# +# getPhevalAlgorithmPerformance(connectionHandler = connectionHandler, +# resultsSchema = resultDatabaseDetails$schema, +# tablePrefix = resultDatabaseDetails$tablePrefix +# ) + + +getPhevalCohortDefinitionSet <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixCOHORT_DEFINITION_SET + ;" + + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +getPhevalDiagnostics <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixDIAGNOSTICS + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +getPhevalEvalInputParams <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixEVALUATION_INPUT_PARAMETERS + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +getPhevalModelCovars <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixMODEL_COVARIATES + ;" + + df <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + + df$databaseId = stringi::stri_trans_general(df$databaseId, "latin-ascii") + df$phenotype = stringi::stri_trans_general(df$phenotype, "latin-ascii") + df$analysisName = stringi::stri_trans_general(df$analysisName, "latin-ascii") + df$covariateName = stringi::stri_trans_general(df$covariateName, "latin-ascii") + + return( + df + ) +} + +# d <- getPhevalModelCovars(connectionHandler = connectionHandler, +# resultsSchema = resultDatabaseDetails$schema, +# tablePrefix = resultDatabaseDetails$tablePrefix, +# databaseIds = databaseIds, +# phenotypes = phenotypes +# ) + + + +getPhevalModelInputParams <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixMODEL_INPUT_PARAMETERS + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +getPhevalModelPerformance <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixMODEL_PERFORMANCE + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +getPhevalTestSubjects <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixTEST_SUBJECTS + ;" + return( + connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + ) +} + +getPhevalTestSubjectsCovars <- function( + connectionHandler, + resultDatabaseSettings +) { + + sql <- "SELECT * FROM @schema.@pv_table_prefixTEST_SUBJECTS_COVARIATES + ;" + + df <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + pv_table_prefix = resultDatabaseSettings$pvTablePrefix + ) + + df$databaseId = stringi::stri_trans_general(df$databaseId, "latin-ascii") + df$phenotype = stringi::stri_trans_general(df$phenotype, "latin-ascii") + df$analysisName = stringi::stri_trans_general(df$analysisName, "latin-ascii") + df$type = stringi::stri_trans_general(df$type, "latin-ascii") + df$covariateName = stringi::stri_trans_general(df$covariateName, "latin-ascii") + + return( + df + ) + +} + + + + + + + + + diff --git a/R/prediction-diagnostics.R b/R/prediction-diagnostics.R deleted file mode 100644 index 634116ec..00000000 --- a/R/prediction-diagnostics.R +++ /dev/null @@ -1,584 +0,0 @@ -# @file prediction-diagnostics.R -# -# Copyright 2022 Observational Health Data Sciences and Informatics -# -# This file is part of OhdsiShinyModules -# -# 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. - - -#' The module viewer for exploring prediction diagnostic results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the prediction diagnostic module -#' -#' @export -predictionDiagnosticsViewer <- function(id) { - ns <- shiny::NS(id) - - shiny::div( - reactable::reactableOutput(ns('diagnosticSummaryTable')), - shiny::uiOutput(ns('main')) - ) - -} - -#' The module server for exploring prediction diagnostic results -#' -#' @details -#' The user specifies the id for the module -#' -#' @param id the unique reference id for the module -#' @param modelDesignId the unique id for the model design -#' @param mySchema the database schema for the model results -#' @param connectionHandler the connection to the prediction result database -#' @param myTableAppend a string that appends the tables in the result schema -#' @param databaseTableAppend a string that appends the database_meta_data table -#' -#' @return -#' The server to the predcition diagnostic module -#' -#' @export -predictionDiagnosticsServer <- function( - id, - modelDesignId, - mySchema, - connectionHandler, - myTableAppend, - databaseTableAppend -) { - shiny::moduleServer( - id, - function(input, output, session) { - - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - - shiny::observe({ - if(!is.null(modelDesignId()) ){ - - diagnosticTable <- getDiagnostics( - modelDesignId = modelDesignId(), - mySchema, - connectionHandler = connectionHandler, - myTableAppend, - databaseTableAppend = databaseTableAppend - ) - # input tables - output$diagnosticSummaryTable <- reactable::renderReactable({ - reactable::reactable( - data = cbind( - diagnosticTable, - participants = rep("",nrow(diagnosticTable)), - predictors = rep("",nrow(diagnosticTable)), - outcomes = rep("",nrow(diagnosticTable)) - ), - columns = list( - '1.1' = reactable::colDef( - header = withTooltip( - "1.1", - "Participants: Were appropriate data sources used, e.g. cohort, RCT or nested case-control study data?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '1.2' = reactable::colDef( - header = withTooltip( - "1.2", - "Participants: Were all inclusions and exclusions of participants appropriate?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '2.1' = reactable::colDef( - header = withTooltip( - "2.1", - "Predictors: Were predictors defined and assessed in a similar way for all participants?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '2.2' = reactable::colDef( - header = withTooltip( - "2.2", - "Predictors: Were predictor assessments made without knowledge of outcome data?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '2.3' = reactable::colDef( - header = withTooltip( - "2.3", - "Predictors: Are all predictors available at the time the model is intended to be used?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '3.4' = reactable::colDef( - header = withTooltip( - "3.4", - "Outcome: Was the outcome defined and determined in a similar way for all participants?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '3.6' = reactable::colDef( - header = withTooltip( - "3.6", - "Outcome: Was the time interval between predictor assessment and outcome determination appropriate?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - '4.1' = reactable::colDef( - header = withTooltip( - "4.1", - "Design: Were there a reasonable number of participants with the outcome?" - ), - cell = reactable::JS(" - function(cellInfo) { - // Render as an X mark or check mark - if(cellInfo.value === 'Fail'){return '\u274c Fail'} else if(cellInfo.value === 'Pass'){return '\u2714\ufe0f Pass'} else{return '? Unkown'} - } - ")), - participants = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View Participants") - ), - predictors = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View Predictors") - ), - outcomes = reactable::colDef( - name = "", - sortable = FALSE, - cell = function() htmltools::tags$button("View Outcomes") - ) - ), - - onClick = reactable::JS( - paste0( - "function(rowInfo, column) { - // Only handle click events on the 'details' column - if (column.id !== 'participants' & column.id !== 'predictors' & column.id !== 'outcomes') { - return - } - - // Display an alert dialog with details for the row - //window.alert('Details for row ' + rowInfo.index + ':\\n' + JSON.stringify(rowInfo.values, null, 2)) - - // Send the click event to Shiny, which will be available in input$show_details - // Note that the row index starts at 0 in JavaScript, so we add 1 - if(column.id == 'participants'){ - Shiny.setInputValue('",session$ns('show_participants'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - if(column.id == 'predictors'){ - Shiny.setInputValue('",session$ns('show_predictors'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - if(column.id == 'outcomes'){ - Shiny.setInputValue('",session$ns('show_outcomes'),"', { index: rowInfo.index + 1 }, { priority: 'event' }) - } - }" - ) - - ) - ) - - }) # end reactable - - - # listen - # PARTICIPANTS - #============ - shiny::observeEvent( - input$show_participants, - { - participants <- getDiagnosticParticipants( - diagnosticId = diagnosticTable$diagnosticId[input$show_participants$index], - mySchema, - connectionHandler = connectionHandler, - myTableAppend - ) - - output$participants <- reactable::renderReactable({ - reactable::reactable( - data = participants %>% - dplyr::filter(.data$parameter == ifelse(is.null(input$participantParameters), unique(participants$parameter)[1], input$participantParameters)) %>% - dplyr::select( - c( - "probastId", - "paramvalue", - "metric", - "value" - ) - ) %>% - dplyr::mutate( - value = format(.data$value, nsmall = 2, ) - ) %>% - tidyr::pivot_wider( - names_from = "paramvalue", #.data$paramvalue, - values_from = "value" #.data$value - ) - ) - }) - output$main <- shiny::renderUI({ - shiny::div( - shiny::selectInput( - inputId = session$ns('participantParameters'), - label = 'Select Parameter', - multiple = F, - choices = unique(participants$parameter) - ), - reactable::reactableOutput(session$ns('participants')) - ) - }) # renderUI - } - ) # end observed event - - - - # PREDICTOR - #================== - shiny::observeEvent( - input$show_predictors, - { - - predTable <- getDiagnosticPredictors( - diagnosticId = diagnosticTable$diagnosticId[input$show_predictors$index], - mySchema, - connectionHandler = connectionHandler, - myTableAppend - ) - - output$predictorPlot <- plotly::renderPlotly({ - - tempPredTable <- predTable %>% - dplyr::filter( - .data$inputType == ifelse( - is.null(input$predictorParameters), - unique(predTable$inputType)[1], - input$predictorParameters - ) - ) %>% - dplyr::select( - c( - "daysToEvent", - "outcomeAtTime", - "observedAtStartOfDay" - ) - ) %>% - dplyr::mutate( - survivalT = (.data$observedAtStartOfDay -.data$outcomeAtTime)/.data$observedAtStartOfDay - ) %>% - dplyr::filter( - !is.na(.data$daysToEvent) - ) - - tempPredTable$probSurvT <- unlist( - lapply( - 1:length(tempPredTable$daysToEvent), - function(x){prod(tempPredTable$survivalT[tempPredTable$daysToEvent <= tempPredTable$daysToEvent[x]])} - ) - ) - - plotly::plot_ly(x = ~ tempPredTable$daysToEvent) %>% - plotly::add_lines( - y = tempPredTable$probSurvT, - name = "hv", - line = list(shape = "hv") - ) %>% - plotly::layout( - title = 'Outcome survival', - plot_bgcolor = "#e5ecf6", - xaxis = list(title = 'Time (days)'), - yaxis = list(title = 'Outcome free (0 = 0%, 1 = 100%)') - ) - }) - - output$main <- shiny::renderUI({ - shiny::div( - shiny::p('Were predictor assessments made without knowledge of outcome data? (if outcome occur shortly after index this may be problematic)'), - shiny::p(''), - - shiny::selectInput( - inputId = session$ns('predictorParameters'), - label = 'Select Parameter', - multiple = F, - choices = unique(predTable$inputType) - ), - - plotly::plotlyOutput(session$ns('predictorPlot')) - ) - - }) # renderUI - } - ) - - # OUTCOME - # ================= - shiny::observeEvent( - input$show_outcomes, - { - - outcomeTable <- getDiagnosticOutcomes( - diagnosticId = diagnosticTable$diagnosticId[input$show_outcomes$index], - mySchema, - connectionHandler = connectionHandler, - myTableAppend - ) - - #output$predictorPlot <- - output$outcomePlot <- plotly::renderPlotly({ - plotly::plot_ly( - data = outcomeTable %>% - dplyr::filter( - .data$aggregation == ifelse( - is.null(input$outcomeParameters), - unique(outcomeTable$aggregation)[1], - input$outcomeParameters - ) - ) %>% - dplyr::group_by(.data$inputType), # dep fix - x = ~ xvalue, - y = ~ outcomePercent, - #group = ~ inputType, - color = ~ inputType, - type = 'scatter', - mode = 'lines' - ) %>% - plotly::layout( - title = "Outcome rate", - xaxis = list(title = "Value"), - yaxis = list (title = "Percent of cohort with outcome") - ) - }) - - output$main <- shiny::renderUI({ - shiny::div( - shiny::p('Was the outcome determined appropriately? (Are age/sex/year/month trends expected?)'), - shiny::p(''), - - shiny::selectInput( - inputId = session$ns('outcomeParameters'), - label = 'Select Parameter', - multiple = F, - choices = unique(outcomeTable$aggregation) - ), - - plotly::plotlyOutput(session$ns('outcomePlot')) - ) - - }) # renderUI - } - ) - - - - } # not null - }) # observe - } - ) # server -} - - -# helpers - - -# get the data -getDiagnostics <- function( - modelDesignId, - mySchema, - connectionHandler, - myTableAppend, - databaseTableAppend = myTableAppend, - threshold1_2 = 0.9 -){ - if(!is.null(modelDesignId)){ - print(paste0('model design: ', modelDesignId)) - } - - sql <- "SELECT distinct design.MODEL_DESIGN_ID, - diagnostics.diagnostic_id, - database.DATABASE_NAME, - cohortT.COHORT_NAME target_name, - cohortO.COHORT_NAME outcome_name, - summary.PROBAST_ID, - summary.RESULT_VALUE - - from - (select * from @my_schema.@my_table_appendDIAGNOSTICS where MODEL_DESIGN_ID = @model_design_id) as diagnostics - inner join - @my_schema.@my_table_appendMODEL_DESIGNS design - on diagnostics.MODEL_DESIGN_ID = design.MODEL_DESIGN_ID - - inner join - @my_schema.@my_table_appendDIAGNOSTIC_SUMMARY summary - on diagnostics.DIAGNOSTIC_ID = summary.DIAGNOSTIC_ID - - inner join - (select dd.database_id, md.cdm_source_abbreviation as database_name - from @my_schema.@database_table_appenddatabase_meta_data md inner join - @my_schema.@my_table_appenddatabase_details dd - on md.database_id = dd.database_meta_data_id) as database - on database.database_id = diagnostics.database_id - - inner join - @my_schema.@my_table_appendCOHORTS cohortT - on cohortT.cohort_id = design.target_id - - inner join - @my_schema.@my_table_appendCOHORTS cohortO - on cohortO.cohort_id = design.outcome_id; - " - - summaryTable <- connectionHandler$queryDb( - sql = sql, - my_schema = mySchema, - my_table_append = myTableAppend, - model_design_id = modelDesignId, - database_table_append = databaseTableAppend - ) - - if(nrow(summaryTable)==0){ - ParallelLogger::logInfo("No diagnostic summary") - return(NULL) - } - - summary <- summaryTable %>% tidyr::pivot_wider( - id_cols = c( - 'diagnosticId', - 'databaseName', - 'targetName', - 'outcomeName' - ), - names_from = 'probastId', - values_from = 'resultValue' - ) - - summary$`1.2` <- ifelse( - apply(summary[,grep('1.2.', colnames(summary))] > threshold1_2, 1, sum) == length(grep('1.2.', colnames(summary))), - 'Pass', - 'Fail' - ) - - summary <- summary[, - grep('1.2.', colnames(summary))] %>% - dplyr::relocate("1.2", .after = "1.1") - ParallelLogger::logInfo("got summary") - return(summary) -} - - -getDiagnosticParticipants <- function( - diagnosticId, - mySchema, - connectionHandler, - myTableAppend -){ - - sql <- "SELECT * FROM @my_schema.@my_table_append@table_name WHERE diagnostic_id = @diagnostic_id;" - - participants <- connectionHandler$queryDb( - sql = sql, - my_schema = mySchema, - table_name = 'diagnostic_participants', - my_table_append = myTableAppend, - diagnostic_id = diagnosticId - ) - - participants$parameter <- unlist( - lapply( - participants$design, - function(x){strsplit(x, ':')[[1]][1]} - ) - ) - participants$paramvalue <- unlist( - lapply( - participants$design, - function(x){gsub(' ', '', strsplit(x, ':')[[1]][2])} - ) - ) - - return(participants) - -} - -getDiagnosticPredictors <- function( - diagnosticId, - mySchema, - connectionHandler, - myTableAppend -){ - - sql <- "SELECT * FROM @my_schema.@my_table_append@table_name WHERE diagnostic_id = @diagnostic_id;" - - predictors <- connectionHandler$queryDb( - sql = sql, - my_schema = mySchema, - table_name = 'diagnostic_predictors', - my_table_append = myTableAppend, - diagnostic_id = diagnosticId - ) - - return(predictors) -} - -getDiagnosticOutcomes <- function( - diagnosticId, - mySchema, - connectionHandler, - myTableAppend -){ - - sql <- "SELECT * FROM @my_schema.@my_table_append@table_name WHERE diagnostic_id = @diagnostic_id;" - - outcomes <- connectionHandler$queryDb( - sql = sql, - my_schema = mySchema, - table_name = 'diagnostic_outcomes', - my_table_append = myTableAppend, - diagnostic_id = diagnosticId - ) - - return(outcomes) - -} diff --git a/R/sccs-diagnosticsSummary.R b/R/sccs-diagnosticsSummary.R index 1158ea32..c6d238eb 100644 --- a/R/sccs-diagnosticsSummary.R +++ b/R/sccs-diagnosticsSummary.R @@ -17,58 +17,431 @@ # limitations under the License. -#' The module viewer for rendering the SCCS diagnostics results -#' -#' @param id the unique reference id for the module -#' -#' @return -#' The user interface to the estimation diagnostics viewer -#' -#' @export sccsDiagnosticsSummaryViewer <- function(id) { ns <- shiny::NS(id) - shiny::div( - # div(HTML("Enhancements to come...")), - reactable::reactableOutput(outputId = ns("diagnosticsTable")) - ) + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Diagnostic Results'), + solidHeader = TRUE, + + shiny::tabsetPanel( + type = 'pills', + id = ns('diagnosticsTablePanel'), + shiny::tabPanel( + title = 'Summary', + resultTableViewer(ns("diagnosticsSummaryTable")) + ), + shiny::tabPanel( + title = 'Full', + resultTableViewer(ns("diagnosticsTable")) + ) + ) + ) + } - -#' The module server for rendering the SCCS diagnostics summary -#' -#' @param id the unique reference id for the module -#' @param connectionHandler the connection to the PLE results database -#' @param resultDatabaseSettings the resultDatabaseSettings with the schemas, prefix and table names -#' -#' @return -#' the SCCS diagnostics summary results -#' -#' @export sccsDiagnosticsSummaryServer <- function( id, connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + inputSelected ) { shiny::moduleServer( id, function(input, output, session) { - output$diagnosticsTable <- reactable::renderReactable({ - data <- getSccsAllDiagnosticsSummary( + + data <- shiny::reactive({ + + getSccsAllDiagnosticsSummary( connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings + resultDatabaseSettings = resultDatabaseSettings, + targetIds = inputSelected()$exposure, + outcomeIds = inputSelected()$outcome, + analysisIds = inputSelected()$analysis ) + }) + + data2 <- shiny::reactive({ # use CM diag function + diagnosticSummaryFormat( + data = data, + idCols = c('databaseName','target','covariateName'), + namesFrom = c('outcome','analysis') + ) + }) - reactable::reactable(data, - striped = TRUE, - filterable = TRUE, - searchable = TRUE, - bordered = TRUE + customColDefs <- list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ) + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ) + ), + outcome = reactable::colDef( + header = withTooltip( + "Outcome", + "The outcome of interest " + ) + ), + analysis = reactable::colDef( + header = withTooltip( + "Analysis", + "The analysis name " + ) + ), + covariateName = reactable::colDef( + header = withTooltip( + "Time Period", + "The time period of interest" + ) + ), + mdrr = reactable::colDef( + header = withTooltip( + "mdrr", + "The minimum detectible relative risk" + ) + ), + ease = reactable::colDef( + header = withTooltip( + "ease", + "The ..." + ) + ), + timeTrendP = reactable::colDef( + header = withTooltip( + "timeTrendP", + "The ..." + ) + ), + preExposureP = reactable::colDef( + header = withTooltip( + "preExposureP", + "The ..." + ) + ), + mdrrDiagnostic = reactable::colDef( + header = withTooltip( + "mdrrDiagnostic", + "The ..." + ) + ), + easeDiagnostic = reactable::colDef( + header = withTooltip( + "easeDiagnostic", + "The ..." + ) + ), + timeTrendDiagnostic = reactable::colDef( + header = withTooltip( + "timeTrendDiagnostic", + "The ..." + ) + ), + preExposureDiagnostic = reactable::colDef( + header = withTooltip( + "preExposureDiagnostic", + "The ..." + ) + ), + + unblind = reactable::colDef( + header = withTooltip( + "unblind", + "If the value is 1 then the diagnostics passed and results can be unblinded" + ) + ) + + ) + + resultTableServer( + id = "diagnosticsTable", + df = data, + colDefsInput = customColDefs + ) + + + resultTableServer( + id = "diagnosticsSummaryTable", + df = data2, + colDefsInput = getColDefsSccsDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) ) - }) } ) } + + + +getSccsDiagAnalyses <- function( + connectionHandler, + resultDatabaseSettings +){ + + sql <- " + SELECT distinct + a.analysis_id, + a.description as analysis + + FROM + @schema.@sccs_table_prefixanalysis a + ; + " + result <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + snakeCaseToCamelCase = TRUE + ) + + res <- result$analysisId + names(res) <- result$analysis + + return(res) +} + + +getSccsDiagOutcomes <- function( + connectionHandler, + resultDatabaseSettings +){ + + sql <- " + SELECT distinct + c.cohort_name as outcome, + c.cohort_definition_id + + FROM @schema.@sccs_table_prefixdiagnostics_summary ds + inner join + @schema.@sccs_table_prefixexposures_outcome_set eos + on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id + inner join + @schema.@cg_table_prefixcohort_definition as c + on c.cohort_definition_id = eos.outcome_id + ; + " + result <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + snakeCaseToCamelCase = TRUE + ) + + res <- result$cohortDefinitionId + names(res) <- result$outcome + + return(res) +} + +getSccsDiagTargets <- function( + connectionHandler, + resultDatabaseSettings +){ + + sql <- " + SELECT distinct + c2.cohort_name as target, + c2.cohort_definition_id + + FROM @schema.@sccs_table_prefixdiagnostics_summary ds + + INNER JOIN + @schema.@sccs_table_prefixcovariate cov + on cov.covariate_id = ds.covariate_id and + cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and + cov.analysis_id = ds.analysis_id and + cov.database_id = ds.database_id + + inner join + @schema.@cg_table_prefixcohort_definition as c2 + on cov.era_id = c2.cohort_definition_id + ; + " + result <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + snakeCaseToCamelCase = TRUE + ) + + res <- result$cohortDefinitionId + names(res) <- result$target + + return(res) +} + + +getSccsAllDiagnosticsSummary <- function( + connectionHandler, + resultDatabaseSettings, + targetIds, + outcomeIds, + analysisIds = NULL +) { + + if(is.null(targetIds)){ + return(NULL) + } + + sql <- " + SELECT + d.cdm_source_abbreviation as database_name, + c.cohort_name as outcome, + c2.cohort_name as target, + a.description as analysis, + cov.covariate_name, + ds.* + FROM @schema.@sccs_table_prefixdiagnostics_summary ds + inner join + @schema.@sccs_table_prefixexposures_outcome_set eos + on ds.exposures_outcome_set_id = eos.exposures_outcome_set_id + inner join + @schema.@cg_table_prefixcohort_definition as c + on c.cohort_definition_id = eos.outcome_id + + INNER JOIN + @schema.@database_table_prefix@database_table d + on d.database_id = ds.database_id + + INNER JOIN + @schema.@sccs_table_prefixanalysis a + on a.analysis_id = ds.analysis_id + + INNER JOIN + @schema.@sccs_table_prefixcovariate cov + on cov.covariate_id = ds.covariate_id and + cov.exposures_outcome_set_id = ds.exposures_outcome_set_id and + cov.analysis_id = ds.analysis_id and + cov.database_id = ds.database_id + + inner join + @schema.@cg_table_prefixcohort_definition as c2 + on cov.era_id = c2.cohort_definition_id + + + where + + c2.cohort_definition_id in (@target_ids) + and c.cohort_definition_id in (@outcome_ids) + {@use_analysis}?{and a.analysis_id in (@analysis_ids)} + ; + " + result <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + + target_ids = paste0(targetIds, collapse = ','), + outcome_ids = paste0(outcomeIds, collapse = ','), + analysis_ids = paste0(analysisIds, collapse = ','), + use_analysis = !is.null(analysisIds), + + snakeCaseToCamelCase = TRUE + ) + + result <- result %>% + dplyr::select(-c("analysisId","exposuresOutcomeSetId","databaseId","covariateId")) + + result$summaryValue <- apply( + X = result[, grep('Diagnostic', colnames(result))], + MARGIN = 1, + FUN = function(x){ + + if(sum(x %in% c('FAIL'))>0){ + return('Fail') + } else if(sum(x %in% c('WARNING')) >0){ + return(sum(x %in% c('WARNING'), na.rm = T)) + } else{ + return('Pass') + } + } + ) + return(result) + +} + + +getColDefsSccsDiag <- function( + connectionHandler, + resultDatabaseSettings +){ + + fixedColumns = list( + databaseName = reactable::colDef( + header = withTooltip( + "Database", + "The database name" + ), + sticky = "left" + ), + target = reactable::colDef( + header = withTooltip( + "Target", + "The target cohort of interest " + ), + sticky = "left" + ), + covariateName = reactable::colDef( + header = withTooltip( + "Time Period", + "The time period of interest" + ), + sticky = "left" + ) + ) + + outcomes <- getSccsDiagOutcomes( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + analyses <- getSccsDiagAnalyses( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + colnameFormat <- merge(unique(names(outcomes)), unique(names(analyses))) + colnameFormat <- apply(colnameFormat, 1, function(x){paste(x, collapse = '_', sep = '_')}) + + styleList <- lapply( + colnameFormat, + FUN = function(x){ + reactable::colDef( + header = withTooltip( + substring(x,1,40), + x + ), + style = function(value) { + color <- 'orange' + if(is.na(value)){ + color <- 'black' + }else if(value == 'Pass'){ + color <- '#AFE1AF' + }else if(value == 'Fail'){ + color <- '#E97451' + } + list(background = color) + } + ) + } + ) + names(styleList) <- colnameFormat + result <- append(fixedColumns, styleList) + + return(result) +} diff --git a/R/sccs-main.R b/R/sccs-main.R index 075d2dd5..6e518992 100644 --- a/R/sccs-main.R +++ b/R/sccs-main.R @@ -21,123 +21,27 @@ sccsView <- function(id = "sccs-module") { #shiny::htmlTemplate(system.file("cohort-diagnostics-www", "cohortCounts.html", package = utils::packageName())) ), + inputSelectionViewer(ns("input-selection-sccs")), - shiny::tabsetPanel( - type = 'pills', - id = ns("mainTabsetPanel"), - shiny::tabPanel( - title = "Diagnostics", - sccsDiagnosticsSummaryViewer(ns("sccsDiganostics")) - ), - shiny::tabPanel( - title = "Results", - - inputSelectionViewer(ns("input-selection-sccs")), + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = shiny::NS(ns("input-selection-sccs")), + + shiny::tabsetPanel( + type = 'pills', + id = ns("mainTabsetPanel"), - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection-sccs")), - - shinydashboard::box( - width = '100%', - - # add database/analysis options here - - reactable::reactableOutput(ns("mainTable")), - - # move these to new tab? - shiny::conditionalPanel( - "output.rowIsSelected == true", - ns = ns, - shiny::tabsetPanel( - id = ns("detailsTabsetPanel"), - shiny::tabPanel( - "Power", - shiny::div(shiny::strong("Table 1."), "For each variable of interest: the number of cases (people with at least one outcome), the number of years those people were observed, the number of outcomes, the number of subjects with at least one exposure, the number of patient-years exposed, the number of outcomes while exposed, and the minimum detectable relative risk (MDRR)."), - shiny::tableOutput(ns("powerTable")) - ), - shiny::tabPanel( - "Attrition", - shiny::plotOutput(ns("attritionPlot"), width = 600, height = 500), - shiny::div( - shiny::strong("Figure 1."), - "Attrition, showing the number of cases (number of subjects with at least one outcome), and number of outcomes (number of ocurrences of the outcome) after each step in the study.") - ), - shiny::tabPanel( - "Model", - shiny::tabsetPanel( - id = ns("modelTabsetPanel"), - shiny::tabPanel( - "Model coefficients", - shiny::div( - shiny::strong("Table 2."), - "The fitted non-zero coefficent (incidence rate ratio) and 95 percent confidence interval for all variables in the model." - ), - shiny::tableOutput(ns("modelTable")) - ), - shiny::tabPanel( - "Age spline", - shiny::plotOutput(ns("ageSplinePlot")), - shiny::div(shiny::strong("Figure 2a."), "Spline fitted for age.") - ), - shiny::tabPanel( - "Season spline", - shiny::plotOutput(ns("seasonSplinePlot")), - shiny::div(shiny::strong("Figure 2b."), "Spline fitted for season") - ), - shiny::tabPanel( - "Calendar time spline", - shiny::plotOutput(ns("calendarTimeSplinePlot")), - shiny::div(shiny::strong("Figure 2c."), "Spline fitted for calendar time") - ) - ) - ), - shiny::tabPanel( - "Spanning", - shiny::radioButtons(ns("spanningType"), label = "Type:", choices = c("Age", "Calendar time")), - shiny::plotOutput(ns("spanningPlot")), - shiny::div(shiny::strong("Figure 3."), "Number of subjects observed for 3 consecutive months, centered on the indicated month.") - ), - shiny::tabPanel( - "Time trend", - shiny::plotOutput(ns("timeTrendPlot"), height = 600), - shiny::div( - shiny::strong("Figure 4."), - "Per calendar month the number of people observed, the unadjusted rate of the outcome, and the rate of the outcome after adjusting for age, season, and calendar time, if specified in the model. Red indicates months where the adjusted rate was significantly different from the mean adjusted rate." - ) - ), - shiny::tabPanel( - "Time to event", - shiny::plotOutput(ns("timeToEventPlot")), - shiny::div( - shiny::strong("Figure 5."), - "The number of events and subjects observed per week relative to the start of the first exposure (indicated by the thick vertical line)." - ) - ), - shiny::tabPanel( - "Event dep. observation", - shiny::plotOutput(ns("eventDepObservationPlot")), - shiny::div(shiny::strong("Figure 6."), "Histograms for the number of months between the first occurrence of the outcome and the end of observation, stratified by whether the end of observation was censored (inferred as not being equal to the end of database time), or uncensored (inferred as having the subject still be observed at the end of database time)." - ) - ), - shiny::tabPanel( - "Systematic error", - shiny::plotOutput(ns("controlEstimatesPlot")), - shiny::div(shiny::strong("Figure 7."), "Systematic error. Effect size estimates for the negative controls (true incidence rate ratio = 1) - and positive controls (true incidence rate ratio > 1), before and after calibration. Estimates below the diagonal dashed - lines are statistically significant (alpha = 0.05) different from the true effect size. A well-calibrated - estimator should have the true effect size within the 95 percent confidence interval 95 percent of times.") - ), - shiny::tabPanel( - "Diagnostics summary", - shiny::tableOutput(ns("diagnosticsSummary")) - - ) - ) + shiny::tabPanel( + title = "Diagnostics", + sccsDiagnosticsSummaryViewer(ns("sccsDiganostics")) + ), + shiny::tabPanel( + title = 'Results', + sccsResultsViewer(ns("sccsResults")), ) - )) - ) - ) + ) + + ) # end condition ) } @@ -162,11 +66,6 @@ sccsServer <- function( ) { ns <- shiny::NS(id) - withTooltip <- function(value, tooltip, ...) { - shiny::div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help", - tippy::tippy(value, tooltip, ...)) - } - # create functions to result list outcomes <- sccsGetOutcomes( connectionHandler = connectionHandler, @@ -176,10 +75,6 @@ sccsServer <- function( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) - databases <- sccsGetDatabases( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings - ) analyses <- sccsGetAnalyses( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings @@ -188,13 +83,6 @@ sccsServer <- function( shiny::moduleServer(id, function(input, output, session) { - - sccsDiagnosticsSummaryServer( - id = "sccsDiganostics", - connectionHandler = connectionHandler, - resultDatabaseSettings - ) - inputSelected <- inputSelectionServer( id = "input-selection-sccs", inputSettingList = list( @@ -204,7 +92,7 @@ sccsServer <- function( varName = 'exposure', uiFunction = 'shinyWidgets::pickerInput', uiInputs = list( - label = 'Exposure: ', + label = 'Target: ', choices = exposures, selected = exposures[1], multiple = F, @@ -238,26 +126,6 @@ sccsServer <- function( ) ) ), - createInputSetting( - rowNumber = 2, - columnWidth = 6, - varName = 'database', - uiFunction = 'shinyWidgets::pickerInput', - uiInputs = list( - label = 'Database: ', - choices = databases, - selected = databases, - multiple = T, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ), createInputSetting( rowNumber = 2, columnWidth = 6, @@ -280,418 +148,24 @@ sccsServer <- function( ) ) ) - - - # inputSelected()$analysis - # inputSelected()$outcome - # inputSelected()$exposure - # inputSelected()$database - # currently reacts to database, analysis and exposure/outcomes to return data - resultSubset <- shiny::reactive({ - results <- getSccsResults(connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - exposureIds = inputSelected()$exposure, - outcomeIds = inputSelected()$outcome, - databaseIds = inputSelected()$database, - analysisIds = inputSelected()$analysis) - - results <- results[order(results$analysisId),] - - idx <- (results$unblind == 0) - if (any(idx)) { - results$rr[idx] <- NA - results$ci95Ub[idx] <- NA - results$ci95Lb[idx] <- NA - results$logRr[idx] <- NA - results$seLogRr[idx] <- NA - results$p[idx] <- NA - results$calibratedRr[idx] <- NA - results$calibratedCi95Ub[idx] <- NA - results$calibratedCi95Lb[idx] <- NA - results$calibratedLogRr[idx] <- NA - results$calibratedSeLogRr[idx] <- NA - results$calibratedP[idx] <- NA - } - - results$rr <- prettyHr(results$rr) - results$ci95Lb <- prettyHr(results$ci95Lb) - results$ci95Ub <- prettyHr(results$ci95Ub) - results$p <- prettyHr(results$p) - results$calibratedRr <- prettyHr(results$calibratedRr) - results$calibratedCi95Lb <- prettyHr(results$calibratedCi95Lb) - results$calibratedCi95Ub <- prettyHr(results$calibratedCi95Ub) - results$calibratedP <- prettyHr(results$calibratedP) - - return(results) - }) - - # add database/analysis select above result table? - output$mainTable <- reactable::renderReactable({ - reactable::reactable( - data = resultSubset() %>% - dplyr::select("description", - "databaseName", - "rr", - "ci95Lb", - "ci95Ub", - "p", - "calibratedRr", - "calibratedCi95Lb", - "calibratedCi95Ub", - "calibratedP"), - rownames = FALSE, - defaultPageSize = 15, - showPageSizeOptions = T, - onClick = 'select', - selection = 'single', - striped = T, - - columns = list( - description = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Analysis", - "Analysis" - )), - databaseName = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Data source", - "Data source" - )), - rr = reactable::colDef( - header = withTooltip( - "IRR", - "Incidence rate ratio (uncalibrated)" - )), - ci95Lb = reactable::colDef( - header = withTooltip( - "LB", - "Lower bound of the 95 percent confidence interval (uncalibrated)" - )), - ci95Ub = reactable::colDef( - header = withTooltip( - "UB", - "Upper bound of the 95 percent confidence interval (uncalibrated)" - )), - p = reactable::colDef( - header = withTooltip( - "P", - "Two-sided p-value (uncalibrated)" - )), - calibratedRr = reactable::colDef( - header = withTooltip( - "Cal.IRR", - "Incidence rate ratio (calibrated)" - )), - calibratedCi95Lb = reactable::colDef( - header = withTooltip( - "Cal.LB", - "Lower bound of the 95 percent confidence interval (calibrated)" - )), - calibratedCi95Ub = reactable::colDef( - header = withTooltip( - "Cal.UB", - "Upper bound of the 95 percent confidence interval (calibrated)" - )), - calibratedP = reactable::colDef( - header = withTooltip( - "Cal.P", - "Two-sided p-value (calibrated)" - )) - ) - ) - - }) - - selectedRow <- shiny::reactive({ - if (getOption("shiny-test-env-enabled", default = FALSE)) { - idx <- input$mainTableRowInput - } else { - idx <- reactable::getReactableState( - outputId = 'mainTable', - name = 'selected' - ) - } - - if (is.null(idx)) { - return(NULL) - } else { - subset <- resultSubset() - if (nrow(subset) == 0) { - return(NULL) - } - row <- subset[idx,] - return(row) - } - }) - - output$rowIsSelected <- shiny::reactive({ - return(!is.null(selectedRow())) - }) - - shiny::outputOptions(output, "rowIsSelected", suspendWhenHidden = FALSE) - - - # move these to a different submodule? - output$powerTable <- shiny::renderTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - resTargetTable <- row %>% - dplyr::mutate(outcomeEvents = ifelse(.data$unblind == 1, .data$outcomeEvents, NA)) %>% - dplyr::select( - "covariateName", - "outcomeSubjects", - "observedDays", - "outcomeEvents", - "covariateSubjects", - "covariateDays", - "covariateOutcomes", - "mdrr" - ) %>% - dplyr::mutate(observedDays = .data$observedDays / 365.25, - covariateDays = .data$covariateDays / 365.25) - colnames(resTargetTable) <- c("Variable", - "Cases", - "Years observed", - "Outcomes", - "Persons exposed", - "Years exposed", - "Outcomes while exposed", - "MDRR") - return(resTargetTable) - } - }) - - output$attritionPlot <- shiny::renderPlot({ - - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - attrition <- getSccsAttrition( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId, - covariateId = row$covariateId - ) - drawAttritionDiagram(attrition) - } - }) - - output$modelTable <- shiny::renderTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - resTargetTable <- getSccsModel( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - exposureId = row$eraId, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - - resTargetTable <- resTargetTable %>% - dplyr::arrange(.data$covariateId) %>% - dplyr::select(-"covariateId") - - colnames(resTargetTable) <- c("Variable", - "IRR", - "LB", - "UB") - return(resTargetTable) - } - }) - - output$timeTrendPlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - timeTrend <- getSccsTimeTrend( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - exposureId = row$eraId, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - plotTimeTrend(timeTrend) - } - }) - - output$timeToEventPlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - timeToEvent <- getSccsTimeToEvent( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - exposureId = row$eraId, - covariateId = row$covariateId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - plotTimeToEventSccs(timeToEvent) - } - }) - - output$eventDepObservationPlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - eventDepObservation <- getSccsEventDepObservation( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - plotEventDepObservation(eventDepObservation) - } - }) - - output$spanningPlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - if (input$spanningType == "Age") { - ageSpanning <- getSccsAgeSpanning( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - plotSpanning(ageSpanning, type = "age") - } else { - calendarTimeSpanning <- getSccsCalendarTimeSpanning( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - plotSpanning(calendarTimeSpanning, type = "calendar time") - } - } - }) - - output$ageSplinePlot <- shiny::renderPlot({ - - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - ageSpline <- getSccsSpline( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId, - splineType = "age" - ) - if (nrow(ageSpline) == 0) { - return(NULL) - } - plotAgeSpline(ageSpline) - } - }) - - output$seasonSplinePlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - seasonSpline <- getSccsSpline( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId, - splineType = "season" - ) - if (nrow(seasonSpline) == 0) { - return(NULL) - } - plotSeasonSpline(seasonSpline) - } - }) - - output$calendarTimeSplinePlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - calendarTimeSpline <- getSccsSpline( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - databaseId = row$databaseId, - analysisId = row$analysisId, - splineType = "calendar time" - ) - if (nrow(calendarTimeSpline) == 0) { - return(NULL) - } - plotCalendarTimeSpline(calendarTimeSpline) - } - }) - - output$controlEstimatesPlot <- shiny::renderPlot({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - controlEstimates <- getSccsControlEstimates( - connectionHandler = connectionHandler, - resultDatabaseSettings, - covariateId = row$covariateId, - databaseId = row$databaseId, - analysisId = row$analysisId - ) - plotControlEstimates(controlEstimates) - } - }) - + sccsDiagnosticsSummaryServer( + id = "sccsDiganostics", + connectionHandler = connectionHandler, + resultDatabaseSettings, + inputSelected = inputSelected + ) - output$diagnosticsSummary <- shiny::renderTable({ - row <- selectedRow() - if (is.null(row)) { - return(NULL) - } else { - diagnosticsSummary <- getSccsDiagnosticsSummary( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - outcomeId = row$outcomeId, - covariateId = row$covariateId, - databaseId = row$databaseId, - analysisId = row$analysisId, - exposureId = row$eraId - ) - - resTargetTable <- renderDiagnosticsSummary(diagnosticsSummary) - return(resTargetTable) - } - }) - + sccsResultsServer( + id = "sccsResults", + connectionHandler = connectionHandler, + resultDatabaseSettings, + inputSelected = inputSelected + ) }) } - - #' The location of the description module helper file #' #' @details diff --git a/R/sccs-results-full.R b/R/sccs-results-full.R new file mode 100644 index 00000000..feb0d9ba --- /dev/null +++ b/R/sccs-results-full.R @@ -0,0 +1,388 @@ +sccsFullResultViewer <- function(id) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Result Explorer'), + solidHeader = TRUE, + + # add selected settings + shinydashboard::box( + status = 'warning', + width = "100%", + title = 'Selected: ', + collapsible = T, + shiny::uiOutput(ns('selection')) + ), + + shiny::tabsetPanel( + id = ns("fullTabsetPanel"), + type = 'pills', + + shiny::tabPanel( + "Power", + shiny::div(shiny::strong("Table 1."), "For each variable of interest: the number of cases (people with at least one outcome), the number of years those people were observed, the number of outcomes, the number of subjects with at least one exposure, the number of patient-years exposed, the number of outcomes while exposed, and the minimum detectable relative risk (MDRR)."), + shiny::tableOutput(ns("powerTable")) + ), + shiny::tabPanel( + "Attrition", + shiny::plotOutput(ns("attritionPlot"), width = 600, height = 500), + shiny::div( + shiny::strong("Figure 1."), + "Attrition, showing the number of cases (number of subjects with at least one outcome), and number of outcomes (number of ocurrences of the outcome) after each step in the study.") + ), + shiny::tabPanel( + "Model", + shiny::tabsetPanel( + id = ns("modelTabsetPanel"), + shiny::tabPanel( + "Model coefficients", + shiny::div( + shiny::strong("Table 2."), + "The fitted non-zero coefficent (incidence rate ratio) and 95 percent confidence interval for all variables in the model." + ), + shiny::tableOutput(ns("modelTable")) + ), + shiny::tabPanel( + "Age spline", + shiny::plotOutput(ns("ageSplinePlot")), + shiny::div(shiny::strong("Figure 2a."), "Spline fitted for age.") + ), + shiny::tabPanel( + "Season spline", + shiny::plotOutput(ns("seasonSplinePlot")), + shiny::div(shiny::strong("Figure 2b."), "Spline fitted for season") + ), + shiny::tabPanel( + "Calendar time spline", + shiny::plotOutput(ns("calendarTimeSplinePlot")), + shiny::div(shiny::strong("Figure 2c."), "Spline fitted for calendar time") + ) + ) + ), + shiny::tabPanel( + "Spanning", + shiny::radioButtons(ns("spanningType"), label = "Type:", choices = c("Age", "Calendar time")), + shiny::plotOutput(ns("spanningPlot")), + shiny::div(shiny::strong("Figure 3."), "Number of subjects observed for 3 consecutive months, centered on the indicated month.") + ), + shiny::tabPanel( + "Time trend", + shiny::plotOutput(ns("timeTrendPlot"), height = 600), + shiny::div( + shiny::strong("Figure 4."), + "Per calendar month the number of people observed, the unadjusted rate of the outcome, and the rate of the outcome after adjusting for age, season, and calendar time, if specified in the model. Red indicates months where the adjusted rate was significantly different from the mean adjusted rate." + ) + ), + shiny::tabPanel( + "Time to event", + shiny::plotOutput(ns("timeToEventPlot")), + shiny::div( + shiny::strong("Figure 5."), + "The number of events and subjects observed per week relative to the start of the first exposure (indicated by the thick vertical line)." + ) + ), + shiny::tabPanel( + "Event dep. observation", + shiny::plotOutput(ns("eventDepObservationPlot")), + shiny::div(shiny::strong("Figure 6."), "Histograms for the number of months between the first occurrence of the outcome and the end of observation, stratified by whether the end of observation was censored (inferred as not being equal to the end of database time), or uncensored (inferred as having the subject still be observed at the end of database time)." + ) + ), + shiny::tabPanel( + "Systematic error", + shiny::plotOutput(ns("controlEstimatesPlot")), + shiny::div(shiny::strong("Figure 7."), "Systematic error. Effect size estimates for the negative controls (true incidence rate ratio = 1) + and positive controls (true incidence rate ratio > 1), before and after calibration. Estimates below the diagonal dashed + lines are statistically significant (alpha = 0.05) different from the true effect size. A well-calibrated + estimator should have the true effect size within the 95 percent confidence interval 95 percent of times.") + ) + ) + + ) + +} + +sccsFullResultServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + selectedRow +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + output$selection <- shiny::renderUI({ + otext <- list() + otext[[1]] <- shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b('Target: '), + selectedRow()$covariateName + ), + shiny::column( + width = 6, + shiny::tags$b('Outcome: '), + selectedRow()$outcome + ) + ) + otext[[2]] <- shiny::fluidRow( + shiny::column( + width = 6, + shiny::tags$b('Analysis: '), + selectedRow()$description + ), + shiny::column( + width = 3, + shiny::tags$b('Database: '), + selectedRow()$databaseName + ) + ) + shiny::div(otext) + }) + + + # selected row: : + + # move these to a different submodule? + output$powerTable <- shiny::renderTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + resTargetTable <- row %>% + dplyr::mutate(outcomeEvents = ifelse(.data$unblind == 1, .data$outcomeEvents, NA)) %>% + dplyr::select( + "covariateName", + "outcomeSubjects", + "observedDays", + "outcomeEvents", + "covariateSubjects", + "covariateDays", + "covariateOutcomes", + "mdrr" + ) %>% + dplyr::mutate(observedDays = .data$observedDays / 365.25, + covariateDays = .data$covariateDays / 365.25) + colnames(resTargetTable) <- c("Variable", + "Cases", + "Years observed", + "Outcomes", + "Persons exposed", + "Years exposed", + "Outcomes while exposed", + "MDRR") + return(resTargetTable) + } + }) + + output$attritionPlot <- shiny::renderPlot({ + + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + attrition <- getSccsAttrition( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId, + covariateId = row$covariateId + ) + drawAttritionDiagram(attrition) + } + }) + + output$modelTable <- shiny::renderTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + resTargetTable <- getSccsModel( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + exposureId = row$eraId, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + + resTargetTable <- resTargetTable %>% + dplyr::arrange(.data$covariateId) %>% + dplyr::select(-"covariateId") + + colnames(resTargetTable) <- c("Variable", + "IRR", + "LB", + "UB") + return(resTargetTable) + } + }) + + output$timeTrendPlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + timeTrend <- getSccsTimeTrend( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + exposureId = row$eraId, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotTimeTrend(timeTrend) + } + }) + + output$timeToEventPlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + timeToEvent <- getSccsTimeToEvent( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + exposureId = row$eraId, + covariateId = row$covariateId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotTimeToEventSccs(timeToEvent) + } + }) + + output$eventDepObservationPlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + eventDepObservation <- getSccsEventDepObservation( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotEventDepObservation(eventDepObservation) + } + }) + + output$spanningPlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + if (input$spanningType == "Age") { + ageSpanning <- getSccsAgeSpanning( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotSpanning(ageSpanning, type = "age") + } else { + calendarTimeSpanning <- getSccsCalendarTimeSpanning( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotSpanning(calendarTimeSpanning, type = "calendar time") + } + } + }) + + output$ageSplinePlot <- shiny::renderPlot({ + + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + ageSpline <- getSccsSpline( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId, + splineType = "age" + ) + if (nrow(ageSpline) == 0) { + return(NULL) + } + plotAgeSpline(ageSpline) + } + }) + + output$seasonSplinePlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + seasonSpline <- getSccsSpline( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId, + splineType = "season" + ) + if (nrow(seasonSpline) == 0) { + return(NULL) + } + plotSeasonSpline(seasonSpline) + } + }) + + output$calendarTimeSplinePlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + calendarTimeSpline <- getSccsSpline( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + outcomeId = row$outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId, + splineType = "calendar time" + ) + if (nrow(calendarTimeSpline) == 0) { + return(NULL) + } + plotCalendarTimeSpline(calendarTimeSpline) + } + }) + + output$controlEstimatesPlot <- shiny::renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + controlEstimates <- getSccsControlEstimates( + connectionHandler = connectionHandler, + resultDatabaseSettings, + covariateId = row$covariateId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotControlEstimates(controlEstimates) + } + }) + + } + ) +} + + + + + + diff --git a/R/sccs-results.R b/R/sccs-results.R new file mode 100644 index 00000000..53b6a3ad --- /dev/null +++ b/R/sccs-results.R @@ -0,0 +1,318 @@ +sccsResultsViewer <- function(id = "sccs-results") { + ns <- shiny::NS(id) + + shiny::tabsetPanel( + type = 'hidden', + id = ns('resultPanel'), + + shiny::tabPanel( + title = "Table", + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span('Result Summary'), + solidHeader = TRUE, + resultTableViewer(ns("resultSummaryTable")) + ) + ), + + shiny::tabPanel( + title = "Results", + shiny::actionButton( + inputId = ns('goBackCmResults'), + label = "Back To Result Summary", + shiny::icon("arrow-left"), + style="color: #fff; background-color: #337ab7; border-color: #2e6da4" + ), + sccsFullResultViewer(ns("sccsFullResults")) + ) + + ) + + + +} + + +sccsResultsServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + inputSelected +) { + ns <- shiny::NS(id) + + shiny::moduleServer(id, function(input, output, session) { + + shiny::observeEvent( + eventExpr = input$goBackCmResults, + { + shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") + } + ) + + data <- shiny::reactive({ + results <- getSccsResults( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + exposureIds = inputSelected()$exposure, + outcomeIds = inputSelected()$outcome, + #databaseIds = inputSelected()$database, + analysisIds = inputSelected()$analysis + ) + }) + + resultTableOutputs <- resultTableServer( + id = "resultSummaryTable", + df = data, + colDefsInput = getSccsResultSummaryTableColDef(), + addActions = c('results') + ) + + selectedRow <- shiny::reactiveVal(value = NULL) + shiny::observeEvent(resultTableOutputs$actionCount(), { + if(resultTableOutputs$actionType() == 'results'){ + selectedRow(data()[resultTableOutputs$actionIndex()$index,]) + shiny::updateTabsetPanel(session, "resultPanel", selected = "Results") + } + }) + + sccsFullResultServer( + id = "sccsFullResults", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow + ) + + + } + ) +} + + +getSccsResultSummaryTableColDef <- function(){ + + results <- list( + + databaseId = reactable::colDef(show = F), + covariateId = reactable::colDef(show = F), + eraId = reactable::colDef(show = F), + covariateAnalysisId = reactable::colDef(show = F), + analysisId = reactable::colDef(show = F), + outcomeId = reactable::colDef(show = F), + outcomeSubjects = reactable::colDef(show = F), + outcomeEvents = reactable::colDef(show = F), + outcomeObservationPeriods = reactable::colDef(show = F), + covariateSubjects = reactable::colDef(show = F), + covariateDays = reactable::colDef(show = F), + covariateEras = reactable::colDef(show = F), + covariateOutcomes = reactable::colDef(show = F), + observedDays = reactable::colDef(show = F), + mdrr = reactable::colDef(show = F), + unblind = reactable::colDef(show = F), + + logRr = reactable::colDef(show = F), + seLogRr = reactable::colDef(show = F), + calibratedLogRr = reactable::colDef(show = F), + calibratedSeLogRr = reactable::colDef(show = F), + llr = reactable::colDef(show = F), + + description = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Analysis", + "Analysis" + ), + minWidth = 300 + ), + databaseName = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Data source", + "Data source" + )), + outcome = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Outcome", + "Outcome of interest" + ), + minWidth = 300 + ), + rr = reactable::colDef( + header = withTooltip( + "IRR", + "Incidence rate ratio (uncalibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + ci95Lb = reactable::colDef( + header = withTooltip( + "LB", + "Lower bound of the 95 percent confidence interval (uncalibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + ci95Ub = reactable::colDef( + header = withTooltip( + "UB", + "Upper bound of the 95 percent confidence interval (uncalibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + p = reactable::colDef( + header = withTooltip( + "P", + "Two-sided p-value (uncalibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + calibratedRr = reactable::colDef( + header = withTooltip( + "Cal.IRR", + "Incidence rate ratio (calibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + calibratedCi95Lb = reactable::colDef( + header = withTooltip( + "Cal.LB", + "Lower bound of the 95 percent confidence interval (calibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + calibratedCi95Ub = reactable::colDef( + header = withTooltip( + "Cal.UB", + "Upper bound of the 95 percent confidence interval (calibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + calibratedP = reactable::colDef( + header = withTooltip( + "Cal.P", + "Two-sided p-value (calibrated)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ) + ) + + return(results) +} + +getSccsResults <- function(connectionHandler, + resultDatabaseSettings, + exposureIds, + outcomeIds, + #databaseIds, + analysisIds) { + sql <- " + SELECT + + ds.cdm_source_abbreviation as database_name, + sr.database_id, + sc.covariate_id, + sc.covariate_name, + sc.era_id, + sc.covariate_analysis_id, + sr.analysis_id, + a.description, + eos.outcome_id, + cg1.cohort_name as outcome, + + sr.outcome_subjects, + sr.outcome_events, + sr.outcome_observation_periods, + sr.covariate_subjects, + sr.covariate_days, + sr.covariate_eras, + sr.covariate_outcomes, + sr.observed_days, + + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.rr end rr, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.ci_95_lb end ci_95_lb, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.ci_95_ub end ci_95_ub, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.p end p, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.log_rr end log_rr, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.se_log_rr end se_log_rr, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.calibrated_rr end calibrated_rr, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.calibrated_ci_95_lb end calibrated_ci_95_lb, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.calibrated_ci_95_ub end calibrated_ci_95_ub, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.calibrated_p end calibrated_p, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.calibrated_log_rr end calibrated_log_rr, + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.calibrated_se_log_rr end calibrated_se_log_rr, + + case when COALESCE(sds.unblind, 0) = 0 then NULL else sr.llr end llr, + + + sds.mdrr, + --sds.ease, + --sds.time_trend_p, + --sds.pre_exposure_p, + --sds.mdrr_diagnostic, + --sds.ease_diagnostic, + --sds.time_trend_diagnostic, + --sds.pre_exposure_diagnostic, + sds.unblind + + FROM @schema.@sccs_table_prefixresult sr + INNER JOIN + @schema.@database_table_prefix@database_table ds + ON sr.database_id = ds.database_id + INNER JOIN + @schema.@sccs_table_prefixdiagnostics_summary sds ON ( + sds.exposures_outcome_set_id = sr.exposures_outcome_set_id AND + sds.database_id = sr.database_id AND + sds.analysis_id = sr.analysis_id AND + sds.covariate_id = sr.covariate_id + ) + INNER JOIN + @schema.@sccs_table_prefixcovariate sc ON ( + sc.exposures_outcome_set_id = sr.exposures_outcome_set_id AND + sc.database_id = sr.database_id AND + sc.analysis_id = sr.analysis_id AND + sc.covariate_id = sr.covariate_id + ) + INNER JOIN @schema.@sccs_table_prefixexposures_outcome_set eos + ON + eos.exposures_outcome_set_id = sr.exposures_outcome_set_id + INNER JOIN + @schema.@sccs_table_prefixanalysis a + on a.analysis_id = sr.analysis_id + + inner join + @schema.@cg_table_prefixcohort_definition cg1 + on cg1.cohort_definition_id = eos.outcome_id + + WHERE sr.analysis_id IN (@analysis_ids) + -- AND sr.database_id IN (@database_ids) + AND eos.outcome_id IN (@outcome_ids) + AND sc.era_id IN (@exposure_ids) + " + + results <- connectionHandler$queryDb( + sql, + schema = resultDatabaseSettings$schema, + database_table_prefix = resultDatabaseSettings$databaseTablePrefix, + database_table = resultDatabaseSettings$databaseTable, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + #database_ids = paste(quoteLiterals(databaseIds), collapse = ','), + analysis_ids = analysisIds, + outcome_ids = paste(outcomeIds, collapse = ','), + exposure_ids = paste(exposureIds, collapse = ','), + snakeCaseToCamelCase = TRUE + ) + + return(results) +} + + diff --git a/_pkgdown.yml b/_pkgdown.yml index 3456fd18..00fb3c41 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -47,46 +47,46 @@ reference: desc: > Modules for prediction results. contents: - - predictionHelperFile - - predictionViewer - - predictionServer - - predictionDiagnosticsServer - - predictionDiagnosticsViewer - - predictionDesignSummaryViewer - - predictionDesignSummaryServer - - predictionModelSummaryViewer - - predictionModelSummaryServer - - predictionSettingsViewer - - predictionSettingsServer - - predictionCovariateSummaryViewer - - predictionCovariateSummaryServer - - predictionCutoffViewer - - predictionCutoffServer - - predictionDiscriminationViewer - - predictionDiscriminationServer - - predictionCalibrationViewer - - predictionCalibrationServer - - predictionNbViewer - - predictionNbServer - - predictionValidationViewer - - predictionValidationServer + - patientLevelPredictionHelperFile + - patientLevelPredictionViewer + - patientLevelPredictionServer + - patientLevelPredictionDiagnosticsServer + - patientLevelPredictionDiagnosticsViewer + - patientLevelPredictionDesignSummaryViewer + - patientLevelPredictionDesignSummaryServer + - patientLevelPredictionModelSummaryViewer + - patientLevelPredictionModelSummaryServer + - patientLevelPredictionSettingsViewer + - patientLevelPredictionSettingsServer + - patientLevelPredictionCovariateSummaryViewer + - patientLevelPredictionCovariateSummaryServer + - patientLevelPredictionCutoffViewer + - patientLevelPredictionCutoffServer + - patientLevelPredictionDiscriminationViewer + - patientLevelPredictionDiscriminationServer + - patientLevelPredictionCalibrationViewer + - patientLevelPredictionCalibrationServer + - patientLevelPredictionNbViewer + - patientLevelPredictionNbServer + - patientLevelPredictionValidationViewer + - patientLevelPredictionValidationServer - title: "Decription module" desc: > Modules for the description analyses. contents: - - descriptionHelperFile - - descriptionViewer - - descriptionServer - - descriptionAggregateFeaturesViewer - - descriptionAggregateFeaturesServer - - descriptionDechallengeRechallengeViewer - - descriptionDechallengeRechallengeServer - - descriptionIncidenceViewer - - descriptionIncidenceServer - - descriptionTableViewer - - descriptionTableServer - - descriptionTimeToEventViewer - - descriptionTimeToEventServer + - characterizationHelperFile + - characterizationViewer + - characterizationServer + - characterizationAggregateFeaturesViewer + - characterizationAggregateFeaturesServer + - characterizationDechallengeRechallengeViewer + - characterizationDechallengeRechallengeServer + - characterizationIncidenceViewer + - characterizationIncidenceServer + - characterizationTableViewer + - characterizationTableServer + - characterizationTimeToEventViewer + - characterizationTimeToEventServer - title: "About module" desc: > Modules for the information page. @@ -105,35 +105,35 @@ reference: desc: > Modules for the CohortMethod package. contents: - - estimationHelperFile - - estimationViewer - - estimationServer - - estimationAttritionViewer - - estimationAttritionServer - - estimationCovariateBalanceViewer - - estimationCovariateBalanceServer - - estimationDiagnosticsSummaryViewer - - estimationDiagnosticsSummaryServer - - estimationForestPlotViewer - - estimationForestPlotServer - - estimationKaplanMeierViewer - - estimationKaplanMeierServer - - estimationPopulationCharacteristicsViewer - - estimationPopulationCharacteristicsServer - - estimationPowerViewer - - estimationPowerServer - - estimationPropensityModelViewer - - estimationPropensityModelServer - - estimationPropensityScoreDistViewer - - estimationPropensityScoreDistServer - - estimationResultsTableViewer - - estimationResultsTableServer - - estimationSubgroupsViewer - - estimationSubgroupsServer - - estimationSystematicErrorViewer - - estimationSystematicErrorServer - - estimationTitlePanelViewer - - estimationTitlePanelServer + - cohortMethodHelperFile + - cohortMethodViewer + - cohortMethodServer + - cohortMethodAttritionViewer + - cohortMethodAttritionServer + - cohortMethodCovariateBalanceViewer + - cohortMethodCovariateBalanceServer + - cohortMethodDiagnosticsSummaryViewer + - cohortMethodDiagnosticsSummaryServer + - cohortMethodForestPlotViewer + - cohortMethodForestPlotServer + - cohortMethodKaplanMeierViewer + - cohortMethodKaplanMeierServer + - cohortMethodPopulationCharacteristicsViewer + - cohortMethodPopulationCharacteristicsServer + - cohortMethodPowerViewer + - cohortMethodPowerServer + - cohortMethodPropensityModelViewer + - cohortMethodPropensityModelServer + - cohortMethodPropensityScoreDistViewer + - cohortMethodPropensityScoreDistServer + - cohortMethodResultsTableViewer + - cohortMethodResultsTableServer + - cohortMethodSubgroupsViewer + - cohortMethodSubgroupsServer + - cohortMethodSystematicErrorViewer + - cohortMethodSystematicErrorServer + - cohortMethodTitlePanelViewer + - cohortMethodTitlePanelServer - title: "Data diagnostics module" desc: > Modules for the DataDiagnostics package. @@ -152,7 +152,7 @@ reference: - cohortDiagnosticsSever - cohortDiagnosticsView - cohortDiagnosticsHelperFile - - characterizationView + - cohortDiagCharacterizationView - cohortCountsModule - cohortCountsView - cohortDefinitionsModule diff --git a/inst/description-www/Description.html b/inst/characterization-www/characterization.html similarity index 100% rename from inst/description-www/Description.html rename to inst/characterization-www/characterization.html diff --git a/inst/description-www/help-OutcomeStratified.html b/inst/characterization-www/help-OutcomeStratified.html similarity index 100% rename from inst/description-www/help-OutcomeStratified.html rename to inst/characterization-www/help-OutcomeStratified.html diff --git a/inst/description-www/help-dechallengeRechallenge.html b/inst/characterization-www/help-dechallengeRechallenge.html similarity index 100% rename from inst/description-www/help-dechallengeRechallenge.html rename to inst/characterization-www/help-dechallengeRechallenge.html diff --git a/inst/description-www/help-incidenceRate.html b/inst/characterization-www/help-incidenceRate.html similarity index 100% rename from inst/description-www/help-incidenceRate.html rename to inst/characterization-www/help-incidenceRate.html diff --git a/inst/description-www/help-targetViewer.html b/inst/characterization-www/help-targetViewer.html similarity index 100% rename from inst/description-www/help-targetViewer.html rename to inst/characterization-www/help-targetViewer.html diff --git a/inst/description-www/help-timeToEvent.html b/inst/characterization-www/help-timeToEvent.html similarity index 100% rename from inst/description-www/help-timeToEvent.html rename to inst/characterization-www/help-timeToEvent.html diff --git a/inst/estimation-ref/Table1Specs.csv b/inst/cohort-method-ref/Table1Specs.csv similarity index 100% rename from inst/estimation-ref/Table1Specs.csv rename to inst/cohort-method-ref/Table1Specs.csv diff --git a/inst/estimation-www/estimation.html b/inst/cohort-method-www/cohort-method.html similarity index 100% rename from inst/estimation-www/estimation.html rename to inst/cohort-method-www/cohort-method.html diff --git a/inst/components-columnInformation/datasources-colDefs.json b/inst/components-columnInformation/datasources-colDefs.json new file mode 100644 index 00000000..8e31f223 --- /dev/null +++ b/inst/components-columnInformation/datasources-colDefs.json @@ -0,0 +1,687 @@ +{ + "cdmSourceName": { + "name": "cdmSourceName", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Name of the database (DB)" + }, + "text": "DB Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cdmSourceAbbreviation": { + "name": "cdmSourceAbbreviation", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Abbreviation for the database (DB)" + }, + "text": "DB Abbreviation" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cdmHolder": { + "name": "cdmHolder", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Holder of the database (DB)" + }, + "text": "DB Holder" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sourceDescription": { + "name": "sourceDescription", + "show": false, + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Description of the database (DB)" + }, + "text": "DB Description" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sourceDocumentationReference": { + "name": "sourceDocumentationReference", + "cell": "\n function(cellInfo) {\n // Render as a link\n const url = cellInfo.value;\n return `RHEALTH Description<\/a>`;\n }\n ", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "HTML link to the database (DB) description" + }, + "text": "DB Description Link" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "html": true, + "attr_class": "colDef" + }, + "cdmEtlReference": { + "name": "cdmEtlReference", + "cell": "\n function(cellInfo) {\n // Render as a link\n const url = cellInfo.value;\n return `ETL<\/a>`;\n }\n ", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "HTML link to the ETL for the database (DB)" + }, + "text": "DB ETL Link" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "html": true, + "attr_class": "colDef" + }, + "sourceReleaseDate": { + "name": "sourceReleaseDate", + "format": { + "cell": { + "date": true, + "attr_class": "colFormat" + }, + "aggregated": { + "date": true, + "attr_class": "colFormat" + } + }, + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Date the source data was released" + }, + "text": "Source Data Release Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cdmReleaseDate": { + "name": "cdmReleaseDate", + "format": { + "cell": { + "date": true, + "attr_class": "colFormat" + }, + "aggregated": { + "date": true, + "attr_class": "colFormat" + } + }, + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Date the CDM database (DB) was accessible" + }, + "text": "CDM DB Release Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cdmVersion": { + "name": "cdmVersion", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Version of the common data model (CDM)" + }, + "text": "CDM Version" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "vocabularyVersion": { + "name": "vocabularyVersion", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Version of the vocabulary used in the database (DB)" + }, + "text": "Vocabulary Version" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId": { + "name": "databaseId", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Unique identifier (ID) of the database (DB)" + }, + "text": "DB ID" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "maxObsPeriodEndDate": { + "name": "maxObsPeriodEndDate", + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Maximum/Latest observation period date in the database (DB)" + }, + "text": "Max Obs. Period End Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + } +} \ No newline at end of file diff --git a/inst/components-columnInformation/phevaluator-colDefs.json b/inst/components-columnInformation/phevaluator-colDefs.json new file mode 100644 index 00000000..33bef9c5 --- /dev/null +++ b/inst/components-columnInformation/phevaluator-colDefs.json @@ -0,0 +1,7793 @@ +{ + "databaseId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cohortId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "ATLAS cohort id" + }, + "text": "Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sensitivity95Ci": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Sensitivity with 95% CIs" + }, + "text": "Sensitivity (95 Ci)" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ppv95Ci": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Positive predictive value with 95% CIs" + }, + "text": "PPV (95 Ci)" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "specificity95Ci": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Specificity with 95% CIs" + }, + "text": "Specificity (95 Ci)" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "npv95Ci": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Negative predictive value with 95% Cis" + }, + "text": "NPV (95 Ci)" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "estimatedPrevalence": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated prevalence based on true positives, true negatives, false positives, false negatives" + }, + "text": "Estimated Prevalence" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "f1Score": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated F1 score" + }, + "text": "F1 Score" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "truePositives": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated true positive count" + }, + "text": "True Positives" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "trueNegatives": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated true negative count" + }, + "text": "True Negatives" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "falsePositives": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated False positive count" + }, + "text": "False Positives" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "falseNegatives": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimate false negative count" + }, + "text": "False Negatives" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "washoutPeriod": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The mininum required continuous observation time prior to index date for subjects within the cohort to test" + }, + "text": "Washout Period" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "splayPrior": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days to allow for testing phenotype visit date prior to evaluation date" + }, + "text": "Splay Prior" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "splayPost": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days to allow for testing phenotype visit date after evaluation date" + }, + "text": "Splay Post" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cutPoint": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "A list of threshold predictions for the evaluations. Includes EV\" for the expected value\"" + }, + "text": "Cut Point" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sensitivity": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated sensitivity" + }, + "text": "Sensitivity" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sensitivityCi95Lb": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated sensitvity 95% CI lower bound" + }, + "text": "Sensitivity CI 95 LB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sensitivityCi95Ub": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated sensitvity 95% CI upper bound" + }, + "text": "Sensitivity CI 95 UB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ppv": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated positive predicted value" + }, + "text": "PPV" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ppvCi95Lb": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated positive predicted value 95% CI lower bound" + }, + "text": "PPV CI 95 LB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ppvCi95Ub": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated positive predicted value 95% CI upper bound" + }, + "text": "PPV CI 95 UB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "specificity": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated specificity" + }, + "text": "Specificity" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "specificityCi95Lb": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated specificity 95% CI lower bound" + }, + "text": "Specificity CI 95 LB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "specificityCi95Ub": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated specificity 95% CI upper bound" + }, + "text": "Specificity CI 95 UB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "npv": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated negative predicted value" + }, + "text": "NPV" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "npvCi95Lb": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated negative predicted value 95% CI lower bound" + }, + "text": "NPV CI 95 LB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "npvCi95Ub": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Estimated negative predicted value 95% CI upper bound" + }, + "text": "NPV CI 95 UB" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTimeGMT": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The date and time (GMT) of the PheValuator run" + }, + "text": "Run Date Time GMT" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of the analysis within the run" + }, + "text": "Analysis Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "description": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Description of the cohort" + }, + "text": "Description" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "conceptId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Concept id" + }, + "text": "Concept Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "covariateValue": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Beta coefficient of the covariate in the model" + }, + "text": "Covariate Value" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "covariateName": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Name of the covariate" + }, + "text": "Covariate Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "covariateId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Covariate Id (concept id plus analysis id)" + }, + "text": "Covariate Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Type of analysis, e.g., 201 - condition group era during first time window" + }, + "text": "Analysis Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "xSpecCohortId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id of the xSpec cohort" + }, + "text": "xSpec Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "daysFromxSpec": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Number of allowed days from xSpec condition until analyzed visit" + }, + "text": "Days From xSpec" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "xSensCohortId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id if the xSens cohort" + }, + "text": "xSens Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "prevalenceCohortId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id of the prevalence cohort" + }, + "text": "Prevalence Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "modelPopulationCohortId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id of the cohort used for cohort used as the base population for the model" + }, + "text": "Model Population Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "modelPopulationCohortIdStartDay": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days relative to the mainPopulationCohortId cohort start date to begin including visits." + }, + "text": "Model Population Cohort Id Start Day" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "modelPopulationCohortIdEndDay": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days relative to the mainPopulationCohortId cohort end date to begin including visits." + }, + "text": "Model Population Cohort Id End Day" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "lowerAgeLimit": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Lower age limit for subjects included in the model" + }, + "text": "Lower Age Limit" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "upperAgeLimit": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Upper age limit for subjects included in the model" + }, + "text": "Upper Age Limit" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "startDayWindow1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Start day for prediction window 1" + }, + "text": "Start Day Window 1" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "endDayWindow1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "End day for prediction window 1" + }, + "text": "End Day Window 1" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "startDayWindow2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Start day for prediction window 2" + }, + "text": "Start Day Window 2" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "endDayWindow2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "End day for prediction window 2" + }, + "text": "End Day Window 2" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "startDayWindow3": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Start day for prediction window 3" + }, + "text": "Start Day Window 3" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "endDayWindow3": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "End day for prediction window 3" + }, + "text": "End Day Window 3" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "visitType": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of allowed visit types in analysis" + }, + "text": "Visit Type" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "visitLength": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Visit length in days (0 = no specified visit length)" + }, + "text": "Visit Length" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "gender": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of sexes included in the model" + }, + "text": "Gender" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "race": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of races included in the model" + }, + "text": "Race" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ethnicity": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of ethnicities included in the model" + }, + "text": "Ethnicity" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "minimumOffsetFromStart": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Minimum number of days to offset for the analysis visit from the start of the observation period" + }, + "text": "Minimum Offset From Start" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "minimumOffsetFromEnd ": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Minimum number of days to offset for the analysis visit from the end of the observation period" + }, + "text": "Minimum Offset From End " + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "startDate": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Start date for model subjects" + }, + "text": "Start Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "endDate": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "End date for model subjects" + }, + "text": "End Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.3": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.3": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.3": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.3": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "inclusionEvaluationCohortId ": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of the cohort of the population to be used to designate which visits are eligible to be in the evaluation cohort" + }, + "text": "Inclusion Evaluation Cohort Id " + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "inclusionEvaluationDaysFromStart": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days from the cohort start date of the inclusionEvaluationCohortId to start eligible included visits" + }, + "text": "Inclusion Evaluation Days From Start" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "inclusionEvaluationDaysFromEnd ": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days from the cohort start date of the inclusionEvaluationCohortId to end eligible included visits" + }, + "text": "Inclusion Evaluation Days From End " + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "exclusionEvaluationCohortId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of the cohort of the population to be used to designate which visits are NOT eligible to be in the evaluation cohort" + }, + "text": "Exclusion Evaluation Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "exclusionEvaluationDaysFromStart": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days from the cohort start date of the exclusionEvaluationCohortId to start ineligible included visits" + }, + "text": "Exclusion Evaluation Days From Start" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "exclusionEvaluationDaysFromEnd": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "The number of days from the cohort end date of the exclusionEvaluationCohortId to end ineligible included visits" + }, + "text": "Exclusion Evaluation Days From End" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "visitType.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of allowed visit types in analysis" + }, + "text": "Visit Type" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "visitLength.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Visit length in days (0 = no specified visit length)" + }, + "text": "Visit Length" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "xSpecCohortId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id of the xSpec cohort" + }, + "text": "xSpec Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "xSensCohortId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id if the xSens cohort" + }, + "text": "xSens Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "prevalenceCohortId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Id of the prevalence cohort" + }, + "text": "Prevalence Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "lowerAgeLimit.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Lower age limit for subjects included in the model" + }, + "text": "Lower Age Limit" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "upperAgeLimit.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Upper age limit for subjects included in the model" + }, + "text": "Upper Age Limit" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "gender.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of sexes included in the model" + }, + "text": "Gender" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "race.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of races included in the model" + }, + "text": "Race" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ethnicity.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "List of ethnicites included in the model" + }, + "text": "Ethnicity" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "minimumOffsetFromStart.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Minimum number of days to offset for the analysis visit from the start of the observation period" + }, + "text": "Minimum Offset From Start" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "minimumOffsetFromEnd .1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Minimum number of days to offset for the analysis visit from the end of the observation period" + }, + "text": "Minimum Offset From End " + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "startDate.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Start date for evaluation subjects" + }, + "text": "Start Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "endDate.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "End date for evaluation subjects" + }, + "text": "End Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "excludeModelFromEvaluation": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "True/false of whether subjects in the xSpec cohort should be excluded from the evaluation subjects" + }, + "text": "Exclude Model From Evaluation" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.4": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.4": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.4": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.4": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "evaluation": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Type of evaluation - Train, test, or CV" + }, + "text": "Evaluation" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "metric": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Performance parameter name" + }, + "text": "Metric" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "value": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Value of the performance parameter" + }, + "text": "Value" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.5": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.5": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.5": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.5": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "subjectId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Subject Id" + }, + "text": "Subject Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cohortStartDate": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Visit start date for analysis" + }, + "text": "Cohort Start Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "daysFromObsStart": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Days visit from observation start date" + }, + "text": "Days From Obs Start" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "daysToObsEnd": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Days visit from observation end date" + }, + "text": "Days To Obs End" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "ageYear": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Age at time of visit" + }, + "text": "Age Year" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "gender.2": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Sex of subject" + }, + "text": "Gender" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "type": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Type of subject - TP: true positive; FP: false positive; TN: true negative; FN: false negative" + }, + "text": "Type" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "value.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Predicted probability of subject having condition" + }, + "text": "Value" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "comparisonCohortStartDate": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Cohort start date for comparison to Prevalence cohort" + }, + "text": "Comparison Cohort Start Date" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.6": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.6": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.6": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.6": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "subjectId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Subject Id" + }, + "text": "Subject Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "type.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Type of subject - TP: true positive; FP: false positive; TN: true negative; FN: false negative" + }, + "text": "Type" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "conceptId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Concept id of the covariate" + }, + "text": "Concept Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "coeffValue": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Predicted probability of subject having condition" + }, + "text": "Coefficient Value" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "covariateName.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Name of the covariate" + }, + "text": "Covariate Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "databaseId.7": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Database Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.7": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Phenotype name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.7": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.7": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "Noncases": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Number of non-cases in the evaluation cohort" + }, + "text": "Noncases" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cases": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Number of cases in the evaluation cohort" + }, + "text": "Cases" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "count30And70pct": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Sum of the prediction value for predictions between 30-70%" + }, + "text": "Count 30 And 70%" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "prop30And70pct": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Proportion of sum of 30-70% subjects to total sum of predicted values" + }, + "text": "Prop 30 And 70%" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "count0And1pct": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Sum of the prediction value for predictions between 0-1%" + }, + "text": "Count 0 And 1%" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "prop0And1pct": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Proportion of sum of 0-1% subjects to total sum of predicted values" + }, + "text": "Prop 0 And 1%" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "countGT80pct": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Sum of the prediction value for predictions greater than or equal to 80%" + }, + "text": "Count GT 80%" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "propGT80pct": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Proportion of sum of greater than 80% subjects to total sum of predicted values" + }, + "text": "Prop GT 80%" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "phenotype.8": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Database name" + }, + "text": "Phenotype" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "analysisName.8": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis name" + }, + "text": "Analysis Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "runDateTime.8": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Analysis run date/time" + }, + "text": "Run Datetime" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "atlasId": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Atlas Id" + }, + "text": "Atlas Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cohortId.1": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Cohort Id" + }, + "text": "Cohort Id" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "cohortName": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "Cohort Name" + }, + "text": "Cohort Name" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "sql": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "sql code for cvohort" + }, + "text": "Sql" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "json": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "json code for cohort" + }, + "text": "Json" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "logicDescription": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "logic description" + }, + "text": "Logic Description" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + }, + "generateStats": { + "header": { + "name": "div", + "attribs": { + "style": "text-decoration: underline; text-decoration-style: dotted; cursor: help" + }, + "children": [ + { + "x": { + "opts": { + "content": "generate stats?" + }, + "text": "Generate Stats" + }, + "width": null, + "height": null, + "sizingPolicy": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "viewer": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": true, + "suppress": false, + "paneHeight": null + }, + "browser": { + "defaultWidth": null, + "defaultHeight": null, + "padding": null, + "fill": false, + "external": false + }, + "knitr": { + "defaultWidth": null, + "defaultHeight": null, + "figure": true + } + }, + "dependencies": null, + "elementId": null, + "preRenderHook": null, + "jsHooks": [], + "attr_class": ["tippy", "htmlwidget"], + "attr_package": "tippy" + } + ], + "attr_class": "shiny.tag" + }, + "attr_class": "colDef" + } +} \ No newline at end of file diff --git a/inst/datasources-www/datasources.html b/inst/datasources-www/datasources.html new file mode 100644 index 00000000..9dcb6d6d --- /dev/null +++ b/inst/datasources-www/datasources.html @@ -0,0 +1,15 @@ +

Below are the descriptions of each column in the Data Sources Module:

+ \ No newline at end of file diff --git a/inst/doc/AddingShinyModules.pdf b/inst/doc/AddingShinyModules.pdf deleted file mode 100644 index d97f662a..00000000 Binary files a/inst/doc/AddingShinyModules.pdf and /dev/null differ diff --git a/inst/prediction-document/export-main.Rmd b/inst/patient-level-prediction-document/export-main.Rmd similarity index 100% rename from inst/prediction-document/export-main.Rmd rename to inst/patient-level-prediction-document/export-main.Rmd diff --git a/inst/prediction-document/main.Rmd b/inst/patient-level-prediction-document/main.Rmd similarity index 100% rename from inst/prediction-document/main.Rmd rename to inst/patient-level-prediction-document/main.Rmd diff --git a/inst/prediction-document/model-design.Rmd b/inst/patient-level-prediction-document/model-design.Rmd similarity index 100% rename from inst/prediction-document/model-design.Rmd rename to inst/patient-level-prediction-document/model-design.Rmd diff --git a/inst/prediction-document/plp-analysis.Rmd b/inst/patient-level-prediction-document/plp-analysis.Rmd similarity index 100% rename from inst/prediction-document/plp-analysis.Rmd rename to inst/patient-level-prediction-document/plp-analysis.Rmd diff --git a/inst/prediction-document/plp-diagnostic.Rmd b/inst/patient-level-prediction-document/plp-diagnostic.Rmd similarity index 100% rename from inst/prediction-document/plp-diagnostic.Rmd rename to inst/patient-level-prediction-document/plp-diagnostic.Rmd diff --git a/inst/prediction-document/plp-introduction.Rmd b/inst/patient-level-prediction-document/plp-introduction.Rmd similarity index 100% rename from inst/prediction-document/plp-introduction.Rmd rename to inst/patient-level-prediction-document/plp-introduction.Rmd diff --git a/inst/prediction-document/plp-metrics.Rmd b/inst/patient-level-prediction-document/plp-metrics.Rmd similarity index 100% rename from inst/prediction-document/plp-metrics.Rmd rename to inst/patient-level-prediction-document/plp-metrics.Rmd diff --git a/inst/prediction-document/plp-outcome.Rmd b/inst/patient-level-prediction-document/plp-outcome.Rmd similarity index 100% rename from inst/prediction-document/plp-outcome.Rmd rename to inst/patient-level-prediction-document/plp-outcome.Rmd diff --git a/inst/prediction-document/plp-output.Rmd b/inst/patient-level-prediction-document/plp-output.Rmd similarity index 100% rename from inst/prediction-document/plp-output.Rmd rename to inst/patient-level-prediction-document/plp-output.Rmd diff --git a/inst/prediction-document/plp-participants.Rmd b/inst/patient-level-prediction-document/plp-participants.Rmd similarity index 100% rename from inst/prediction-document/plp-participants.Rmd rename to inst/patient-level-prediction-document/plp-participants.Rmd diff --git a/inst/prediction-document/plp-plots.Rmd b/inst/patient-level-prediction-document/plp-plots.Rmd similarity index 100% rename from inst/prediction-document/plp-plots.Rmd rename to inst/patient-level-prediction-document/plp-plots.Rmd diff --git a/inst/prediction-document/plp-predictors.Rmd b/inst/patient-level-prediction-document/plp-predictors.Rmd similarity index 100% rename from inst/prediction-document/plp-predictors.Rmd rename to inst/patient-level-prediction-document/plp-predictors.Rmd diff --git a/inst/prediction-document/plp-results-external.rmd b/inst/patient-level-prediction-document/plp-results-external.rmd similarity index 100% rename from inst/prediction-document/plp-results-external.rmd rename to inst/patient-level-prediction-document/plp-results-external.rmd diff --git a/inst/prediction-document/plp-results-internal.Rmd b/inst/patient-level-prediction-document/plp-results-internal.Rmd similarity index 100% rename from inst/prediction-document/plp-results-internal.Rmd rename to inst/patient-level-prediction-document/plp-results-internal.Rmd diff --git a/inst/prediction-document/plp-results-template.Rmd b/inst/patient-level-prediction-document/plp-results-template.Rmd similarity index 100% rename from inst/prediction-document/plp-results-template.Rmd rename to inst/patient-level-prediction-document/plp-results-template.Rmd diff --git a/inst/prediction-document/plp-results.Rmd b/inst/patient-level-prediction-document/plp-results.Rmd similarity index 100% rename from inst/prediction-document/plp-results.Rmd rename to inst/patient-level-prediction-document/plp-results.Rmd diff --git a/inst/prediction-www/DataInfo.html b/inst/patient-level-prediction-www/DataInfo.html similarity index 100% rename from inst/prediction-www/DataInfo.html rename to inst/patient-level-prediction-www/DataInfo.html diff --git a/inst/prediction-www/Description.html b/inst/patient-level-prediction-www/Description.html similarity index 100% rename from inst/prediction-www/Description.html rename to inst/patient-level-prediction-www/Description.html diff --git a/inst/prediction-www/Help.html b/inst/patient-level-prediction-www/Help.html similarity index 100% rename from inst/prediction-www/Help.html rename to inst/patient-level-prediction-www/Help.html diff --git a/inst/prediction-www/Log.html b/inst/patient-level-prediction-www/Log.html similarity index 100% rename from inst/prediction-www/Log.html rename to inst/patient-level-prediction-www/Log.html diff --git a/inst/prediction-www/Model.html b/inst/patient-level-prediction-www/Model.html similarity index 100% rename from inst/prediction-www/Model.html rename to inst/patient-level-prediction-www/Model.html diff --git a/inst/prediction-www/Performance.html b/inst/patient-level-prediction-www/Performance.html similarity index 100% rename from inst/prediction-www/Performance.html rename to inst/patient-level-prediction-www/Performance.html diff --git a/inst/prediction-www/Settings.html b/inst/patient-level-prediction-www/Settings.html similarity index 100% rename from inst/prediction-www/Settings.html rename to inst/patient-level-prediction-www/Settings.html diff --git a/inst/prediction-www/Summary.html b/inst/patient-level-prediction-www/Summary.html similarity index 100% rename from inst/prediction-www/Summary.html rename to inst/patient-level-prediction-www/Summary.html diff --git a/inst/prediction-www/boxHelp.html b/inst/patient-level-prediction-www/boxHelp.html similarity index 100% rename from inst/prediction-www/boxHelp.html rename to inst/patient-level-prediction-www/boxHelp.html diff --git a/inst/prediction-www/calHelp.html b/inst/patient-level-prediction-www/calHelp.html similarity index 100% rename from inst/prediction-www/calHelp.html rename to inst/patient-level-prediction-www/calHelp.html diff --git a/inst/prediction-www/demoHelp.html b/inst/patient-level-prediction-www/demoHelp.html similarity index 100% rename from inst/prediction-www/demoHelp.html rename to inst/patient-level-prediction-www/demoHelp.html diff --git a/inst/prediction-www/f1Help.html b/inst/patient-level-prediction-www/f1Help.html similarity index 100% rename from inst/prediction-www/f1Help.html rename to inst/patient-level-prediction-www/f1Help.html diff --git a/inst/prediction-www/help-designSummary.html b/inst/patient-level-prediction-www/help-designSummary.html similarity index 100% rename from inst/prediction-www/help-designSummary.html rename to inst/patient-level-prediction-www/help-designSummary.html diff --git a/inst/prediction-www/help-fullResults.html b/inst/patient-level-prediction-www/help-fullResults.html similarity index 100% rename from inst/prediction-www/help-fullResults.html rename to inst/patient-level-prediction-www/help-fullResults.html diff --git a/inst/patient-level-prediction-www/main-diagnosticsSummaryHelp.html b/inst/patient-level-prediction-www/main-diagnosticsSummaryHelp.html new file mode 100644 index 00000000..0d6b4b88 --- /dev/null +++ b/inst/patient-level-prediction-www/main-diagnosticsSummaryHelp.html @@ -0,0 +1,6 @@ +

This shows the model design diagnostic results for the selected model design across databases. These diagnostics are based on PROBAST.

+ +

+add details +

+ diff --git a/inst/prediction-www/main-modelSummaryHelp.html b/inst/patient-level-prediction-www/main-modelSummaryHelp.html similarity index 100% rename from inst/prediction-www/main-modelSummaryHelp.html rename to inst/patient-level-prediction-www/main-modelSummaryHelp.html diff --git a/inst/prediction-www/prediction.html b/inst/patient-level-prediction-www/patient-level-prediction.html similarity index 100% rename from inst/prediction-www/prediction.html rename to inst/patient-level-prediction-www/patient-level-prediction.html diff --git a/inst/prediction-www/prcHelp.html b/inst/patient-level-prediction-www/prcHelp.html similarity index 100% rename from inst/prediction-www/prcHelp.html rename to inst/patient-level-prediction-www/prcHelp.html diff --git a/inst/prediction-www/predDistHelp.html b/inst/patient-level-prediction-www/predDistHelp.html similarity index 100% rename from inst/prediction-www/predDistHelp.html rename to inst/patient-level-prediction-www/predDistHelp.html diff --git a/inst/prediction-www/prefDistHelp.html b/inst/patient-level-prediction-www/prefDistHelp.html similarity index 100% rename from inst/prediction-www/prefDistHelp.html rename to inst/patient-level-prediction-www/prefDistHelp.html diff --git a/inst/prediction-www/rocHelp.html b/inst/patient-level-prediction-www/rocHelp.html similarity index 100% rename from inst/prediction-www/rocHelp.html rename to inst/patient-level-prediction-www/rocHelp.html diff --git a/inst/phevaluator-www/phevaluator.html b/inst/phevaluator-www/phevaluator.html new file mode 100644 index 00000000..92d23643 --- /dev/null +++ b/inst/phevaluator-www/phevaluator.html @@ -0,0 +1,10 @@ +

Below are the descriptions of each tab in the PheValuator Module, which will appear after clicking the "Generate Results" button below:

+ \ No newline at end of file diff --git a/man/aboutServer.Rd b/man/aboutServer.Rd index e2922a0e..6f767497 100644 --- a/man/aboutServer.Rd +++ b/man/aboutServer.Rd @@ -4,10 +4,18 @@ \alias{aboutServer} \title{The module server for the shiny app home} \usage{ -aboutServer(id = "homepage") +aboutServer( + id = "homepage", + connectionHandler = NULL, + resultDatabaseSettings = NULL +) } \arguments{ \item{id}{the unique reference id for the module} + +\item{connectionHandler}{a connection to the database with the results} + +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} } \value{ The server for the shiny app home diff --git a/man/characterizationAggregateFeaturesServer.Rd b/man/characterizationAggregateFeaturesServer.Rd new file mode 100644 index 00000000..97d46583 --- /dev/null +++ b/man/characterizationAggregateFeaturesServer.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/characterization-aggregateFeatures.R +\name{characterizationAggregateFeaturesServer} +\alias{characterizationAggregateFeaturesServer} +\title{The module server for exploring aggregate features results} +\usage{ +characterizationAggregateFeaturesServer( + id, + connectionHandler, + mainPanelTab, + resultDatabaseSettings +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{connectionHandler}{the connection to the prediction result database} + +\item{mainPanelTab}{the current tab} + +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} +} +\value{ +The server to the description aggregate features module +} +\description{ +The module server for exploring aggregate features results +} +\details{ +The user specifies the id for the module +} diff --git a/man/descriptionAggregateFeaturesViewer.Rd b/man/characterizationAggregateFeaturesViewer.Rd similarity index 64% rename from man/descriptionAggregateFeaturesViewer.Rd rename to man/characterizationAggregateFeaturesViewer.Rd index 3ab53d83..75b82348 100644 --- a/man/descriptionAggregateFeaturesViewer.Rd +++ b/man/characterizationAggregateFeaturesViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-aggregateFeatures.R -\name{descriptionAggregateFeaturesViewer} -\alias{descriptionAggregateFeaturesViewer} +% Please edit documentation in R/characterization-aggregateFeatures.R +\name{characterizationAggregateFeaturesViewer} +\alias{characterizationAggregateFeaturesViewer} \title{The module viewer for exploring aggregate feature results} \usage{ -descriptionAggregateFeaturesViewer(id) +characterizationAggregateFeaturesViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/characterizationDechallengeRechallengeServer.Rd b/man/characterizationDechallengeRechallengeServer.Rd new file mode 100644 index 00000000..d292b070 --- /dev/null +++ b/man/characterizationDechallengeRechallengeServer.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/characterization-dechallengeRechallenge.R +\name{characterizationDechallengeRechallengeServer} +\alias{characterizationDechallengeRechallengeServer} +\title{The module server for exploring Dechallenge Rechallenge results} +\usage{ +characterizationDechallengeRechallengeServer( + id, + connectionHandler, + mainPanelTab, + resultDatabaseSettings +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{connectionHandler}{the connection to the prediction result database} + +\item{mainPanelTab}{the current tab} + +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} +} +\value{ +The server to the Dechallenge Rechallenge module +} +\description{ +The module server for exploring Dechallenge Rechallenge results +} +\details{ +The user specifies the id for the module +} diff --git a/man/descriptionDechallengeRechallengeViewer.Rd b/man/characterizationDechallengeRechallengeViewer.Rd similarity index 63% rename from man/descriptionDechallengeRechallengeViewer.Rd rename to man/characterizationDechallengeRechallengeViewer.Rd index 77ea9c32..f937ae7e 100644 --- a/man/descriptionDechallengeRechallengeViewer.Rd +++ b/man/characterizationDechallengeRechallengeViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-dechallengeRechallenge.R -\name{descriptionDechallengeRechallengeViewer} -\alias{descriptionDechallengeRechallengeViewer} +% Please edit documentation in R/characterization-dechallengeRechallenge.R +\name{characterizationDechallengeRechallengeViewer} +\alias{characterizationDechallengeRechallengeViewer} \title{The module viewer for exploring Dechallenge Rechallenge results} \usage{ -descriptionDechallengeRechallengeViewer(id) +characterizationDechallengeRechallengeViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/characterizationHelperFile.Rd b/man/characterizationHelperFile.Rd new file mode 100644 index 00000000..67cd8f45 --- /dev/null +++ b/man/characterizationHelperFile.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/characterization-main.R +\name{characterizationHelperFile} +\alias{characterizationHelperFile} +\title{The location of the characterization module helper file} +\usage{ +characterizationHelperFile() +} +\value{ +string location of the characterization helper file +} +\description{ +The location of the characterization module helper file +} +\details{ +Returns the location of the characterization helper file +} diff --git a/man/descriptionIncidenceServer.Rd b/man/characterizationIncidenceServer.Rd similarity index 54% rename from man/descriptionIncidenceServer.Rd rename to man/characterizationIncidenceServer.Rd index 84d9014e..fdd4cf3a 100644 --- a/man/descriptionIncidenceServer.Rd +++ b/man/characterizationIncidenceServer.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-incidence.R -\name{descriptionIncidenceServer} -\alias{descriptionIncidenceServer} +% Please edit documentation in R/characterization-incidence.R +\name{characterizationIncidenceServer} +\alias{characterizationIncidenceServer} \title{The module server for exploring incidence results} \usage{ -descriptionIncidenceServer( +characterizationIncidenceServer( id, connectionHandler, mainPanelTab, - schema, - incidenceTablePrefix, - databaseTable = "DATABASE_META_DATA" + resultDatabaseSettings ) } \arguments{ @@ -20,11 +18,7 @@ descriptionIncidenceServer( \item{mainPanelTab}{the current tab} -\item{schema}{the database schema for the model results} - -\item{incidenceTablePrefix}{a string that appends the incidence table in the result schema} - -\item{databaseTable}{name of the database table} +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} } \value{ The server to the prediction incidence module diff --git a/man/descriptionIncidenceViewer.Rd b/man/characterizationIncidenceViewer.Rd similarity index 67% rename from man/descriptionIncidenceViewer.Rd rename to man/characterizationIncidenceViewer.Rd index 8f53cab8..8bb718f7 100644 --- a/man/descriptionIncidenceViewer.Rd +++ b/man/characterizationIncidenceViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-incidence.R -\name{descriptionIncidenceViewer} -\alias{descriptionIncidenceViewer} +% Please edit documentation in R/characterization-incidence.R +\name{characterizationIncidenceViewer} +\alias{characterizationIncidenceViewer} \title{The module viewer for exploring incidence results} \usage{ -descriptionIncidenceViewer(id) +characterizationIncidenceViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/characterizationServer.Rd b/man/characterizationServer.Rd new file mode 100644 index 00000000..b85af663 --- /dev/null +++ b/man/characterizationServer.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/characterization-main.R +\name{characterizationServer} +\alias{characterizationServer} +\title{The module server for exploring characterization studies} +\usage{ +characterizationServer( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1) +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{connectionHandler}{a connection to the database with the results} + +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} +} +\value{ +The server for the characterization module +} +\description{ +The module server for exploring characterization studies +} +\details{ +The user specifies the id for the module +} diff --git a/man/descriptionTableServer.Rd b/man/characterizationTableServer.Rd similarity index 51% rename from man/descriptionTableServer.Rd rename to man/characterizationTableServer.Rd index 104cb8bd..20d5e3f0 100644 --- a/man/descriptionTableServer.Rd +++ b/man/characterizationTableServer.Rd @@ -1,17 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-cohorts.R -\name{descriptionTableServer} -\alias{descriptionTableServer} +% Please edit documentation in R/characterization-cohorts.R +\name{characterizationTableServer} +\alias{characterizationTableServer} \title{The module server for exploring 1 or more cohorts features} \usage{ -descriptionTableServer( +characterizationTableServer( id, connectionHandler, mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix, - databaseTable = "DATABASE_META_DATA" + resultDatabaseSettings ) } \arguments{ @@ -21,13 +18,7 @@ descriptionTableServer( \item{mainPanelTab}{the current tab} -\item{schema}{the database schema for the model results} - -\item{tablePrefix}{a string that appends the tables in the result schema} - -\item{cohortTablePrefix}{a string that appends the cohort table in the result schema} - -\item{databaseTable}{name of the database table} +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} } \value{ The server to the cohorts features server diff --git a/man/descriptionTableViewer.Rd b/man/characterizationTableViewer.Rd similarity index 69% rename from man/descriptionTableViewer.Rd rename to man/characterizationTableViewer.Rd index f2825d50..b82f445c 100644 --- a/man/descriptionTableViewer.Rd +++ b/man/characterizationTableViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-cohorts.R -\name{descriptionTableViewer} -\alias{descriptionTableViewer} +% Please edit documentation in R/characterization-cohorts.R +\name{characterizationTableViewer} +\alias{characterizationTableViewer} \title{The module viewer for exploring 1 or more cohorts features} \usage{ -descriptionTableViewer(id) +characterizationTableViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/descriptionTimeToEventServer.Rd b/man/characterizationTimeToEventServer.Rd similarity index 50% rename from man/descriptionTimeToEventServer.Rd rename to man/characterizationTimeToEventServer.Rd index 3f877337..42f783ef 100644 --- a/man/descriptionTimeToEventServer.Rd +++ b/man/characterizationTimeToEventServer.Rd @@ -1,17 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-timeToEvent.R -\name{descriptionTimeToEventServer} -\alias{descriptionTimeToEventServer} +% Please edit documentation in R/characterization-timeToEvent.R +\name{characterizationTimeToEventServer} +\alias{characterizationTimeToEventServer} \title{The module server for exploring time to event results} \usage{ -descriptionTimeToEventServer( +characterizationTimeToEventServer( id, connectionHandler, mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix = "cg_", - databaseTable = "DATABASE_META_DATA" + resultDatabaseSettings ) } \arguments{ @@ -21,13 +18,7 @@ descriptionTimeToEventServer( \item{mainPanelTab}{the current tab} -\item{schema}{the database schema for the model results} - -\item{tablePrefix}{a string that appends the tables in the result schema} - -\item{cohortTablePrefix}{a string that appends the cohort table in the result schema} - -\item{databaseTable}{name of the database table} +\item{resultDatabaseSettings}{a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix} } \value{ The server to the prediction time to event module diff --git a/man/descriptionTimeToEventViewer.Rd b/man/characterizationTimeToEventViewer.Rd similarity index 55% rename from man/descriptionTimeToEventViewer.Rd rename to man/characterizationTimeToEventViewer.Rd index 1b82b5b6..f5626ffc 100644 --- a/man/descriptionTimeToEventViewer.Rd +++ b/man/characterizationTimeToEventViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-timeToEvent.R -\name{descriptionTimeToEventViewer} -\alias{descriptionTimeToEventViewer} +% Please edit documentation in R/characterization-timeToEvent.R +\name{characterizationTimeToEventViewer} +\alias{characterizationTimeToEventViewer} \title{The module viewer for exploring time to event results} \usage{ -descriptionTimeToEventViewer(id) +characterizationTimeToEventViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the description time to event module +The user interface to the characterization time to event module } \description{ The module viewer for exploring time to event results diff --git a/man/characterizationViewer.Rd b/man/characterizationViewer.Rd new file mode 100644 index 00000000..641ee31c --- /dev/null +++ b/man/characterizationViewer.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/characterization-main.R +\name{characterizationViewer} +\alias{characterizationViewer} +\title{The module viewer for exploring characterization studies} +\usage{ +characterizationViewer(id = 1) +} +\arguments{ +\item{id}{the unique reference id for the module} +} +\value{ +The user interface to the characterization viewer module +} +\description{ +The module viewer for exploring characterization studies +} +\details{ +The user specifies the id for the module +} diff --git a/man/cohortCountsModule.Rd b/man/cohortCountsModule.Rd index 5b5229e3..8c4cce1f 100644 --- a/man/cohortCountsModule.Rd +++ b/man/cohortCountsModule.Rd @@ -8,7 +8,7 @@ cohortCountsModule( id, dataSource, cohortTable = dataSource$cohortTable, - databaseTable = dataSource$databaseTable, + databaseTable = dataSource$dbTable, selectedCohorts, selectedDatabaseIds, cohortIds diff --git a/man/cohortDefinitionsModule.Rd b/man/cohortDefinitionsModule.Rd index dcda2dca..87a60709 100644 --- a/man/cohortDefinitionsModule.Rd +++ b/man/cohortDefinitionsModule.Rd @@ -10,7 +10,7 @@ cohortDefinitionsModule( cohortDefinitions, cohortTable = dataSource$cohortTable, cohortCountTable = dataSource$cohortCountTable, - databaseTable = dataSource$databaseTable + databaseTable = dataSource$dbTable ) } \arguments{ diff --git a/man/characterizationView.Rd b/man/cohortDiagCharacterizationView.Rd similarity index 73% rename from man/characterizationView.Rd rename to man/cohortDiagCharacterizationView.Rd index 6695baaa..171c47b1 100644 --- a/man/characterizationView.Rd +++ b/man/cohortDiagCharacterizationView.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/cohort-diagnostics-characterization.R -\name{characterizationView} -\alias{characterizationView} +\name{cohortDiagCharacterizationView} +\alias{cohortDiagCharacterizationView} \title{characterization} \usage{ -characterizationView(id) +cohortDiagCharacterizationView(id) } \arguments{ \item{id}{Namespace Id - use namespaced id ns("characterization") inside diagnosticsExplorer module} diff --git a/man/cohortDiagnosticsSever.Rd b/man/cohortDiagnosticsServer.Rd similarity index 85% rename from man/cohortDiagnosticsSever.Rd rename to man/cohortDiagnosticsServer.Rd index c50aaed3..824adc41 100644 --- a/man/cohortDiagnosticsSever.Rd +++ b/man/cohortDiagnosticsServer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/cohort-diagnostics-main.R -\name{cohortDiagnosticsSever} -\alias{cohortDiagnosticsSever} +\name{cohortDiagnosticsServer} +\alias{cohortDiagnosticsServer} \title{Cohort Diagnostics Explorer main module} \usage{ -cohortDiagnosticsSever( +cohortDiagnosticsServer( id, connectionHandler, resultDatabaseSettings, diff --git a/man/cohortGeneratorHelperFile.Rd b/man/cohortGeneratorHelperFile.Rd index 9e0d4575..cfb9d71f 100644 --- a/man/cohortGeneratorHelperFile.Rd +++ b/man/cohortGeneratorHelperFile.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohortgenerator-main.R +% Please edit documentation in R/cohort-generator-main.R \name{cohortGeneratorHelperFile} \alias{cohortGeneratorHelperFile} \title{The location of the cohort-generator module helper file} diff --git a/man/cohortGeneratorServer.Rd b/man/cohortGeneratorServer.Rd index 487a68ce..792a984f 100644 --- a/man/cohortGeneratorServer.Rd +++ b/man/cohortGeneratorServer.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohortgenerator-main.R +% Please edit documentation in R/cohort-generator-main.R \name{cohortGeneratorServer} \alias{cohortGeneratorServer} \title{The module server for the main cohort generator module} diff --git a/man/cohortGeneratorViewer.Rd b/man/cohortGeneratorViewer.Rd index 9fb3f81d..ed2776df 100644 --- a/man/cohortGeneratorViewer.Rd +++ b/man/cohortGeneratorViewer.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cohortgenerator-main.R +% Please edit documentation in R/cohort-generator-main.R \name{cohortGeneratorViewer} \alias{cohortGeneratorViewer} \title{The viewer of the main cohort generator module} diff --git a/man/estimationAttritionServer.Rd b/man/cohortMethodAttritionServer.Rd similarity index 55% rename from man/estimationAttritionServer.Rd rename to man/cohortMethodAttritionServer.Rd index b6bbcc42..6e3444cc 100644 --- a/man/estimationAttritionServer.Rd +++ b/man/cohortMethodAttritionServer.Rd @@ -1,17 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-attrition.R -\name{estimationAttritionServer} -\alias{estimationAttritionServer} +% Please edit documentation in R/cohort-method-attrition.R +\name{cohortMethodAttritionServer} +\alias{cohortMethodAttritionServer} \title{The module server for rendering the PLE attrition results} \usage{ -estimationAttritionServer( +cohortMethodAttritionServer( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix, - databaseTable + resultDatabaseSettings ) } \arguments{ @@ -19,15 +16,9 @@ estimationAttritionServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{databaseTable}{databaseTable} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ the PLE attrition results content server diff --git a/man/estimationAttritionViewer.Rd b/man/cohortMethodAttritionViewer.Rd similarity index 55% rename from man/estimationAttritionViewer.Rd rename to man/cohortMethodAttritionViewer.Rd index c8d79da9..9b16769e 100644 --- a/man/estimationAttritionViewer.Rd +++ b/man/cohortMethodAttritionViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-attrition.R -\name{estimationAttritionViewer} -\alias{estimationAttritionViewer} +% Please edit documentation in R/cohort-method-attrition.R +\name{cohortMethodAttritionViewer} +\alias{cohortMethodAttritionViewer} \title{The module viewer for rendering the PLE attrition results} \usage{ -estimationAttritionViewer(id) +cohortMethodAttritionViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation attrition +The user interface to the cohort method attrition } \description{ The module viewer for rendering the PLE attrition results diff --git a/man/estimationCovariateBalanceServer.Rd b/man/cohortMethodCovariateBalanceServer.Rd similarity index 60% rename from man/estimationCovariateBalanceServer.Rd rename to man/cohortMethodCovariateBalanceServer.Rd index b793620e..41a874bc 100644 --- a/man/estimationCovariateBalanceServer.Rd +++ b/man/cohortMethodCovariateBalanceServer.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-covariateBalance.R -\name{estimationCovariateBalanceServer} -\alias{estimationCovariateBalanceServer} +% Please edit documentation in R/cohort-method-covariateBalance.R +\name{cohortMethodCovariateBalanceServer} +\alias{cohortMethodCovariateBalanceServer} \title{The module server for rendering the covariate balance plot} \usage{ -estimationCovariateBalanceServer( +cohortMethodCovariateBalanceServer( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix, + resultDatabaseSettings, metaAnalysisDbIds = NULL ) } @@ -19,13 +17,9 @@ estimationCovariateBalanceServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} \item{metaAnalysisDbIds}{metaAnalysisDbIds} } diff --git a/man/estimationCovariateBalanceViewer.Rd b/man/cohortMethodCovariateBalanceViewer.Rd similarity index 52% rename from man/estimationCovariateBalanceViewer.Rd rename to man/cohortMethodCovariateBalanceViewer.Rd index 0fdb4082..5e9011c5 100644 --- a/man/estimationCovariateBalanceViewer.Rd +++ b/man/cohortMethodCovariateBalanceViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-covariateBalance.R -\name{estimationCovariateBalanceViewer} -\alias{estimationCovariateBalanceViewer} +% Please edit documentation in R/cohort-method-covariateBalance.R +\name{cohortMethodCovariateBalanceViewer} +\alias{cohortMethodCovariateBalanceViewer} \title{The module viewer for rendering the PLE covariate balance analysis} \usage{ -estimationCovariateBalanceViewer(id) +cohortMethodCovariateBalanceViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation covariate balance results +The user interface to the cohort method covariate balance results } \description{ The module viewer for rendering the PLE covariate balance analysis diff --git a/man/cohortMethodDiagnosticsSummaryServer.Rd b/man/cohortMethodDiagnosticsSummaryServer.Rd new file mode 100644 index 00000000..b9660fed --- /dev/null +++ b/man/cohortMethodDiagnosticsSummaryServer.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-diagnosticsSummary.R +\name{cohortMethodDiagnosticsSummaryServer} +\alias{cohortMethodDiagnosticsSummaryServer} +\title{The module server for rendering the PLE diagnostics summary} +\usage{ +cohortMethodDiagnosticsSummaryServer( + id, + connectionHandler, + resultDatabaseSettings, + inputSelected +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{connectionHandler}{the connection to the PLE results database} + +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} + +\item{inputSelected}{The target id, comparator id, outcome id and analysis id selected by the user} +} +\value{ +the PLE diagnostics summary results +} +\description{ +The module server for rendering the PLE diagnostics summary +} diff --git a/man/estimationDiagnosticsSummaryViewer.Rd b/man/cohortMethodDiagnosticsSummaryViewer.Rd similarity index 51% rename from man/estimationDiagnosticsSummaryViewer.Rd rename to man/cohortMethodDiagnosticsSummaryViewer.Rd index 12252704..c14dcde7 100644 --- a/man/estimationDiagnosticsSummaryViewer.Rd +++ b/man/cohortMethodDiagnosticsSummaryViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-diagnosticsSummary.R -\name{estimationDiagnosticsSummaryViewer} -\alias{estimationDiagnosticsSummaryViewer} +% Please edit documentation in R/cohort-method-diagnosticsSummary.R +\name{cohortMethodDiagnosticsSummaryViewer} +\alias{cohortMethodDiagnosticsSummaryViewer} \title{The module viewer for rendering the PLE diagnostics results} \usage{ -estimationDiagnosticsSummaryViewer(id) +cohortMethodDiagnosticsSummaryViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation diagnostics viewer +The user interface to the cohort method diagnostics viewer } \description{ The module viewer for rendering the PLE diagnostics results diff --git a/man/cohortMethodHelperFile.Rd b/man/cohortMethodHelperFile.Rd new file mode 100644 index 00000000..01ba84ca --- /dev/null +++ b/man/cohortMethodHelperFile.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-main.R +\name{cohortMethodHelperFile} +\alias{cohortMethodHelperFile} +\title{The location of the cohort method module helper file} +\usage{ +cohortMethodHelperFile() +} +\value{ +string location of the cohort method helper file +} +\description{ +The location of the cohort method module helper file +} +\details{ +Returns the location of the cohort method helper file +} diff --git a/man/cohortMethodKaplanMeierServer.Rd b/man/cohortMethodKaplanMeierServer.Rd new file mode 100644 index 00000000..0f3f3c4b --- /dev/null +++ b/man/cohortMethodKaplanMeierServer.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-kaplainMeier.R +\name{cohortMethodKaplanMeierServer} +\alias{cohortMethodKaplanMeierServer} +\title{The module server for rendering the Kaplan Meier curve} +\usage{ +cohortMethodKaplanMeierServer( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{selectedRow}{the selected row from the main results table} + +\item{connectionHandler}{the connection to the PLE results database} + +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} +} +\value{ +the PLE Kaplain Meier content server +} +\description{ +The module server for rendering the Kaplan Meier curve +} diff --git a/man/estimationKaplanMeierViewer.Rd b/man/cohortMethodKaplanMeierViewer.Rd similarity index 64% rename from man/estimationKaplanMeierViewer.Rd rename to man/cohortMethodKaplanMeierViewer.Rd index 805828d4..a896e9b1 100644 --- a/man/estimationKaplanMeierViewer.Rd +++ b/man/cohortMethodKaplanMeierViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-kaplainMeier.R -\name{estimationKaplanMeierViewer} -\alias{estimationKaplanMeierViewer} +% Please edit documentation in R/cohort-method-kaplainMeier.R +\name{cohortMethodKaplanMeierViewer} +\alias{cohortMethodKaplanMeierViewer} \title{The module viewer for rendering the PLE Kaplan Meier curve} \usage{ -estimationKaplanMeierViewer(id) +cohortMethodKaplanMeierViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/estimationPopulationCharacteristicsServer.Rd b/man/cohortMethodPopulationCharacteristicsServer.Rd similarity index 55% rename from man/estimationPopulationCharacteristicsServer.Rd rename to man/cohortMethodPopulationCharacteristicsServer.Rd index bd31131f..34119408 100644 --- a/man/estimationPopulationCharacteristicsServer.Rd +++ b/man/cohortMethodPopulationCharacteristicsServer.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-populationCharacteristics.R -\name{estimationPopulationCharacteristicsServer} -\alias{estimationPopulationCharacteristicsServer} +% Please edit documentation in R/cohort-method-populationCharacteristics.R +\name{cohortMethodPopulationCharacteristicsServer} +\alias{cohortMethodPopulationCharacteristicsServer} \title{The module server for rendering the population characteristics} \usage{ -estimationPopulationCharacteristicsServer( +cohortMethodPopulationCharacteristicsServer( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix + resultDatabaseSettings ) } \arguments{ @@ -18,13 +16,9 @@ estimationPopulationCharacteristicsServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ the PLE population characteristics content server diff --git a/man/cohortMethodPopulationCharacteristicsViewer.Rd b/man/cohortMethodPopulationCharacteristicsViewer.Rd new file mode 100644 index 00000000..9262f9e3 --- /dev/null +++ b/man/cohortMethodPopulationCharacteristicsViewer.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-populationCharacteristics.R +\name{cohortMethodPopulationCharacteristicsViewer} +\alias{cohortMethodPopulationCharacteristicsViewer} +\title{The module viewer for rendering the PLE population characteristics} +\usage{ +cohortMethodPopulationCharacteristicsViewer(id) +} +\arguments{ +\item{id}{the unique reference id for the module} +} +\value{ +The user interface to the cohort method population characteristics objects +} +\description{ +The module viewer for rendering the PLE population characteristics +} diff --git a/man/estimationPowerServer.Rd b/man/cohortMethodPowerServer.Rd similarity index 55% rename from man/estimationPowerServer.Rd rename to man/cohortMethodPowerServer.Rd index 80cfad1b..d9b9b201 100644 --- a/man/estimationPowerServer.Rd +++ b/man/cohortMethodPowerServer.Rd @@ -1,17 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-power.R -\name{estimationPowerServer} -\alias{estimationPowerServer} +% Please edit documentation in R/cohort-method-power.R +\name{cohortMethodPowerServer} +\alias{cohortMethodPowerServer} \title{The module server for rendering the PLE power analysis results} \usage{ -estimationPowerServer( +cohortMethodPowerServer( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix, - metaAnalysisDbIds = NULL + resultDatabaseSettings ) } \arguments{ @@ -19,15 +16,9 @@ estimationPowerServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ the PLE systematic error power server diff --git a/man/estimationPowerViewer.Rd b/man/cohortMethodPowerViewer.Rd similarity index 55% rename from man/estimationPowerViewer.Rd rename to man/cohortMethodPowerViewer.Rd index f8a0dde2..cea46b77 100644 --- a/man/estimationPowerViewer.Rd +++ b/man/cohortMethodPowerViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-power.R -\name{estimationPowerViewer} -\alias{estimationPowerViewer} +% Please edit documentation in R/cohort-method-power.R +\name{cohortMethodPowerViewer} +\alias{cohortMethodPowerViewer} \title{The module viewer for rendering the PLE power analysis} \usage{ -estimationPowerViewer(id) +cohortMethodPowerViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation power calculation results +The user interface to the cohort method power calculation results } \description{ The module viewer for rendering the PLE power analysis diff --git a/man/estimationPropensityModelServer.Rd b/man/cohortMethodPropensityModelServer.Rd similarity index 56% rename from man/estimationPropensityModelServer.Rd rename to man/cohortMethodPropensityModelServer.Rd index 0e1e0726..1c0ab242 100644 --- a/man/estimationPropensityModelServer.Rd +++ b/man/cohortMethodPropensityModelServer.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-propensityModel.R -\name{estimationPropensityModelServer} -\alias{estimationPropensityModelServer} +% Please edit documentation in R/cohort-method-propensityModel.R +\name{cohortMethodPropensityModelServer} +\alias{cohortMethodPropensityModelServer} \title{The module server for rendering the propensity score model} \usage{ -estimationPropensityModelServer( +cohortMethodPropensityModelServer( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix + resultDatabaseSettings ) } \arguments{ @@ -18,13 +16,9 @@ estimationPropensityModelServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ the PLE propensity score model diff --git a/man/estimationPropensityModelViewer.Rd b/man/cohortMethodPropensityModelViewer.Rd similarity index 54% rename from man/estimationPropensityModelViewer.Rd rename to man/cohortMethodPropensityModelViewer.Rd index 997df210..d05b543a 100644 --- a/man/estimationPropensityModelViewer.Rd +++ b/man/cohortMethodPropensityModelViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-propensityModel.R -\name{estimationPropensityModelViewer} -\alias{estimationPropensityModelViewer} +% Please edit documentation in R/cohort-method-propensityModel.R +\name{cohortMethodPropensityModelViewer} +\alias{cohortMethodPropensityModelViewer} \title{The module viewer for rendering the PLE propensity score model covariates/coefficients} \usage{ -estimationPropensityModelViewer(id) +cohortMethodPropensityModelViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation propensity score model covariates/coefficients +The user interface to the cohort method propensity score model covariates/coefficients } \description{ The module viewer for rendering the PLE propensity score model covariates/coefficients diff --git a/man/estimationPropensityScoreDistServer.Rd b/man/cohortMethodPropensityScoreDistServer.Rd similarity index 56% rename from man/estimationPropensityScoreDistServer.Rd rename to man/cohortMethodPropensityScoreDistServer.Rd index 4a155ebc..a5b57e16 100644 --- a/man/estimationPropensityScoreDistServer.Rd +++ b/man/cohortMethodPropensityScoreDistServer.Rd @@ -1,17 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-propensityScoreDistribution.R -\name{estimationPropensityScoreDistServer} -\alias{estimationPropensityScoreDistServer} +% Please edit documentation in R/cohort-method-propensityScoreDistribution.R +\name{cohortMethodPropensityScoreDistServer} +\alias{cohortMethodPropensityScoreDistServer} \title{The module server for rendering a PLE propensity score distribution} \usage{ -estimationPropensityScoreDistServer( +cohortMethodPropensityScoreDistServer( id, selectedRow, - inputParams, connectionHandler, - resultsSchema, - tablePrefix, - cohortTablePrefix, + resultDatabaseSettings, metaAnalysisDbIds = F ) } @@ -20,15 +17,9 @@ estimationPropensityScoreDistServer( \item{selectedRow}{the selected row from the main results table} -\item{inputParams}{the selected study parameters of interest} - \item{connectionHandler}{the connection to the PLE results database} -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{cohortTablePrefix}{cohortTablePrefix} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} \item{metaAnalysisDbIds}{metaAnalysisDbIds} } diff --git a/man/estimationPropensityScoreDistViewer.Rd b/man/cohortMethodPropensityScoreDistViewer.Rd similarity index 50% rename from man/estimationPropensityScoreDistViewer.Rd rename to man/cohortMethodPropensityScoreDistViewer.Rd index 69cd86fe..ba8e780a 100644 --- a/man/estimationPropensityScoreDistViewer.Rd +++ b/man/cohortMethodPropensityScoreDistViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-propensityScoreDistribution.R -\name{estimationPropensityScoreDistViewer} -\alias{estimationPropensityScoreDistViewer} +% Please edit documentation in R/cohort-method-propensityScoreDistribution.R +\name{cohortMethodPropensityScoreDistViewer} +\alias{cohortMethodPropensityScoreDistViewer} \title{The module viewer for rendering the propensity score distribution} \usage{ -estimationPropensityScoreDistViewer(id) +cohortMethodPropensityScoreDistViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation propensity score distribution +The user interface to the cohort method propensity score distribution } \description{ The module viewer for rendering the propensity score distribution diff --git a/man/cohortMethodResultSummaryServer.Rd b/man/cohortMethodResultSummaryServer.Rd new file mode 100644 index 00000000..b32b7b21 --- /dev/null +++ b/man/cohortMethodResultSummaryServer.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-resultSummary.R +\name{cohortMethodResultSummaryServer} +\alias{cohortMethodResultSummaryServer} +\title{The module server for rendering the PLE diagnostics summary} +\usage{ +cohortMethodResultSummaryServer( + id, + connectionHandler, + resultDatabaseSettings, + inputSelected +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{connectionHandler}{the connection to the PLE results database} + +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} + +\item{inputSelected}{The target id, comparator id, outcome id and analysis id selected by the user} +} +\value{ +the PLE diagnostics summary results +} +\description{ +The module server for rendering the PLE diagnostics summary +} diff --git a/man/cohortMethodResultSummaryViewer.Rd b/man/cohortMethodResultSummaryViewer.Rd new file mode 100644 index 00000000..d1545136 --- /dev/null +++ b/man/cohortMethodResultSummaryViewer.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-resultSummary.R +\name{cohortMethodResultSummaryViewer} +\alias{cohortMethodResultSummaryViewer} +\title{The module viewer for rendering the cohort method results} +\usage{ +cohortMethodResultSummaryViewer(id) +} +\arguments{ +\item{id}{the unique reference id for the module} +} +\value{ +The user interface to the cohort method diagnostics viewer +} +\description{ +The module viewer for rendering the cohort method results +} diff --git a/man/estimationServer.Rd b/man/cohortMethodServer.Rd similarity index 55% rename from man/estimationServer.Rd rename to man/cohortMethodServer.Rd index 0c89841b..83f734dd 100644 --- a/man/estimationServer.Rd +++ b/man/cohortMethodServer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-main.R -\name{estimationServer} -\alias{estimationServer} -\title{The module server for the main estimation module} +% Please edit documentation in R/cohort-method-main.R +\name{cohortMethodServer} +\alias{cohortMethodServer} +\title{The module server for the main cohort method module} \usage{ -estimationServer(id, connectionHandler, resultDatabaseSettings) +cohortMethodServer(id, connectionHandler, resultDatabaseSettings) } \arguments{ \item{id}{the unique reference id for the module} @@ -17,5 +17,5 @@ estimationServer(id, connectionHandler, resultDatabaseSettings) the PLE results viewer main module server } \description{ -The module server for the main estimation module +The module server for the main cohort method module } diff --git a/man/cohortMethodSystematicErrorServer.Rd b/man/cohortMethodSystematicErrorServer.Rd new file mode 100644 index 00000000..3f44490e --- /dev/null +++ b/man/cohortMethodSystematicErrorServer.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-systematicError.R +\name{cohortMethodSystematicErrorServer} +\alias{cohortMethodSystematicErrorServer} +\title{The module server for rendering the systematic error objects} +\usage{ +cohortMethodSystematicErrorServer( + id, + selectedRow, + connectionHandler, + resultDatabaseSettings +) +} +\arguments{ +\item{id}{the unique reference id for the module} + +\item{selectedRow}{the selected row from the main results table} + +\item{connectionHandler}{the connection handler to the result databases} + +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} +} +\value{ +the PLE systematic error content server +} +\description{ +The module server for rendering the systematic error objects +} diff --git a/man/estimationSystematicErrorViewer.Rd b/man/cohortMethodSystematicErrorViewer.Rd similarity index 53% rename from man/estimationSystematicErrorViewer.Rd rename to man/cohortMethodSystematicErrorViewer.Rd index b2f9bbd6..c4dea713 100644 --- a/man/estimationSystematicErrorViewer.Rd +++ b/man/cohortMethodSystematicErrorViewer.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-systematicError.R -\name{estimationSystematicErrorViewer} -\alias{estimationSystematicErrorViewer} +% Please edit documentation in R/cohort-method-systematicError.R +\name{cohortMethodSystematicErrorViewer} +\alias{cohortMethodSystematicErrorViewer} \title{The module viewer for rendering the PLE systematic error objects} \usage{ -estimationSystematicErrorViewer(id) +cohortMethodSystematicErrorViewer(id) } \arguments{ \item{id}{the unique reference id for the module} } \value{ -The user interface to the estimation systematic error module +The user interface to the cohort method systematic error module } \description{ The module viewer for rendering the PLE systematic error objects diff --git a/man/cohortMethodViewer.Rd b/man/cohortMethodViewer.Rd new file mode 100644 index 00000000..ae650d1a --- /dev/null +++ b/man/cohortMethodViewer.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cohort-method-main.R +\name{cohortMethodViewer} +\alias{cohortMethodViewer} +\title{The viewer of the main cohort method module} +\usage{ +cohortMethodViewer(id) +} +\arguments{ +\item{id}{the unique reference id for the module} +} +\value{ +The user interface to the cohort method results viewer +} +\description{ +The viewer of the main cohort method module +} diff --git a/man/createCdDatabaseDataSource.Rd b/man/createCdDatabaseDataSource.Rd index 89b5359e..60bab3d9 100644 --- a/man/createCdDatabaseDataSource.Rd +++ b/man/createCdDatabaseDataSource.Rd @@ -6,11 +6,7 @@ \usage{ createCdDatabaseDataSource( connectionHandler, - schema, - vocabularyDatabaseSchema = schema, - tablePrefix = "", - cohortTableName = paste0(tablePrefix, "cohort"), - databaseTableName = paste0(tablePrefix, "database"), + resultDatabaseSettings, dataModelSpecificationsPath = system.file("cohort-diagnostics-ref", "resultsDataModelSpecification.csv", package = utils::packageName()), dataMigrationsRef = system.file("cohort-diagnostics-ref", "migrations.csv", package = @@ -21,15 +17,7 @@ createCdDatabaseDataSource( \arguments{ \item{connectionHandler}{An instance of a ResultModelManager::connectionHander - manages a connection to a database.} -\item{schema}{The schema containing the results tables in the database.} - -\item{vocabularyDatabaseSchema}{The schema containing the vocabulary tables in the database. If not provided, defaults to `resultsDatabaseSchema`.} - -\item{tablePrefix}{An optional prefix to add to the table names.} - -\item{cohortTableName}{The name of the cohort table in the database.} - -\item{databaseTableName}{The name of the database table in the database.} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} \item{dataModelSpecificationsPath}{The path to a file containing specifications for the data model used by the database.} diff --git a/man/createCustomColDefList.Rd b/man/createCustomColDefList.Rd new file mode 100644 index 00000000..94c175e3 --- /dev/null +++ b/man/createCustomColDefList.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpers-componentsCreateCustomColDefList.R +\name{createCustomColDefList} +\alias{createCustomColDefList} +\title{Creating a list of custom column definitions for use in reactables} +\usage{ +createCustomColDefList( + rawColNames, + niceColNames = NULL, + tooltipText = NULL, + case = NULL, + customColDefOptions = NULL +) +} +\arguments{ +\item{rawColNames}{The raw column names taken directly from the source +data table that are to be overwritten in the reactable} + +\item{niceColNames}{The formatted column names that will appear as-specified in +the reactable} + +\item{tooltipText}{The text to be displayed in a toolTip when hovering over the +column in the reactable} + +\item{case}{Optional argument to convert raw column names to snake or camel case. Defaults to NULL and preserves +whatever raw column names are passed in} + +\item{customColDefOptions}{A list of lists, where the inner lists are any custom options from +reactable::colDef for each column} +} +\value{ +A named list of reactable::colDef objects +} +\description{ +Creating a list of custom column definitions for use in reactables +} diff --git a/man/dataDiagnosticDrillServer.Rd b/man/dataDiagnosticDrillServer.Rd index fa1b461d..cff580fb 100644 --- a/man/dataDiagnosticDrillServer.Rd +++ b/man/dataDiagnosticDrillServer.Rd @@ -4,16 +4,14 @@ \alias{dataDiagnosticDrillServer} \title{The module server for exploring prediction summary results} \usage{ -dataDiagnosticDrillServer(id, connectionHandler, mySchema, myTableAppend) +dataDiagnosticDrillServer(id, connectionHandler, resultDatabaseSettings) } \arguments{ \item{id}{the unique reference id for the module} \item{connectionHandler}{the connection to the prediction result database} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the summary module diff --git a/man/dataDiagnosticSummaryServer.Rd b/man/dataDiagnosticSummaryServer.Rd index 44305008..a5eea92d 100644 --- a/man/dataDiagnosticSummaryServer.Rd +++ b/man/dataDiagnosticSummaryServer.Rd @@ -4,16 +4,14 @@ \alias{dataDiagnosticSummaryServer} \title{The module server for exploring prediction summary results} \usage{ -dataDiagnosticSummaryServer(id, connectionHandler, mySchema, myTableAppend) +dataDiagnosticSummaryServer(id, connectionHandler, resultDatabaseSettings) } \arguments{ \item{id}{the unique reference id for the module} \item{connectionHandler}{the connection to the prediction result database} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the summary module diff --git a/man/datasourcesHelperFile.Rd b/man/datasourcesHelperFile.Rd new file mode 100644 index 00000000..02a08575 --- /dev/null +++ b/man/datasourcesHelperFile.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasources-main.R +\name{datasourcesHelperFile} +\alias{datasourcesHelperFile} +\title{Define the helper file for the module} +\usage{ +datasourcesHelperFile() +} +\value{ +The helper html file for the datasources module +} +\description{ +Define the helper file for the module +} diff --git a/man/datasourcesServer.Rd b/man/datasourcesServer.Rd new file mode 100644 index 00000000..5feb4cd5 --- /dev/null +++ b/man/datasourcesServer.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasources-main.R +\name{datasourcesServer} +\alias{datasourcesServer} +\title{The server function for the datasources module} +\usage{ +datasourcesServer(id, connectionHandler, resultDatabaseSettings) +} +\arguments{ +\item{id}{The unique id for the datasources server namespace} + +\item{connectionHandler}{A connection to the database with the results} + +\item{resultDatabaseSettings}{A named list containing the cohort generator results database details (schema, table prefix)} +} +\value{ +The server for the datasources module +} +\description{ +The server function for the datasources module +} diff --git a/man/datasourcesViewer.Rd b/man/datasourcesViewer.Rd new file mode 100644 index 00000000..5fb47f5e --- /dev/null +++ b/man/datasourcesViewer.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasources-main.R +\name{datasourcesViewer} +\alias{datasourcesViewer} +\title{The viewer function for hte datasources module} +\usage{ +datasourcesViewer(id) +} +\arguments{ +\item{id}{The unique id for the datasources viewer namespace} +} +\value{ +The UI for the datasources module +} +\description{ +The viewer function for hte datasources module +} diff --git a/man/descriptionAggregateFeaturesServer.Rd b/man/descriptionAggregateFeaturesServer.Rd deleted file mode 100644 index 8724cbaa..00000000 --- a/man/descriptionAggregateFeaturesServer.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-aggregateFeatures.R -\name{descriptionAggregateFeaturesServer} -\alias{descriptionAggregateFeaturesServer} -\title{The module server for exploring aggregate features results} -\usage{ -descriptionAggregateFeaturesServer( - id, - connectionHandler, - mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix = "cg_", - databaseTable = "DATABASE_META_DATA" -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{the connection to the prediction result database} - -\item{mainPanelTab}{the current tab} - -\item{schema}{the database schema for the model results} - -\item{tablePrefix}{a string that appends the tables in the result schema} - -\item{cohortTablePrefix}{a string that appends the COHORT_DEFINITION table in the result schema} - -\item{databaseTable}{The database table name} -} -\value{ -The server to the description aggregate features module -} -\description{ -The module server for exploring aggregate features results -} -\details{ -The user specifies the id for the module -} diff --git a/man/descriptionDechallengeRechallengeServer.Rd b/man/descriptionDechallengeRechallengeServer.Rd deleted file mode 100644 index 4eef475c..00000000 --- a/man/descriptionDechallengeRechallengeServer.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-dechallengeRechallenge.R -\name{descriptionDechallengeRechallengeServer} -\alias{descriptionDechallengeRechallengeServer} -\title{The module server for exploring Dechallenge Rechallenge results} -\usage{ -descriptionDechallengeRechallengeServer( - id, - connectionHandler, - mainPanelTab, - schema, - tablePrefix, - cohortTablePrefix = "cg_", - databaseTable = "DATABASE_META_DATA" -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{the connection to the prediction result database} - -\item{mainPanelTab}{the current tab} - -\item{schema}{the database schema for the model results} - -\item{tablePrefix}{a string that appends the tables in the result schema} - -\item{cohortTablePrefix}{a string that appends the cohort table in the result schema} - -\item{databaseTable}{name of the database table} -} -\value{ -The server to the Dechallenge Rechallenge module -} -\description{ -The module server for exploring Dechallenge Rechallenge results -} -\details{ -The user specifies the id for the module -} diff --git a/man/descriptionHelperFile.Rd b/man/descriptionHelperFile.Rd deleted file mode 100644 index fb0ab4e2..00000000 --- a/man/descriptionHelperFile.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-main.R -\name{descriptionHelperFile} -\alias{descriptionHelperFile} -\title{The location of the description module helper file} -\usage{ -descriptionHelperFile() -} -\value{ -string location of the description helper file -} -\description{ -The location of the description module helper file -} -\details{ -Returns the location of the description helper file -} diff --git a/man/descriptionServer.Rd b/man/descriptionServer.Rd deleted file mode 100644 index 6a638949..00000000 --- a/man/descriptionServer.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-main.R -\name{descriptionServer} -\alias{descriptionServer} -\title{The module server for exploring description studies} -\usage{ -descriptionServer( - id, - connectionHandler, - resultDatabaseSettings = list(port = 1) -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{a connection to the database with the results} - -\item{resultDatabaseSettings}{a list containing the description result schema, dbms, tablePrefix, databaseTable and cohortTablePrefix} -} -\value{ -The server for the description module -} -\description{ -The module server for exploring description studies -} -\details{ -The user specifies the id for the module -} diff --git a/man/descriptionViewer.Rd b/man/descriptionViewer.Rd deleted file mode 100644 index 51938b36..00000000 --- a/man/descriptionViewer.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/description-main.R -\name{descriptionViewer} -\alias{descriptionViewer} -\title{The module viewer for exploring description studies} -\usage{ -descriptionViewer(id = 1) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the description viewer module -} -\description{ -The module viewer for exploring description studies -} -\details{ -The user specifies the id for the module -} diff --git a/man/estimationDiagnosticsSummaryServer.Rd b/man/estimationDiagnosticsSummaryServer.Rd deleted file mode 100644 index 6b9136d9..00000000 --- a/man/estimationDiagnosticsSummaryServer.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-diagnosticsSummary.R -\name{estimationDiagnosticsSummaryServer} -\alias{estimationDiagnosticsSummaryServer} -\title{The module server for rendering the PLE diagnostics summary} -\usage{ -estimationDiagnosticsSummaryServer( - id, - connectionHandler, - resultsSchema, - tablePrefix, - cohortTablePrefix, - databaseTable -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{the connection to the PLE results database} - -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{cohortTablePrefix}{cohortTablePrefix} - -\item{databaseTable}{databaseTable} -} -\value{ -the PLE diagnostics summary results -} -\description{ -The module server for rendering the PLE diagnostics summary -} diff --git a/man/estimationForestPlotServer.Rd b/man/estimationForestPlotServer.Rd deleted file mode 100644 index b4bf929c..00000000 --- a/man/estimationForestPlotServer.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-forestPlot.R -\name{estimationForestPlotServer} -\alias{estimationForestPlotServer} -\title{The module server for rendering the PLE multiple results forest plot} -\usage{ -estimationForestPlotServer( - id, - connectionHandler, - selectedRow, - inputParams, - metaAnalysisDbIds = NULL, - resultsSchema, - tablePrefix, - databaseTable -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{connection} - -\item{selectedRow}{the selected row from the main results table} - -\item{inputParams}{the selected study parameters of interest} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} - -\item{resultsSchema}{resultsSchema} - -\item{tablePrefix}{tablePrefix} - -\item{databaseTable}{databaseTable} -} -\value{ -the PLE forest plot content server -} -\description{ -The module server for rendering the PLE multiple results forest plot -} diff --git a/man/estimationForestPlotViewer.Rd b/man/estimationForestPlotViewer.Rd deleted file mode 100644 index cd32e58b..00000000 --- a/man/estimationForestPlotViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-forestPlot.R -\name{estimationForestPlotViewer} -\alias{estimationForestPlotViewer} -\title{The module viewer for rendering the PLE results forest plot} -\usage{ -estimationForestPlotViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the estimation forest plot -} -\description{ -The module viewer for rendering the PLE results forest plot -} diff --git a/man/estimationHelperFile.Rd b/man/estimationHelperFile.Rd deleted file mode 100644 index e87ed22b..00000000 --- a/man/estimationHelperFile.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-main.R -\name{estimationHelperFile} -\alias{estimationHelperFile} -\title{The location of the estimation module helper file} -\usage{ -estimationHelperFile() -} -\value{ -string location of the estimation helper file -} -\description{ -The location of the estimation module helper file -} -\details{ -Returns the location of the estimation helper file -} diff --git a/man/estimationKaplanMeierServer.Rd b/man/estimationKaplanMeierServer.Rd deleted file mode 100644 index f5f1ab56..00000000 --- a/man/estimationKaplanMeierServer.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-kaplainMeier.R -\name{estimationKaplanMeierServer} -\alias{estimationKaplanMeierServer} -\title{The module server for rendering the Kaplan Meier curve} -\usage{ -estimationKaplanMeierServer( - id, - selectedRow, - inputParams, - connectionHandler, - resultsSchema, - tablePrefix, - cohortTablePrefix, - databaseTable, - metaAnalysisDbIds = NULL -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{selectedRow}{the selected row from the main results table} - -\item{inputParams}{the selected study parameters of interest} - -\item{connectionHandler}{the connection to the PLE results database} - -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{cohortTablePrefix}{cohortTablePrefix} - -\item{databaseTable}{databaseTable} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} -} -\value{ -the PLE Kaplain Meier content server -} -\description{ -The module server for rendering the Kaplan Meier curve -} diff --git a/man/estimationPopulationCharacteristicsViewer.Rd b/man/estimationPopulationCharacteristicsViewer.Rd deleted file mode 100644 index 996635a1..00000000 --- a/man/estimationPopulationCharacteristicsViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-populationCharacteristics.R -\name{estimationPopulationCharacteristicsViewer} -\alias{estimationPopulationCharacteristicsViewer} -\title{The module viewer for rendering the PLE population characteristics} -\usage{ -estimationPopulationCharacteristicsViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the estimation population characteristics objects -} -\description{ -The module viewer for rendering the PLE population characteristics -} diff --git a/man/estimationResultsTableServer.Rd b/man/estimationResultsTableServer.Rd deleted file mode 100644 index 3278644c..00000000 --- a/man/estimationResultsTableServer.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-resultsTable.R -\name{estimationResultsTableServer} -\alias{estimationResultsTableServer} -\title{The module server for rendering the PLE results per current selections} -\usage{ -estimationResultsTableServer( - id, - connectionHandler, - inputParams, - resultsSchema, - tablePrefix, - databaseTable -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{the connection to the PLE results database} - -\item{inputParams}{the selected study parameters of interest} - -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{databaseTable}{databaseTable} -} -\value{ -the PLE main results table server server -} -\description{ -The module server for rendering the PLE results per current selections -} diff --git a/man/estimationResultsTableViewer.Rd b/man/estimationResultsTableViewer.Rd deleted file mode 100644 index a8e6123a..00000000 --- a/man/estimationResultsTableViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-resultsTable.R -\name{estimationResultsTableViewer} -\alias{estimationResultsTableViewer} -\title{The module viewer for rendering the PLE main results} -\usage{ -estimationResultsTableViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the PLE main results -} -\description{ -The module viewer for rendering the PLE main results -} diff --git a/man/estimationSubgroupsServer.Rd b/man/estimationSubgroupsServer.Rd deleted file mode 100644 index 9dcd833c..00000000 --- a/man/estimationSubgroupsServer.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-subgroups.R -\name{estimationSubgroupsServer} -\alias{estimationSubgroupsServer} -\title{The module server for rendering the subgroup results} -\usage{ -estimationSubgroupsServer( - id, - selectedRow, - inputParams, - exposureOfInterest, - outcomeOfInterest, - connectionHandler -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{selectedRow}{the selected row from the main results table} - -\item{inputParams}{the selected study parameters of interest} - -\item{exposureOfInterest}{exposureOfInterest} - -\item{outcomeOfInterest}{outcomeOfInterest} - -\item{connectionHandler}{connection} -} -\value{ -the PLE subgroup results server -} -\description{ -The module server for rendering the subgroup results -} diff --git a/man/estimationSubgroupsViewer.Rd b/man/estimationSubgroupsViewer.Rd deleted file mode 100644 index f746061a..00000000 --- a/man/estimationSubgroupsViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-subgroups.R -\name{estimationSubgroupsViewer} -\alias{estimationSubgroupsViewer} -\title{The module viewer for rendering the PLE subgroup results} -\usage{ -estimationSubgroupsViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the estimation subgroup results module -} -\description{ -The module viewer for rendering the PLE subgroup results -} diff --git a/man/estimationSystematicErrorServer.Rd b/man/estimationSystematicErrorServer.Rd deleted file mode 100644 index bb265bff..00000000 --- a/man/estimationSystematicErrorServer.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-systematicError.R -\name{estimationSystematicErrorServer} -\alias{estimationSystematicErrorServer} -\title{The module server for rendering the systematic error objects} -\usage{ -estimationSystematicErrorServer( - id, - selectedRow, - inputParams, - connectionHandler, - resultsSchema, - tablePrefix, - metaAnalysisDbIds = NULL -) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{selectedRow}{the selected row from the main results table} - -\item{inputParams}{the selected study parameters of interest} - -\item{connectionHandler}{the connection to the PLE results database} - -\item{resultsSchema}{the schema with the PLE results} - -\item{tablePrefix}{tablePrefix} - -\item{metaAnalysisDbIds}{metaAnalysisDbIds} -} -\value{ -the PLE systematic error content server -} -\description{ -The module server for rendering the systematic error objects -} diff --git a/man/estimationViewer.Rd b/man/estimationViewer.Rd deleted file mode 100644 index 4033bbc3..00000000 --- a/man/estimationViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/estimation-main.R -\name{estimationViewer} -\alias{estimationViewer} -\title{The viewer of the main estimation module} -\usage{ -estimationViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the estimation results viewer -} -\description{ -The viewer of the main estimation module -} diff --git a/man/evidenceSynthesisServer.Rd b/man/evidenceSynthesisServer.Rd index e0ce73d0..cf33e7d6 100644 --- a/man/evidenceSynthesisServer.Rd +++ b/man/evidenceSynthesisServer.Rd @@ -15,7 +15,7 @@ evidenceSynthesisServer( \item{connectionHandler}{a connection to the database with the results} -\item{resultDatabaseSettings}{a list containing the prediction result schema and connection details} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server for the PatientLevelPrediction module diff --git a/man/makeButtonLabel.Rd b/man/makeButtonLabel.Rd new file mode 100644 index 00000000..c30a84f5 --- /dev/null +++ b/man/makeButtonLabel.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpers-componentsCreateCustomColDefList.R +\name{makeButtonLabel} +\alias{makeButtonLabel} +\title{Make a label for an html button} +\usage{ +makeButtonLabel(label) +} +\arguments{ +\item{label}{The desired label for hte button} +} +\value{ +html code to make a button label +} +\description{ +Make a label for an html button +} diff --git a/man/predictionCalibrationServer.Rd b/man/patientLevelPredictionCalibrationServer.Rd similarity index 65% rename from man/predictionCalibrationServer.Rd rename to man/patientLevelPredictionCalibrationServer.Rd index 61aaad16..b06dbf22 100644 --- a/man/predictionCalibrationServer.Rd +++ b/man/patientLevelPredictionCalibrationServer.Rd @@ -1,16 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-calibration.R -\name{predictionCalibrationServer} -\alias{predictionCalibrationServer} +% Please edit documentation in R/patient-level-prediction-calibration.R +\name{patientLevelPredictionCalibrationServer} +\alias{patientLevelPredictionCalibrationServer} \title{The module server for exploring prediction validation results} \usage{ -predictionCalibrationServer( +patientLevelPredictionCalibrationServer( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) } \arguments{ @@ -22,9 +21,7 @@ predictionCalibrationServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the prediction calibration module diff --git a/man/predictionCalibrationViewer.Rd b/man/patientLevelPredictionCalibrationViewer.Rd similarity index 65% rename from man/predictionCalibrationViewer.Rd rename to man/patientLevelPredictionCalibrationViewer.Rd index 6514fb60..be958e62 100644 --- a/man/predictionCalibrationViewer.Rd +++ b/man/patientLevelPredictionCalibrationViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-calibration.R -\name{predictionCalibrationViewer} -\alias{predictionCalibrationViewer} +% Please edit documentation in R/patient-level-prediction-calibration.R +\name{patientLevelPredictionCalibrationViewer} +\alias{patientLevelPredictionCalibrationViewer} \title{The module viewer for exploring prediction model calibration results} \usage{ -predictionCalibrationViewer(id) +patientLevelPredictionCalibrationViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionCovariateSummaryServer.Rd b/man/patientLevelPredictionCovariateSummaryServer.Rd similarity index 69% rename from man/predictionCovariateSummaryServer.Rd rename to man/patientLevelPredictionCovariateSummaryServer.Rd index 9f50eeb7..32ed5c59 100644 --- a/man/predictionCovariateSummaryServer.Rd +++ b/man/patientLevelPredictionCovariateSummaryServer.Rd @@ -1,18 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-covariateSummary.R -\name{predictionCovariateSummaryServer} -\alias{predictionCovariateSummaryServer} +% Please edit documentation in R/patient-level-prediction-covariateSummary.R +\name{patientLevelPredictionCovariateSummaryServer} +\alias{patientLevelPredictionCovariateSummaryServer} \title{The module server for exploring prediction covariate summary results} \usage{ -predictionCovariateSummaryServer( +patientLevelPredictionCovariateSummaryServer( id, modelDesignId, developmentDatabaseId, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend = "" + resultDatabaseSettings ) } \arguments{ @@ -28,9 +27,7 @@ predictionCovariateSummaryServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the covariate summary module diff --git a/man/predictionCovariateSummaryViewer.Rd b/man/patientLevelPredictionCovariateSummaryViewer.Rd similarity index 63% rename from man/predictionCovariateSummaryViewer.Rd rename to man/patientLevelPredictionCovariateSummaryViewer.Rd index 6be09a9b..fd4fb28d 100644 --- a/man/predictionCovariateSummaryViewer.Rd +++ b/man/patientLevelPredictionCovariateSummaryViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-covariateSummary.R -\name{predictionCovariateSummaryViewer} -\alias{predictionCovariateSummaryViewer} +% Please edit documentation in R/patient-level-prediction-covariateSummary.R +\name{patientLevelPredictionCovariateSummaryViewer} +\alias{patientLevelPredictionCovariateSummaryViewer} \title{The module viewer for exploring prediction covariate summary results} \usage{ -predictionCovariateSummaryViewer(id) +patientLevelPredictionCovariateSummaryViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionCutoffServer.Rd b/man/patientLevelPredictionCutoffServer.Rd similarity index 66% rename from man/predictionCutoffServer.Rd rename to man/patientLevelPredictionCutoffServer.Rd index 817a9f82..5f2916d8 100644 --- a/man/predictionCutoffServer.Rd +++ b/man/patientLevelPredictionCutoffServer.Rd @@ -1,16 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-cutoff.R -\name{predictionCutoffServer} -\alias{predictionCutoffServer} +% Please edit documentation in R/patient-level-prediction-cutoff.R +\name{patientLevelPredictionCutoffServer} +\alias{patientLevelPredictionCutoffServer} \title{The module server for exploring prediction cut-off results} \usage{ -predictionCutoffServer( +patientLevelPredictionCutoffServer( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) } \arguments{ @@ -22,9 +21,7 @@ predictionCutoffServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the prediction cut-off module diff --git a/man/predictionCutoffViewer.Rd b/man/patientLevelPredictionCutoffViewer.Rd similarity index 66% rename from man/predictionCutoffViewer.Rd rename to man/patientLevelPredictionCutoffViewer.Rd index 15377296..c4dcd60f 100644 --- a/man/predictionCutoffViewer.Rd +++ b/man/patientLevelPredictionCutoffViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-cutoff.R -\name{predictionCutoffViewer} -\alias{predictionCutoffViewer} +% Please edit documentation in R/patient-level-prediction-cutoff.R +\name{patientLevelPredictionCutoffViewer} +\alias{patientLevelPredictionCutoffViewer} \title{The module viewer for exploring prediction cut-off results} \usage{ -predictionCutoffViewer(id) +patientLevelPredictionCutoffViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionDesignSummaryServer.Rd b/man/patientLevelPredictionDesignSummaryServer.Rd similarity index 56% rename from man/predictionDesignSummaryServer.Rd rename to man/patientLevelPredictionDesignSummaryServer.Rd index 7860f5e4..238528ae 100644 --- a/man/predictionDesignSummaryServer.Rd +++ b/man/patientLevelPredictionDesignSummaryServer.Rd @@ -1,19 +1,21 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-designSummary.R -\name{predictionDesignSummaryServer} -\alias{predictionDesignSummaryServer} +% Please edit documentation in R/patient-level-prediction-designSummary.R +\name{patientLevelPredictionDesignSummaryServer} +\alias{patientLevelPredictionDesignSummaryServer} \title{The module server for exploring prediction designs in the results} \usage{ -predictionDesignSummaryServer(id, connectionHandler, mySchema, myTableAppend) +patientLevelPredictionDesignSummaryServer( + id, + connectionHandler, + resultDatabaseSettings +) } \arguments{ \item{id}{the unique reference id for the module} \item{connectionHandler}{the connection to the prediction result database} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the prediction design module diff --git a/man/predictionDesignSummaryViewer.Rd b/man/patientLevelPredictionDesignSummaryViewer.Rd similarity index 64% rename from man/predictionDesignSummaryViewer.Rd rename to man/patientLevelPredictionDesignSummaryViewer.Rd index a26663d5..311bcd6e 100644 --- a/man/predictionDesignSummaryViewer.Rd +++ b/man/patientLevelPredictionDesignSummaryViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-designSummary.R -\name{predictionDesignSummaryViewer} -\alias{predictionDesignSummaryViewer} +% Please edit documentation in R/patient-level-prediction-designSummary.R +\name{patientLevelPredictionDesignSummaryViewer} +\alias{patientLevelPredictionDesignSummaryViewer} \title{The module viewer for exploring prediction designs that have been run} \usage{ -predictionDesignSummaryViewer(id) +patientLevelPredictionDesignSummaryViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionDiagnosticsServer.Rd b/man/patientLevelPredictionDiagnosticsServer.Rd similarity index 51% rename from man/predictionDiagnosticsServer.Rd rename to man/patientLevelPredictionDiagnosticsServer.Rd index acf885a1..8b2db8f0 100644 --- a/man/predictionDiagnosticsServer.Rd +++ b/man/patientLevelPredictionDiagnosticsServer.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-diagnostics.R -\name{predictionDiagnosticsServer} -\alias{predictionDiagnosticsServer} +% Please edit documentation in R/patient-level-prediction-diagnostics.R +\name{patientLevelPredictionDiagnosticsServer} +\alias{patientLevelPredictionDiagnosticsServer} \title{The module server for exploring prediction diagnostic results} \usage{ -predictionDiagnosticsServer( +patientLevelPredictionDiagnosticsServer( id, modelDesignId, - mySchema, connectionHandler, - myTableAppend, - databaseTableAppend + resultDatabaseSettings ) } \arguments{ @@ -18,16 +16,12 @@ predictionDiagnosticsServer( \item{modelDesignId}{the unique id for the model design} -\item{mySchema}{the database schema for the model results} - \item{connectionHandler}{the connection to the prediction result database} -\item{myTableAppend}{a string that appends the tables in the result schema} - -\item{databaseTableAppend}{a string that appends the database_meta_data table} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ -The server to the predcition diagnostic module +The server to the prediction diagnostic module } \description{ The module server for exploring prediction diagnostic results diff --git a/man/predictionDiagnosticsViewer.Rd b/man/patientLevelPredictionDiagnosticsViewer.Rd similarity index 64% rename from man/predictionDiagnosticsViewer.Rd rename to man/patientLevelPredictionDiagnosticsViewer.Rd index 2ebce3e0..c2eccf8b 100644 --- a/man/predictionDiagnosticsViewer.Rd +++ b/man/patientLevelPredictionDiagnosticsViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-diagnostics.R -\name{predictionDiagnosticsViewer} -\alias{predictionDiagnosticsViewer} +% Please edit documentation in R/patient-level-prediction-diagnostics.R +\name{patientLevelPredictionDiagnosticsViewer} +\alias{patientLevelPredictionDiagnosticsViewer} \title{The module viewer for exploring prediction diagnostic results} \usage{ -predictionDiagnosticsViewer(id) +patientLevelPredictionDiagnosticsViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionDiscriminationServer.Rd b/man/patientLevelPredictionDiscriminationServer.Rd similarity index 65% rename from man/predictionDiscriminationServer.Rd rename to man/patientLevelPredictionDiscriminationServer.Rd index 3941df34..1cafe353 100644 --- a/man/predictionDiscriminationServer.Rd +++ b/man/patientLevelPredictionDiscriminationServer.Rd @@ -1,16 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-discrimination.R -\name{predictionDiscriminationServer} -\alias{predictionDiscriminationServer} +% Please edit documentation in R/patient-level-prediction-discrimination.R +\name{patientLevelPredictionDiscriminationServer} +\alias{patientLevelPredictionDiscriminationServer} \title{The module server for exploring prediction model discrimination results} \usage{ -predictionDiscriminationServer( +patientLevelPredictionDiscriminationServer( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) } \arguments{ @@ -22,9 +21,7 @@ predictionDiscriminationServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the model discrimination module diff --git a/man/predictionDiscriminationViewer.Rd b/man/patientLevelPredictionDiscriminationViewer.Rd similarity index 64% rename from man/predictionDiscriminationViewer.Rd rename to man/patientLevelPredictionDiscriminationViewer.Rd index 5be24a48..0c2c43f1 100644 --- a/man/predictionDiscriminationViewer.Rd +++ b/man/patientLevelPredictionDiscriminationViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-discrimination.R -\name{predictionDiscriminationViewer} -\alias{predictionDiscriminationViewer} +% Please edit documentation in R/patient-level-prediction-discrimination.R +\name{patientLevelPredictionDiscriminationViewer} +\alias{patientLevelPredictionDiscriminationViewer} \title{The module viewer for exploring prediction model discrimination results} \usage{ -predictionDiscriminationViewer(id) +patientLevelPredictionDiscriminationViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionHelperFile.Rd b/man/patientLevelPredictionHelperFile.Rd similarity index 62% rename from man/predictionHelperFile.Rd rename to man/patientLevelPredictionHelperFile.Rd index 7a8c9ab2..c200cbc6 100644 --- a/man/predictionHelperFile.Rd +++ b/man/patientLevelPredictionHelperFile.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-main.R -\name{predictionHelperFile} -\alias{predictionHelperFile} +% Please edit documentation in R/patient-level-prediction-main.R +\name{patientLevelPredictionHelperFile} +\alias{patientLevelPredictionHelperFile} \title{The location of the prediction module helper file} \usage{ -predictionHelperFile() +patientLevelPredictionHelperFile() } \value{ string location of the prediction helper file diff --git a/man/predictionModelSummaryServer.Rd b/man/patientLevelPredictionModelSummaryServer.Rd similarity index 54% rename from man/predictionModelSummaryServer.Rd rename to man/patientLevelPredictionModelSummaryServer.Rd index 166ace74..0de376f4 100644 --- a/man/predictionModelSummaryServer.Rd +++ b/man/patientLevelPredictionModelSummaryServer.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-modelSummary.R -\name{predictionModelSummaryServer} -\alias{predictionModelSummaryServer} +% Please edit documentation in R/patient-level-prediction-modelSummary.R +\name{patientLevelPredictionModelSummaryServer} +\alias{patientLevelPredictionModelSummaryServer} \title{The module server for exploring prediction summary results} \usage{ -predictionModelSummaryServer( +patientLevelPredictionModelSummaryServer( id, connectionHandler, - mySchema, - myTableAppend, - modelDesignId, - databaseTableAppend = myTableAppend + resultDatabaseSettings, + modelDesignId ) } \arguments{ @@ -18,13 +16,9 @@ predictionModelSummaryServer( \item{connectionHandler}{the connection to the prediction result database} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} \item{modelDesignId}{a reactable id specifying the prediction model design identifier} - -\item{databaseTableAppend}{a string that appends the database_meta_data table} } \value{ The server to the summary module diff --git a/man/predictionModelSummaryViewer.Rd b/man/patientLevelPredictionModelSummaryViewer.Rd similarity index 62% rename from man/predictionModelSummaryViewer.Rd rename to man/patientLevelPredictionModelSummaryViewer.Rd index 99f52cf5..92aa79f3 100644 --- a/man/predictionModelSummaryViewer.Rd +++ b/man/patientLevelPredictionModelSummaryViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-modelSummary.R -\name{predictionModelSummaryViewer} -\alias{predictionModelSummaryViewer} +% Please edit documentation in R/patient-level-prediction-modelSummary.R +\name{patientLevelPredictionModelSummaryViewer} +\alias{patientLevelPredictionModelSummaryViewer} \title{The module viewer for exploring prediction summary results} \usage{ -predictionModelSummaryViewer(id) +patientLevelPredictionModelSummaryViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionNbServer.Rd b/man/patientLevelPredictionNbServer.Rd similarity index 67% rename from man/predictionNbServer.Rd rename to man/patientLevelPredictionNbServer.Rd index 3ba9dc00..e0c3a360 100644 --- a/man/predictionNbServer.Rd +++ b/man/patientLevelPredictionNbServer.Rd @@ -1,16 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-netbenefit.R -\name{predictionNbServer} -\alias{predictionNbServer} +% Please edit documentation in R/patient-level-prediction-netbenefit.R +\name{patientLevelPredictionNbServer} +\alias{patientLevelPredictionNbServer} \title{The module server for exploring prediction net-benefit results} \usage{ -predictionNbServer( +patientLevelPredictionNbServer( id, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend + resultDatabaseSettings ) } \arguments{ @@ -22,9 +21,7 @@ predictionNbServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the net-benefit module diff --git a/man/predictionNbViewer.Rd b/man/patientLevelPredictionNbViewer.Rd similarity index 67% rename from man/predictionNbViewer.Rd rename to man/patientLevelPredictionNbViewer.Rd index 3a4f764a..93badc2b 100644 --- a/man/predictionNbViewer.Rd +++ b/man/patientLevelPredictionNbViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-netbenefit.R -\name{predictionNbViewer} -\alias{predictionNbViewer} +% Please edit documentation in R/patient-level-prediction-netbenefit.R +\name{patientLevelPredictionNbViewer} +\alias{patientLevelPredictionNbViewer} \title{The module viewer for exploring prediction net-benefit results} \usage{ -predictionNbViewer(id) +patientLevelPredictionNbViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionServer.Rd b/man/patientLevelPredictionServer.Rd similarity index 78% rename from man/predictionServer.Rd rename to man/patientLevelPredictionServer.Rd index 61bce1a7..7c725ebd 100644 --- a/man/predictionServer.Rd +++ b/man/patientLevelPredictionServer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-main.R -\name{predictionServer} -\alias{predictionServer} +% Please edit documentation in R/patient-level-prediction-main.R +\name{patientLevelPredictionServer} +\alias{patientLevelPredictionServer} \title{The module server for exploring PatientLevelPrediction} \usage{ -predictionServer( +patientLevelPredictionServer( id, connectionHandler, resultDatabaseSettings = list(port = 1) diff --git a/man/predictionSettingsServer.Rd b/man/patientLevelPredictionSettingsServer.Rd similarity index 58% rename from man/predictionSettingsServer.Rd rename to man/patientLevelPredictionSettingsServer.Rd index 4da8460e..b987945c 100644 --- a/man/predictionSettingsServer.Rd +++ b/man/patientLevelPredictionSettingsServer.Rd @@ -1,20 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-settings.R -\name{predictionSettingsServer} -\alias{predictionSettingsServer} +% Please edit documentation in R/patient-level-prediction-settings.R +\name{patientLevelPredictionSettingsServer} +\alias{patientLevelPredictionSettingsServer} \title{The module server for exploring prediction settings} \usage{ -predictionSettingsServer( +patientLevelPredictionSettingsServer( id, modelDesignId, developmentDatabaseId, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend, - cohortTableAppend = myTableAppend, - databaseTableAppend = myTableAppend + resultDatabaseSettings ) } \arguments{ @@ -30,13 +27,7 @@ predictionSettingsServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} - -\item{cohortTableAppend}{a string that appends the cohort_definition table} - -\item{databaseTableAppend}{a string that appends the database_meta_data table} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the settings module diff --git a/man/predictionSettingsViewer.Rd b/man/patientLevelPredictionSettingsViewer.Rd similarity index 63% rename from man/predictionSettingsViewer.Rd rename to man/patientLevelPredictionSettingsViewer.Rd index a3f674df..63ee8176 100644 --- a/man/predictionSettingsViewer.Rd +++ b/man/patientLevelPredictionSettingsViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-settings.R -\name{predictionSettingsViewer} -\alias{predictionSettingsViewer} +% Please edit documentation in R/patient-level-prediction-settings.R +\name{patientLevelPredictionSettingsViewer} +\alias{patientLevelPredictionSettingsViewer} \title{The module viewer for exploring prediction settings} \usage{ -predictionSettingsViewer(id) +patientLevelPredictionSettingsViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionValidationServer.Rd b/man/patientLevelPredictionValidationServer.Rd similarity index 63% rename from man/predictionValidationServer.Rd rename to man/patientLevelPredictionValidationServer.Rd index d269be9a..2e36700a 100644 --- a/man/predictionValidationServer.Rd +++ b/man/patientLevelPredictionValidationServer.Rd @@ -1,19 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-validation.R -\name{predictionValidationServer} -\alias{predictionValidationServer} +% Please edit documentation in R/patient-level-prediction-validation.R +\name{patientLevelPredictionValidationServer} +\alias{patientLevelPredictionValidationServer} \title{The module server for exploring prediction validation results} \usage{ -predictionValidationServer( +patientLevelPredictionValidationServer( id, modelDesignId, developmentDatabaseId, performanceId, connectionHandler, inputSingleView, - mySchema, - myTableAppend = NULL, - databaseTableAppend = myTableAppend + resultDatabaseSettings ) } \arguments{ @@ -29,11 +27,7 @@ predictionValidationServer( \item{inputSingleView}{the current tab} -\item{mySchema}{the database schema for the model results} - -\item{myTableAppend}{a string that appends the tables in the result schema} - -\item{databaseTableAppend}{a string that appends the database_meta_data table} +\item{resultDatabaseSettings}{a list containing the result schema and prefixes} } \value{ The server to the validation module diff --git a/man/predictionValidationViewer.Rd b/man/patientLevelPredictionValidationViewer.Rd similarity index 64% rename from man/predictionValidationViewer.Rd rename to man/patientLevelPredictionValidationViewer.Rd index d7dc0dad..abab5da5 100644 --- a/man/predictionValidationViewer.Rd +++ b/man/patientLevelPredictionValidationViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-validation.R -\name{predictionValidationViewer} -\alias{predictionValidationViewer} +% Please edit documentation in R/patient-level-prediction-validation.R +\name{patientLevelPredictionValidationViewer} +\alias{patientLevelPredictionValidationViewer} \title{The module viewer for exploring prediction validation results} \usage{ -predictionValidationViewer(id) +patientLevelPredictionValidationViewer(id) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/predictionViewer.Rd b/man/patientLevelPredictionViewer.Rd similarity index 68% rename from man/predictionViewer.Rd rename to man/patientLevelPredictionViewer.Rd index 93bb91bf..010e47c3 100644 --- a/man/predictionViewer.Rd +++ b/man/patientLevelPredictionViewer.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prediction-main.R -\name{predictionViewer} -\alias{predictionViewer} +% Please edit documentation in R/patient-level-prediction-main.R +\name{patientLevelPredictionViewer} +\alias{patientLevelPredictionViewer} \title{The module viewer for exploring PatientLevelPrediction} \usage{ -predictionViewer(id = 1) +patientLevelPredictionViewer(id = 1) } \arguments{ \item{id}{the unique reference id for the module} diff --git a/man/phevaluatorHelperFile.Rd b/man/phevaluatorHelperFile.Rd new file mode 100644 index 00000000..dfad1544 --- /dev/null +++ b/man/phevaluatorHelperFile.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/phevaluator-main.R +\name{phevaluatorHelperFile} +\alias{phevaluatorHelperFile} +\title{The location of the phevaluator module helper file} +\usage{ +phevaluatorHelperFile() +} +\value{ +String location of the phevaluator helper file +} +\description{ +The location of the phevaluator module helper file +} +\details{ +Returns the location of the cohort-generator helper file +} diff --git a/man/phevaluatorServer.Rd b/man/phevaluatorServer.Rd new file mode 100644 index 00000000..0f2a8275 --- /dev/null +++ b/man/phevaluatorServer.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/phevaluator-main.R +\name{phevaluatorServer} +\alias{phevaluatorServer} +\title{The module server for the main phevaluator module} +\usage{ +phevaluatorServer(id, connectionHandler, resultDatabaseSettings) +} +\arguments{ +\item{id}{The unique reference id for the module} + +\item{connectionHandler}{A connection to the database with the results} + +\item{resultDatabaseSettings}{A named list containing the cohort generator results database details (schema, table prefix)} +} +\value{ +The phevaluator main module server +} +\description{ +The module server for the main phevaluator module +} diff --git a/man/phevaluatorViewer.Rd b/man/phevaluatorViewer.Rd new file mode 100644 index 00000000..2b1530de --- /dev/null +++ b/man/phevaluatorViewer.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/phevaluator-main.R +\name{phevaluatorViewer} +\alias{phevaluatorViewer} +\title{The viewer of the phevaluator module} +\usage{ +phevaluatorViewer(id) +} +\arguments{ +\item{id}{The unique reference id for the module} +} +\value{ +The user interface to the phevaluator results viewer +} +\description{ +The viewer of the phevaluator module +} diff --git a/man/resultTableServer.Rd b/man/resultTableServer.Rd new file mode 100644 index 00000000..fb375c88 --- /dev/null +++ b/man/resultTableServer.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/components-data-viewer.R +\name{resultTableServer} +\alias{resultTableServer} +\title{Result Table Server} +\usage{ +resultTableServer( + id, + df, + colDefsInput, + addActions = NULL, + downloadedFileName = NULL +) +} +\arguments{ +\item{id}{string, table id must match resultsTableViewer function} + +\item{df}{reactive that returns a data frame} + +\item{colDefsInput}{named list of reactable::colDefs} + +\item{addActions}{add a button row selector column to the table to a column called 'actions'. +actions must be a column in df} + +\item{downloadedFileName}{string, desired name of downloaded data file. can use the name from the module that is being used} +} +\value{ +shiny module server +} +\description{ +Result Table Server +} diff --git a/man/resultTableViewer.Rd b/man/resultTableViewer.Rd new file mode 100644 index 00000000..05816917 --- /dev/null +++ b/man/resultTableViewer.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/components-data-viewer.R +\name{resultTableViewer} +\alias{resultTableViewer} +\title{Result Table Viewer} +\usage{ +resultTableViewer(id = "result-table", downloadedFileName = NULL) +} +\arguments{ +\item{id}{string} + +\item{downloadedFileName}{string, desired name of downloaded data file. can use the name from the module that is being used} +} +\value{ +shiny module UI +} +\description{ +Result Table Viewer +} diff --git a/man/sccsDiagnosticsSummaryServer.Rd b/man/sccsDiagnosticsSummaryServer.Rd deleted file mode 100644 index 6a733aa4..00000000 --- a/man/sccsDiagnosticsSummaryServer.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sccs-diagnosticsSummary.R -\name{sccsDiagnosticsSummaryServer} -\alias{sccsDiagnosticsSummaryServer} -\title{The module server for rendering the SCCS diagnostics summary} -\usage{ -sccsDiagnosticsSummaryServer(id, connectionHandler, resultDatabaseSettings) -} -\arguments{ -\item{id}{the unique reference id for the module} - -\item{connectionHandler}{the connection to the PLE results database} - -\item{resultDatabaseSettings}{the resultDatabaseSettings with the schemas, prefix and table names} -} -\value{ -the SCCS diagnostics summary results -} -\description{ -The module server for rendering the SCCS diagnostics summary -} diff --git a/man/sccsDiagnosticsSummaryViewer.Rd b/man/sccsDiagnosticsSummaryViewer.Rd deleted file mode 100644 index b25f1d9f..00000000 --- a/man/sccsDiagnosticsSummaryViewer.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sccs-diagnosticsSummary.R -\name{sccsDiagnosticsSummaryViewer} -\alias{sccsDiagnosticsSummaryViewer} -\title{The module viewer for rendering the SCCS diagnostics results} -\usage{ -sccsDiagnosticsSummaryViewer(id) -} -\arguments{ -\item{id}{the unique reference id for the module} -} -\value{ -The user interface to the estimation diagnostics viewer -} -\description{ -The module viewer for rendering the SCCS diagnostics results -} diff --git a/renv/settings.dcf b/renv/settings.dcf deleted file mode 100644 index 169d82f1..00000000 --- a/renv/settings.dcf +++ /dev/null @@ -1,10 +0,0 @@ -bioconductor.version: -external.libraries: -ignored.packages: -package.dependency.fields: Imports, Depends, LinkingTo -r.version: -snapshot.type: implicit -use.cache: TRUE -vcs.ignore.cellar: TRUE -vcs.ignore.library: TRUE -vcs.ignore.local: TRUE diff --git a/tests/resources/descDatabase/databaseFile.sqlite b/tests/resources/characterizationDatabase/databaseFile.sqlite similarity index 100% rename from tests/resources/descDatabase/databaseFile.sqlite rename to tests/resources/characterizationDatabase/databaseFile.sqlite diff --git a/tests/resources/estDatabase/databaseFile.sqlite b/tests/resources/cmDatabase/databaseFile.sqlite similarity index 100% rename from tests/resources/estDatabase/databaseFile.sqlite rename to tests/resources/cmDatabase/databaseFile.sqlite diff --git a/tests/resources/pvDatabase/phevaluator.sqlite b/tests/resources/pvDatabase/phevaluator.sqlite new file mode 100644 index 00000000..5fff4fd0 Binary files /dev/null and b/tests/resources/pvDatabase/phevaluator.sqlite differ diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 05332bf8..7ede8354 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -16,7 +16,7 @@ dbmsTest <- 'sqlite' schemaTest <- 'main' # =========== CG START -cohortTablePrefix <- 'cg_' +cgTablePrefix <- 'cg_' connectionDetailsCG <- DatabaseConnector::createConnectionDetails( server = "../resources/cgDatabase/databaseFile.sqlite", @@ -24,6 +24,16 @@ connectionDetailsCG <- DatabaseConnector::createConnectionDetails( ) connectionHandlerCG <- ResultModelManager::ConnectionHandler$new(connectionDetailsCG, loadConnection = FALSE) +resultDatabaseSettingsCG <- list( + dbms = 'sqlite', + cgTablePrefix = 'cg_', + cgTablePrefix = 'cg_', + databaseTable = 'DATABASE_META_DATA', + databaseTablePrefix = '', + schema = 'main', + tempEmulationSchema = NULL +) + # =========== CG START # =========== PLP START @@ -37,8 +47,8 @@ connectionHandlerPlp <- ResultModelManager::ConnectionHandler$new(connectionDeta resultDatabaseSettingsPlp <- list( dbms = 'sqlite', # should this be removed - can use connection - tablePrefix = '', - cohortTablePrefix = '', + plpTablePrefix = '', + cgTablePrefix = '', databaseTablePrefix = '', schema = 'main' ) @@ -46,19 +56,22 @@ resultDatabaseSettingsPlp <- list( -# =========== Desc START -serverDesc <- "../resources/descDatabase/databaseFile.sqlite" -connectionDetailsDesc <- DatabaseConnector::createConnectionDetails( +# =========== characterization START +serverCharacterization <- "../resources/characterizationDatabase/databaseFile.sqlite" +connectionDetailsCharacterization <- DatabaseConnector::createConnectionDetails( dbms = 'sqlite', - server = serverDesc + server = serverCharacterization ) -connectionHandlerDesc <- ResultModelManager::ConnectionHandler$new(connectionDetailsDesc, loadConnection = FALSE) +connectionHandlerCharacterization <- ResultModelManager::ConnectionHandler$new( + connectionDetailsCharacterization, + loadConnection = FALSE + ) -resultDatabaseSettingsDesc <- list( +resultDatabaseSettingsCharacterization <- list( dbms = 'sqlite', # should this be removed - can use connection - tablePrefix = 'c_', - cohortTablePrefix = 'cg_', + cTablePrefix = 'c_', + cgTablePrefix = 'cg_', databaseTablePrefix = '', schema = 'main', databaseTable = 'DATABASE_META_DATA', @@ -67,27 +80,30 @@ resultDatabaseSettingsDesc <- list( ) -# =========== Desc START +# =========== Characterization END -# =========== Estimation START -connectionDetailsEst <- DatabaseConnector::createConnectionDetails( +# =========== Cohort Method START +connectionDetailsCm <- DatabaseConnector::createConnectionDetails( dbms = 'sqlite', - server = "../resources/estDatabase/databaseFile.sqlite" + server = "../resources/cmDatabase/databaseFile.sqlite" ) -connectionHandlerEst <- ResultModelManager::ConnectionHandler$new(connectionDetailsEst, loadConnection = FALSE) +connectionHandlerCm <- ResultModelManager::ConnectionHandler$new( + connectionDetailsCm, + loadConnection = FALSE + ) -resultDatabaseSettingsEst <- list( +resultDatabaseSettingsCm <- list( dbms = 'sqlite', - tablePrefix = 'cm_', - cohortTablePrefix = 'cg_', + cmTablePrefix = 'cm_', + cgTablePrefix = 'cg_', databaseTable = 'DATABASE_META_DATA', schema = "main", tempEmulationSchema = NULL ) -# =========== Estimation END +# =========== Cohort Method END # =========== Data diag START @@ -100,7 +116,7 @@ connectionHandlerDataDiag <- ResultModelManager::ConnectionHandler$new(connectio resultDatabaseSettingsDataDiag <- list( dbms = 'sqlite', - tablePrefix = '', + ddTablePrefix = '', schema = "main" ) @@ -115,10 +131,13 @@ connectionDetailsCohortDiag <- DatabaseConnector::createConnectionDetails( resultDatabaseSettingsCohortDiag <- list( dbms = 'sqlite', - tablePrefix = '', + cdTablePrefix = '', schema = "main", - cohortTableName = "cohort", - databaseTableName = "database" + cgTablePrefix = '', + cgTable = "cohort", + databaseTablePrefix = '', + databaseTable = "database", + vocabularyDatabaseSchema = "main" ) connectionHandlerCohortDiag <- ResultModelManager::ConnectionHandler$new(connectionDetailsCohortDiag, loadConnection = FALSE) @@ -126,11 +145,7 @@ connectionHandlerCohortDiag <- ResultModelManager::ConnectionHandler$new(connect dataSourceCd <- createCdDatabaseDataSource( connectionHandler = connectionHandlerCohortDiag, - schema = "main", - vocabularyDatabaseSchema = "main", - tablePrefix = "", - cohortTableName = "cohort", - databaseTableName = "database", + resultDatabaseSettings = resultDatabaseSettingsCohortDiag, displayProgress = FALSE ) @@ -147,8 +162,8 @@ connectionHandlerSccs <- ResultModelManager::ConnectionHandler$new(connectionDe resultDatabaseSettingsSccs <- list( dbms = 'sqlite', - tablePrefix = 'sccs_', - cohortTablePrefix = 'cg_', + sccsTablePrefix = 'sccs_', + cgTablePrefix = 'cg_', databaseTable = 'DATABASE_META_DATA', schema = "main", tempEmulationSchema = NULL @@ -170,7 +185,7 @@ connectionHandlerES <- ResultModelManager::ConnectionHandler$new( resultDatabaseSettingsES <- list( dbms = 'sqlite', - tablePrefix = 'es_', + esTablePrefix = 'es_', cgTablePrefix = 'cg_', cmTablePrefix = 'cm_', sccsTablePrefix = 'sccs_', @@ -182,15 +197,58 @@ resultDatabaseSettingsES <- list( # ==== +# ====== PheValuator + +connectionDetailsPV <- DatabaseConnector::createConnectionDetails( + dbms = 'sqlite', + server = "../resources/pvDatabase/phevaluator.sqlite" +) + +connectionHandlerPV <- ResultModelManager::ConnectionHandler$new( + connectionDetailsPV, + loadConnection = FALSE +) + +resultDatabaseSettingsPV = list( + dbms = 'sqlite', + pvTablePrefix = 'pv_', + schema = 'main' +) + +# ==== + +# ====== DataSources + +connectionDetailsDS <- DatabaseConnector::createConnectionDetails( + dbms = 'sqlite', + server = "../resources/DSDatabase/databaseFile.sqlite" +) + +connectionHandlerDS <- ResultModelManager::ConnectionHandler$new( + connectionDetailsDS, + loadConnection = FALSE +) + +resultDatabaseSettingsDS = list( + dbms = 'sqlite', + databaseTablePrefix = '', + schema = 'main', + databaseTable = 'DATABASE_META_DATA' +) + +# ==== + ## cleanup after tests complete withr::defer({ options("shiny-test-env-enabled" = FALSE) connectionHandlerCG$finalize() connectionHandlerPlp$finalize() - connectionHandlerDesc$finalize() + connectionHandlerCharacterization$finalize() connectionHandlerDataDiag$finalize() - connectionHandlerEst$finalize() + connectionHandlerCm$finalize() connectionHandlerCohortDiag$finalize() connectionHandlerSccs$finalize() connectionHandlerES$finalize() + connectionHandlerDS$finalize() + connectionHandlerPV$finalize() }, testthat::teardown_env()) \ No newline at end of file diff --git a/tests/testthat/test-description-aggregate-features.R b/tests/testthat/test-characterization-aggregate-features.R similarity index 65% rename from tests/testthat/test-description-aggregate-features.R rename to tests/testthat/test-characterization-aggregate-features.R index 0aa5dba4..959a3e27 100644 --- a/tests/testthat/test-description-aggregate-features.R +++ b/tests/testthat/test-characterization-aggregate-features.R @@ -1,15 +1,12 @@ -context("description-aggregateFeatures") +context("characterization-aggregateFeatures") shiny::testServer( - app = descriptionAggregateFeaturesServer, + app = characterizationAggregateFeaturesServer, args = list( - connectionHandler = connectionHandlerDesc , - schema = resultDatabaseSettingsDesc$schema, - mainPanelTab = shiny::reactiveVal("Feature Comparison"), - tablePrefix = resultDatabaseSettingsDesc$tablePrefix, - cohortTablePrefix = resultDatabaseSettingsDesc$cohortTablePrefix, - databaseTable = resultDatabaseSettingsDesc$databaseTable - ), + connectionHandler = connectionHandlerCharacterization , + resultDatabaseSettings = resultDatabaseSettingsCharacterization, + mainPanelTab = shiny::reactiveVal("Feature Comparison") + ), expr = { # expect the binaryData() to be the default diff --git a/tests/testthat/test-description-cohorts.R b/tests/testthat/test-characterization-cohorts.R similarity index 67% rename from tests/testthat/test-description-cohorts.R rename to tests/testthat/test-characterization-cohorts.R index 96fccc7f..465b6c86 100644 --- a/tests/testthat/test-description-cohorts.R +++ b/tests/testthat/test-characterization-cohorts.R @@ -1,15 +1,12 @@ -context("description-cohorts") +context("characterization-cohorts") shiny::testServer( - app = descriptionTableServer, + app = characterizationTableServer, args = list( - connectionHandler = connectionHandlerDesc , - schema = resultDatabaseSettingsDesc$schema, + connectionHandler = connectionHandlerCharacterization, mainPanelTab = shiny::reactiveVal("Feature Comparison"), - tablePrefix = resultDatabaseSettingsDesc$tablePrefix, - cohortTablePrefix = resultDatabaseSettingsDesc$cohortTablePrefix, - databaseTable = resultDatabaseSettingsDesc$databaseTable - ), + resultDatabaseSettings = resultDatabaseSettingsCharacterization + ), expr = { diff --git a/tests/testthat/test-description-dechallengeRechallenge.R b/tests/testthat/test-characterization-dechallengeRechallenge.R similarity index 69% rename from tests/testthat/test-description-dechallengeRechallenge.R rename to tests/testthat/test-characterization-dechallengeRechallenge.R index 16610d09..02906b26 100644 --- a/tests/testthat/test-description-dechallengeRechallenge.R +++ b/tests/testthat/test-characterization-dechallengeRechallenge.R @@ -1,14 +1,11 @@ -context("description-DechallengeRechallenge") +context("characterization-DechallengeRechallenge") shiny::testServer( - app = descriptionDechallengeRechallengeServer, + app = characterizationDechallengeRechallengeServer, args = list( - connectionHandler = connectionHandlerDesc , - schema = resultDatabaseSettingsDesc$schema, + connectionHandler = connectionHandlerCharacterization, mainPanelTab = shiny::reactiveVal("Feature Comparison"), - tablePrefix = resultDatabaseSettingsDesc$tablePrefix, - cohortTablePrefix = resultDatabaseSettingsDesc$cohortTablePrefix, - databaseTable = resultDatabaseSettingsDesc$databaseTable + resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-description-incidence.R b/tests/testthat/test-characterization-incidence.R similarity index 61% rename from tests/testthat/test-description-incidence.R rename to tests/testthat/test-characterization-incidence.R index a8fe7764..351af9a5 100644 --- a/tests/testthat/test-description-incidence.R +++ b/tests/testthat/test-characterization-incidence.R @@ -1,13 +1,11 @@ -context("description-incidence") +context("characterization-incidence") shiny::testServer( - app = descriptionIncidenceServer, + app = characterizationIncidenceServer, args = list( - connectionHandler = connectionHandlerDesc , - schema = resultDatabaseSettingsDesc$schema, + connectionHandler = connectionHandlerCharacterization, mainPanelTab = shiny::reactiveVal("Feature Comparison"), - incidenceTablePrefix = resultDatabaseSettingsDesc$incidenceTablePrefix, - databaseTable = resultDatabaseSettingsDesc$databaseTable + resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { @@ -21,5 +19,4 @@ shiny::testServer( session$setInputs(outcomeId = 3) session$setInputs(generate = T) - }) diff --git a/tests/testthat/test-description-main.R b/tests/testthat/test-characterization-main.R similarity index 52% rename from tests/testthat/test-description-main.R rename to tests/testthat/test-characterization-main.R index 1f8c49d1..f00553e1 100644 --- a/tests/testthat/test-description-main.R +++ b/tests/testthat/test-characterization-main.R @@ -1,10 +1,10 @@ -context("description-main") +context("characterization-main") shiny::testServer( - app = descriptionServer, + app = characterizationServer, args = list( - connectionHandler = connectionHandlerDesc , - resultDatabaseSettings = resultDatabaseSettingsDesc + connectionHandler = connectionHandlerCharacterization, + resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { @@ -16,8 +16,8 @@ shiny::testServer( }) -test_that("Test description ui", { +test_that("Test characterization ui", { # Test ui - ui <- descriptionViewer() + ui <- characterizationViewer() checkmate::expect_list(ui) }) diff --git a/tests/testthat/test-description-timeToEvent.R b/tests/testthat/test-characterization-timeToEvent.R similarity index 58% rename from tests/testthat/test-description-timeToEvent.R rename to tests/testthat/test-characterization-timeToEvent.R index b36f852e..fcb497bb 100644 --- a/tests/testthat/test-description-timeToEvent.R +++ b/tests/testthat/test-characterization-timeToEvent.R @@ -1,14 +1,11 @@ -context("description-TimeToEvent") +context("characterization-TimeToEvent") shiny::testServer( - app = descriptionTimeToEventServer, + app = characterizationTimeToEventServer, args = list( - connectionHandler = connectionHandlerDesc, - schema = resultDatabaseSettingsDesc$schema, + connectionHandler = connectionHandlerCharacterization, mainPanelTab = shiny::reactiveVal("Feature Comparison"), - tablePrefix = resultDatabaseSettingsDesc$tablePrefix, - cohortTablePrefix = resultDatabaseSettingsDesc$cohortTablePrefix, - databaseTable = resultDatabaseSettingsDesc$databaseTable + resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-cohort-diagnostics-characterization.R b/tests/testthat/test-cohort-diagnostics-characterization.R index 6754cdcc..233bcf5e 100644 --- a/tests/testthat/test-cohort-diagnostics-characterization.R +++ b/tests/testthat/test-cohort-diagnostics-characterization.R @@ -1,6 +1,7 @@ context("cohort-diagnostics-characterization") -shiny::testServer(characterizationModule, args = list( +shiny::testServer(cohortDiagCharacterizationModule, + args = list( id = "characterization", dataSource = dataSourceCd ), { diff --git a/tests/testthat/test-cohort-diagnostics-counts.R b/tests/testthat/test-cohort-diagnostics-counts.R index d69b0b5d..507052ad 100644 --- a/tests/testthat/test-cohort-diagnostics-counts.R +++ b/tests/testthat/test-cohort-diagnostics-counts.R @@ -4,7 +4,7 @@ shiny::testServer(cohortCountsModule, args = list( id = "testcohortcounts", #Any string is ok? dataSource = dataSourceCd, cohortTable = dataSourceCd$cohortTable, - databaseTable = dataSourceCd$databaseTable, + databaseTable = dataSourceCd$dbTable, selectedCohorts = shiny::reactive("Any String"), selectedDatabaseIds = shiny::reactive("Eunomia"), cohortIds = shiny::reactive({ c(14906, 14907) }) diff --git a/tests/testthat/test-cohort-diagnostics-definition.R b/tests/testthat/test-cohort-diagnostics-definition.R index 26febe64..7f22c68d 100644 --- a/tests/testthat/test-cohort-diagnostics-definition.R +++ b/tests/testthat/test-cohort-diagnostics-definition.R @@ -22,7 +22,7 @@ shiny::testServer(cohortDefinitionsModule, args = list( checkmate::expect_data_frame(getCountForConceptIdInCohort( dataSource = dataSourceCd, - databaseIds = dataSourceCd$databaseTable$databaseId, + databaseIds = dataSourceCd$dbTable$databaseId, cohortId = 14906 )) }) \ No newline at end of file diff --git a/tests/testthat/test-cohort-diagnostics-main.R b/tests/testthat/test-cohort-diagnostics-main.R index 9f5da96d..9e589ab8 100644 --- a/tests/testthat/test-cohort-diagnostics-main.R +++ b/tests/testthat/test-cohort-diagnostics-main.R @@ -1,6 +1,6 @@ context("cohort-diagnostics-main") -shiny::testServer(cohortDiagnosticsSever, args = list( +shiny::testServer(cohortDiagnosticsServer, args = list( id = "testCdServer", connectionHandler = connectionHandlerCohortDiag, resultDatabaseSettings = resultDatabaseSettingsCohortDiag, diff --git a/tests/testthat/test-cohortGenerator-main.R b/tests/testthat/test-cohort-generator-main.R similarity index 77% rename from tests/testthat/test-cohortGenerator-main.R rename to tests/testthat/test-cohort-generator-main.R index e891b592..cc83403f 100644 --- a/tests/testthat/test-cohortGenerator-main.R +++ b/tests/testthat/test-cohort-generator-main.R @@ -4,14 +4,7 @@ shiny::testServer( app = cohortGeneratorServer, args = list( connectionHandler = connectionHandlerCG, - resultDatabaseSettings = list( - dbms = 'sqlite', - tablePrefix = 'cg_', - cohortTablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA', - schema = 'main', - tempEmulationSchema = NULL - ) + resultDatabaseSettings = resultDatabaseSettingsCG ), expr = { @@ -40,10 +33,7 @@ test_that("Test getCohortGeneratorCohortCounts ", { result <- getCohortGeneratorCohortCounts( connectionHandler = connectionHandlerCG, - resultsSchema = 'main', - tablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA', - databaseTablePrefix = '' + resultDatabaseSettings = resultDatabaseSettingsCG ) testthat::expect_true( nrow(result) > 0 ) @@ -55,8 +45,7 @@ test_that("Test getCohortGeneratorCohortMeta ", { result <- getCohortGeneratorCohortMeta( connectionHandler = connectionHandlerCG, - resultsSchema = 'main', - tablePrefix = 'cg_' + resultDatabaseSettings = resultDatabaseSettingsCG ) testthat::expect_true( nrow(result) > 0 ) @@ -68,10 +57,7 @@ test_that("Test getCohortGeneratorCohortInclusionSummary ", { result <- getCohortGeneratorCohortInclusionSummary( connectionHandler = connectionHandlerCG, - resultsSchema = 'main', - tablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA', - databaseTablePrefix = '' + resultDatabaseSettings = resultDatabaseSettingsCG ) testthat::expect_true( nrow(result) > 0 ) @@ -84,8 +70,7 @@ test_that("Test getCohortGeneratorInclusionRules ", { result <- getCohortGeneratorInclusionRules( connectionHandler = connectionHandlerCG, - resultsSchema = 'main', - tablePrefix = 'cg_' + resultDatabaseSettings = resultDatabaseSettingsCG ) testthat::expect_true( nrow(result) > 0 ) @@ -97,10 +82,7 @@ test_that("Test getCohortGeneratorInclusionStats ", { result <- getCohortGeneratorInclusionStats( connectionHandler = connectionHandlerCG, - resultsSchema = 'main', - tablePrefix = 'cg_', - databaseTable = 'DATABASE_META_DATA', - databaseTablePrefix = '' + resultDatabaseSettings = resultDatabaseSettingsCG ) testthat::expect_true( nrow(result) > 0 ) diff --git a/tests/testthat/test-cohort-method-CovariateBalance.R b/tests/testthat/test-cohort-method-CovariateBalance.R new file mode 100644 index 00000000..53d12c52 --- /dev/null +++ b/tests/testthat/test-cohort-method-CovariateBalance.R @@ -0,0 +1,132 @@ +context("cohort-method-CovariateBalance") + +shiny::testServer( + app = cohortMethodCovariateBalanceServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + # should start null + testthat::expect_true(is.null(balance())) + + # make sure this runs if we pick the first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 2, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '' + ) + ) + + testthat::expect_true(!is.null(output$balanceSummaryPlot)) + testthat::expect_true(!is.null(balance())) + testthat::expect_true(nrow(balance())>0) + + testthat::expect_true(!is.null(output$balancePlotCaption)) + testthat::expect_true(!is.null(output$balanceSummaryPlotCaption)) + + # check textsearch + textSearchCohortMethod('heart') + + + balance <- getCohortMethodCovariateBalanceShared( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + targetId = 1, + comparatorId = 2, + databaseId = '1', + analysisId = 2) + + testthat::expect_true(!is.null(balance)) + testthat::expect_true(nrow(balance)>0) + + plot <- plotCohortMethodCovariateBalanceScatterPlotNew( + balance = balance, + beforeLabel = "Before propensity score adjustment", + afterLabel = "After propensity score adjustment" + ) + + testthat::expect_is(object = plot, class = 'plotly') + + + }) + + + +test_that("plotCohortMethodCovariateBalanceSummary", { + + # not the output of getEstimationCovariateBalance - where does it come from?? + balance <- data.frame( + databaseId = rep(1,2), + #covariateId = 1, + #covariateName = '1', + #analysisId = 1, + #beforeMatchingMeanTreated = 1, + #beforeMatchingMeanComparator = 1, + #beforeMatchingStdDiff = 0, + #afterMatchingMeanTreated = 1, + #afterMatchingMeanComparator = 1, + #afterMatchingStdDiff = 0, + absBeforeMatchingStdDiff = c(0.1,0.4), + absAfterMatchingStdDiff = c(0.1,0.4), + x = rep(1,2), + ymin = rep(1,2), + lower = rep(1,2), + median = rep(1,2), + upper = rep(1,2), + ymax = rep(1,2), + covariateCount = rep(1,2), + type = c("Before matching","After matching") + ) + + # added test for this in covariatebal + #resP <- plotEstimationCovariateBalanceScatterPlotNew( + # balance = balance, + # beforeLabel = "Before matching", + # afterLabel = "After matching", + # textsearch = shiny::reactiveVal(NULL) + #) + #testthat::expect_true(inherits(resP, 'plotly')) + + balanceSummary <- data.frame( + databaseId = rep(1,2), + #covariateId = 1, + #covariateName = '1', + #analysisId = 1, + #beforeMatchingMeanTreated = 1, + #beforeMatchingMeanComparator = 1, + #beforeMatchingStdDiff = 0, + #afterMatchingMeanTreated = 1, + #afterMatchingMeanComparator = 1, + #afterMatchingStdDiff = 0, + x = rep(1,2), + ymin = rep(1,2), + lower = rep(1,2), + median = rep(1,2), + upper = rep(1,2), + ymax = rep(1,2), + covariateCount = rep(1,2), + type = c("Before matching","After matching") + ) + + resP <- plotCohortMethodCovariateBalanceSummary( + balanceSummary = balanceSummary, + threshold = 0, + beforeLabel = "Before matching", + afterLabel = "After matching" + ) + + testthat::expect_true(inherits(resP, 'gtable')) + +}) \ No newline at end of file diff --git a/tests/testthat/test-cohort-method-DiagnosticsSummary.R b/tests/testthat/test-cohort-method-DiagnosticsSummary.R new file mode 100644 index 00000000..c9993dcb --- /dev/null +++ b/tests/testthat/test-cohort-method-DiagnosticsSummary.R @@ -0,0 +1,66 @@ +context("cohort-method-DiagnosticsSummary") + +shiny::testServer( + app = cohortMethodDiagnosticsSummaryServer, + args = list( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + # should start null + testthat::expect_true(!is.null(data)) + + }) + +test_that("diagnosticSummaryFormat", { + + datar <- function(){ + data.frame(a=1,b=1,c=1,name ='name', summaryValue = 1) + } +val <- diagnosticSummaryFormat( + data = datar, + idCols = c('a','b', 'c'), + namesFrom = c('name') +) + +testthat::expect_true(nrow(val) == 1) +testthat::expect_true(ncol(val) == 4) + +}) + +test_that("getCmDiagnosticData", { +colDefs <- getColDefsCmDiag( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm +) + +testthat::expect_is(colDefs, 'list') +testthat::expect_is(colDefs[[1]], 'colDef') + +}) + +test_that("getCmDiagnosticData", { + + inputSelected <- function(){ + return( + list( + targetIds = 1, + comparatorIds = 2, + outcomeIds = 3, + analysesIds = c(1,2) + ) + ) + } + + +diag <- getCmDiagnosticsData( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + inputSelected +) + +testthat::expect_true(nrow(diag) > 0) + +}) + diff --git a/tests/testthat/test-cohort-method-KaplanMeier.R b/tests/testthat/test-cohort-method-KaplanMeier.R new file mode 100644 index 00000000..a3bff823 --- /dev/null +++ b/tests/testthat/test-cohort-method-KaplanMeier.R @@ -0,0 +1,35 @@ +context("cohort-method-KaplanMeier") + +shiny::testServer( + app = cohortMethodKaplanMeierServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + # should start null + testthat::expect_true(is.null(kaplanMeierPlot())) + + # make sure this runs if we pick the first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 1, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '' + ) + ) + testthat::expect_true(!is.null(kaplanMeierPlot())) + + testthat::expect_true(!is.null(output$kaplanMeierPlotPlotCaption)) + + }) diff --git a/tests/testthat/test-cohort-method-PopulationCharacteristics.R b/tests/testthat/test-cohort-method-PopulationCharacteristics.R new file mode 100644 index 00000000..80dd2f50 --- /dev/null +++ b/tests/testthat/test-cohort-method-PopulationCharacteristics.R @@ -0,0 +1,32 @@ +context("cohort-method-PopulationCharacteristics") + +shiny::testServer( + app = cohortMethodPopulationCharacteristicsServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + # make sure this runs if we pick the first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 1, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '' + ) + ) + testthat::expect_true(!is.null(output$table1Table)) + + testthat::expect_true(!is.null(output$table1Caption)) + + }) diff --git a/tests/testthat/test-cohort-method-Power.R b/tests/testthat/test-cohort-method-Power.R new file mode 100644 index 00000000..770149a9 --- /dev/null +++ b/tests/testthat/test-cohort-method-Power.R @@ -0,0 +1,58 @@ +context("cohort-method-Power") + +shiny::testServer( + app = cohortMethodPowerServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + #testthat::expect_true(is.null(output$powerTable)) + + followUp <- getCmFollowUpDist( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + targetId = 1, + comparatorId = 2, + outcomeId = 3, + databaseId = '1', + analysisId = 2 + ) + testthat::expect_true(nrow(followUp)>0) + + tablet <- prepareCohortMethodFollowUpDistTable(followUp) + testthat::expect_true(nrow(tablet)>0) + + # make sure this runs if we pick the first row + selectedRow( + data.frame( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = F, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) + ) + testthat::expect_true(!is.null(output$powerTable)) + testthat::expect_true(!is.null(output$powerTableCaption)) + testthat::expect_true(!is.null(output$timeAtRiskTableCaption)) + testthat::expect_true(!is.null(output$timeAtRiskTable)) + + + }) diff --git a/tests/testthat/test-cohort-method-PropensityScoreDist.R b/tests/testthat/test-cohort-method-PropensityScoreDist.R new file mode 100644 index 00000000..975f1c78 --- /dev/null +++ b/tests/testthat/test-cohort-method-PropensityScoreDist.R @@ -0,0 +1,55 @@ +context("cohort-method-PropensityScoreDist") + +shiny::testServer( + app = cohortMethodPropensityScoreDistServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + testthat::expect_true(is.null(psDistPlot())) + + ps <- getCohortMethodPs( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + targetId = 1, + comparatorId = 2, + analysisId = 2, + databaseId = '1' + ) + + testthat::expect_true('preferenceScore' %in% colnames(ps)) + testthat::expect_true('targetDensity' %in% colnames(ps)) + testthat::expect_true('comparatorDensity' %in% colnames(ps)) + + # make sure this runs if we pick the first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = 0, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) + ) + + testthat::expect_true(!is.null(psDistPlot())) + + + }) diff --git a/tests/testthat/test-cohort-method-attrition.R b/tests/testthat/test-cohort-method-attrition.R new file mode 100644 index 00000000..f1439766 --- /dev/null +++ b/tests/testthat/test-cohort-method-attrition.R @@ -0,0 +1,34 @@ +context("cohort-method-attrition") + +shiny::testServer( + app = cohortMethodAttritionServer, + args = list( + selectedRow = shiny::reactiveVal( + NULL + ), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + # should start null + testthat::expect_true(is.null(attritionPlot())) + + # make sure this runs if we pick the first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 2, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome' + ) + ) + testthat::expect_true(!is.null(attritionPlot())) + + }) diff --git a/tests/testthat/test-cohort-method-full-result.R b/tests/testthat/test-cohort-method-full-result.R new file mode 100644 index 00000000..5ad28c8d --- /dev/null +++ b/tests/testthat/test-cohort-method-full-result.R @@ -0,0 +1,34 @@ +context("cohort-method-full-result") + +shiny::testServer( + app = cohortMethodFullResultServer, + args = list( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm, + selectedRow = shiny::reactiveVal(NULL) + ), + expr = { + + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + analysisId = 2, + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome' + ) + ) + + }) + + +test_that("Test full ui", { + # Test ui + ui <- cohortMethodFullResultViewer('test') + checkmate::expect_list(ui) +}) \ No newline at end of file diff --git a/tests/testthat/test-cohort-method-main.R b/tests/testthat/test-cohort-method-main.R new file mode 100644 index 00000000..6c5b4bc9 --- /dev/null +++ b/tests/testthat/test-cohort-method-main.R @@ -0,0 +1,22 @@ +context("cohort-method-main") + +shiny::testServer( + app = cohortMethodServer, + args = list( + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + testthat::expect_true(inherits(connectionHandler,"ConnectionHandler")) + + testthat::expect_true(!is.null(targetIds)) + + }) + + +test_that("Test estimation ui", { + # Test ui + ui <- cohortMethodViewer('test') + checkmate::expect_list(ui) +}) \ No newline at end of file diff --git a/tests/testthat/test-cohort-method-propensityModel.R b/tests/testthat/test-cohort-method-propensityModel.R new file mode 100644 index 00000000..ca5e6b62 --- /dev/null +++ b/tests/testthat/test-cohort-method-propensityModel.R @@ -0,0 +1,41 @@ +context("cohort-method-propensityModel") + +shiny::testServer( + app = cohortMethodPropensityModelServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + #testthat::expect_true(is.null(output$powerTable)) + + # make sure this runs if we pick the first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = F, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) + ) + testthat::expect_true(!is.null(output$propensityModelTable)) + + + }) diff --git a/tests/testthat/test-cohort-method-systematicError.R b/tests/testthat/test-cohort-method-systematicError.R new file mode 100644 index 00000000..cfad0323 --- /dev/null +++ b/tests/testthat/test-cohort-method-systematicError.R @@ -0,0 +1,71 @@ +context("cohort-method-systematicError") + +# issues with this modules! + +shiny::testServer( + app = cohortMethodSystematicErrorServer, + args = list( + selectedRow = shiny::reactiveVal(NULL), + connectionHandler = connectionHandlerCm, + resultDatabaseSettings = resultDatabaseSettingsCm + ), + expr = { + + # check result table loads + testthat::expect_true(is.null(systematicErrorPlot())) + + # select first row + selectedRow( + list( + databaseId = '1', + cdmSourceAbbreviation = 'Eunomia', + description = 'madeup', + target = 'test target', + targetId = 1, + comparatorId = 2, + comparator = 'test comparator', + outcomeId = 3, + outcome = 'test outcome', + psStrategy = '', + analysisId = 2, + psStrategy = '', + unblind = 0, + targetSubjects = 100, + comparatorSubjects = 100, + targetOutcomes = 10, + comparatorOutcomes = 5, + targetDays = 1000, + comparatorDays = 1000 + ) + ) + # setting selectedRow() activates the following + ##testthat::expect_true(!is.null(systematicErrorPlot())) + testthat::expect_true(!is.null(output$systematicErrorPlot)) + ##testthat::expect_true(!is.null(systematicErrorSummaryPlot())) + ##testthat::expect_true(!is.null(output$systematicErrorSummaryPlot)) + + }) + + + +test_that("plotCohortMethodScatter", { + + + controlResults <- data.frame( + databaseId = 1:10, + seLogRr = runif(10), + logRr = runif(10), + ci95Lb = runif(10), + ci95Ub = runif(10), + effectSize = runif(10), + calibratedLogRr = runif(10), + calibratedSeLogRr = runif(10), + calibratedCi95Lb = runif(10), + calibratedCi95Ub = runif(10), + trueRr = rep(1,10) + + ) + resP <- plotCohortMethodScatter(controlResults) + testthat::expect_true(inherits(resP, 'ggplot')) + +}) diff --git a/tests/testthat/test-data-diagnostic-drill.R b/tests/testthat/test-data-diagnostic-drill.R index 470057f7..f4b3e44a 100644 --- a/tests/testthat/test-data-diagnostic-drill.R +++ b/tests/testthat/test-data-diagnostic-drill.R @@ -4,8 +4,7 @@ shiny::testServer( app = dataDiagnosticDrillServer, args = list( connectionHandler = connectionHandlerDataDiag, - mySchema = resultDatabaseSettingsDataDiag$schema, - myTableAppend = resultDatabaseSettingsDataDiag$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsDataDiag ), expr = { diff --git a/tests/testthat/test-data-diagnostic-summary.R b/tests/testthat/test-data-diagnostic-summary.R index 4971cfe2..e92ac26b 100644 --- a/tests/testthat/test-data-diagnostic-summary.R +++ b/tests/testthat/test-data-diagnostic-summary.R @@ -4,8 +4,7 @@ shiny::testServer( app = dataDiagnosticSummaryServer, args = list( connectionHandler = connectionHandlerDataDiag, - mySchema = resultDatabaseSettingsDataDiag$schema, - myTableAppend = resultDatabaseSettingsDataDiag$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsDataDiag ), expr = { diff --git a/tests/testthat/test-datasources-main.R b/tests/testthat/test-datasources-main.R new file mode 100644 index 00000000..6369a297 --- /dev/null +++ b/tests/testthat/test-datasources-main.R @@ -0,0 +1,19 @@ +context("datasources-main") + +shiny::testServer(datasourcesServer, args = list( + id = "datasourcesServer", + connectionHandler = connectionHandlerPV, + resultDatabaseSettings = resultDatabaseSettingsPlp +), { + + testthat::expect_is(datasourcesData, 'reactive') + testthat::expect_true(!is.null(datasourcesColList)) + +}) + + +test_that("Test datasources ui", { + # Test ui + ui <- datasourcesViewer("datasources") + checkmate::expect_list(ui) +}) diff --git a/tests/testthat/test-estimation-CovariateBalance.R b/tests/testthat/test-estimation-CovariateBalance.R deleted file mode 100644 index 30f7f00b..00000000 --- a/tests/testthat/test-estimation-CovariateBalance.R +++ /dev/null @@ -1,44 +0,0 @@ -context("estimation-CovariateBalance") - -shiny::testServer( - app = estimationCovariateBalanceServer, - args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - metaAnalysisDbIds = '1' - ), - expr = { - - # should start null - testthat::expect_true(is.null(balance())) - - # make sure this runs if we pick the first row - selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '')) - testthat::expect_true(!is.null(balance())) - testthat::expect_true(nrow(balance())>0) - - testthat::expect_true(!is.null(balancePlot())) - - testthat::expect_true(!is.null(output$balancePlotCaption)) - #session$setInputs(plotHoverBalanceScatter = list( - # x = balance()$absBeforeMatchingStdDiff[1], - # y = balance()$absAfterMatchingStdDiff[1], - # domain = list(left = 0.9, right = 1, top = 3, bottom = 0), - # range = list(left = 3, right = 5, top = 3, bottom = 0) - # ) - #) - #testthat::expect_true(!is.null(output$hoverInfoBalanceScatter)) - ##testthat::expect_true(!is.null(balanceSummaryPlot())) - doesnt work - testthat::expect_true(!is.null(output$balanceSummaryPlotCaption)) - - # check textsearch - textSearchEstimation('heart') - - }) diff --git a/tests/testthat/test-estimation-DiagnosticsSummary.R b/tests/testthat/test-estimation-DiagnosticsSummary.R deleted file mode 100644 index 4a2cbdc5..00000000 --- a/tests/testthat/test-estimation-DiagnosticsSummary.R +++ /dev/null @@ -1,16 +0,0 @@ -context("estimation-DiagnosticsSummary") - -shiny::testServer( - app = estimationDiagnosticsSummaryServer, - args = list( - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - cohortTablePrefix = resultDatabaseSettingsEst$cohortTablePrefix - ), - expr = { - - # should start null - testthat::expect_true(!is.null(data)) - - }) diff --git a/tests/testthat/test-estimation-ForestPlot.R b/tests/testthat/test-estimation-ForestPlot.R deleted file mode 100644 index 6849a5b8..00000000 --- a/tests/testthat/test-estimation-ForestPlot.R +++ /dev/null @@ -1,23 +0,0 @@ -context("estimation-ForestPlot") - -shiny::testServer( - app = estimationForestPlotServer, - args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - metaAnalysisDbIds = NULL, - databaseTable = resultDatabaseSettingsEst$databaseTable - ), - expr = { - - # doesnt seem to be currently used? - testthat::expect_true(is.null(forestPlot())) - - }) diff --git a/tests/testthat/test-estimation-KaplanMeier.R b/tests/testthat/test-estimation-KaplanMeier.R deleted file mode 100644 index cfc8fceb..00000000 --- a/tests/testthat/test-estimation-KaplanMeier.R +++ /dev/null @@ -1,30 +0,0 @@ -context("estimation-KaplanMeier") - -shiny::testServer( - app = estimationKaplanMeierServer, - args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - cohortTablePrefix = resultDatabaseSettingsEst$cohortTablePrefix, - databaseTable = resultDatabaseSettingsEst$databaseTable, - metaAnalysisDbIds = '1' - ), - expr = { - - # should start null - testthat::expect_true(is.null(kaplanMeierPlot())) - - # make sure this runs if we pick the first row - selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '')) - testthat::expect_true(!is.null(kaplanMeierPlot())) - - testthat::expect_true(!is.null(output$kaplanMeierPlotPlotCaption)) - - }) diff --git a/tests/testthat/test-estimation-PopulationCharacteristics.R b/tests/testthat/test-estimation-PopulationCharacteristics.R deleted file mode 100644 index 18711d1f..00000000 --- a/tests/testthat/test-estimation-PopulationCharacteristics.R +++ /dev/null @@ -1,27 +0,0 @@ -context("estimation-PopulationCharacteristics") - -shiny::testServer( - app = estimationPopulationCharacteristicsServer, - args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_' - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable, - #metaAnalysisDbIds = '1' - ), - expr = { - - # make sure this runs if we pick the first row - selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '')) - testthat::expect_true(!is.null(output$table1Table)) - - testthat::expect_true(!is.null(output$table1Caption)) - - }) diff --git a/tests/testthat/test-estimation-Power.R b/tests/testthat/test-estimation-Power.R deleted file mode 100644 index c9f8f394..00000000 --- a/tests/testthat/test-estimation-Power.R +++ /dev/null @@ -1,37 +0,0 @@ -context("estimation-Power") - -shiny::testServer( - app = estimationPowerServer, - args = list( - selectedRow = shiny::reactiveVal( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable, - metaAnalysisDbIds = NULL - ), - expr = { - - #testthat::expect_true(is.null(output$powerTable)) - - # make sure this runs if we pick the first row - #selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F)) - - testthat::expect_true(!is.null(output$powerTable)) - testthat::expect_true(!is.null(output$powerTableCaption)) - testthat::expect_true(!is.null(output$timeAtRiskTableCaption)) - testthat::expect_true(!is.null(output$timeAtRiskTable)) - - - }) diff --git a/tests/testthat/test-estimation-PropensityScoreDist.R b/tests/testthat/test-estimation-PropensityScoreDist.R deleted file mode 100644 index 88491bd8..00000000 --- a/tests/testthat/test-estimation-PropensityScoreDist.R +++ /dev/null @@ -1,41 +0,0 @@ -context("estimation-PropensityScoreDist") - -shiny::testServer( - app = estimationPropensityScoreDistServer, - args = list( - selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - cohortTablePrefix = resultDatabaseSettingsEst$cohortTablePrefix, - #databaseTable = databaseTable, - metaAnalysisDbIds = NULL - ), - expr = { - - testthat::expect_true(is.null(psDistPlot())) - - # make sure this runs if we pick the first row - selectedRow( - - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - - ) - - testthat::expect_true(!is.null(psDistPlot())) - - - }) diff --git a/tests/testthat/test-estimation-ResultsTable.R b/tests/testthat/test-estimation-ResultsTable.R deleted file mode 100644 index f5f8416f..00000000 --- a/tests/testthat/test-estimation-ResultsTable.R +++ /dev/null @@ -1,43 +0,0 @@ -context("estimation-ResultsTable") - -shiny::testServer( - app = estimationResultsTableServer, - args = list( - #selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - #), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3, - database = 1, - analysis = 1 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - #cohortTablePrefix = cohortTablePrefix, - databaseTable = resultDatabaseSettingsEst$databaseTable - #metaAnalysisDbIds = NULL - ), - expr = { - - # check result table loads - testthat::expect_true(!is.null(resultSubset())) - - # select first row - testthat::expect_true(is.null(selectedRow())) - #reactable::updateReactable( - # outputId = "mainTable", - # selected = 1, - # session = session - # ) - session$setInputs(mainTable__reactable__selected = 1) - #session$setInputs(mainTable_rows_selected = 1) - testthat::expect_true(!is.null(selectedRow())) # could check columns - - - }) diff --git a/tests/testthat/test-estimation-Subgroups.R b/tests/testthat/test-estimation-Subgroups.R deleted file mode 100644 index 58991923..00000000 --- a/tests/testthat/test-estimation-Subgroups.R +++ /dev/null @@ -1,53 +0,0 @@ -context("estimation-Subgroups") - - -# tests cannot be done due to getEstimationSubgroupResults() missing? -if(F){ -shiny::testServer( - app = estimationSubgroupsServer, - args = list( - selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3, - database = 1, - analysis = 1 - )), - connectionHandler = connectionHandlerEst, - exposureOfInterest = list(exposureId = c(1,2), exposureName = c(1,2)), - outcomeOfInterest = list(outcomeId = 3, outcomeName = 3) - #resultsSchema = 'main', - #tablePrefix = 'cm_', - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable - #metaAnalysisDbIds = NULL - ), - expr = { - - # check result table loads - testthat::expect_true(is.null(interactionEffects())) - - # select first row - selectedRow( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ) - # setting selectedRow() activates the following - testthat::expect_true(!is.null(interactionEffects())) - - testthat::expect_true(!is.null(output$subgroupTableCaption)) - testthat::expect_true(!is.null(output$subgroupTable)) - - # add code to test blind works - - }) - -} diff --git a/tests/testthat/test-estimation-attrition.R b/tests/testthat/test-estimation-attrition.R deleted file mode 100644 index f875b7ea..00000000 --- a/tests/testthat/test-estimation-attrition.R +++ /dev/null @@ -1,26 +0,0 @@ -context("estimation-attrition") - -shiny::testServer( - app = estimationAttritionServer, - args = list( - selectedRow = shiny::reactiveVal(NULL), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - databaseTable = resultDatabaseSettingsEst$databaseTable - ), - expr = { - - # should start null - testthat::expect_true(is.null(attritionPlot())) - - # make sure this runs if we pick the first row - selectedRow(list(databaseId = 'Eunomia', analysisId = 1)) - testthat::expect_true(!is.null(attritionPlot())) - - }) diff --git a/tests/testthat/test-estimation-main.R b/tests/testthat/test-estimation-main.R deleted file mode 100644 index 954fa6e0..00000000 --- a/tests/testthat/test-estimation-main.R +++ /dev/null @@ -1,32 +0,0 @@ -context("estimation-main") - -shiny::testServer( - app = estimationServer, - args = list( - connectionHandler = connectionHandlerEst, - resultDatabaseSettings = resultDatabaseSettingsEst - ), - expr = { - - testthat::expect_true(inherits(connectionHandler,"ConnectionHandler")) - - - testthat::expect_true(!is.null(output$targetWidget)) - testthat::expect_true(!is.null(output$comparatorWidget)) - testthat::expect_true(!is.null(output$outcomeWidget)) - testthat::expect_true(!is.null(output$databaseWidget)) - testthat::expect_true(!is.null(output$analysisWidget)) - - # check setting target updates inputParams - session$setInputs(target = '1') - testthat::expect_true(inputParams()$target == '1') - - - }) - - -test_that("Test estimation ui", { - # Test ui - ui <- estimationViewer('test') - checkmate::expect_list(ui) -}) \ No newline at end of file diff --git a/tests/testthat/test-estimation-propensityModel.R b/tests/testthat/test-estimation-propensityModel.R deleted file mode 100644 index b98d46c3..00000000 --- a/tests/testthat/test-estimation-propensityModel.R +++ /dev/null @@ -1,34 +0,0 @@ -context("estimation-propensityModel") - -shiny::testServer( - app = estimationPropensityModelServer, - args = list( - selectedRow = shiny::reactiveVal( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_' - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable, - #metaAnalysisDbIds = NULL - ), - expr = { - - #testthat::expect_true(is.null(output$powerTable)) - - # make sure this runs if we pick the first row - #selectedRow(list(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F)) - - testthat::expect_true(!is.null(output$propensityModelTable)) - - - }) diff --git a/tests/testthat/test-estimation-systematicError.R b/tests/testthat/test-estimation-systematicError.R deleted file mode 100644 index bf111319..00000000 --- a/tests/testthat/test-estimation-systematicError.R +++ /dev/null @@ -1,46 +0,0 @@ -context("estimation-systematicError") - -# issues with this modules! - -shiny::testServer( - app = estimationSystematicErrorServer, - args = list( - selectedRow = shiny::reactiveVal(NULL - #data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - # targetSubjects = 100, comparatorSubjects = 100, - # targetOutcomes = 10, comparatorOutcomes = 5, - # targetDays = 1000, comparatorDays = 1000) - ), - inputParams = shiny::reactiveVal(list( - target = 1, - comparator = 2, - outcome = 3, - database = 1, - analysis = 1 - )), - connectionHandler = connectionHandlerEst, - resultsSchema = 'main', - tablePrefix = 'cm_', - #cohortTablePrefix = cohortTablePrefix, - #databaseTable = databaseTable - metaAnalysisDbIds = 1 - ), - expr = { - - # check result table loads - testthat::expect_true(is.null(systematicErrorPlot())) - - # select first row - selectedRow( - data.frame(databaseId = '1', analysisId = 2, psStrategy = '', unblind = F, - targetSubjects = 100, comparatorSubjects = 100, - targetOutcomes = 10, comparatorOutcomes = 5, - targetDays = 1000, comparatorDays = 1000) - ) - # setting selectedRow() activates the following - ##testthat::expect_true(!is.null(systematicErrorPlot())) - ##testthat::expect_true(!is.null(output$systematicErrorPlot)) - ##testthat::expect_true(!is.null(systematicErrorSummaryPlot())) - ##testthat::expect_true(!is.null(output$systematicErrorSummaryPlot)) - - }) diff --git a/tests/testthat/test-evidence-synth-main.R b/tests/testthat/test-evidence-synth-main.R index 617c469d..3fd7d382 100644 --- a/tests/testthat/test-evidence-synth-main.R +++ b/tests/testthat/test-evidence-synth-main.R @@ -9,13 +9,21 @@ shiny::testServer(evidenceSynthesisServer, args = list( expect_true(length(targetIds) > 0) expect_true(length(outcomeIds) > 0) - #session$setInputs( - # `input-selection-targetId` = 1, - # `input-selection-outcomeId` = 3, - # `input-selection-generate` = 1 - #) + inputSelected( + list( + targetId = targetIds[1], + targetIds = targetIds[1], + target = 'test target', + comparatorId = 2, + comparator = 'test comparator', + outcome = 'test outcome', + outcomeId = 3, + outcomeIds = 3 + ) + ) + + testthat::expect_is(output$esCohortMethodPlot, 'list') - inputSelected(list(targetId = targetIds[1], outcomeId = 3)) testthat::expect_true( nrow(unique(rbind(data(),data2()))) >0 ) testthat::expect_equal(as.double(inputSelected()$outcomeId), 3) @@ -32,10 +40,7 @@ test_that("getCMEstimation", { res <- getCMEstimation( connectionHandler = connectionHandlerES, - mySchema = 'main', - cmTablePrefix = 'cm_', - cgTablePrefix = 'cg_', - databaseMetaData = 'database_meta_data', + resultDatabaseSettings = resultDatabaseSettingsES, targetId = 1, outcomeId = 3 ) @@ -48,10 +53,7 @@ test_that("getMetaEstimation", { res <- getMetaEstimation( connectionHandler = connectionHandlerES, - mySchema = 'main', - cmTablePrefix = 'cm_', - cgTablePrefix = 'cg_', - esTablePrefix = 'es_', + resultDatabaseSettings = resultDatabaseSettingsES, targetId = 1, outcomeId = 3 ) @@ -102,11 +104,7 @@ test_that("getSccsEstimation", { res <- getSccsEstimation( connectionHandlerES, - mySchema = 'main', - sccsTablePrefix = 'sccs_', - cgTablePrefix = 'cg_', - esTablePrefix = 'es_', - databaseMetaData = 'database_meta_data', + resultDatabaseSettings = resultDatabaseSettingsES, targetId = 1, outcomeId = 3 ) diff --git a/tests/testthat/test-helpers-estimationPlotsAndTables.R b/tests/testthat/test-helpers-estimationPlotsAndTables.R deleted file mode 100644 index bf1e0440..00000000 --- a/tests/testthat/test-helpers-estimationPlotsAndTables.R +++ /dev/null @@ -1,191 +0,0 @@ -context('tests-helpers-estimationPlotsAndTables') - -test_that("Subgroup stuff", { - -subgroupRes <- getEstimationSubgroupResults( - connectionHandler = connectionHandlerEst, - targetIds = 1, - comparatorIds = 2, - outcomeIds = 3, - databaseIds = 1, - analysisIds = 1, - subgroupIds = 372328212, - cmInteractionResult = data.frame( - targetId = 1, - comparatorId = 2, - outcomeId = 3, - databaseId = 1, - analysisId = 1, - interactionCovariateId = 372328212, - targetSubjects = 10, - comparatorSubjects =10, - rrr = 1, - ci95Lb = 1, - ci95Ub = 1, - p = 1, - calibratedP = 1 - ), - covariate = list( - covariateId = 372328212, - covariateName = 'test', - databaseId = 1 - ) - ) - -testthat::expect_true(nrow(subgroupRes) > 0) - -res <- prepareEstimationSubgroupTable(subgroupResults = subgroupRes, output = "latex") -testthat::expect_true(nrow(res) > 0) - -}) - - -test_that("CovariateBalance stuff", { - - # not the output of getEstimationCovariateBalance - where does it come from?? - balance <- data.frame( - databaseId = rep(1,2), - #covariateId = 1, - #covariateName = '1', - #analysisId = 1, - #beforeMatchingMeanTreated = 1, - #beforeMatchingMeanComparator = 1, - #beforeMatchingStdDiff = 0, - #afterMatchingMeanTreated = 1, - #afterMatchingMeanComparator = 1, - #afterMatchingStdDiff = 0, - absBeforeMatchingStdDiff = c(0.1,0.4), - absAfterMatchingStdDiff = c(0.1,0.4), - x = rep(1,2), - ymin = rep(1,2), - lower = rep(1,2), - median = rep(1,2), - upper = rep(1,2), - ymax = rep(1,2), - covariateCount = rep(1,2), - type = c("Before matching","After matching") - ) - - # added test for this in covariatebal - #resP <- plotEstimationCovariateBalanceScatterPlotNew( - # balance = balance, - # beforeLabel = "Before matching", - # afterLabel = "After matching", - # textsearch = shiny::reactiveVal(NULL) - #) - #testthat::expect_true(inherits(resP, 'plotly')) - - balanceSummary <- data.frame( - databaseId = rep(1,2), - #covariateId = 1, - #covariateName = '1', - #analysisId = 1, - #beforeMatchingMeanTreated = 1, - #beforeMatchingMeanComparator = 1, - #beforeMatchingStdDiff = 0, - #afterMatchingMeanTreated = 1, - #afterMatchingMeanComparator = 1, - #afterMatchingStdDiff = 0, - x = rep(1,2), - ymin = rep(1,2), - lower = rep(1,2), - median = rep(1,2), - upper = rep(1,2), - ymax = rep(1,2), - covariateCount = rep(1,2), - type = c("Before matching","After matching") - ) - - resP <- plotEstimationCovariateBalanceSummary( - balanceSummary = balanceSummary, - threshold = 0, - beforeLabel = "Before matching", - afterLabel = "After matching" - ) - - testthat::expect_true(inherits(resP, 'gtable')) - -}) - -test_that("nonZeroEstimationHazardRatio", { - - testthat::expect_equal( - nonZeroEstimationHazardRatio(hrLower = 0.5, hrUpper = 0.5, terms = 'test'), - 'test' - ) - testthat::expect_equal( - nonZeroEstimationHazardRatio(hrLower = 1.1, hrUpper = 1.1, terms = c('test','sec')), - 'sec' - ) - testthat::expect_equal( - nonZeroEstimationHazardRatio(hrLower = 0.9, hrUpper = 1.1, terms = c('test','sec','3')), - '3' - ) - -}) - -test_that("goodEstimationPropensityScore", { - testthat::expect_equal(goodEstimationPropensityScore(0.5), F) - testthat::expect_equal(goodEstimationPropensityScore(1), F) - testthat::expect_equal(goodEstimationPropensityScore(1.01), T) -}) - -test_that("goodEstimationSystematicBias", { - testthat::expect_equal(goodEstimationSystematicBias(0.5), F) - testthat::expect_equal(goodEstimationSystematicBias(1), F) - testthat::expect_equal(goodEstimationSystematicBias(1.01), T) -}) - - -test_that("plotEstimationForest", { - - results <- data.frame( - databaseId = 1:10, - seLogRr = runif(10), - logRr = runif(10), - ci95Lb = runif(10), - ci95Ub = runif(10), - calibratedLogRr = runif(10), - calibratedCi95Lb = runif(10), - calibratedCi95Ub = runif(10), - i2 = runif(10) - ) -resP <- plotEstimationForest(results, limits = c(0.1, 10), metaAnalysisDbIds = 2) -testthat::expect_true(inherits(resP, 'gtable')) - -}) - -test_that("plotEstimationScatter", { - - - controlResults <- data.frame( - databaseId = 1:10, - seLogRr = runif(10), - logRr = runif(10), - ci95Lb = runif(10), - ci95Ub = runif(10), - effectSize = runif(10), - calibratedLogRr = runif(10), - calibratedSeLogRr = runif(10), - calibratedCi95Lb = runif(10), - calibratedCi95Ub = runif(10), - trueRr = rep(1,10) - - ) - resP <- plotEstimationScatter(controlResults) - testthat::expect_true(inherits(resP, 'ggplot')) - -}) - -## Functions remaining to add tests: -# getEstimationTcoChoice -# getEstimationTargetChoices -# getEstimationComparatorChoices -# getEstimationOutcomeChoices -# getEstimationDatabaseChoices -# getCmAnalysisOptions -# getAllEstimationResults -# getEstimationControlResults -# getEstimationStudyPeriod -# getEstimationNegativeControlEstimates -# getDiagnosticsData diff --git a/tests/testthat/test-helpers-sccsPlots.R b/tests/testthat/test-helpers-sccsPlots.R index e9e1af70..71651df7 100644 --- a/tests/testthat/test-helpers-sccsPlots.R +++ b/tests/testthat/test-helpers-sccsPlots.R @@ -1,10 +1,5 @@ context("helpers-sccsPlots") -test_that("prettyHr", { - testthat::expect_equal(prettyHr(2), "2.00") - testthat::expect_equal(prettyHr(200), "NA") -}) - test_that("convert to dates", { testthat::expect_equal(as.character(convertToStartDate(2020,3)), "2020-03-01") testthat::expect_equal(as.character(convertToEndDate(2020,11)), "2020-11-30") diff --git a/tests/testthat/test-prediction-calibration.R b/tests/testthat/test-patient-level-prediction-calibration.R similarity index 75% rename from tests/testthat/test-prediction-calibration.R rename to tests/testthat/test-patient-level-prediction-calibration.R index fc5a2af8..871c4405 100644 --- a/tests/testthat/test-prediction-calibration.R +++ b/tests/testthat/test-patient-level-prediction-calibration.R @@ -1,13 +1,12 @@ -context("prediction-calibration") +context("patient-level-prediction-calibration") shiny::testServer( - app = predictionCalibrationServer, + app = patientLevelPredictionCalibrationServer, args = list( performanceId = shiny::reactiveVal(1), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal("Calibration"), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { diff --git a/tests/testthat/test-prediction-covariateSummary.R b/tests/testthat/test-patient-level-prediction-covariateSummary.R similarity index 82% rename from tests/testthat/test-prediction-covariateSummary.R rename to tests/testthat/test-patient-level-prediction-covariateSummary.R index 462e8aee..83bd72db 100644 --- a/tests/testthat/test-prediction-covariateSummary.R +++ b/tests/testthat/test-patient-level-prediction-covariateSummary.R @@ -1,15 +1,14 @@ -context("prediction-covariateSummary") +context("patient-level-prediction-covariateSummary") shiny::testServer( - app = predictionCovariateSummaryServer, + app = patientLevelPredictionCovariateSummaryServer, args = list( modelDesignId = shiny::reactiveVal(1), developmentDatabaseId = shiny::reactiveVal(1), performanceId = shiny::reactiveVal(NULL), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal("Discrimination"), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { expect_true(is.null(covariateSummary())) diff --git a/tests/testthat/test-prediction-cutoff.R b/tests/testthat/test-patient-level-prediction-cutoff.R similarity index 77% rename from tests/testthat/test-prediction-cutoff.R rename to tests/testthat/test-patient-level-prediction-cutoff.R index 6be88cd5..364ba35a 100644 --- a/tests/testthat/test-prediction-cutoff.R +++ b/tests/testthat/test-patient-level-prediction-cutoff.R @@ -1,13 +1,12 @@ -context("prediction-cutoff") +context("patient-level-prediction-cutoff") shiny::testServer( - app = predictionCutoffServer, + app = patientLevelPredictionCutoffServer, args = list( performanceId = shiny::reactiveVal(1), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal("Threshold Dependant"), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { diff --git a/tests/testthat/test-patient-level-prediction-designSummary.R b/tests/testthat/test-patient-level-prediction-designSummary.R new file mode 100644 index 00000000..a8931f0a --- /dev/null +++ b/tests/testthat/test-patient-level-prediction-designSummary.R @@ -0,0 +1,30 @@ +context("patient-level-prediction-designSummary") + +shiny::testServer( + app = patientLevelPredictionDesignSummaryServer, + args = list( + connectionHandler = connectionHandlerPlp, + resultDatabaseSettings = resultDatabaseSettingsPlp + ), + expr = { + + expect_true(is.null(modelDesignId())) + #session$setInputs(show_details = list(index = 1)) + #expect_true(!is.null(modelDesignId())) + + expect_true(is.null(reportId())) + #session$setInputs(show_report = list(index = 1)) + #expect_true(!is.null(reportId())) + + expect_true(is.null(diagnosticId())) + #session$setInputs(show_diagnostic = list(index = 1)) + #expect_true(!is.null(diagnosticId())) + + designSummary <- getPredictionDesignSummary( + connectionHandler = connectionHandler, #plp? + resultDatabaseSettings = resultDatabaseSettings,#plp? + targetIds = targetIds[1], + outcomeIds = outcomeIds[1] + ) + + }) diff --git a/tests/testthat/test-prediction-diagnostics.R b/tests/testthat/test-patient-level-prediction-diagnostics.R similarity index 56% rename from tests/testthat/test-prediction-diagnostics.R rename to tests/testthat/test-patient-level-prediction-diagnostics.R index 6e4481a4..941443f5 100644 --- a/tests/testthat/test-prediction-diagnostics.R +++ b/tests/testthat/test-patient-level-prediction-diagnostics.R @@ -1,22 +1,18 @@ -context("prediction-diagnostics") +context("patient-level-prediction-diagnostics") shiny::testServer( - app = predictionDiagnosticsServer, + app = patientLevelPredictionDiagnosticsServer, args = list( modelDesignId = shiny::reactiveVal(1), connectionHandler = connectionHandlerPlp, - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix, - databaseTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { - diag <- getDiagnostics( + diag <- getPredictionDiagnostics( modelDesignId = modelDesignId(), - mySchema = mySchema, connectionHandler = connectionHandler, - myTableAppend = myTableAppend, - databaseTableAppend = databaseTableAppend + resultDatabaseSettings = resultDatabaseSettings ) expect_true(nrow(diag) >0 ) diff --git a/tests/testthat/test-prediction-discrimination.R b/tests/testthat/test-patient-level-prediction-discrimination.R similarity index 80% rename from tests/testthat/test-prediction-discrimination.R rename to tests/testthat/test-patient-level-prediction-discrimination.R index 48ed4830..2783b348 100644 --- a/tests/testthat/test-prediction-discrimination.R +++ b/tests/testthat/test-patient-level-prediction-discrimination.R @@ -1,13 +1,12 @@ -context("prediction-discrimination") +context("patient-level-prediction-discrimination") shiny::testServer( - app = predictionDiscriminationServer, + app = patientLevelPredictionDiscriminationServer, args = list( performanceId = shiny::reactiveVal(1), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal("Discrimination"), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { diff --git a/tests/testthat/test-patient-level-prediction-main.R b/tests/testthat/test-patient-level-prediction-main.R new file mode 100644 index 00000000..eaba8af2 --- /dev/null +++ b/tests/testthat/test-patient-level-prediction-main.R @@ -0,0 +1,50 @@ +context("patient-level-prediction-main") + +shiny::testServer( + app = patientLevelPredictionServer, + args = list( + connectionHandler = connectionHandlerPlp, + resultDatabaseSettings = resultDatabaseSettingsPlp + ), + expr = { + + expect_true(is.null(modelDesignId())) + # designSummary + ##designSummary$modelDesignId(1) + ##expect_true(!is.null(modelDesignId())) + + ##designSummary$diagnosticId(1) + + ##designSummary$reportId(1) + ##expect_true(file.exists(file.path(tempdir(), 'main.html'))) + + ##performance$performanceId(1) + # check performanceId() and developmentDatabaseId() + ##expect_true(!is.null(performanceId())) + ##expect_true(!is.null(developmentDatabaseId())) + + session$setInputs(allView = 'Model Designs Summary') + session$setInputs(backToModelSummary = T) + session$setInputs(backToDesignSummary = T) + + result <- getPlpResultSelection( # prediction?? + connectionHandler = connectionHandlerPlp, + resultDatabaseSettings = resultDatabaseSettingsPlp, + modelDesignId = 1, + performanceId = 1 + ) + + testthat::expect_is(result, 'shiny.tag.list') + + }) + + + +test_that("Test prediction ui", { + # Test ui + ui <- patientLevelPredictionViewer() + checkmate::expect_list(ui) +}) + + + diff --git a/tests/testthat/test-patient-level-prediction-modelSummary.R b/tests/testthat/test-patient-level-prediction-modelSummary.R new file mode 100644 index 00000000..d89fbd3d --- /dev/null +++ b/tests/testthat/test-patient-level-prediction-modelSummary.R @@ -0,0 +1,21 @@ +context("patient-level-prediction-modelSummary") + +shiny::testServer( + app = patientLevelPredictionModelSummaryServer, + args = list( + connectionHandler = connectionHandlerPlp, + modelDesignId = shiny::reactiveVal(1), + resultDatabaseSettings = resultDatabaseSettingsPlp + ), + expr = { + + expect_true(nrow(resultTable())>0) + # check reactives are null untill input set + expect_true(is.null(performanceId())) + expect_true(is.null(developmentDatabaseId())) + + #session$setInputs(view_details = list(index = 1)) + #expect_true(!is.null(performanceId())) + #expect_true(!is.null(developmentDatabaseId())) + + }) diff --git a/tests/testthat/test-prediction-netbenefit.R b/tests/testthat/test-patient-level-prediction-netbenefit.R similarity index 75% rename from tests/testthat/test-prediction-netbenefit.R rename to tests/testthat/test-patient-level-prediction-netbenefit.R index b22e3e43..688c4e20 100644 --- a/tests/testthat/test-prediction-netbenefit.R +++ b/tests/testthat/test-patient-level-prediction-netbenefit.R @@ -1,13 +1,12 @@ -context("prediction-netbenefit") +context("patient-level-prediction-netbenefit") shiny::testServer( - app = predictionNbServer, + app = patientLevelPredictionNbServer, args = list( performanceId = shiny::reactiveVal(NULL), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal("Discrimination"), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { diff --git a/tests/testthat/test-prediction-settings.R b/tests/testthat/test-patient-level-prediction-settings.R similarity index 72% rename from tests/testthat/test-prediction-settings.R rename to tests/testthat/test-patient-level-prediction-settings.R index b84b1665..d429fc60 100644 --- a/tests/testthat/test-prediction-settings.R +++ b/tests/testthat/test-patient-level-prediction-settings.R @@ -1,22 +1,20 @@ -context("prediction-settings") +context("patient-level-prediction-settings") shiny::testServer( - app = predictionSettingsServer, + app = patientLevelPredictionSettingsServer, args = list( modelDesignId = shiny::reactiveVal(NULL), developmentDatabaseId = shiny::reactiveVal(1), performanceId = shiny::reactiveVal(1), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal('Design Settings'), # only works with this - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { modelDesignId(1) - session$setInputs(showAttrition = T) - expect_true(!is.null(output$attrition)) session$setInputs(showCohort = T) + expect_true(!is.null(output$cohort)) session$setInputs(showOutcome = T) session$setInputs(showRestrictPlpData = T) session$setInputs(showPopulation = T) @@ -28,13 +26,11 @@ shiny::testServer( session$setInputs(showSample = T) session$setInputs(showHyperparameters = T) - design <- getModelDesign( + design <- getPredictionModelDesign( inputSingleView = inputSingleView, modelDesignId = modelDesignId, - mySchema = mySchema, connectionHandler = connectionHandler, - myTableAppend = myTableAppend, - cohortTableAppend = '' # add as input? + resultDatabaseSettings = resultDatabaseSettings ) expect_true(class(design) == 'list') expect_true(!is.null(design$RestrictPlpData)) diff --git a/tests/testthat/test-prediction-validation.R b/tests/testthat/test-patient-level-prediction-validation.R similarity index 76% rename from tests/testthat/test-prediction-validation.R rename to tests/testthat/test-patient-level-prediction-validation.R index 0da81ee3..407f60b8 100644 --- a/tests/testthat/test-prediction-validation.R +++ b/tests/testthat/test-patient-level-prediction-validation.R @@ -1,16 +1,14 @@ -context("prediction-valdiation") +context("patient-level-prediction-valdiation") shiny::testServer( - app = predictionValidationServer, + app = patientLevelPredictionValidationServer, args = list( modelDesignId = shiny::reactiveVal(1), developmentDatabaseId = shiny::reactiveVal(1), performanceId = shiny::reactiveVal(1), connectionHandler = connectionHandlerPlp, inputSingleView = shiny::reactiveVal('No Validation'), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix, - databaseTableAppend = resultDatabaseSettingsPlp$tablePrefix + resultDatabaseSettings = resultDatabaseSettingsPlp ), expr = { diff --git a/tests/testthat/test-phevaluator-main.R b/tests/testthat/test-phevaluator-main.R new file mode 100644 index 00000000..a41bce6c --- /dev/null +++ b/tests/testthat/test-phevaluator-main.R @@ -0,0 +1,47 @@ +context("phevaluator-main") + +shiny::testServer(phevaluatorServer, args = list( + id = "phevaluatorServer", + connectionHandler = connectionHandlerPV, + resultDatabaseSettings = resultDatabaseSettingsPV +), { + #set inputs + session$setInputs( + phenotypes = c("hyperprolactinemia", "interstitialLungDisease"), + databaseIds = c("CCAE_RS", "Amb EMR"), + generate = T + ) + + #make sure the selection options are stored in an accesible df + checkmate::expect_data_frame(optionCols) + + #make sure there is at least one selection for each input option + checkmate::expect_character(unique(optionCols$databaseId), min.len = 1) + checkmate::expect_character(unique(optionCols$phenotype), min.len = 1) + + #make sure all extracted data are accessible dfs + checkmate::expect_data_frame(dataAlgorithmPerformance()) + checkmate::expect_data_frame(dataCohortDefinitionSet()) + checkmate::expect_data_frame(dataDiagnostics()) + checkmate::expect_data_frame(dataEvalInputParams()) + checkmate::expect_data_frame(dataModelCovars()) + checkmate::expect_data_frame(dataModelInputParams()) + checkmate::expect_data_frame(dataModelPerformance()) + checkmate::expect_data_frame(dataTestSubjects()) + checkmate::expect_data_frame(dataTestSubjectsCovars()) + + #check that customColDefs are a list or that they are ser to null (no custom col defs specified) + testthat::expect_true(class(customColDefs) == 'list' | is.null(customColDefs)) + + #make sure all output tables work + # output$algorithmPerformanceResultsTable + # output$cohortDefinitionSetTable + # output$diagnosticsTable + # output$evaluationInputParametersTable + # output$modelCovariatesTable + # output$modelInputParametersTable + # output$modelPerformanceTable + # output$testSubjectsTable + # output$testSubjectsCovariatesTable + +}) \ No newline at end of file diff --git a/tests/testthat/test-prediction-designSummary.R b/tests/testthat/test-prediction-designSummary.R deleted file mode 100644 index e82ca46b..00000000 --- a/tests/testthat/test-prediction-designSummary.R +++ /dev/null @@ -1,24 +0,0 @@ -context("prediction-designSummary") - -shiny::testServer( - app = predictionDesignSummaryServer, - args = list( - connectionHandler = connectionHandlerPlp, - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix - ), - expr = { - - expect_true(is.null(modelDesignId())) - session$setInputs(show_details = list(index = 1)) - expect_true(!is.null(modelDesignId())) - - expect_true(is.null(reportId())) - session$setInputs(show_report = list(index = 1)) - expect_true(!is.null(reportId())) - - expect_true(is.null(diagnosticId())) - session$setInputs(show_diagnostic = list(index = 1)) - expect_true(!is.null(diagnosticId())) - - }) diff --git a/tests/testthat/test-prediction-main.R b/tests/testthat/test-prediction-main.R deleted file mode 100644 index 8a7201b6..00000000 --- a/tests/testthat/test-prediction-main.R +++ /dev/null @@ -1,38 +0,0 @@ -context("prediction-main") - -shiny::testServer( - app = predictionServer, - args = list( - connectionHandler = connectionHandlerPlp, - resultDatabaseSettings = resultDatabaseSettingsPlp - ), - expr = { - - expect_true(is.null(modelDesignId())) - designSummary$modelDesignId(1) - ##expect_true(!is.null(modelDesignId())) - - performance$performanceId(1) - # check performanceId() and developmentDatabaseId() - ##expect_true(!is.null(performanceId())) - ##expect_true(!is.null(developmentDatabaseId())) - - designSummary$reportId(NULL) - designSummary$reportId(1) - ##expect_true(file.exists(file.path(tempdir(), 'main.html'))) - - designSummary$diagnosticId(1) - - session$setInputs(allView = 'Model Designs Summary') - - - }) - - - -test_that("Test prediction ui", { - # Test ui - ui <- predictionViewer() - checkmate::expect_list(ui) -}) - diff --git a/tests/testthat/test-prediction-modelSummary.R b/tests/testthat/test-prediction-modelSummary.R deleted file mode 100644 index fb2a2f3e..00000000 --- a/tests/testthat/test-prediction-modelSummary.R +++ /dev/null @@ -1,23 +0,0 @@ -context("prediction-modelSummary") - -shiny::testServer( - app = predictionModelSummaryServer, - args = list( - connectionHandler = connectionHandlerPlp, - modelDesignId = shiny::reactiveVal(1), - mySchema = resultDatabaseSettingsPlp$schema, - myTableAppend = resultDatabaseSettingsPlp$tablePrefix, - databaseTableAppend = resultDatabaseSettingsPlp$tablePrefix - ), - expr = { - - expect_true(nrow(resultTable())>0) - # check reactives are null untill input set - expect_true(is.null(performanceId())) - expect_true(is.null(developmentDatabaseId())) - - session$setInputs(view_details = list(index = 1)) - expect_true(!is.null(performanceId())) - expect_true(!is.null(developmentDatabaseId())) - - }) diff --git a/tests/testthat/test-sccs-main.R b/tests/testthat/test-sccs-main.R index 1a542449..eb57e4f0 100644 --- a/tests/testthat/test-sccs-main.R +++ b/tests/testthat/test-sccs-main.R @@ -5,48 +5,14 @@ shiny::testServer(sccsServer, args = list( connectionHandler = connectionHandlerSccs, resultDatabaseSettings = resultDatabaseSettingsSccs ), { - #session$setInputs( - # exposuresOutcome = "[EPI_1024] canagliflozin exposures w 0d prior obsv, 30d gap, male - [EPI_1024] Prostatitis Syndrome events (remove testicular lesions, bladder neoplasm and hernia)", - # database = "1038356333", - # analysis = 1 - #) + inputSelected( list( - database = 1, analysis = 13, outcome = 11123, exposure = 1 ) ) - - checkmate::expect_data_frame(resultSubset()) - - checkmate::expect_class(output$mainTable, "json") - - expect_null(selectedRow()) - - # Dependency injection to mimic selection of a row in the table - - session$setInputs( - mainTableRowInput = 1, - mainTable__reactable__selected = 1 - ) - - ##testthat::expect_true(nrow(resultSubset())>0) - ##testthat::expect_equal(selectedRow(),1) - # End of testing that can be done without data - # The following will be filled in when test data are available - # checkmate::expect_data_frame(selectedRow()) - # output$powerTable - # output$timeTrendPlot - # output$modelTable - # output$attritionPlot - # output$timeTrendPlot - # output$timeToEventPlot - # output$ageSplinePlot - # output$seasonSplinePlot - # output$controlEstimatesPlot - # output$diagnosticsSummary }) @@ -110,7 +76,6 @@ test_that("Test getSccsResults", { resultDatabaseSettings = resultDatabaseSettingsSccs, exposureIds = 1, outcomeIds = 11123, - databaseIds = 1, analysisIds = 13 ) diff --git a/tests/testthat/test-sccs-results-full.R b/tests/testthat/test-sccs-results-full.R new file mode 100644 index 00000000..e159778f --- /dev/null +++ b/tests/testthat/test-sccs-results-full.R @@ -0,0 +1,42 @@ +context("sccs-results-full") + +shiny::testServer(sccsFullResultServer, args = list( + id = "testSccsResultFullServer", + connectionHandler = connectionHandlerSccs, + resultDatabaseSettings = resultDatabaseSettingsSccs, + selectedRow = shiny::reactiveVal(NULL) +), { + + testthat::expect_is(selectedRow(), "NULL") + + selectedRow( + data.frame( + outcomeId = 11123, + databaseId = 1, + analysisId = 13, + covariateId = 1, + covariateName = 'test', + description = 'madeup', + databaseName = 'db', + analysis = 13, + outcome = 11123, + exposure = 1, + unblind = 1, + outcomeEvents = 10, + outcomeSubjects = 100, + observedDays = 100, + covariateSubjects = 1000, + covariateDays = 1000, + covariateOutcomes = 20, + mdrr = 2 + ) + ) + +}) + +test_that("Test sccs full results ui", { + # Test ui + ui <- sccsFullResultViewer('fullview') + checkmate::expect_list(ui) +}) + diff --git a/tests/testthat/test-sccs-results.R b/tests/testthat/test-sccs-results.R new file mode 100644 index 00000000..8602c0b1 --- /dev/null +++ b/tests/testthat/test-sccs-results.R @@ -0,0 +1,29 @@ +context("sccs-results") + +shiny::testServer(sccsResultsServer, args = list( + id = "testSccsResultsServer", + connectionHandler = connectionHandlerSccs, + resultDatabaseSettings = resultDatabaseSettingsSccs, + inputSelected = shiny::reactiveVal(NULL) +), { + + testthat::expect_is(selectedRow(), "NULL") + + inputSelected( + list( + analysis = 13, + outcome = 11123, + exposure = 1 + ) + ) + + testthat::expect_true(!is.null(data())) + +}) + +test_that("Test sccs results ui", { + # Test ui + ui <- sccsResultsViewer('testing') + checkmate::expect_list(ui) +}) +