diff --git a/NAMESPACE b/NAMESPACE index 37b82f11..1fba30b5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -65,6 +65,9 @@ export(databaseInformationView) export(datasourcesHelperFile) export(datasourcesServer) export(datasourcesViewer) +export(estimationHelperFile) +export(estimationServer) +export(estimationViewer) export(evidenceSynthesisHelperFile) export(evidenceSynthesisServer) export(evidenceSynthesisViewer) diff --git a/R/components-helpInfo.R b/R/components-helpInfo.R index eae6f807..77f46a3c 100644 --- a/R/components-helpInfo.R +++ b/R/components-helpInfo.R @@ -6,7 +6,7 @@ infoHelperViewer <- function( shinydashboard::box( collapsible = TRUE, - collapsed = FALSE, + collapsed = TRUE, title = shiny::span( shiny::icon("circle-question"), "Help & Information"), width = "100%", shiny::htmlTemplate(helpLocation) diff --git a/R/estimation-cm-diagnostics.R b/R/estimation-cm-diagnostics.R new file mode 100644 index 00000000..c623f314 --- /dev/null +++ b/R/estimation-cm-diagnostics.R @@ -0,0 +1,263 @@ +estimationCmDiagnosticViewer <- function(id=1) { + ns <- shiny::NS(id) + + resultTableViewer(ns("cmDiagnosticsTable")) + +} + + +estimationCmDiagnosticServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + targetIds, + comparatorIds, + outcomeId +) { + shiny::moduleServer( + id, + function(input, output, session) { + + + + cmDiagnostics <- shiny::reactive({ + estimationGetCmDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeId = outcomeId + ) + }) + + resultTableServer( + id = "cmDiagnosticsTable", + df = cmDiagnostics, + colDefsInput = estimationGetCmDiagnosticColDefs(), + selectedCols = c( + 'databaseName', + 'analysis', + 'target', + 'comparator', + 'summaryValue' + ) + ) + + + } + ) +} + + +estimationGetCmDiagnostics <- function( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeId = outcomeId +){ + targetIds <- targetIds() + comparatorIds <- comparatorIds() + outcomeId <- outcomeId() + + 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.ease, + cmds.balance_diagnostic, + cmds.shared_balance_diagnostic, -- added back + cmds.equipoise_diagnostic, + cmds.mdrr_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(outcomeId, collapse = ','), + + use_comparators = T, + use_analyses = F + ) + + # 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') + } + } + ) + + # add summaryValue after outcome + result <- result %>% + dplyr::relocate(.data$summaryValue, .after = .data$outcome) + + return( + result + ) + +} + + +estimationGetCmDiagnosticColDefs <- function(){ + result <- 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" + ), + outcome = reactable::colDef( + show = F + ), + summaryValue = reactable::colDef( + header = withTooltip( + "Diagnostic", + "The overall result of the diagostics" + ), + 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) + } + ), + 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 expected absolute systematic error" + ), + format = reactable::colFormat(digits = 4) + ), + maxSdm = reactable::colDef( + header = withTooltip( + "Max SDM", + "The maximum absolute standardized difference of mean" + ), + format = reactable::colFormat(digits = 4) + ), + sharedMaxSdm = reactable::colDef( + header = withTooltip( + "Shared Max SDM", + "The maximum absolute standardized difference of mean of the shared balance (shared across outcomes)" + ), + format = reactable::colFormat(digits = 4) + ), + equipoise = reactable::colDef( + header = withTooltip( + "Equipoise", + "The fraction of the study population with a preference score between 0.3 and 0.7" + ), + format = reactable::colFormat(digits = 4) + ), + balanceDiagnostic = reactable::colDef( + header = withTooltip( + "Balance Diagnostic", + "Pass / warning / fail classification of the balance diagnostic (Max SDM)" + ) + ), + mdrrDiagnostic = reactable::colDef( + header = withTooltip( + "MDRR Diagnostic", + "Pass / warning / fail classification of the MDRR diagnostic" + ) + ), + sharedBalanceDiagnostic = reactable::colDef( + header = withTooltip( + "Shared Balance Diagnostic", + "Pass / warning / fail classification of the shared balance diagnostic (Shared Max SDM)" + ) + ), + easeDiagnostic = reactable::colDef( + header = withTooltip( + "Ease Diagnostic", + "Pass / warning / fail classification of the EASE diagnostic" + ) + ), + equipoiseDiagnostic = reactable::colDef( + header = withTooltip( + "Equipoise Diagnostic", + "Pass / warning / fail classification of the equipoise diagnostic" + ) + ), + + unblind = reactable::colDef( + header = withTooltip( + "Unblind", + "If the value is 1 then the diagnostics passed and results can be unblinded" + ) + ) + ) + + return(result) +} \ No newline at end of file diff --git a/R/estimation-cohort-method-full-result.R b/R/estimation-cohort-method-full-result.R new file mode 100644 index 00000000..76987d5c --- /dev/null +++ b/R/estimation-cohort-method-full-result.R @@ -0,0 +1,163 @@ +estimationCmFullResultViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + # add selected settings + + inputSelectionDfViewer( + id = ns("input-selection-df"), + title = 'Result Selected: ' + ), + + 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")) + ) + ) + ) + +} + +estimationCmFullResultServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + selectedRow, + actionCount +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + # reset the tab when a new result is selected + shiny::observeEvent(actionCount(), { + shiny::updateTabsetPanel(session, "fullTabsetPanel", selected = "Power") + }) + + modifiedRow <- shiny::reactive({ + selectedRow() %>% + dplyr::select( + "target", + "comparator", + "outcome", + "description", + "cdmSourceAbbreviation" + ) %>% + dplyr::rename( + 'Target' = .data$target, + 'Comparator' = .data$comparator, + 'Outcome' = .data$outcome, + 'Analysis' = .data$description, + 'Database' = .data$cdmSourceAbbreviation + ) + }) + + inputSelectionDfServer( + id = "input-selection-df", + dataFrameRow = modifiedRow, + ncol = 2 + ) + + 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 + ) + + } + ) +} diff --git a/R/estimation-cohort-method-plots.R b/R/estimation-cohort-method-plots.R new file mode 100644 index 00000000..0caa8684 --- /dev/null +++ b/R/estimation-cohort-method-plots.R @@ -0,0 +1,116 @@ +estimationCmPlotsViewer <- function(id=1) { + ns <- shiny::NS(id) + shiny::plotOutput(ns('esCohortMethodPlot')) +} + + +estimationCmPlotsServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + cmData +) { + shiny::moduleServer( + id, + function(input, output, session) { + + output$esCohortMethodPlot <- shiny::renderPlot( + estimationCreateCmPlot( + data = cmData + ) + ) + + } + ) +} + +estimationCreateCmPlot <- function(data) { + print('PLOT') + data <- data() + data <- data[!is.na(data$calibratedRr),] + data$database <- data$cdmSourceAbbreviation + + print(data) + if(is.null(data$comparator)){ + return(NULL) + } + + + # TODO create plot for each target + + 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 top + db <- unique(data$database) + bInd <- grep('bayesian', tolower(db)) + withoutb <- db[-bInd] + b <- db[bInd] + data$database <- factor( + x = data$database, + levels = c(b, sort(withoutb)) + ) + metadata <- data[data$database == b,] + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8) + title <- sprintf("%s", data$target[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/estimation-cohort-method-results.R b/R/estimation-cohort-method-results.R new file mode 100644 index 00000000..43cd8bc9 --- /dev/null +++ b/R/estimation-cohort-method-results.R @@ -0,0 +1,470 @@ +# @file cohort-method-resultSummary +# +# Copyright 2024 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. + + +estimationCmResultsViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::tabsetPanel( + type = 'hidden', + id = ns('resultPanel'), + + shiny::tabPanel( + title = "Table", + 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" + ), + estimationCmFullResultViewer(ns("cmFullResults")) + ) + + ) + + +} + + +estimationCmResultsServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + targetIds, + comparatorIds, + outcomeId +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + shiny::observeEvent( + eventExpr = input$goBackCmResults, + { + shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") + }) + + # extract results from CM tables + cmData <- shiny::reactive({ + estimationGetCmResultData( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeId = outcomeId + ) + }) + + # extract results from ES tables if tables exist + esData <- shiny::reactive({ + tryCatch( + { + estimationGetCMMetaEstimation( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId + ) + }, error = function(e){print('CM ES error');return(NULL)} + ) + }) + + data <- shiny::reactive({ + rbind(cmData(), esData()) + }) + + resultTableOutputs <- resultTableServer( + id = "resultSummaryTable", + df = data, + colDefsInput = estimationGetCmResultSummaryTableColDef(), + addActions = c('results') # TODO wont work for esData + ) + + selectedRow <- shiny::reactiveVal(value = NULL) + shiny::observeEvent(resultTableOutputs$actionCount(), { + if(resultTableOutputs$actionType() == 'results'){ # add an and here to only work for cmData + selectedRow(data()[resultTableOutputs$actionIndex()$index,]) + shiny::updateTabsetPanel(session, "resultPanel", selected = "Results") + } + }) + + estimationCmFullResultServer( + id = "cmFullResults", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow, + actionCount = resultTableOutputs$actionCount + ) + + + return(data) + + } + ) +} + + +estimationGetCmResultSummaryTableColDef <- 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 estimated relative risk (e.g. the hazard ratio)" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + ci95Lb = reactable::colDef( + header = withTooltip( + "Lower 95% CI", + "The lower bound of the 95% confidence internval of the uncalibrated relative risk" + ), + format = reactable::colFormat(digits = 4), + na = "-" + ), + + ci95Ub = reactable::colDef( + header = withTooltip( + "Upper 95% CI", + "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-val", + "The two-sided 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 Lower 95% CI", + "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 Upper 95% CI", + "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-val", + "The two-sided 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) +} + +estimationGetCmResultData <- function( + connectionHandler, + resultDatabaseSettings, + targetIds, + comparatorIds, + outcomeId, + runEvidenceSynthesis = F +) { + + targetIds = targetIds() + comparatorIds = comparatorIds() + outcomeId = outcomeId() + + if(is.null(comparatorIds) || is.null(targetIds) || is.null(outcomeId) ){ + 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) + ; + " + + 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(outcomeId, collapse = ','), + use_comparators = !is.null(comparatorIds), + ) + + return( + result + ) +} + + +estimationGetCMMetaEstimation <- function( + connectionHandler, + resultDatabaseSettings, + targetIds, + outcomeId +){ + targetIds <- targetIds() + outcomeId <- outcomeId() + + sql <- "select + r.analysis_id, + a.description, + 0 as database_id, + ev.evidence_synthesis_description as cdm_source_abbreviation, + r.target_id, + c1.cohort_name as target, + r.outcome_id, + c3.cohort_name as outcome, + r.comparator_id, + c2.cohort_name as comparator, + NULL as rr, + NULL as ci_95_lb, + NULL as ci_95_ub, + NULL as p, + NULL as log_rr, + NULL as se_log_rr, + 0 as target_subjects, + 0 as comparator_subjects, + 0 as target_days, + 0 as comparator_days, + 0 as target_outcomes, + 0 as comparator_outcomes, + 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, + 1 unblind + + 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 in (@target_ids) 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_ids = paste0(targetIds, collapse = ',') + ) %>% + dplyr::mutate( + calibratedP = ifelse( + .data$calibratedRr < 1, + computeTraditionalP( + logRr = .data$calibratedLogRr, + seLogRr = .data$calibratedSeLogRr, + twoSided = FALSE, + upper = TRUE + ), + .data$calibratedP / 2) + ) + + return(unique(result)) +} diff --git a/R/estimation-main.R b/R/estimation-main.R new file mode 100644 index 00000000..1eaac499 --- /dev/null +++ b/R/estimation-main.R @@ -0,0 +1,383 @@ +# @file Estimation-main.R +# +# Copyright 2024 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 estimation module helper file +#' +#' @details +#' Returns the location of the characterization helper file +#' +#' @return +#' string location of the characterization helper file +#' +#' @export +estimationHelperFile <- function(){ + fileLoc <- system.file('estimation-www', "estimation.html", package = "OhdsiShinyModules") + return(fileLoc) +} + +#' The module viewer for exploring characterization studies +#' +#' @details +#' The user specifies the id for the module +#' +#' @param id the unique reference id for the module +#' +#' @return +#' The user interface to the characterization viewer module +#' +#' @export +estimationViewer <- function(id=1) { + ns <- shiny::NS(id) + + shinydashboard::box( + status = 'info', + width = '100%', + title = shiny::span( shiny::icon("table"), "Estimation Viewer"), + solidHeader = TRUE, + + # pick a targetId of interest + shiny::uiOutput(ns("targetSelection")), + + inputSelectionDfViewer(id = ns('targetSelected'), title = 'Selected'), + + + # first show diagnostics with: + # database, analysis, pass/fail, viewResult/viewDiagnostic + # extracts from SCCS/CM/Evidence Synthesis + + conditionalPanel( + condition = 'input.targetSelect', + ns = ns, + + shiny::tabsetPanel( + type = 'pills', + id = ns('mainPanel'), + + shiny::tabPanel( + title = 'Diagnostics', + shiny::tabsetPanel( + type = 'pills', + id = ns('diagnosticsPanel') + ) + ), + + shiny::tabPanel( + title = 'Results', + shiny::tabsetPanel( + type = 'pills', + id = ns('resultsPanel') + ) + ), + ) + ) # end conditional panel + + ) + +} + + +#' The module server for exploring estimation 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 characterization result schema, dbms, tablePrefix, databaseTable and cgTablePrefix +#' +#' @return +#' The server for the estimation module +#' +#' @export +estimationServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1) +) { + 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 + estimationTypes <- getEstimationTypes( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings + ) + + # add the tabs based on results + types <- list( + c("Cohort Method","estimationCmDiagnosticViewer", "estimationCmDiagnostic", "diagnosticsPanel", "Cohort Method"), + c("SCCS", "estimationSccsDiagnosticViewer", "estimationSccsDiagnostic", "diagnosticsPanel", "SCCS"), + c("Cohort Method", "estimationCmResultsViewer", "estimationCmResults", "resultsPanel", "Cohort Method Table"), + c("Cohort Method", "estimationCmPlotsViewer", "estimationCmPlots", "resultsPanel", "Cohort Method Plot"), + c("SCCS", "estimationSccsResultsViewer", "estimationSccsResults", "resultsPanel", "SCCS Table") + ) + selectValD <- T + selectValR <- T + for( type in types){ + if(type[1] %in% estimationTypes){ + shiny::insertTab( + inputId = type[4], + tab = shiny::tabPanel( + title = type[5], + do.call(what = type[2], args = list(id = session$ns(type[3]))) + ), + select = ifelse(type[4] == "diagnosticsPanel", selectValD, selectValR) + ) + if(type[4] == "diagnosticsPanel"){ + selectValD = F + } else{ + selectValR = F + } + } + + } + + + + # use the function in report-main to get parent Ts with all children Ts, the outcomes for the Ts and the Cs + options <- OhdsiShinyModules:::getTandOs( + connectionHandler, + resultDatabaseSettings, + includeCharacterization = F, + includeCohortIncidence = F, + includeCohortMethod = T, + includePrediction = F, + includeSccs = F # slow so turning off + ) + + # Targets + targets <- lapply(options$groupedTs, function(x) x$cohortId) + targets <- unlist(targets) + + # initial outcomes for first T + outcomeDf <- options$tos[[1]] + initialOutcomes <- outcomeDf$outcomeId + names(initialOutcomes ) <- outcomeDf$outcomeName + outcomes <- shiny::reactiveVal() + + shiny::observeEvent(input$targetId,{ + + outcomes(unique( + do.call( + 'rbind', + lapply( + options$groupedTs[[which(targets == input$targetId)]]$subsets$targetId, + function(id){ + if(id %in% names(options$tos)){ + return(options$tos[[which(id == names(options$tos))]]) + } else{ + return(NULL) + } + } + ) + ) + )) + + + if(length(options()$outcomeId)>0){ + outcomeDf <- options() + outcomesVector <- options()$outcomeId + names(outcomesVector) <- options()$outcomeName + + shiny::updateSelectInput( + session = session, + inputId = 'outcomeId', + label = 'Outcome: ', + choices = outcomesVector, + selected = outcomesVector[1] + ) + } + }) + + output$targetSelection <- shiny::renderUI({ + shiny::fluidRow( + shiny::div( + shiny::selectInput( + inputId = session$ns('targetId'), + label = 'Target: ', + choices = targets, + selected = 1, + multiple = FALSE, + selectize = TRUE, + width = NULL, + size = NULL + ), + shiny::selectInput( + inputId = session$ns('outcomeId'), + label = 'Outcome: ', + choices = initialOutcomes, + selected = initialOutcomes[1], + multiple = FALSE, + selectize = TRUE, + width = NULL, + size = NULL + ), + style = 'margin-left: 2%; width: 78%; display: inline-block; vertical-align: middle;' + ), + div( + shiny::actionButton( + inputId = session$ns('targetSelect'), + label = 'Select', + icon = shiny::icon('redo') + ), + style = 'display: inline-block; vertical-align: bottom; margin-bottom: 20px' + ) + ) + }) + + + targetSelected <- shiny::reactiveVal() + comparatorIds <- shiny::reactiveVal() + targetIds <- shiny::reactiveVal() + outcomeId <- shiny::reactiveVal() + + shiny::observeEvent(input$targetSelect, { + + targetSelected( + data.frame( + Target = names(targets)[targets == input$targetId], + Outcome = outcomes()$outcomeName[outcomes()$outcomeId == input$outcomeId] + ) + ) + inputSelectionDfServer( + id = 'targetSelected', + dataFrameRow = targetSelected, + ncol = 1 + ) + + #======================================== + # code to update diagnostics database + #======================================== + # get all the ids that are children of the id selected + targetIdsTemp <- options$groupedTs[[which(targets == input$targetId)]]$subsets$targetId + + comparators <- do.call( + 'rbind', + lapply( + options$groupedTs[[which(targets == input$targetId)]]$subsets$targetId, + function(id){ + if(id %in% names(options$cs)){ + return(options$cs[[which(id == names(options$cs))]]) + } else{ + return(NULL) + } + } + ) + ) + targetIds(targetIdsTemp) + comparatorIds(comparators$comparatorId) + outcomeId(input$outcomeId) + }) + + #======================================= + # SERVERS + #======================================= + estimationCmDiagnosticServer( + id = 'estimationCmDiagnostic', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeId = outcomeId + ) + + cmData <- estimationCmResultsServer( + id = 'estimationCmResults', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeId = outcomeId + ) + + estimationCmPlotsServer( + id = 'estimationCmPlots', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + cmData = cmData + ) + + estimationSccsDiagnosticServer( + id = 'estimationSccsDiagnostic', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId + ) + + estimationSccsResultsServer( + id = 'estimationSccsResults', + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId + ) + + } + ) +} + + + + +getEstimationTypes <- function( + connectionHandler, + resultDatabaseSettings +){ + + results <- c() + + conn <- DatabaseConnector::connect( + connectionDetails = connectionHandler$connectionDetails + ) + on.exit(DatabaseConnector::disconnect(conn)) + tbls <- DatabaseConnector::getTableNames( + connection = conn, + databaseSchema = resultDatabaseSettings$schema + ) + + # Cohort Method + if(paste0( + resultDatabaseSettings$cmTablePrefix, + c('result') + ) %in% tbls){ + results <- c(results, "Cohort Method") + } + + # SCCS + if(paste0( + resultDatabaseSettings$sccsTablePrefix, + 'result' + ) %in% tbls){ + results <- c(results, "SCCS") + } + + # Evidence Synthesis + if(paste0( + resultDatabaseSettings$esTablePrefix, + 'result' + ) %in% tbls){ + results <- c(results, "Evidence Synthesis") + } + + return(results) +} diff --git a/R/estimation-sccs-diagnostics.R b/R/estimation-sccs-diagnostics.R new file mode 100644 index 00000000..cbe13b52 --- /dev/null +++ b/R/estimation-sccs-diagnostics.R @@ -0,0 +1,255 @@ +estimationSccsDiagnosticViewer <- function(id=1) { + ns <- shiny::NS(id) + resultTableViewer(ns("sccsDiagnosticsTable")) +} + + +estimationSccsDiagnosticServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + targetIds, + outcomeId +) { + shiny::moduleServer( + id, + function(input, output, session) { + + + + sccsDiagnostics <- shiny::reactive({ + estimationGetSccsDiagnostics( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId + ) + }) + + resultTableServer( + id = "sccsDiagnosticsTable", + df = sccsDiagnostics, + colDefsInput = estimationGetSccsDiagnosticColDefs(), + selectedCols = c( + 'databaseName', + 'analysis', + 'target', + 'indication', + 'summaryValue' + ) + ) + + + } + ) +} + + +estimationGetSccsDiagnostics <- function( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + targetIds = targetIds, + outcomeId = outcomeId +){ + targetIds <- targetIds() + outcomeId <- outcomeId() + + sql <- " + SELECT + d.cdm_source_abbreviation as database_name, + a.description as analysis, + c2.cohort_name as target, + c3.cohort_name as indication, + c.cohort_name as outcome, + 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 + + left join + @schema.@cg_table_prefixcohort_definition as c3 + on eos.nesting_cohort_id = c3.cohort_definition_id + + where + + cov.era_id in (@target_ids) + and eos.outcome_id in (@outcome_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(outcomeId, collapse = ','), + 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') + } + } + ) + + # add summaryValue after outcome + result <- result %>% + dplyr::relocate(.data$summaryValue, .after = .data$outcome) + + return( + result + ) + +} + + + + + +estimationGetSccsDiagnosticColDefs <- function(){ + result <- 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 " + ) + ), + summaryValue = reactable::colDef( + header = withTooltip( + "Diagnostic", + "The overall result of the diagostics" + ), + 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) + } + ), + 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" + ) + ) + ) + + return(result) +} \ No newline at end of file diff --git a/R/estimation-sccs-results-full.R b/R/estimation-sccs-results-full.R new file mode 100644 index 00000000..73eca306 --- /dev/null +++ b/R/estimation-sccs-results-full.R @@ -0,0 +1,427 @@ +estimationSccsFullResultViewer <- function(id) { + ns <- shiny::NS(id) + + shiny::div( + + # add selection module + inputSelectionDfViewer( + id = ns("input-selection-df"), + title = 'Result Selected' + ), + + 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)."), + resultTableViewer(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."), + "The ratio of observed to expected outcomes per month. The expected count is computing either assuming a constant rate (bottom plot) or adjusting for calendar time, seasonality, and / or age, as specified in the model (top plot)." + ) + ), + 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.") + ) + ) + + ) + +} + + +estimationSccsFullResultServer <- function( + id, + connectionHandler, + resultDatabaseSettings, + selectedRow, + actionCount +) { + + shiny::moduleServer( + id, + function(input, output, session) { + + # reset the tab when a new result is selected + shiny::observeEvent(actionCount(), { + shiny::updateTabsetPanel(session, "fullTabsetPanel", selected = "Power") + }) + + modifiedRow <- shiny::reactive({ + selectedRow() %>% + dplyr::select( + "covariateName", + "outcome", + "description", + "databaseName" + ) %>% + dplyr::rename( + 'Outcome' = .data$outcome, + 'Analysis' = .data$description, + 'Database' = .data$databaseName + ) + }) + + inputSelectionDfServer( + id = "input-selection-df", + dataFrameRow = modifiedRow, + ncol = 2 + ) + + powerTable <- shiny::reactive({ + 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) + + return(resTargetTable) + } + }) + + colDefsInput <- list( + covariateName = reactable::colDef( + header = withTooltip( + "Variable", + "The covariate" + )), + outcomeSubjects = reactable::colDef( + header = withTooltip( + "Cases", + "The number of cases" + )), + observedDays = reactable::colDef( + format = reactable::colFormat(digits = 2), + header = withTooltip( + "Years observed", + "The total years observed" + )), + outcomeEvents = reactable::colDef( + header = withTooltip( + "Outcomes", + "The total number of outcomes" + )), + covariateSubjects = reactable::colDef( + header = withTooltip( + "Persons exposed", + "The total number of people exposed" + )), + covariateDays = reactable::colDef( + format = reactable::colFormat(digits = 2), + header = withTooltip( + "Years exposed", + "The total number of years exposed" + )), + covariateOutcomes = reactable::colDef( + header = withTooltip( + "Outcomes while exposed", + "The total number of outcomes while exposed" + )), + mdrr = reactable::colDef( + format = reactable::colFormat(digits = 4), + header = withTooltip( + "MDRR", + "The minimal detectable relative risk" + )) + ) + + # move these to a different submodule? + resultTableServer( + id = "powerTable", # how is this working without session$ns + df = powerTable, + colDefsInput = colDefsInput + ) + + 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 + ) + + if (all(c(hasData(timeTrend$ratio), hasData(timeTrend$adjustedRatio)))) { + plotTimeTrend(timeTrend) + } else { + plotTimeTrendStability(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 = resultDatabaseSettings, + covariateId = row$covariateId, + databaseId = row$databaseId, + analysisId = row$analysisId + ) + plotControlEstimates(controlEstimates) + } + }) + + } + ) +} + + + + + + diff --git a/R/estimation-sccs-results.R b/R/estimation-sccs-results.R new file mode 100644 index 00000000..31192317 --- /dev/null +++ b/R/estimation-sccs-results.R @@ -0,0 +1,318 @@ +estimationSccsResultsViewer <- function(id = "sccs-results") { + ns <- shiny::NS(id) + + shiny::tabsetPanel( + type = 'hidden', + id = ns('resultPanel'), + + shiny::tabPanel( + title = "Table", + resultTableViewer(ns("resultSummaryTable")) + ), + + shiny::tabPanel( + title = "Results", + shiny::actionButton( + inputId = ns('goBackSccsResults'), + label = "Back To Result Summary", + shiny::icon("arrow-left"), + style="color: #fff; background-color: #337ab7; border-color: #2e6da4" + ), + estimationSccsFullResultViewer(ns("sccsFullResults")) + ) + + ) + + + +} + + +estimationSccsResultsServer <- function( + id, + connectionHandler, + resultDatabaseSettings = list(port = 1), + targetIds, + outcomeId +) { + ns <- shiny::NS(id) + + shiny::moduleServer(id, function(input, output, session) { + + shiny::observeEvent( + eventExpr = input$goBackSccsResults, + { + shiny::updateTabsetPanel(session, "resultPanel", selected = "Table") + } + ) + + data <- shiny::reactive({ + estimationGetSccsResults( + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + exposureIds = targetIds, + outcomeIds = outcomeId + ) + }) + + # add evidence synth if exists + + resultTableOutputs <- resultTableServer( + id = "resultSummaryTable", + df = data, + colDefsInput = estimationGetSccsResultSummaryTableColDef(), + 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") + } + }) + + estimationSccsFullResultServer( + id = "sccsFullResults", + connectionHandler = connectionHandler, + resultDatabaseSettings = resultDatabaseSettings, + selectedRow = selectedRow, + actionCount = resultTableOutputs$actionCount + ) + + # return data for plot server + + } + ) +} + + +estimationGetSccsResultSummaryTableColDef <- 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) +} + +estimationGetSccsResults <- function(connectionHandler, + resultDatabaseSettings, + exposureIds, + outcomeIds + ) { + exposureIds <- exposureIds() + outcomeIds <- outcomeIds() + print('SCCS main') + print(exposureIds) + print(outcomeIds ) + + 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 + 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, + outcome_ids = paste(outcomeIds, collapse = ','), + exposure_ids = paste(exposureIds, collapse = ','), + snakeCaseToCamelCase = TRUE + ) + + return(results) +} + + diff --git a/R/report-main.R b/R/report-main.R index 6e09d227..fc63cb2a 100644 --- a/R/report-main.R +++ b/R/report-main.R @@ -733,7 +733,12 @@ reportServer <- function( getTandOs <- function( connectionHandler, - resultDatabaseSettings + resultDatabaseSettings, + includeCharacterization = T, + includeCohortIncidence = T, + includeCohortMethod = T, + includePrediction = T, + includeSccs = T ){ # get cohorts @@ -744,38 +749,68 @@ getTandOs <- function( cg_table_prefix = resultDatabaseSettings$cgTablePrefix ) - characterization <- tryCatch( - {nrow(connectionHandler$queryDb( - 'select * from @schema.@c_table_prefixcohort_details limit 1;', - schema = resultDatabaseSettings$schema, - c_table_prefix = resultDatabaseSettings$cTablePrefix - ))>=0}, - error = function(e){return(F)} - ) - cohortIncidence <- tryCatch( - {nrow(connectionHandler$queryDb( - 'select * from @schema.@ci_table_prefixincidence_summary limit 1;', - schema = resultDatabaseSettings$schema, - ci_table_prefix = resultDatabaseSettings$incidenceTablePrefix - ))>=0}, - error = function(e){return(F)} - ) - cohortMethod <- tryCatch( - {nrow(connectionHandler$queryDb( - 'select * from @schema.@cm_table_prefixtarget_comparator_outcome limit 1;', - schema = resultDatabaseSettings$schema, - cm_table_prefix = resultDatabaseSettings$cmTablePrefix - ))>=0}, - error = function(e){return(F)} - ) - prediction <- tryCatch( - {nrow(connectionHandler$queryDb( - 'select * from @schema.@plp_table_prefixmodel_designs limit 1;', - schema = resultDatabaseSettings$schema, - plp_table_prefix = resultDatabaseSettings$plpTablePrefix - ))>=0}, - error = function(e){return(F)} - ) + if(includeCharacterization){ + characterization <- tryCatch( + {nrow(connectionHandler$queryDb( + 'select * from @schema.@c_table_prefixcohort_details limit 1;', + schema = resultDatabaseSettings$schema, + c_table_prefix = resultDatabaseSettings$cTablePrefix + ))>=0}, + error = function(e){return(F)} + ) + } else{ + characterization <- F + } + + if(includeCohortIncidence){ + cohortIncidence <- tryCatch( + {nrow(connectionHandler$queryDb( + 'select * from @schema.@ci_table_prefixincidence_summary limit 1;', + schema = resultDatabaseSettings$schema, + ci_table_prefix = resultDatabaseSettings$incidenceTablePrefix + ))>=0}, + error = function(e){return(F)} + ) + } else{ + cohortIncidence <- F + } + + if(includeCohortMethod){ + cohortMethod <- tryCatch( + {nrow(connectionHandler$queryDb( + 'select * from @schema.@cm_table_prefixtarget_comparator_outcome limit 1;', + schema = resultDatabaseSettings$schema, + cm_table_prefix = resultDatabaseSettings$cmTablePrefix + ))>=0}, + error = function(e){return(F)} + ) + } else{ + cohortMethod <- F + } + + if(includePrediction){ + prediction <- tryCatch( + {nrow(connectionHandler$queryDb( + 'select * from @schema.@plp_table_prefixmodel_designs limit 1;', + schema = resultDatabaseSettings$schema, + plp_table_prefix = resultDatabaseSettings$plpTablePrefix + ))>=0}, + error = function(e){return(F)} + )} else{ + prediction <- F + } + + if(includeSccs){ + sccs <- tryCatch( + {nrow(connectionHandler$queryDb( + 'select * from @schema.@sccs_table_prefixexposures_outcome_set limit 1;', + schema = resultDatabaseSettings$schema, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix + ))>=0}, + error = function(e){return(F)} + )} else{ + sccs <- F + } # get T and O pairs sql <- "select distinct tid, oid from @@ -790,14 +825,14 @@ getTandOs <- function( } {@cohort_incidence} ? { - union + {@characterization}?{union} select distinct TARGET_COHORT_DEFINITION_ID as tid, OUTCOME_COHORT_DEFINITION_ID as oid from @schema.@ci_table_prefixincidence_summary } {@cohort_method} ? { - union + {@cohort_incidence | @characterization}?{union} select distinct TARGET_ID as tid, OUTCOME_ID as oid from @schema.@cm_table_prefixtarget_comparator_outcome where OUTCOME_OF_INTEREST = 1 @@ -805,7 +840,8 @@ getTandOs <- function( } {@prediction} ? { - union + {@cohort_method | @cohort_incidence | @characterization}?{union} + select distinct c1.cohort_definition_id as tid, c2.cohort_definition_id as oid from @schema.@plp_table_prefixmodel_designs md inner join @schema.@plp_table_prefixcohorts c1 @@ -814,6 +850,28 @@ getTandOs <- function( on c2.cohort_id = md.outcome_id } + {@sccs} ? { + {@cohort_method | @cohort_incidence | @characterization | @prediction}?{union} + + SELECT distinct + cov.era_id as tid, + eos.outcome_id as oid + + 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.@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 + + } + ) temp_t_o ;" @@ -824,10 +882,12 @@ getTandOs <- function( ci_table_prefix = resultDatabaseSettings$incidenceTablePrefix, cm_table_prefix = resultDatabaseSettings$cmTablePrefix, plp_table_prefix = resultDatabaseSettings$plpTablePrefix, + sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix, characterization = characterization, cohort_incidence = cohortIncidence, cohort_method = cohortMethod, - prediction = prediction + prediction = prediction, + sccs = sccs ) # add cohort names @@ -873,11 +933,18 @@ getTandOs <- function( cg$subsetDefinitionId[is.na(cg$subsetDefinitionId)] <- 0 if(sum(cg$isSubset == 0) > 0 ){ - parents <- cg[cg$isSubset == 0,] - groupedCohorts <- lapply(1:nrow(parents), function(i){ - x <- parents$cohortDefinitionId[i]; - - if(x %in% unique(res$tid)){ + # + parentChild <- unique( + merge( + x = cg[, c('cohortDefinitionId','subsetParent')], + y = res, + by.x = 'cohortDefinitionId', + by.y = 'tid' + ) + ) + parents <- unique(parentChild$subsetParent) + groupedCohorts <- lapply(1:length(parents), function(i){ + x <- parents[i]; list( cohortId = x, cohortName = cg$cohortName[cg$cohortDefinitionId == x], @@ -886,15 +953,13 @@ getTandOs <- function( targetName = cg$cohortName[cg$subsetParent == x], subsetId = cg$subsetDefinitionId[cg$subsetParent == x] ) - ) - }else{ - return(NULL) - }; + ); }) - names(groupedCohorts) <- parents$cohortName + names(groupedCohorts) <- unlist(lapply(groupedCohorts, function(x){x$cohortName})) }} # get comparators + cs <- NULL if(cohortMethod){ comps <- connectionHandler$queryDb( 'select distinct target_id, comparator_id from diff --git a/extras/examples/app.R b/extras/examples/app.R index 0c354deb..38a0188e 100644 --- a/extras/examples/app.R +++ b/extras/examples/app.R @@ -20,12 +20,25 @@ if(!dir.exists('./drivers')){ connectionDetails <- OhdsiShinyModules::getExampleConnectionDetails() schema <- "main" +est <- ShinyAppBuilder::createModuleConfig( + moduleId = 'estimation', + tabName = 'Estimation', + shinyModulePackage = 'OhdsiShinyModules', + moduleUiFunction = 'estimationViewer', + moduleServerFunction = 'estimationServer', + moduleInfoBoxFile = 'esimationHelperFile()', + moduleIcon = 'list' + ) + # Specify the config - create a new one and then add # each shiny module you want to include config <- initializeModuleConfig() %>% addModuleConfig( createDefaultAboutConfig() ) %>% + addModuleConfig( + est + ) %>% addModuleConfig( createDefaultDatasourcesConfig() ) %>% diff --git a/inst/estimation-www/estimation.html b/inst/estimation-www/estimation.html new file mode 100644 index 00000000..e69de29b diff --git a/tests/testthat/test-report-main.R b/tests/testthat/test-report-main.R new file mode 100644 index 00000000..1b9e235a --- /dev/null +++ b/tests/testthat/test-report-main.R @@ -0,0 +1,31 @@ +context("report-main") + +shiny::testServer(reportServer, args = list( + id = "testReportServer", + connectionHandler = connectionHandlerEs, + resultDatabaseSettings = resultDatabaseSettingsEs#, + #server = Sys.getenv("RESULTS_SERVER"), + #username = Sys.getenv("RESULTS_USER"), + #password = Sys.getenv("RESULTS_PASSWORD"), + #dbms = "postgresql" +), { + + # input$cmTargetNext + # input$cmTargetPrevious + # input$comparatorNext + # input$comparatorPrevious + # input$outcomeNext + # input$outcomePrevious + # input$generatePrevious + + session$setInputs(cmTargetNext = TRUE) + session$setInputs(cmTargetPrevious = TRUE) + +}) + +test_that("Test report ui", { + # Test ui + ui <- reportViewer() + checkmate::expect_list(ui) + checkmate::expect_file_exists(reportHelperFile()) +})