diff --git a/DESCRIPTION b/DESCRIPTION index fc7e52c4..7286c00b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: OhdsiShinyModules Type: Package Title: Repository of Shiny Modules for OHDSI Result Viewers -Version: 2.0.0 +Version: 2.0.2 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 . diff --git a/NEWS.md b/NEWS.md index 9d38a25e..75a87848 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,14 @@ +OhdsiShinyModules v2.0.2 +======================== +edited characterization server to work with new aggregate features method in characterization package +edited characterization server to work when one or more characterization result is missing +edited evidence synth module to highlight the bayesian and fix issue with comparison names not showing + +OhdsiShinyModules v2.0.1 +======================== +Bug Fixes: +- Fix for CohortDiagnostic app not loading when characterization was set to FALSE + OhdsiShinyModules v2.0.0 ======================== - updated all models to use the same resultDatabaseSettings diff --git a/R/characterization-aggregateFeatures.R b/R/characterization-aggregateFeatures.R index c2b41045..f3628ca9 100644 --- a/R/characterization-aggregateFeatures.R +++ b/R/characterization-aggregateFeatures.R @@ -91,7 +91,6 @@ characterizationAggregateFeaturesViewer <- 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 resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return @@ -101,7 +100,6 @@ characterizationAggregateFeaturesViewer <- function(id) { characterizationAggregateFeaturesServer <- function( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) { shiny::moduleServer( diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R index 7d4c306c..811c607f 100644 --- a/R/characterization-cohorts.R +++ b/R/characterization-cohorts.R @@ -62,7 +62,6 @@ characterizationTableViewer <- 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 resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return @@ -72,7 +71,6 @@ characterizationTableViewer <- function(id) { characterizationTableServer <- function( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) { shiny::moduleServer( diff --git a/R/characterization-dechallengeRechallenge.R b/R/characterization-dechallengeRechallenge.R index d748d2b8..e924812a 100644 --- a/R/characterization-dechallengeRechallenge.R +++ b/R/characterization-dechallengeRechallenge.R @@ -60,7 +60,6 @@ characterizationDechallengeRechallengeViewer <- 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 resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return @@ -70,7 +69,6 @@ characterizationDechallengeRechallengeViewer <- function(id) { characterizationDechallengeRechallengeServer <- function( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) { shiny::moduleServer( diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R index 69541010..1097675e 100644 --- a/R/characterization-incidence.R +++ b/R/characterization-incidence.R @@ -216,7 +216,6 @@ characterizationIncidenceViewer <- 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 resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return @@ -226,7 +225,6 @@ characterizationIncidenceViewer <- function(id) { characterizationIncidenceServer <- function( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) { shiny::moduleServer( diff --git a/R/characterization-main.R b/R/characterization-main.R index 0fbf84df..a105c107 100644 --- a/R/characterization-main.R +++ b/R/characterization-main.R @@ -52,33 +52,8 @@ characterizationViewer <- function(id=1) { shiny::tabsetPanel( type = 'pills', - id = ns('mainPanel'), - - shiny::tabPanel( - "Target Viewer", - characterizationTableViewer(ns('descriptiveTableTab')) - ), - - shiny::tabPanel( - "Outcome Stratified", - characterizationAggregateFeaturesViewer(ns('aggregateFeaturesTab')) - ), - - shiny::tabPanel( - "Incidence Rate", - characterizationIncidenceViewer(ns('incidenceTab')) - ), - - shiny::tabPanel( - "Time To Event", - characterizationTimeToEventViewer(ns('timeToEventTab')) - ), - - shiny::tabPanel( - "Dechallenge Rechallenge", - characterizationDechallengeRechallengeViewer(ns('dechallengeRechallengeTab')) - ) - ) + id = ns('mainPanel') + ) ) } @@ -104,71 +79,168 @@ characterizationServer <- function( shiny::moduleServer( id, function(input, output, session) { + + # this function checks tables exist for the tabs + # and returns the tabs that should be displayed + # as the tables exist + charTypes <- getCharacterizationTypes( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) - mainPanelTab <- shiny::reactiveVal(input$mainPanel) - shiny::observeEvent( - input$mainPanel, - { - mainPanelTab(input$mainPanel) - }) + # add the tabs based on results + types <- list( + c("Target Viewer","characterizationTableViewer", "descriptiveTableTab"), + c("Outcome Stratified", "characterizationAggregateFeaturesViewer", "aggregateFeaturesTab"), + c("Incidence Rate", "characterizationIncidenceViewer", "incidenceTab"), + c("Time To Event", "characterizationTimeToEventViewer", "timeToEventTab"), + c("Dechallenge Rechallenge", 'characterizationDechallengeRechallengeViewer', 'dechallengeRechallengeTab') + ) + selectVal <- T + for( type in types){ + if(type[1] %in% charTypes){ + shiny::insertTab( + inputId = "mainPanel", + tab = shiny::tabPanel( + type[1], + do.call(what = type[2], args = list(id = session$ns(type[3]))) + ), + select = selectVal + ) + } + selectVal = F + } + + previouslyLoaded <- shiny::reactiveVal(c()) + # only render the tab when selected + shiny::observeEvent(input$mainPanel,{ # ============================= # Table of cohorts # ============================= - characterizationTableServer( - id = 'descriptiveTableTab', - connectionHandler = connectionHandler, - mainPanelTab = mainPanelTab, - resultDatabaseSettings = resultDatabaseSettings - ) + if(input$mainPanel == "Target Viewer"){ + if(!"Target Viewer" %in% previouslyLoaded()){ + characterizationTableServer( + id = 'descriptiveTableTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + previouslyLoaded(c(previouslyLoaded(), "Target Viewer")) + } + } # ============================= # Aggregrate Features # ============================= - - characterizationAggregateFeaturesServer( - id = 'aggregateFeaturesTab', - connectionHandler = connectionHandler, - mainPanelTab = mainPanelTab, - resultDatabaseSettings = resultDatabaseSettings - ) + if(input$mainPanel == "Outcome Stratified"){ + if(!"Outcome Stratified" %in% previouslyLoaded()){ + characterizationAggregateFeaturesServer( + id = 'aggregateFeaturesTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + previouslyLoaded(c(previouslyLoaded(), "Outcome Stratified")) + } + } # ============================= # Incidence # ============================= - characterizationIncidenceServer( - id = 'incidenceTab', - connectionHandler = connectionHandler, - mainPanelTab = mainPanelTab, - resultDatabaseSettings = resultDatabaseSettings - ) + if(input$mainPanel == "Incidence Rate"){ + if(!"Incidence Rate" %in% previouslyLoaded()){ + characterizationIncidenceServer( + id = 'incidenceTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + previouslyLoaded(c(previouslyLoaded(), "Incidence Rate")) + } + } # ============================= # Time To Event # ============================= - - characterizationTimeToEventServer( - id = 'timeToEventTab', - connectionHandler = connectionHandler, - mainPanelTab = mainPanelTab, - resultDatabaseSettings = resultDatabaseSettings - ) - + if(input$mainPanel == "Time To Event"){ + if(!"Time To Event" %in% previouslyLoaded()){ + characterizationTimeToEventServer( + id = 'timeToEventTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + previouslyLoaded(c(previouslyLoaded(), "Time To Event")) + } + } # ============================= # Dechallenge Rechallenge # ============================= - - characterizationDechallengeRechallengeServer( - id = 'dechallengeRechallengeTab', - connectionHandler = connectionHandler, - mainPanelTab = mainPanelTab, - resultDatabaseSettings = resultDatabaseSettings - ) + if(input$mainPanel == "Dechallenge Rechallenge"){ + if(!"Dechallenge Rechallenge" %in% previouslyLoaded()){ + characterizationDechallengeRechallengeServer( + id = 'dechallengeRechallengeTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + previouslyLoaded(c(previouslyLoaded(), "Dechallenge Rechallenge")) + } + } + + }) # end observed input tab } ) } + +getCharacterizationTypes <- function( + connectionHandler, + resultDatabaseSettings +){ + + results <- c() + + conn <- DatabaseConnector::connect( + connectionDetails = connectionHandler$connectionDetails + ) + on.exit(DatabaseConnector::disconnect(conn)) + tbls <- DatabaseConnector::getTableNames( + connection = conn, + databaseSchema = resultDatabaseSettings$schema + ) + + # check Targets + if(sum(paste0( + resultDatabaseSettings$cTablePrefix, + c('covariates', 'covariate_ref', 'cohort_details', 'settings') + ) %in% tbls) == 4){ + results <- c(results, "Target Viewer", "Outcome Stratified" ) + } + + # check dechallenge_rechallenge + if(paste0( + resultDatabaseSettings$cTablePrefix, + 'dechallenge_rechallenge' + ) %in% tbls){ + results <- c(results, "Dechallenge Rechallenge") + } + + # check time_to_event + if(paste0( + resultDatabaseSettings$cTablePrefix, + 'time_to_event' + ) %in% tbls){ + results <- c(results, "Time To Event") + } + + # check incidence + if(paste0( + resultDatabaseSettings$incidenceTablePrefix, + 'incidence_summary' + ) %in% tbls){ + results <- c(results, "Incidence Rate") + } + + return(results) +} \ No newline at end of file diff --git a/R/characterization-timeToEvent.R b/R/characterization-timeToEvent.R index b0aea21d..b6430ea2 100644 --- a/R/characterization-timeToEvent.R +++ b/R/characterization-timeToEvent.R @@ -75,7 +75,6 @@ characterizationTimeToEventViewer <- 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 resultDatabaseSettings a list containing the characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix #' #' @return @@ -85,17 +84,12 @@ characterizationTimeToEventViewer <- function(id) { characterizationTimeToEventServer <- function( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) { shiny::moduleServer( id, function(input, output, session) { - #if(mainPanelTab() != 'Time To Event'){ - # return(invisible(NULL)) - #} - # get the possible target ids bothIds <- timeToEventGetIds( connectionHandler, diff --git a/R/cohort-diagnostics-main.R b/R/cohort-diagnostics-main.R index dd4ae2a7..5e669248 100644 --- a/R/cohort-diagnostics-main.R +++ b/R/cohort-diagnostics-main.R @@ -235,14 +235,16 @@ createCdDatabaseDataSource <- function( dataSource$temporalAnalysisRef <- loadResultsTable(dataSource, "temporal_analysis_ref", cdTablePrefix = dataSource$cdTablePrefix) dataSource$temporalChoices <- getResultsTemporalTimeRef(dataSource = dataSource) - dataSource$temporalCharacterizationTimeIdChoices <- dataSource$temporalChoices %>% - dplyr::arrange(sequence) - dataSource$characterizationTimeIdChoices <- dataSource$temporalChoices %>% - dplyr::filter(.data$isTemporal == 0) %>% - dplyr::filter(.data$primaryTimeId == 1) %>% - dplyr::arrange(.data$sequence) + if (hasData(dataSource$temporalChoices)) { + dataSource$temporalCharacterizationTimeIdChoices <- dataSource$temporalChoices %>% + dplyr::arrange(.data$sequence) + dataSource$characterizationTimeIdChoices <- dataSource$temporalChoices %>% + dplyr::filter(.data$isTemporal == 0) %>% + dplyr::filter(.data$primaryTimeId == 1) %>% + dplyr::arrange(.data$sequence) + } if (!is.null(dataSource$temporalAnalysisRef)) { dataSource$temporalAnalysisRef <- dplyr::bind_rows( diff --git a/R/evidence-synth-cm.R b/R/evidence-synth-cm.R new file mode 100644 index 00000000..e87e7d97 --- /dev/null +++ b/R/evidence-synth-cm.R @@ -0,0 +1,549 @@ +evidenceSynthesisCmViewer <- function(id=1) { + ns <- shiny::NS(id) + + shiny::div( + + inputSelectionViewer(ns("input-selection-cm")), + + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = shiny::NS(ns("input-selection-cm")), + + shiny::tabsetPanel( + type = 'pills', + id = ns('esCohortMethodTabs'), + + # diagnostic view + shiny::tabPanel( + title = 'Diagnostics', + resultTableViewer(ns("diagnosticsCmSummaryTable")) + ), + + shiny::tabPanel( + "Plot", + shiny::plotOutput(ns('esCohortMethodPlot')) + ), + shiny::tabPanel( + "Table", + resultTableViewer(ns("esCohortMethodTable")) + ) + ) + ) + ) +} + + +evidenceSynthesisCmServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1) +) { + shiny::moduleServer( + id, + function(input, output, session) { + + targetIds <- getEsCmTargetIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + outcomeIds <- getEsOutcomeIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + inputSelected <- inputSelectionServer( + id = "input-selection-cm", + inputSettingList = list( + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'targetIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Target: ', + choices = targetIds, + multiple = F, + 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, + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ) + ) + ) + + # plots and tables + cmdata <- shiny::reactive({ + unique( + rbind( + getCMEstimation( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds + ), + getMetaEstimation( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds + ) + ) + ) + }) + + + diagSumData <- shiny::reactive({ + getEvidenceSynthCmDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected, + targetIds = inputSelected()$targetIds, + outcomeIds = inputSelected()$outcomeIds + ) + }) + + + resultTableServer( + id = "diagnosticsCmSummaryTable", + df = diagSumData, + colDefsInput = getColDefsESDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + ) + + output$esCohortMethodPlot <- shiny::renderPlot( + createPlotForAnalysis( + cmdata() + ) + ) + + + resultTableServer( + id = "esCohortMethodTable", + df = cmdata, + colDefsInput = list( + targetId = reactable::colDef(show = F), + outcomeId = reactable::colDef(show = F), + comparatorId = reactable::colDef(show = F), + analysisId = reactable::colDef(show = F), + description = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Analysis", + "Analysis" + )), + database = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Data source", + "Data source" + )), + calibratedRr = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.HR", + "Hazard ratio (calibrated)" + )), + calibratedCi95Lb = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.LB", + "Lower bound of the 95 percent confidence interval (calibrated)" + )), + calibratedCi95Ub = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.UB", + "Upper bound of the 95 percent confidence interval (calibrated)" + )), + calibratedP = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.P", + "Two-sided p-value (calibrated)" + )), + calibratedLogRr = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.Log.HR", + "Log of Hazard ratio (calibrated)" + )), + calibratedSeLogRr = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.Se.Log.HR", + "Log Standard Error of Hazard ratio (calibrated)" + )), + target = reactable::colDef( + minWidth = 300 + ), + outcome = reactable::colDef( + minWidth = 300 + ), + comparator = reactable::colDef( + minWidth = 300 + ) + ) + ) + + } + ) + +} + + +getEsCmTargetIds <- function( + connectionHandler, + resultDatabaseSettings +){ + + sql <- "select distinct + c1.cohort_name as target, + r.target_id + + from + @schema.@cm_table_prefixresult as r + inner join + @schema.@cg_table_prefixcohort_definition as c1 + on c1.cohort_definition_id = r.target_id + ;" + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix + ) + + output <- as.list(result$targetId) + names(output) <- result$target + + return(output) + +} + +getCMEstimation <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId +){ + + if(is.null(targetId)){ + return(NULL) + } + + sql <- "select + c1.cohort_name as target, + c2.cohort_name as comparator, + c3.cohort_name as outcome, + r.target_id, r.comparator_id, r.outcome_id, r.analysis_id, + a.description, + db.cdm_source_abbreviation as database, r.calibrated_rr, + r.calibrated_ci_95_lb, r.calibrated_ci_95_ub, r.calibrated_p, + r.calibrated_log_rr, r.calibrated_se_log_rr + + from + @schema.@cm_table_prefixresult as r + inner join + @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 + + @schema.@cm_table_prefixdiagnostics_summary as unblind + on + r.analysis_id = unblind.analysis_id and + r.target_id = unblind.target_id and + r.comparator_id = unblind.comparator_id and + r.outcome_id = unblind.outcome_id and + r.database_id = unblind.database_id + + inner join + @schema.@database_table as db + on db.database_id = r.database_id + + inner join + @schema.@cg_table_prefixcohort_definition as c1 + on c1.cohort_definition_id = r.target_id + + inner join + @schema.@cg_table_prefixcohort_definition as c2 + on c2.cohort_definition_id = r.comparator_id + + inner join + @schema.@cg_table_prefixcohort_definition as c3 + on c3.cohort_definition_id = r.outcome_id + + inner join + @schema.@cm_table_prefixanalysis as a + on a.analysis_id = r.analysis_id + + where + r.calibrated_rr != 0 and + tco.outcome_of_interest = 1 and + unblind.unblind = 1 and + r.target_id = @target_id and + r.outcome_id = @outcome_id + ;" + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + outcome_id = outcomeId, + target_id = targetId + ) %>% + dplyr::mutate( + calibratedP = ifelse( + .data$calibratedRr < 1, + computeTraditionalP( + logRr = .data$calibratedLogRr, + seLogRr = .data$calibratedSeLogRr, + twoSided = FALSE, + upper = TRUE + ), + .data$calibratedP / 2) + ) + + return(result) +} + +getMetaEstimation <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId +){ + + if(is.null(targetId)){ + return(NULL) + } + + sql <- "select + c1.cohort_name as target, + c2.cohort_name as comparator, + c3.cohort_name as outcome, + r.target_id, r.comparator_id, r.outcome_id, r.analysis_id, + a.description, + ev.evidence_synthesis_description as database, + r.calibrated_rr, + r.calibrated_ci_95_lb, r.calibrated_ci_95_ub, r.calibrated_p, + r.calibrated_log_rr, r.calibrated_se_log_rr + + from + @schema.@es_table_prefixcm_result as r + inner join + @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 + + @schema.@es_table_prefixcm_diagnostics_summary as unblind + on + r.analysis_id = unblind.analysis_id and + r.target_id = unblind.target_id and + r.comparator_id = unblind.comparator_id and + r.outcome_id = unblind.outcome_id + + inner join + @schema.@cg_table_prefixcohort_definition as c1 + on c1.cohort_definition_id = r.target_id + + inner join + @schema.@cg_table_prefixcohort_definition as c2 + on c2.cohort_definition_id = r.comparator_id + + inner join + @schema.@cg_table_prefixcohort_definition as c3 + on c3.cohort_definition_id = r.outcome_id + + inner join + @schema.@cm_table_prefixanalysis as a + on a.analysis_id = r.analysis_id + + inner join + @schema.@es_table_prefixanalysis as ev + on ev.evidence_synthesis_analysis_id = r.evidence_synthesis_analysis_id + + where + r.calibrated_rr != 0 and + tco.outcome_of_interest = 1 and + unblind.unblind = 1 and + r.target_id = @target_id and + r.outcome_id = @outcome_id + ;" + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + es_table_prefix = resultDatabaseSettings$esTablePrefix, + outcome_id = outcomeId, + target_id = targetId + ) %>% + dplyr::mutate( + calibratedP = ifelse( + .data$calibratedRr < 1, + computeTraditionalP( + logRr = .data$calibratedLogRr, + seLogRr = .data$calibratedSeLogRr, + twoSided = FALSE, + upper = TRUE + ), + .data$calibratedP / 2) + ) + + return(unique(result)) +} + +getEvidenceSynthCmDiagnostics <- function( + connectionHandler, + resultDatabaseSettings, + inputSelected, + targetIds, + outcomeIds +){ + + if(is.null(targetIds)){ + return(NULL) + } + + cmDiagTemp <- getCmDiagnosticsData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected + ) + + if(is.null(cmDiagTemp)){ + return(NULL) + } + + # select columns of interest and rename for consistency + cmDiagTemp <- diagnosticSummaryFormat( + data = shiny::reactive({cmDiagTemp}), + idCols = c('databaseName','target'), + namesFrom = c('analysis','comparator','outcome') + ) + + # return + return(cmDiagTemp) +} + + +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) + ) + + data <- merge( + data, + compText, + by = "comparator" + ) + + # make sure bayesian is at bottom + db <- unique(data$database) + bInd <- grep('bayesian', tolower(db)) + withoutb <- db[-bInd] + b <- db[bInd] + data$database <- factor( + x = data$database, + levels = c(sort(withoutb), b) + ) + metadata <- data[data$database == b,] + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8) + title <- sprintf("%s", data$outcome[1]) + plot <- ggplot2::ggplot( + data = data, + ggplot2::aes(x = .data$calibratedRr, y = .data$comparatorText)) + + ggplot2::geom_vline(xintercept = 1, size = 0.5) + + ggplot2::geom_point(color = "#000088", alpha = 0.8) + + ggplot2::geom_errorbarh( + ggplot2::aes( + xmin = .data$calibratedCi95Lb, + xmax = .data$calibratedCi95Ub + ), + height = 0.5, + color = "#000088", + alpha = 0.8 + ) + + ggplot2::scale_x_log10( + "Effect size (Hazard Ratio)", + breaks = breaks, + labels = breaks + ) + + + # shade the bayesian + ggplot2::geom_rect( + data = metadata, + ggplot2::aes(fill = .data$database), + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = Inf, + alpha = 0.2 + ) + + + ggplot2::coord_cartesian(xlim = c(0.1, 10)) + + ggplot2::facet_grid(.data$database ~ .data$description) + + ggplot2::ggtitle(title) + + ggplot2::theme( + axis.title.y = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + strip.text.y.right = ggplot2::element_text(angle = 0), + legend.position = "none" + ) + + ggplot2::labs( + caption = paste( + apply( + X = compText, + MARGIN = 1, + FUN = function(x){paste0(paste(substring(x, 1, 50),collapse = ': ', sep=':'), '...')} + ), + collapse = '\n ') + ) + + return(plot) +} diff --git a/R/evidence-synth-main.R b/R/evidence-synth-main.R index b949416f..f270ab2c 100644 --- a/R/evidence-synth-main.R +++ b/R/evidence-synth-main.R @@ -37,44 +37,26 @@ evidenceSynthesisViewer <- function(id=1) { helpLocation= system.file("evidence-synthesis-www", "evidence-synthesis.html", package = utils::packageName()) ), - inputSelectionViewer(ns("input-selection")), - - shiny::conditionalPanel( - condition = 'input.generate != 0', - ns = shiny::NS(ns("input-selection")), + # add two buttons - CM or SCCs + shiny::tabsetPanel( + id = ns('typeTab'), + type = 'pills', - shiny::tabsetPanel( - type = 'pills', - id = ns('esCohortTabs'), - - # diagnostic view - shiny::tabPanel( - title = 'Diagnostics', - resultTableViewer(ns("diagnosticsSummaryTable")) - ), - - shiny::tabPanel( - "Cohort Method Plot", - shiny::plotOutput(ns('esCohortMethodPlot')) - ), - shiny::tabPanel( - "Cohort Method Table", - resultTableViewer(ns("esCohortMethodTable")) - ), - shiny::tabPanel("SCCS Plot", - shiny::plotOutput(ns('esSccsPlot')) - ), - shiny::tabPanel("SCCS Table", - resultTableViewer(ns("esSccsTable")) - ) + shiny::tabPanel( + title = 'Cohort Method', + evidenceSynthesisCmViewer(ns('cohortMethodTab')) + ), + shiny::tabPanel( + title = 'Self Controlled Case Series', + evidenceSynthesisSccsViewer(ns('sccsTab')) ) + ) ) } - #' The module server for exploring PatientLevelPrediction #' #' @details @@ -97,291 +79,25 @@ evidenceSynthesisServer <- function( id, function(input, output, session) { - targetIds <- getESTargetIds( + evidenceSynthesisCmServer( + id = 'cohortMethodTab', connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings - ) - outcomeIds <- getESOutcomeIds( - 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, - multiple = F, - 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, - multiple = F, - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - liveSearch = TRUE, - size = 10, - liveSearchStyle = "contains", - liveSearchPlaceholder = "Type here to search", - virtualScroll = 50 - ) - ) - ) - ) - ) - - # plots and tables - cmdata <- shiny::reactive({ - unique( - rbind( - getCMEstimation( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetId = inputSelected()$targetIds, - outcomeId = inputSelected()$outcomeIds - ), - getMetaEstimation( - connectionHandler = connectionHandler, - 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( - cmdata() - ) - ) - - resultTableServer( - id = "esCohortMethodTable", - df = cmdata, - colDefsInput = list( - targetId = reactable::colDef(show = F), - outcomeId = reactable::colDef(show = F), - comparatorId = reactable::colDef(show = F), - analysisId = reactable::colDef(show = F), - description = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Analysis", - "Analysis" - )), - database = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Data source", - "Data source" - )), - calibratedRr = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.HR", - "Hazard ratio (calibrated)" - )), - calibratedCi95Lb = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.LB", - "Lower bound of the 95 percent confidence interval (calibrated)" - )), - calibratedCi95Ub = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.UB", - "Upper bound of the 95 percent confidence interval (calibrated)" - )), - calibratedP = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.P", - "Two-sided p-value (calibrated)" - )), - calibratedLogRr = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.Log.HR", - "Log of Hazard ratio (calibrated)" - )), - calibratedSeLogRr = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.Se.Log.HR", - "Log Standard Error of Hazard ratio (calibrated)" - )), - target = reactable::colDef( - minWidth = 300 - ), - outcome = reactable::colDef( - minWidth = 300 - ), - comparator = reactable::colDef( - minWidth = 300 - ) - ) - ) - - - # SCCS plots and tables - - sccsData <- shiny::reactive({ - unique( - getSccsEstimation( - connectionHandler = connectionHandler, - resultDatabaseSettings = resultDatabaseSettings, - targetId = inputSelected()$targetIds, - outcomeId = inputSelected()$outcomeIds - ) - ) - }) - - output$esSccsPlot <- shiny::renderPlot({ - sccsRes <- sccsData() - shiny::validate(shiny::need(hasData(sccsRes), "No valid data for selected target")) - createPlotForSccsAnalysis(sccsRes) - }) - - - resultTableServer( - id = "esSccsTable", - df = sccsData, - colDefsInput = list( - targetId = reactable::colDef(show = F), - outcomeId = reactable::colDef(show = F), - analysisId = reactable::colDef(show = F), - description = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Analysis", - "Analysis" - )), - database = reactable::colDef( - filterable = TRUE, - header = withTooltip( - "Data source", - "Data source" - )), - calibratedRr = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.IRR", - "Incidence rate ratio (calibrated)" - )), - calibratedCi95Lb = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.LB", - "Lower bound of the 95 percent confidence interval (calibrated)" - )), - calibratedCi95Ub = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.UB", - "Upper bound of the 95 percent confidence interval (calibrated)" - )), - calibratedP = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.P", - "Two-sided p-value (calibrated)" - )), - calibratedLogRr = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.Log.IRR", - "Log of Incidence rate ratio (calibrated)" - )), - calibratedSeLogRr = reactable::colDef( - format = reactable::colFormat(digits = 3), - header = withTooltip( - "Cal.Se.Log.IRR", - "Log Standard Error of Incidence rate ratio (calibrated)" - )) + evidenceSynthesisSccsServer( + id = 'sccsTab', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings ) - ) - + } ) - -} - - -getESTargetIds <- function( - connectionHandler, - resultDatabaseSettings -){ - - sql <- "select distinct - c1.cohort_name as target, - r.target_id - - from - @schema.@cm_table_prefixresult as r - inner join - @schema.@cg_table_prefixcohort_definition as c1 - on c1.cohort_definition_id = r.target_id - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix - ) - - output <- as.list(result$targetId) - names(output) <- result$target - - return(output) - } -getESOutcomeIds <- function( +# Function to get outcome ids +# used by both cm and sccs +getEsOutcomeIds <- function( connectionHandler, resultDatabaseSettings ) { @@ -420,251 +136,8 @@ getESOutcomeIds <- function( } - -getCMEstimation <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - outcomeId -){ - - if(is.null(targetId)){ - return(NULL) - } - - sql <- "select - c1.cohort_name as target, - c2.cohort_name as comparator, - c3.cohort_name as outcome, - r.target_id, r.comparator_id, r.outcome_id, r.analysis_id, - a.description, - db.cdm_source_abbreviation as database, r.calibrated_rr, - r.calibrated_ci_95_lb, r.calibrated_ci_95_ub, r.calibrated_p, - r.calibrated_log_rr, r.calibrated_se_log_rr - - from - @schema.@cm_table_prefixresult as r - inner join - @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 - - @schema.@cm_table_prefixdiagnostics_summary as unblind - on - r.analysis_id = unblind.analysis_id and - r.target_id = unblind.target_id and - r.comparator_id = unblind.comparator_id and - r.outcome_id = unblind.outcome_id and - r.database_id = unblind.database_id - - inner join - @schema.@database_table as db - on db.database_id = r.database_id - - inner join - @schema.@cg_table_prefixcohort_definition as c1 - on c1.cohort_definition_id = r.target_id - - inner join - @schema.@cg_table_prefixcohort_definition as c2 - on c2.cohort_definition_id = r.comparator_id - - inner join - @schema.@cg_table_prefixcohort_definition as c3 - on c3.cohort_definition_id = r.outcome_id - - inner join - @schema.@cm_table_prefixanalysis as a - on a.analysis_id = r.analysis_id - - where - r.calibrated_rr != 0 and - tco.outcome_of_interest = 1 and - unblind.unblind = 1 and - r.target_id = @target_id and - r.outcome_id = @outcome_id - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - database_table = resultDatabaseSettings$databaseTable, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - outcome_id = outcomeId, - target_id = targetId - ) %>% - dplyr::mutate( - calibratedP = ifelse( - .data$calibratedRr < 1, - computeTraditionalP( - logRr = .data$calibratedLogRr, - seLogRr = .data$calibratedSeLogRr, - twoSided = FALSE, - upper = TRUE - ), - .data$calibratedP / 2) - ) - - return(result) -} - -getMetaEstimation <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - outcomeId -){ - - if(is.null(targetId)){ - return(NULL) - } - - sql <- "select - c1.cohort_name as target, - c2.cohort_name as comparator, - c3.cohort_name as outcome, - r.target_id, r.comparator_id, r.outcome_id, r.analysis_id, - a.description, - ev.evidence_synthesis_description as database, - r.calibrated_rr, - r.calibrated_ci_95_lb, r.calibrated_ci_95_ub, r.calibrated_p, - r.calibrated_log_rr, r.calibrated_se_log_rr - - from - @schema.@es_table_prefixcm_result as r - inner join - @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 - - @schema.@es_table_prefixcm_diagnostics_summary as unblind - on - r.analysis_id = unblind.analysis_id and - r.target_id = unblind.target_id and - r.comparator_id = unblind.comparator_id and - r.outcome_id = unblind.outcome_id - - inner join - @schema.@cg_table_prefixcohort_definition as c1 - on c1.cohort_definition_id = r.target_id - - inner join - @schema.@cg_table_prefixcohort_definition as c2 - on c2.cohort_definition_id = r.comparator_id - - inner join - @schema.@cg_table_prefixcohort_definition as c3 - on c3.cohort_definition_id = r.outcome_id - - inner join - @schema.@cm_table_prefixanalysis as a - on a.analysis_id = r.analysis_id - - inner join - @schema.@es_table_prefixanalysis as ev - on ev.evidence_synthesis_analysis_id = r.evidence_synthesis_analysis_id - - where - r.calibrated_rr != 0 and - tco.outcome_of_interest = 1 and - unblind.unblind = 1 and - r.target_id = @target_id and - r.outcome_id = @outcome_id - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - es_table_prefix = resultDatabaseSettings$esTablePrefix, - outcome_id = outcomeId, - target_id = targetId - ) %>% - dplyr::mutate( - calibratedP = ifelse( - .data$calibratedRr < 1, - computeTraditionalP( - logRr = .data$calibratedLogRr, - seLogRr = .data$calibratedSeLogRr, - twoSided = FALSE, - upper = TRUE - ), - .data$calibratedP / 2) - ) - - 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) - ) - - data <- merge( - data, - compText, - by = "comparator" - ) - - breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8) - title <- sprintf("%s", data$outcome[1]) - plot <- ggplot2::ggplot( - data = data, - ggplot2::aes(x = .data$calibratedRr, y = .data$comparatorText)) + - ggplot2::geom_vline(xintercept = 1, size = 0.5) + - ggplot2::geom_point(color = "#000088", alpha = 0.8) + - ggplot2::geom_errorbarh( - ggplot2::aes( - xmin = .data$calibratedCi95Lb, - xmax = .data$calibratedCi95Ub - ), - height = 0.5, - color = "#000088", - alpha = 0.8 - ) + - ggplot2::scale_x_log10( - "Effect size (Hazard Ratio)", - breaks = breaks, - labels = breaks - ) + - ggplot2::coord_cartesian(xlim = c(0.1, 10)) + - ggplot2::facet_grid(.data$database ~ .data$description) + - ggplot2::ggtitle(title) + - ggplot2::theme( - axis.title.y = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - strip.text.y.right = ggplot2::element_text(angle = 0) - ) + - ggplot2::labs( - caption = paste( - apply( - X = compText, - MARGIN = 1, - FUN = function(x){paste(x,collapse = ': ', sep=':')} - ), - collapse = '; ') - ) - - return(plot) -} - - +# Function to format results +# used by both cm and sccs computeTraditionalP <- function( logRr, seLogRr, @@ -690,220 +163,8 @@ computeTraditionalP <- function( - -getSccsEstimation <- function( - connectionHandler, - resultDatabaseSettings, - targetId, - outcomeId -){ - if(is.null(targetId)){ - return(NULL) - } - - sql <- "select - c1.cohort_name as target, - c3.cohort_name as outcome, - cov.era_id as target_id, eos.outcome_id, r.analysis_id, - a.description, - cov.covariate_name as type, - db.cdm_source_abbreviation as database, - r.calibrated_rr, - r.calibrated_ci_95_lb, - r.calibrated_ci_95_ub, - r.calibrated_p, - r.calibrated_log_rr, - r.calibrated_se_log_rr - - from - @schema.@sccs_table_prefixresult as r - inner join - @schema.@sccs_table_prefixexposures_outcome_set as eos - on - r.exposures_outcome_set_id = eos.exposures_outcome_set_id - - inner join - @schema.@sccs_table_prefixcovariate as cov - on - r.covariate_id = cov.covariate_id and - r.database_id = cov.database_id and - r.analysis_id = cov.analysis_id and - r.exposures_outcome_set_id = cov.exposures_outcome_set_id - - inner join - @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 - - @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 - r.covariate_id = unblind.covariate_id and - r.database_id = unblind.database_id - - inner join - @schema.@database_table as db - on db.database_id = r.database_id - - inner join - @schema.@cg_table_prefixcohort_definition as c1 - on c1.cohort_definition_id = cov.era_id - - inner join - @schema.@cg_table_prefixcohort_definition as c3 - on c3.cohort_definition_id = eos.outcome_id - - inner join - @schema.@sccs_table_prefixanalysis as a - on a.analysis_id = r.analysis_id - - where - r.calibrated_rr != 0 and - --ex.true_effect_size != 1 and - cov.covariate_name in ('Main', 'Second dose') and - unblind.unblind = 1 and - cov.era_id = @target_id and - eos.outcome_id = @outcome_id - ;" - - result <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - database_table = resultDatabaseSettings$databaseTable, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - outcome_id = outcomeId, - target_id = targetId - ) - - sql <- "select distinct - c1.cohort_name as target, - c3.cohort_name as outcome, - cov.era_id as target_id, eos.outcome_id, r.analysis_id, - a.description, - cov.covariate_name as type, - ev.evidence_synthesis_description as database, - r.calibrated_rr, - r.calibrated_ci_95_lb, - r.calibrated_ci_95_ub, - r.calibrated_p, - r.calibrated_log_rr, - r.calibrated_se_log_rr - - from - @schema.@es_table_prefixsccs_result as r - inner join - @schema.@sccs_table_prefixexposures_outcome_set as eos - on - r.exposures_outcome_set_id = eos.exposures_outcome_set_id - - inner join - @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 - @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 - - @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 - r.covariate_id = unblind.covariate_id and - r.evidence_synthesis_analysis_id = unblind.evidence_synthesis_analysis_id - - inner join - @schema.@cg_table_prefixcohort_definition as c1 - on c1.cohort_definition_id = cov.era_id - - inner join - @schema.@cg_table_prefixcohort_definition as c3 - on c3.cohort_definition_id = eos.outcome_id - - inner join - @schema.@sccs_table_prefixanalysis as a - on a.analysis_id = r.analysis_id - - inner join - @schema.@es_table_prefixanalysis as ev - on ev.evidence_synthesis_analysis_id = r.evidence_synthesis_analysis_id - - where - r.calibrated_rr != 0 and - --ex.true_effect_size != 1 and - cov.covariate_name in ('Main', 'Second dose') and - unblind.unblind = 1 and - cov.era_id = @target_id and - eos.outcome_id = @outcome_id - ;" - - result2 <- connectionHandler$queryDb( - sql = sql, - schema = resultDatabaseSettings$schema, - es_table_prefix = resultDatabaseSettings$esTablePrefix, - sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, - cg_table_prefix = resultDatabaseSettings$cgTablePrefix, - outcome_id = outcomeId, - target_id = targetId - ) - - return(rbind(result,result2)) - -} - - -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, - ggplot2::aes(x = .data$calibratedRr, y = .data$type) - ) + - ggplot2::geom_vline(xintercept = 1, size = 0.5) + - ggplot2::geom_point(color = "#000088", alpha = 0.8) + - ggplot2::geom_errorbarh( - ggplot2::aes( - xmin = .data$calibratedCi95Lb, - xmax = .data$calibratedCi95Ub - ), - height = 0.5, - color = "#000088", - alpha = 0.8 - ) + - ggplot2::scale_x_log10( - "Effect size (Incidence Rate Ratio)", - breaks = breaks, - labels = breaks - ) + - ggplot2::coord_cartesian(xlim = c(0.1, 10)) + - ggplot2::facet_grid(.data$database ~ .data$description) + - ggplot2::ggtitle(data$outcome[1]) + - ggplot2::theme( - axis.title.y = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - strip.text.y.right = ggplot2::element_text(angle = 0) - ) - return(plot) -} - - +# Functions to get column formatting and names +# used by both cm and sccs getOACcombinations <- function( connectionHandler, resultDatabaseSettings @@ -951,61 +212,6 @@ getOACcombinations <- function( 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 @@ -1028,7 +234,7 @@ getColDefsESDiag <- function( ) ) - outcomes <- getESOutcomeIds( + outcomes <- getEsOutcomeIds( connectionHandler = connectionHandler, resultDatabaseSettings = resultDatabaseSettings ) diff --git a/R/evidence-synth-sccs.R b/R/evidence-synth-sccs.R new file mode 100644 index 00000000..791c7207 --- /dev/null +++ b/R/evidence-synth-sccs.R @@ -0,0 +1,532 @@ +evidenceSynthesisSccsViewer <- function(id=1) { + ns <- shiny::NS(id) + + shiny::div( + + inputSelectionViewer(ns("input-selection-sccs")), + + shiny::conditionalPanel( + condition = 'input.generate != 0', + ns = shiny::NS(ns("input-selection-sccs")), + + shiny::tabsetPanel( + type = 'pills', + id = ns('esSccsTabs'), + + # diagnostic view + shiny::tabPanel( + title = 'Diagnostics', + resultTableViewer(ns("diagnosticsSccsSummaryTable")) + ), + + shiny::tabPanel( + "Plot", + shiny::plotOutput(ns('esSccsPlot')) + ), + shiny::tabPanel( + "Table", + resultTableViewer(ns("esSccsTable")) + ) + ) + ) + ) +} + +evidenceSynthesisSccsServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1) +) { + shiny::moduleServer( + id, + function(input, output, session) { + + targetIds <- getSccsTargetIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + outcomeIds <- getEsOutcomeIds( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + inputSelected <- inputSelectionServer( + id = "input-selection-sccs", + inputSettingList = list( + createInputSetting( + rowNumber = 1, + columnWidth = 6, + varName = 'targetIds', + uiFunction = 'shinyWidgets::pickerInput', + uiInputs = list( + label = 'Target: ', + choices = targetIds, + multiple = F, + 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, + multiple = F, + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + liveSearch = TRUE, + size = 10, + liveSearchStyle = "contains", + liveSearchPlaceholder = "Type here to search", + virtualScroll = 50 + ) + ) + ) + ) + ) + + + + diagSumData <- shiny::reactive({ + getEvidenceSynthSccsDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + inputSelected = inputSelected, + targetIds = inputSelected()$targetIds, + outcomeIds = inputSelected()$outcomeIds + ) + }) + + # SCCS plots and tables + + resultTableServer( + id = "diagnosticsSccsSummaryTable", + df = diagSumData, + colDefsInput = getColDefsESDiag( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + ) + + sccsData <- shiny::reactive({ + unique( + getSccsEstimation( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetId = inputSelected()$targetIds, + outcomeId = inputSelected()$outcomeIds + ) + ) + }) + + output$esSccsPlot <- shiny::renderPlot({ + sccsRes <- sccsData() + shiny::validate(shiny::need(hasData(sccsRes), "No valid data for selected target")) + createPlotForSccsAnalysis(sccsRes) + }) + + + resultTableServer( + id = "esSccsTable", + df = sccsData, + colDefsInput = list( + targetId = reactable::colDef(show = F), + outcomeId = reactable::colDef(show = F), + analysisId = reactable::colDef(show = F), + description = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Analysis", + "Analysis" + ), + minWidth = 300 + ), + database = reactable::colDef( + filterable = TRUE, + header = withTooltip( + "Data source", + "Data source" + )), + calibratedRr = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.IRR", + "Incidence rate ratio (calibrated)" + )), + calibratedCi95Lb = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.LB", + "Lower bound of the 95 percent confidence interval (calibrated)" + )), + calibratedCi95Ub = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.UB", + "Upper bound of the 95 percent confidence interval (calibrated)" + )), + calibratedP = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.P", + "Two-sided p-value (calibrated)" + )), + calibratedLogRr = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.Log.IRR", + "Log of Incidence rate ratio (calibrated)" + )), + calibratedSeLogRr = reactable::colDef( + format = reactable::colFormat(digits = 3), + header = withTooltip( + "Cal.Se.Log.IRR", + "Log Standard Error of Incidence rate ratio (calibrated)" + )), + target = reactable::colDef( + minWidth = 300 + ), + outcome = reactable::colDef( + minWidth = 300 + ) + ) + ) + + } + ) + +} + + +# TODO update this for SCCS +#getSccsDiagTargets +getSccsTargetIds <- function( + connectionHandler, + resultDatabaseSettings +){ + + output <- getSccsDiagTargets( + connectionHandler, + resultDatabaseSettings + ) + return(output) + +} + +getSccsEstimation <- function( + connectionHandler, + resultDatabaseSettings, + targetId, + outcomeId +){ + if(is.null(targetId)){ + return(NULL) + } + + sql <- "select + c1.cohort_name as target, + c3.cohort_name as outcome, + cov.era_id as target_id, eos.outcome_id, r.analysis_id, + a.description, + cov.covariate_name as type, + db.cdm_source_abbreviation as database, + r.calibrated_rr, + r.calibrated_ci_95_lb, + r.calibrated_ci_95_ub, + r.calibrated_p, + r.calibrated_log_rr, + r.calibrated_se_log_rr + + from + @schema.@sccs_table_prefixresult as r + inner join + @schema.@sccs_table_prefixexposures_outcome_set as eos + on + r.exposures_outcome_set_id = eos.exposures_outcome_set_id + + inner join + @schema.@sccs_table_prefixcovariate as cov + on + r.covariate_id = cov.covariate_id and + r.database_id = cov.database_id and + r.analysis_id = cov.analysis_id and + r.exposures_outcome_set_id = cov.exposures_outcome_set_id + + inner join + @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 + + @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 + r.covariate_id = unblind.covariate_id and + r.database_id = unblind.database_id + + inner join + @schema.@database_table as db + on db.database_id = r.database_id + + inner join + @schema.@cg_table_prefixcohort_definition as c1 + on c1.cohort_definition_id = cov.era_id + + inner join + @schema.@cg_table_prefixcohort_definition as c3 + on c3.cohort_definition_id = eos.outcome_id + + inner join + @schema.@sccs_table_prefixanalysis as a + on a.analysis_id = r.analysis_id + + where + r.calibrated_rr != 0 and + --ex.true_effect_size != 1 and + cov.covariate_name in ('Main', 'Second dose') and + unblind.unblind = 1 and + cov.era_id = @target_id and + eos.outcome_id = @outcome_id + ;" + + result <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + database_table = resultDatabaseSettings$databaseTable, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + outcome_id = outcomeId, + target_id = targetId + ) + + sql <- "select distinct + c1.cohort_name as target, + c3.cohort_name as outcome, + cov.era_id as target_id, eos.outcome_id, r.analysis_id, + a.description, + cov.covariate_name as type, + ev.evidence_synthesis_description as database, + r.calibrated_rr, + r.calibrated_ci_95_lb, + r.calibrated_ci_95_ub, + r.calibrated_p, + r.calibrated_log_rr, + r.calibrated_se_log_rr + + from + @schema.@es_table_prefixsccs_result as r + inner join + @schema.@sccs_table_prefixexposures_outcome_set as eos + on + r.exposures_outcome_set_id = eos.exposures_outcome_set_id + + inner join + @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 + @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 + + @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 + r.covariate_id = unblind.covariate_id and + r.evidence_synthesis_analysis_id = unblind.evidence_synthesis_analysis_id + + inner join + @schema.@cg_table_prefixcohort_definition as c1 + on c1.cohort_definition_id = cov.era_id + + inner join + @schema.@cg_table_prefixcohort_definition as c3 + on c3.cohort_definition_id = eos.outcome_id + + inner join + @schema.@sccs_table_prefixanalysis as a + on a.analysis_id = r.analysis_id + + inner join + @schema.@es_table_prefixanalysis as ev + on ev.evidence_synthesis_analysis_id = r.evidence_synthesis_analysis_id + + where + r.calibrated_rr != 0 and + --ex.true_effect_size != 1 and + cov.covariate_name in ('Main', 'Second dose') and + unblind.unblind = 1 and + cov.era_id = @target_id and + eos.outcome_id = @outcome_id + ;" + + result2 <- connectionHandler$queryDb( + sql = sql, + schema = resultDatabaseSettings$schema, + es_table_prefix = resultDatabaseSettings$esTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, + cg_table_prefix = resultDatabaseSettings$cgTablePrefix, + outcome_id = outcomeId, + target_id = targetId + ) + + return(rbind(result,result2)) + +} + +createPlotForSccsAnalysis <- function( + data +){ + + if(is.null(data)){ + return(NULL) + } + + # change the description to add at bottom + renameDf <- data.frame( + shortName = paste0( + 1:length(unique(data$description)), + ') ', + substring(sort(unique(data$description)), 1, 15), + '...' + ), + description = sort(unique(data$description)) + ) + data <- merge( + x = data, + y = renameDf, + by = 'description' + ) + + # make sure bayesian is at bottom + db <- unique(data$database) + bInd <- grep('bayesian', tolower(db)) + withoutb <- db[-bInd] + b <- db[bInd] + data$database <- factor( + x = data$database, + levels = c(sort(withoutb), b) + ) + metadata <- data[data$database == b,] + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8) + plot <- ggplot2::ggplot( + data = data, + ggplot2::aes(x = .data$calibratedRr, y = .data$type) + ) + + ggplot2::geom_vline(xintercept = 1, size = 0.5) + + ggplot2::geom_point(color = "#000088", alpha = 0.8) + + ggplot2::geom_errorbarh( + ggplot2::aes( + xmin = .data$calibratedCi95Lb, + xmax = .data$calibratedCi95Ub + ), + height = 0.5, + color = "#000088", + alpha = 0.8 + ) + + ggplot2::scale_x_log10( + "Effect size (Incidence Rate Ratio)", + breaks = breaks, + labels = breaks + ) + + + # shade the bayesian + ggplot2::geom_rect( + data = metadata, + ggplot2::aes(fill = .data$database), + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = Inf, + alpha = 0.2 + ) + + + ggplot2::coord_cartesian(xlim = c(0.1, 10)) + + ggplot2::facet_grid(.data$database ~ .data$shortName) + + ggplot2::ggtitle(data$outcome[1]) + + ggplot2::theme( + axis.title.y = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + strip.text.y.right = ggplot2::element_text(angle = 0), + legend.position = "none" + ) + + ### Add table below the graph + renameDf$description <- sapply( + strwrap(renameDf$description, width = 50, simplify = FALSE), + paste, + collapse = "\n" + ) + + tt <- gridExtra::ttheme_default( + base_size = 8, + colhead=list(fg_params = list(parse=TRUE)) + ) + tbl <- gridExtra::tableGrob( + renameDf, + rows=NULL, + theme=tt + ) + plot <- gridExtra::grid.arrange( + plot, + tbl, + nrow = 2, + as.table = TRUE + ) + + return(plot) +} + +getEvidenceSynthSccsDiagnostics <- function( + connectionHandler, + resultDatabaseSettings, + inputSelected, + targetIds, + outcomeIds +){ + + if(is.null(targetIds)){ + return(NULL) + } + + sccsDiagTemp <- getSccsAllDiagnosticsSummary( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeIds = outcomeIds + ) + + if(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') + ) + + # return + return(sccsDiagTemp) +} diff --git a/man/characterizationAggregateFeaturesServer.Rd b/man/characterizationAggregateFeaturesServer.Rd index 97d46583..37c27cbd 100644 --- a/man/characterizationAggregateFeaturesServer.Rd +++ b/man/characterizationAggregateFeaturesServer.Rd @@ -7,7 +7,6 @@ characterizationAggregateFeaturesServer( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) } @@ -16,8 +15,6 @@ characterizationAggregateFeaturesServer( \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{ diff --git a/man/characterizationDechallengeRechallengeServer.Rd b/man/characterizationDechallengeRechallengeServer.Rd index d292b070..0dc4a02f 100644 --- a/man/characterizationDechallengeRechallengeServer.Rd +++ b/man/characterizationDechallengeRechallengeServer.Rd @@ -7,7 +7,6 @@ characterizationDechallengeRechallengeServer( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) } @@ -16,8 +15,6 @@ characterizationDechallengeRechallengeServer( \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{ diff --git a/man/characterizationIncidenceServer.Rd b/man/characterizationIncidenceServer.Rd index fdd4cf3a..42dd31cc 100644 --- a/man/characterizationIncidenceServer.Rd +++ b/man/characterizationIncidenceServer.Rd @@ -4,20 +4,13 @@ \alias{characterizationIncidenceServer} \title{The module server for exploring incidence results} \usage{ -characterizationIncidenceServer( - id, - connectionHandler, - mainPanelTab, - resultDatabaseSettings -) +characterizationIncidenceServer(id, connectionHandler, 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{ diff --git a/man/characterizationTableServer.Rd b/man/characterizationTableServer.Rd index 20d5e3f0..d92445bb 100644 --- a/man/characterizationTableServer.Rd +++ b/man/characterizationTableServer.Rd @@ -4,20 +4,13 @@ \alias{characterizationTableServer} \title{The module server for exploring 1 or more cohorts features} \usage{ -characterizationTableServer( - id, - connectionHandler, - mainPanelTab, - resultDatabaseSettings -) +characterizationTableServer(id, connectionHandler, 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{ diff --git a/man/characterizationTimeToEventServer.Rd b/man/characterizationTimeToEventServer.Rd index 42f783ef..638499bd 100644 --- a/man/characterizationTimeToEventServer.Rd +++ b/man/characterizationTimeToEventServer.Rd @@ -7,7 +7,6 @@ characterizationTimeToEventServer( id, connectionHandler, - mainPanelTab, resultDatabaseSettings ) } @@ -16,8 +15,6 @@ characterizationTimeToEventServer( \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{ diff --git a/tests/testthat/test-characterization-aggregate-features.R b/tests/testthat/test-characterization-aggregate-features.R index ed07e218..7821cc35 100644 --- a/tests/testthat/test-characterization-aggregate-features.R +++ b/tests/testthat/test-characterization-aggregate-features.R @@ -4,8 +4,7 @@ shiny::testServer( app = characterizationAggregateFeaturesServer, args = list( connectionHandler = connectionHandlerCharacterization , - resultDatabaseSettings = resultDatabaseSettingsCharacterization, - mainPanelTab = shiny::reactiveVal("Feature Comparison") + resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-characterization-cohorts.R b/tests/testthat/test-characterization-cohorts.R index e91f2457..de1b391a 100644 --- a/tests/testthat/test-characterization-cohorts.R +++ b/tests/testthat/test-characterization-cohorts.R @@ -4,7 +4,6 @@ shiny::testServer( app = characterizationTableServer, args = list( connectionHandler = connectionHandlerCharacterization, - mainPanelTab = shiny::reactiveVal("Feature Comparison"), resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-characterization-dechallengeRechallenge.R b/tests/testthat/test-characterization-dechallengeRechallenge.R index 928fdb0e..68c98ab7 100644 --- a/tests/testthat/test-characterization-dechallengeRechallenge.R +++ b/tests/testthat/test-characterization-dechallengeRechallenge.R @@ -4,7 +4,6 @@ shiny::testServer( app = characterizationDechallengeRechallengeServer, args = list( connectionHandler = connectionHandlerCharacterization, - mainPanelTab = shiny::reactiveVal("Feature Comparison"), resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-characterization-incidence.R b/tests/testthat/test-characterization-incidence.R index 7f55c944..234979b5 100644 --- a/tests/testthat/test-characterization-incidence.R +++ b/tests/testthat/test-characterization-incidence.R @@ -4,7 +4,6 @@ shiny::testServer( app = characterizationIncidenceServer, args = list( connectionHandler = connectionHandlerCharacterization, - mainPanelTab = shiny::reactiveVal("Feature Comparison"), resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-characterization-main.R b/tests/testthat/test-characterization-main.R index 5949c802..5cf9dcdd 100644 --- a/tests/testthat/test-characterization-main.R +++ b/tests/testthat/test-characterization-main.R @@ -10,8 +10,26 @@ shiny::testServer( testthat::expect_true(inherits(connectionHandler,"ConnectionHandler")) - session$setInputs(mainPanel = 'testing') - testthat::expect_true(mainPanelTab() == 'testing') + session$setInputs(mainPanel = 'Target Viewer') + testthat::expect_true(input$mainPanel == 'Target Viewer') + + testthat::expect_true(previouslyLoaded() == c('Target Viewer')) + + session$setInputs(mainPanel = 'Outcome Stratified') + testthat::expect_true(input$mainPanel == 'Outcome Stratified') + + testthat::expect_true(sum(previouslyLoaded() %in% c('Target Viewer','Outcome Stratified')) == 2) + + + session$setInputs(mainPanel = 'Incidence Rate') + testthat::expect_true(input$mainPanel == 'Incidence Rate') + + session$setInputs(mainPanel = 'Time To Event') + testthat::expect_true(input$mainPanel == 'Time To Event') + + session$setInputs(mainPanel = 'Dechallenge Rechallenge') + testthat::expect_true(input$mainPanel == 'Dechallenge Rechallenge') + }) @@ -21,3 +39,14 @@ test_that("Test characterization ui", { ui <- characterizationViewer(id = 'viewer') checkmate::expect_list(ui) }) + +test_that("getCharacterizationTypes", { + + types <- getCharacterizationTypes( + connectionHandler = connectionHandlerCharacterization, + resultDatabaseSettings = resultDatabaseSettingsCharacterization + ) + + testthat::expect_is(types, 'character') + +}) diff --git a/tests/testthat/test-characterization-timeToEvent.R b/tests/testthat/test-characterization-timeToEvent.R index 1f123a0a..340a85c1 100644 --- a/tests/testthat/test-characterization-timeToEvent.R +++ b/tests/testthat/test-characterization-timeToEvent.R @@ -4,7 +4,6 @@ shiny::testServer( app = characterizationTimeToEventServer, args = list( connectionHandler = connectionHandlerCharacterization, - mainPanelTab = shiny::reactiveVal("Feature Comparison"), resultDatabaseSettings = resultDatabaseSettingsCharacterization ), expr = { diff --git a/tests/testthat/test-evidence-synth-cm.R b/tests/testthat/test-evidence-synth-cm.R new file mode 100644 index 00000000..06fa686e --- /dev/null +++ b/tests/testthat/test-evidence-synth-cm.R @@ -0,0 +1,94 @@ +context("evidence-synth-cm") + +shiny::testServer(evidenceSynthesisCmServer, args = list( + id = "testEvidenceSynthesisCmServer", + connectionHandler = connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES +), { + + expect_true(length(targetIds) > 0) + expect_true(length(outcomeIds) > 0) + + 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') + + testthat::expect_true( nrow(unique(cmdata())) >0 ) + testthat::expect_equal(as.double(inputSelected()$outcomeId), 3) + +}) + +test_that("Test es cm ui", { + # Test ui + ui <- evidenceSynthesisCmViewer() + checkmate::expect_list(ui) + }) + + +test_that("getEsCmTargetIds", { +tarId <- getEsCmTargetIds( + connectionHandler = connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES +) + +testthat::expect_true(length(tarId) > 0 ) + +}) + +test_that("getCMEstimation", { + + res <- getCMEstimation( + connectionHandler = connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES, + targetId = 1, + outcomeId = 3 + ) + + testthat::expect_true(nrow(res)==0) # no results as calibrated rr is NA + +}) + +test_that("getMetaEstimation", { + + res <- getMetaEstimation( + connectionHandler = connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES, + targetId = 1, + outcomeId = 3 + ) + + testthat::expect_true(nrow(res)==1) + +}) + +# getEvidenceSynthCmDiagnostics ? + +test_that("createPlotForAnalysis", { + + data <- data.frame( + database = 'database 1', + description = 'test plot', + outcome = 'sdsd', + comparator = 'test', + calibratedRr = 1, + calibratedCi95Lb = 0.5, + calibratedCi95Ub = 1.5 + ) + + res <- createPlotForAnalysis(data) + testthat::expect_is(res, "ggplot") + +}) + + diff --git a/tests/testthat/test-evidence-synth-main.R b/tests/testthat/test-evidence-synth-main.R index 7867a0ca..212d963b 100644 --- a/tests/testthat/test-evidence-synth-main.R +++ b/tests/testthat/test-evidence-synth-main.R @@ -6,26 +6,8 @@ shiny::testServer(evidenceSynthesisServer, args = list( resultDatabaseSettings = resultDatabaseSettingsES ), { - expect_true(length(targetIds) > 0) - expect_true(length(outcomeIds) > 0) - - 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') - - testthat::expect_true( nrow(unique(cmdata())) >0 ) - testthat::expect_equal(as.double(inputSelected()$outcomeId), 3) + a <- 2 + testthat::expect_true(a == 2) }) @@ -36,50 +18,30 @@ test_that("Test es ui", { checkmate::expect_file_exists(evidenceSynthesisHelperFile()) }) -test_that("getCMEstimation", { +test_that("getEsOutcomeIds", { - res <- getCMEstimation( + outcomes <- getEsOutcomeIds( connectionHandler = connectionHandlerES, - resultDatabaseSettings = resultDatabaseSettingsES, - targetId = 1, - outcomeId = 3 + resultDatabaseSettings = resultDatabaseSettingsES ) + testthat::expect_true(length(outcomes)>0) - testthat::expect_true(nrow(res)==0) # no results as calibrated rr is NA - }) -test_that("getMetaEstimation", { +test_that("getColDefsESDiag", { - res <- getMetaEstimation( +colDef <- getColDefsESDiag( connectionHandler = connectionHandlerES, - resultDatabaseSettings = resultDatabaseSettingsES, - targetId = 1, - outcomeId = 3 - ) - - testthat::expect_true(nrow(res)==1) - -}) + resultDatabaseSettings = resultDatabaseSettingsES +) -test_that("createPlotForAnalysis", { - - data <- data.frame( - database = 'database 1', - description = 'test plot', - outcome = 'sdsd', - comparator = 'test', - calibratedRr = 1, - calibratedCi95Lb = 0.5, - calibratedCi95Ub = 1.5 +testthat::expect_is( + object = colDef, + class = 'list' ) - - res <- createPlotForAnalysis(data) - testthat::expect_is(res, "ggplot") }) - test_that("computeTraditionalP", { p1 <- computeTraditionalP( @@ -99,32 +61,3 @@ test_that("computeTraditionalP", { testthat::expect_true(p2 < p1) }) - -test_that("getSccsEstimation", { - -res <- getSccsEstimation( - connectionHandlerES, - resultDatabaseSettings = resultDatabaseSettingsES, - targetId = 1, - outcomeId = 3 -) - testthat::expect_equal(nrow(res), 0) - -}) - -test_that("createPlotForSccsAnalysis", { - - data <- data.frame( - calibratedRr = 1, - calibratedCi95Lb = 0.8, - calibratedCi95Ub = 1.2, - type = 'test', - database = 'database 1', - description = 'test', - outcome = 'outcome 1' - ) - - res <- createPlotForSccsAnalysis(data) - testthat::expect_is(res, 'ggplot') - -}) diff --git a/tests/testthat/test-evidence-synth-sccs.R b/tests/testthat/test-evidence-synth-sccs.R new file mode 100644 index 00000000..10bc295d --- /dev/null +++ b/tests/testthat/test-evidence-synth-sccs.R @@ -0,0 +1,76 @@ +context("evidence-synth-sccs") + +shiny::testServer(evidenceSynthesisSccsServer, args = list( + id = "testEvidenceSynthesisSccsServer", + connectionHandler = connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES +), { + + expect_true(length(targetIds) > 0) + expect_true(length(outcomeIds) > 0) + + inputSelected( + list( + targetId = targetIds[1], + targetIds = targetIds[1], + target = 'test target', + outcome = 'test outcome', + outcomeId = 3, + outcomeIds = 3 + ) + ) + + #testthat::expect_is(output$esSccsPlot, 'list') + + testthat::expect_is( sccsData(), 'data.frame') + testthat::expect_equal(as.double(inputSelected()$outcomeId), 3) + +}) + +test_that("Test es ui", { + # Test ui + ui <- evidenceSynthesisSccsViewer() + checkmate::expect_list(ui) +}) + +test_that("getSccsEstimation", { + tarIds <- getSccsTargetIds( + connectionHandler = connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES + ) + + testthat::expect_true( length(tarIds) > 0 ) + +}) + +test_that("getSccsEstimation", { + +res <- getSccsEstimation( + connectionHandlerES, + resultDatabaseSettings = resultDatabaseSettingsES, + targetId = 1, + outcomeId = 3 +) + testthat::expect_equal(nrow(res), 0) + +}) + +test_that("createPlotForSccsAnalysis", { + + data <- data.frame( + calibratedRr = 1, + calibratedCi95Lb = 0.8, + calibratedCi95Ub = 1.2, + type = 'test', + database = 'database 1', + description = 'test', + outcome = 'outcome 1' + ) + + res <- createPlotForSccsAnalysis(data) + testthat::expect_is(res, 'gtable') + +}) + +# getEvidenceSynthSccsDiagnostics ? +